From 0de01be51b092611f2c28ee10bd75168adb851ab Mon Sep 17 00:00:00 2001 From: Attila Mihaly Date: Thu, 26 Mar 2020 16:56:03 -0400 Subject: [PATCH 01/42] Added missing module declarations. #37 --- src/Morphir/IR/SDK.elm | 12 +++++++++++- src/Morphir/IR/SDK/Bool.elm | 15 ++++++++++++++- src/Morphir/IR/SDK/Float.elm | 15 ++++++++++++++- src/Morphir/IR/SDK/List.elm | 15 ++++++++++++++- src/Morphir/IR/SDK/Maybe.elm | 20 +++++++++++++++++++- src/Morphir/IR/SDK/String.elm | 15 ++++++++++++++- 6 files changed, 86 insertions(+), 6 deletions(-) diff --git a/src/Morphir/IR/SDK.elm b/src/Morphir/IR/SDK.elm index 4790e040f..23821f7c7 100644 --- a/src/Morphir/IR/SDK.elm +++ b/src/Morphir/IR/SDK.elm @@ -2,13 +2,23 @@ module Morphir.IR.SDK exposing (..) import Dict import Morphir.IR.Advanced.Package as Package +import Morphir.IR.SDK.Bool as Bool +import Morphir.IR.SDK.Float as Float import Morphir.IR.SDK.Int as Int +import Morphir.IR.SDK.List as List +import Morphir.IR.SDK.Maybe as Maybe +import Morphir.IR.SDK.String as String packageDeclaration : Package.Declaration () packageDeclaration = { modules = Dict.fromList - [ ( [ [ "int" ] ], Int.moduleDeclaration ) + [ ( [ [ "bool" ] ], Bool.moduleDeclaration ) + , ( [ [ "int" ] ], Int.moduleDeclaration ) + , ( [ [ "float" ] ], Float.moduleDeclaration ) + , ( [ [ "string" ] ], String.moduleDeclaration ) + , ( [ [ "maybe" ] ], Maybe.moduleDeclaration ) + , ( [ [ "list" ] ], List.moduleDeclaration ) ] } diff --git a/src/Morphir/IR/SDK/Bool.elm b/src/Morphir/IR/SDK/Bool.elm index 51204a7f7..ecda1f068 100644 --- a/src/Morphir/IR/SDK/Bool.elm +++ b/src/Morphir/IR/SDK/Bool.elm @@ -1,6 +1,8 @@ module Morphir.IR.SDK.Bool exposing (..) -import Morphir.IR.Advanced.Type exposing (Type(..)) +import Dict +import Morphir.IR.Advanced.Module as Module +import Morphir.IR.Advanced.Type exposing (Declaration(..), Type(..)) import Morphir.IR.FQName as FQName exposing (FQName) import Morphir.IR.Name as Name import Morphir.IR.Path exposing (Path) @@ -13,6 +15,17 @@ moduleName = [ [ "bool" ] ] +moduleDeclaration : Module.Declaration () +moduleDeclaration = + { types = + Dict.fromList + [ ( [ "bool" ], OpaqueTypeDeclaration [] ) + ] + , values = + Dict.empty + } + + fromLocalName : String -> FQName fromLocalName name = name diff --git a/src/Morphir/IR/SDK/Float.elm b/src/Morphir/IR/SDK/Float.elm index e7173089a..14062ef0c 100644 --- a/src/Morphir/IR/SDK/Float.elm +++ b/src/Morphir/IR/SDK/Float.elm @@ -1,6 +1,8 @@ module Morphir.IR.SDK.Float exposing (..) -import Morphir.IR.Advanced.Type exposing (Type(..)) +import Dict +import Morphir.IR.Advanced.Module as Module +import Morphir.IR.Advanced.Type exposing (Declaration(..), Type(..)) import Morphir.IR.FQName as FQName exposing (FQName) import Morphir.IR.Name as Name import Morphir.IR.Path exposing (Path) @@ -13,6 +15,17 @@ moduleName = [ [ "float" ] ] +moduleDeclaration : Module.Declaration () +moduleDeclaration = + { types = + Dict.fromList + [ ( [ "float" ], OpaqueTypeDeclaration [] ) + ] + , values = + Dict.empty + } + + fromLocalName : String -> FQName fromLocalName name = name diff --git a/src/Morphir/IR/SDK/List.elm b/src/Morphir/IR/SDK/List.elm index 45a300ca1..ab7e973dd 100644 --- a/src/Morphir/IR/SDK/List.elm +++ b/src/Morphir/IR/SDK/List.elm @@ -1,6 +1,8 @@ module Morphir.IR.SDK.List exposing (..) -import Morphir.IR.Advanced.Type exposing (Type(..)) +import Dict +import Morphir.IR.Advanced.Module as Module +import Morphir.IR.Advanced.Type exposing (Declaration(..), Type(..)) import Morphir.IR.FQName as FQName exposing (FQName) import Morphir.IR.Name as Name import Morphir.IR.Path exposing (Path) @@ -13,6 +15,17 @@ moduleName = [ [ "list" ] ] +moduleDeclaration : Module.Declaration () +moduleDeclaration = + { types = + Dict.fromList + [ ( [ "list" ], OpaqueTypeDeclaration [ [ "a" ] ] ) + ] + , values = + Dict.empty + } + + fromLocalName : String -> FQName fromLocalName name = name diff --git a/src/Morphir/IR/SDK/Maybe.elm b/src/Morphir/IR/SDK/Maybe.elm index bf64a481e..281087162 100644 --- a/src/Morphir/IR/SDK/Maybe.elm +++ b/src/Morphir/IR/SDK/Maybe.elm @@ -1,6 +1,8 @@ module Morphir.IR.SDK.Maybe exposing (..) -import Morphir.IR.Advanced.Type exposing (Type(..)) +import Dict +import Morphir.IR.Advanced.Module as Module +import Morphir.IR.Advanced.Type as Type exposing (Declaration(..), Type(..)) import Morphir.IR.FQName as FQName exposing (FQName) import Morphir.IR.Name as Name import Morphir.IR.Path exposing (Path) @@ -13,6 +15,22 @@ moduleName = [ [ "maybe" ] ] +moduleDeclaration : Module.Declaration () +moduleDeclaration = + { types = + Dict.fromList + [ ( [ "maybe" ] + , CustomTypeDeclaration [ [ "a" ] ] + [ ( [ "just" ], [ ( [ "value" ], Type.Variable [ "a" ] () ) ] ) + , ( [ "nothing" ], [] ) + ] + ) + ] + , values = + Dict.empty + } + + fromLocalName : String -> FQName fromLocalName name = name diff --git a/src/Morphir/IR/SDK/String.elm b/src/Morphir/IR/SDK/String.elm index 033adfef1..d46b9df82 100644 --- a/src/Morphir/IR/SDK/String.elm +++ b/src/Morphir/IR/SDK/String.elm @@ -1,6 +1,8 @@ module Morphir.IR.SDK.String exposing (..) -import Morphir.IR.Advanced.Type exposing (Type(..)) +import Dict +import Morphir.IR.Advanced.Module as Module +import Morphir.IR.Advanced.Type exposing (Declaration(..), Type(..)) import Morphir.IR.FQName as FQName exposing (FQName) import Morphir.IR.Name as Name import Morphir.IR.Path exposing (Path) @@ -13,6 +15,17 @@ moduleName = [ [ "string" ] ] +moduleDeclaration : Module.Declaration () +moduleDeclaration = + { types = + Dict.fromList + [ ( [ "string" ], OpaqueTypeDeclaration [] ) + ] + , values = + Dict.empty + } + + fromLocalName : String -> FQName fromLocalName name = name From edcdabfd07007aaa8475648b7f7a8bdfe1144e36 Mon Sep 17 00:00:00 2001 From: Attila Mihaly Date: Thu, 26 Mar 2020 21:13:14 -0400 Subject: [PATCH 02/42] Process only those modules that are reachable from exposed ones. Remove package path from module names. #21 --- morphir.json | 6 +-- src/Morphir/Elm/Frontend.elm | 70 +++++++++++++++++++++++----- src/Morphir/Elm/Frontend/Resolve.elm | 2 + src/Morphir/{DAG.elm => Graph.elm} | 69 +++++++++++++++++++++++---- src/Morphir/IR/SDK.elm | 4 ++ src/Morphir/IR/SDK/Char.elm | 39 ++++++++++++++++ src/Morphir/IR/SDK/Result.elm | 44 +++++++++++++++++ tests/Morphir/Elm/FrontendTests.elm | 18 +++++-- tests/Morphir/GraphTests.elm | 36 ++++++++++++++ 9 files changed, 259 insertions(+), 29 deletions(-) rename src/Morphir/{DAG.elm => Graph.elm} (50%) create mode 100644 src/Morphir/IR/SDK/Char.elm create mode 100644 src/Morphir/IR/SDK/Result.elm create mode 100644 tests/Morphir/GraphTests.elm diff --git a/morphir.json b/morphir.json index ba294d695..a1524892c 100644 --- a/morphir.json +++ b/morphir.json @@ -1,8 +1,8 @@ { - "name": "morphir", + "name": "Morphir", "sourceDirectory": "src", "exposedModules": [ - "Morphir.IR.Name", - "Morphir.IR.Path" + "IR.Advanced.Type", + "IR.Advanced.Value" ] } \ No newline at end of file diff --git a/src/Morphir/Elm/Frontend.elm b/src/Morphir/Elm/Frontend.elm index 64d617120..f677dfc46 100644 --- a/src/Morphir/Elm/Frontend.elm +++ b/src/Morphir/Elm/Frontend.elm @@ -13,9 +13,9 @@ import Elm.Syntax.Node as Node exposing (Node(..)) import Elm.Syntax.TypeAnnotation exposing (TypeAnnotation(..)) import Json.Decode as Decode import Json.Encode as Encode -import Morphir.DAG as DAG exposing (DAG) import Morphir.Elm.Frontend.Resolve as Resolve exposing (ModuleResolver, PackageResolver) -import Morphir.IR.AccessControlled as AccessControlled exposing (AccessControlled, private, public) +import Morphir.Graph as Graph exposing (Graph) +import Morphir.IR.AccessControlled exposing (AccessControlled, private, public) import Morphir.IR.Advanced.Module as Module import Morphir.IR.Advanced.Package as Package import Morphir.IR.Advanced.Type as Type exposing (Type) @@ -124,7 +124,7 @@ type alias Errors = type Error = ParseError String (List Parser.DeadEnd) - | CyclicModules (DAG (List String)) + | CyclicModules (Graph (List String)) | ResolveError SourceLocation Resolve.Error @@ -180,6 +180,41 @@ packageDefinitionFromSource packageInfo sourceFiles = ) |> ResultList.toResult + exposedModuleNames : Set ModuleName + exposedModuleNames = + packageInfo.exposedModules + |> Set.map + (\modulePath -> + (packageInfo.name |> Path.toList) + ++ (modulePath |> Path.toList) + |> List.map Name.toTitleCase + ) + + treeShakeModules : List ( ModuleName, ParsedFile ) -> List ( ModuleName, ParsedFile ) + treeShakeModules allModules = + let + allUsedModules : Set ModuleName + allUsedModules = + allModules + |> List.map + (\( moduleName, parsedFile ) -> + ( moduleName + , parsedFile.rawFile + |> RawFile.imports + |> List.map (.moduleName >> Node.value) + |> Set.fromList + ) + ) + |> Dict.fromList + |> Graph.fromDict + |> Graph.reachableNodes exposedModuleNames + in + allModules + |> List.filter + (\( moduleName, _ ) -> + allUsedModules |> Set.member moduleName + ) + sortModules : List ( ModuleName, ParsedFile ) -> Result Errors (List ModuleName) sortModules modules = let @@ -195,10 +230,10 @@ packageDefinitionFromSource packageInfo sourceFiles = ) ) |> Dict.fromList - |> DAG.fromDict - |> DAG.topologicalSort + |> Graph.fromDict + |> Graph.topologicalSort in - if DAG.isEmpty cycles then + if Graph.isEmpty cycles then Ok sortedModules else @@ -212,7 +247,9 @@ packageDefinitionFromSource packageInfo sourceFiles = parsedFiles |> Dict.fromList in - sortModules parsedFiles + parsedFiles + |> treeShakeModules + |> sortModules |> Result.andThen (mapParsedFiles packageInfo.name parsedFilesByModuleName) ) |> Result.map @@ -220,14 +257,23 @@ packageDefinitionFromSource packageInfo sourceFiles = { dependencies = Dict.empty , modules = moduleDefs - |> Dict.map - (\modulePath m -> - if packageInfo.exposedModules |> Set.member modulePath then - public m + |> Dict.toList + |> List.map + (\( modulePath, m ) -> + let + packageLessModulePath = + modulePath + |> Path.toList + |> List.drop (packageInfo.name |> Path.toList |> List.length) + |> Path.fromList + in + if packageInfo.exposedModules |> Set.member packageLessModulePath then + ( packageLessModulePath, public m ) else - private m + ( packageLessModulePath, private m ) ) + |> Dict.fromList } ) diff --git a/src/Morphir/Elm/Frontend/Resolve.elm b/src/Morphir/Elm/Frontend/Resolve.elm index efce611ad..d39d22612 100644 --- a/src/Morphir/Elm/Frontend/Resolve.elm +++ b/src/Morphir/Elm/Frontend/Resolve.elm @@ -111,10 +111,12 @@ defaultImports = ) in [ importExplicit [ "Morphir", "SDK", "Bool" ] Nothing [ TypeOrAliasExpose "Bool" ] + , importExplicit [ "Morphir", "SDK", "Char" ] Nothing [ TypeOrAliasExpose "Char" ] , importExplicit [ "Morphir", "SDK", "Int" ] Nothing [ TypeOrAliasExpose "Int" ] , importExplicit [ "Morphir", "SDK", "Float" ] Nothing [ TypeOrAliasExpose "Float" ] , importExplicit [ "Morphir", "SDK", "String" ] Nothing [ TypeOrAliasExpose "String" ] , importExplicit [ "Morphir", "SDK", "Maybe" ] Nothing [ TypeOrAliasExpose "Maybe" ] + , importExplicit [ "Morphir", "SDK", "Result" ] Nothing [ TypeOrAliasExpose "Result" ] , importExplicit [ "Morphir", "SDK", "List" ] Nothing [ TypeOrAliasExpose "List" ] ] diff --git a/src/Morphir/DAG.elm b/src/Morphir/Graph.elm similarity index 50% rename from src/Morphir/DAG.elm rename to src/Morphir/Graph.elm index 92647a1b2..bc93f4f16 100644 --- a/src/Morphir/DAG.elm +++ b/src/Morphir/Graph.elm @@ -1,25 +1,38 @@ -module Morphir.DAG exposing (DAG, fromDict, isEmpty, topologicalSort) +module Morphir.Graph exposing (Graph, empty, fromDict, fromList, isEmpty, reachableNodes, topologicalSort) import Dict exposing (Dict) import Set exposing (Set) -type DAG comparable - = DAG (Dict comparable (Set comparable)) +type Graph comparable + = Graph (Dict comparable (Set comparable)) -fromDict : Dict comparable (Set comparable) -> DAG comparable +fromDict : Dict comparable (Set comparable) -> Graph comparable fromDict = - DAG + Graph -isEmpty : DAG comparable -> Bool -isEmpty (DAG edges) = +fromList : List ( comparable, List comparable ) -> Graph comparable +fromList list = + list + |> List.map (\( from, tos ) -> ( from, Set.fromList tos )) + |> Dict.fromList + |> Graph + + +empty : Graph comparable +empty = + Graph Dict.empty + + +isEmpty : Graph comparable -> Bool +isEmpty (Graph edges) = Dict.isEmpty edges -topologicalSort : DAG comparable -> ( List comparable, DAG comparable ) -topologicalSort (DAG edges) = +topologicalSort : Graph comparable -> ( List comparable, Graph comparable ) +topologicalSort (Graph edges) = let normalize graphEdges = let @@ -74,6 +87,42 @@ topologicalSort (DAG edges) = step newGraphEdges (startNode :: sorting) Nothing -> - ( List.reverse sorting, DAG graphEdges ) + ( List.reverse sorting, Graph graphEdges ) in step (normalize edges) [] + + +reachableNodes : Set comparable -> Graph comparable -> Set comparable +reachableNodes startNodes (Graph edges) = + let + directlyReachable : Set comparable -> Set comparable + directlyReachable fromNodes = + edges + |> Dict.toList + |> List.filterMap + (\( fromNode, toNodes ) -> + if fromNodes |> Set.member fromNode then + Just toNodes + + else + Nothing + ) + |> List.foldl Set.union Set.empty + + transitivelyReachable : Set comparable -> Set comparable + transitivelyReachable fromNodes = + if Set.isEmpty fromNodes then + Set.empty + + else + let + reachables = + Set.union (directlyReachable fromNodes) fromNodes + in + if reachables == fromNodes then + fromNodes + + else + Set.union fromNodes (transitivelyReachable reachables) + in + transitivelyReachable startNodes diff --git a/src/Morphir/IR/SDK.elm b/src/Morphir/IR/SDK.elm index 23821f7c7..b8e45fe5a 100644 --- a/src/Morphir/IR/SDK.elm +++ b/src/Morphir/IR/SDK.elm @@ -3,10 +3,12 @@ module Morphir.IR.SDK exposing (..) import Dict import Morphir.IR.Advanced.Package as Package import Morphir.IR.SDK.Bool as Bool +import Morphir.IR.SDK.Char as Char import Morphir.IR.SDK.Float as Float import Morphir.IR.SDK.Int as Int import Morphir.IR.SDK.List as List import Morphir.IR.SDK.Maybe as Maybe +import Morphir.IR.SDK.Result as Result import Morphir.IR.SDK.String as String @@ -15,10 +17,12 @@ packageDeclaration = { modules = Dict.fromList [ ( [ [ "bool" ] ], Bool.moduleDeclaration ) + , ( [ [ "char" ] ], Char.moduleDeclaration ) , ( [ [ "int" ] ], Int.moduleDeclaration ) , ( [ [ "float" ] ], Float.moduleDeclaration ) , ( [ [ "string" ] ], String.moduleDeclaration ) , ( [ [ "maybe" ] ], Maybe.moduleDeclaration ) + , ( [ [ "result" ] ], Result.moduleDeclaration ) , ( [ [ "list" ] ], List.moduleDeclaration ) ] } diff --git a/src/Morphir/IR/SDK/Char.elm b/src/Morphir/IR/SDK/Char.elm new file mode 100644 index 000000000..29d2383a7 --- /dev/null +++ b/src/Morphir/IR/SDK/Char.elm @@ -0,0 +1,39 @@ +module Morphir.IR.SDK.Char exposing (..) + +import Dict +import Morphir.IR.Advanced.Module as Module +import Morphir.IR.Advanced.Type exposing (Declaration(..), Type(..)) +import Morphir.IR.FQName as FQName exposing (FQName) +import Morphir.IR.Name as Name +import Morphir.IR.Path exposing (Path) +import Morphir.IR.QName as QName +import Morphir.IR.SDK.Common exposing (packageName) + + +moduleName : Path +moduleName = + [ [ "char" ] ] + + +moduleDeclaration : Module.Declaration () +moduleDeclaration = + { types = + Dict.fromList + [ ( [ "char" ], OpaqueTypeDeclaration [] ) + ] + , values = + Dict.empty + } + + +fromLocalName : String -> FQName +fromLocalName name = + name + |> Name.fromString + |> QName.fromName moduleName + |> FQName.fromQName packageName + + +charType : extra -> Type extra +charType extra = + Reference (fromLocalName "char") [] extra diff --git a/src/Morphir/IR/SDK/Result.elm b/src/Morphir/IR/SDK/Result.elm new file mode 100644 index 000000000..d15d93f20 --- /dev/null +++ b/src/Morphir/IR/SDK/Result.elm @@ -0,0 +1,44 @@ +module Morphir.IR.SDK.Result exposing (..) + +import Dict +import Morphir.IR.Advanced.Module as Module +import Morphir.IR.Advanced.Type as Type exposing (Declaration(..), Type(..)) +import Morphir.IR.FQName as FQName exposing (FQName) +import Morphir.IR.Name as Name +import Morphir.IR.Path exposing (Path) +import Morphir.IR.QName as QName +import Morphir.IR.SDK.Common exposing (packageName) + + +moduleName : Path +moduleName = + [ [ "result" ] ] + + +moduleDeclaration : Module.Declaration () +moduleDeclaration = + { types = + Dict.fromList + [ ( [ "result" ] + , CustomTypeDeclaration [ [ "e" ], [ "a" ] ] + [ ( [ "ok" ], [ ( [ "value" ], Type.Variable [ "a" ] () ) ] ) + , ( [ "err" ], [ ( [ "error" ], Type.Variable [ "e" ] () ) ] ) + ] + ) + ] + , values = + Dict.empty + } + + +fromLocalName : String -> FQName +fromLocalName name = + name + |> Name.fromString + |> QName.fromName moduleName + |> FQName.fromQName packageName + + +resultType : Type extra -> extra -> Type extra +resultType itemType extra = + Reference (fromLocalName "result") [ itemType ] extra diff --git a/tests/Morphir/Elm/FrontendTests.elm b/tests/Morphir/Elm/FrontendTests.elm index 18c4c6936..2e067ba88 100644 --- a/tests/Morphir/Elm/FrontendTests.elm +++ b/tests/Morphir/Elm/FrontendTests.elm @@ -57,14 +57,24 @@ type Bee = Bee """ } + sourceC = + { path = "My/Package/C.elm" + , content = + unindent """ +module My.Package.C exposing (..) + +type Cee = Cee + """ + } + packageName = - Path.fromString "my/package" + Path.fromString "My.Package" moduleA = - Path.fromString "My.Package.A" + Path.fromString "A" moduleB = - Path.fromString "My.Package.B" + Path.fromString "B" packageInfo = { name = @@ -152,7 +162,7 @@ type Bee = Bee in test "first" <| \_ -> - Frontend.packageDefinitionFromSource packageInfo [ sourceA, sourceB ] + Frontend.packageDefinitionFromSource packageInfo [ sourceA, sourceB, sourceC ] |> Result.map Package.eraseDefinitionExtra |> Expect.equal (Ok expected) diff --git a/tests/Morphir/GraphTests.elm b/tests/Morphir/GraphTests.elm new file mode 100644 index 000000000..4862e9c65 --- /dev/null +++ b/tests/Morphir/GraphTests.elm @@ -0,0 +1,36 @@ +module Morphir.GraphTests exposing (..) + +import Expect +import Morphir.Graph as Graph +import Set +import Test exposing (..) + + +topologicalSortTests : Test +topologicalSortTests = + describe "topologicalSort" + [ test "empty graph is sorted" <| + \_ -> + Graph.topologicalSort Graph.empty + |> Expect.equal ( [], Graph.empty ) + ] + + +reachableNodesTests : Test +reachableNodesTests = + describe "reachableNodes" + [ test "empty graph returns empty" <| + \_ -> + Graph.reachableNodes Set.empty Graph.empty + |> Expect.equal Set.empty + , test "unreachable node removed" <| + \_ -> + Graph.fromList [ ( 1, [ 2 ] ), ( 2, [ 3 ] ), ( 4, [ 5 ] ) ] + |> Graph.reachableNodes (Set.fromList [ 1 ]) + |> Expect.equal (Set.fromList [ 1, 2, 3 ]) + , test "cycles handled gracefully" <| + \_ -> + Graph.fromList [ ( 1, [ 2 ] ), ( 2, [ 1 ] ), ( 4, [ 5 ] ) ] + |> Graph.reachableNodes (Set.fromList [ 1 ]) + |> Expect.equal (Set.fromList [ 1, 2 ]) + ] From b9166d97405842f3a2099a82a66544fb226011f2 Mon Sep 17 00:00:00 2001 From: Attila Mihaly Date: Sat, 28 Mar 2020 13:45:11 -0400 Subject: [PATCH 03/42] Renaming concepts based on review feedback. #41 --- src/Morphir/Elm/Frontend.elm | 6 +- src/Morphir/Elm/Frontend/Resolve.elm | 6 +- src/Morphir/IR/Advanced/Module.elm | 82 ++++++++++++------------- src/Morphir/IR/Advanced/Package.elm | 72 +++++++++++----------- src/Morphir/IR/Advanced/Type.elm | 86 +++++++++++++------------- src/Morphir/IR/Advanced/Value.elm | 92 ++++++++++++++-------------- src/Morphir/IR/Package.elm | 10 +-- src/Morphir/IR/SDK.elm | 20 +++--- src/Morphir/IR/SDK/Bool.elm | 8 +-- src/Morphir/IR/SDK/Char.elm | 8 +-- src/Morphir/IR/SDK/Float.elm | 8 +-- src/Morphir/IR/SDK/Int.elm | 8 +-- src/Morphir/IR/SDK/List.elm | 8 +-- src/Morphir/IR/SDK/Maybe.elm | 8 +-- src/Morphir/IR/SDK/Result.elm | 8 +-- src/Morphir/IR/SDK/String.elm | 8 +-- src/Morphir/IR/Type.elm | 10 +-- src/Morphir/IR/Value.elm | 26 ++++---- 18 files changed, 238 insertions(+), 236 deletions(-) diff --git a/src/Morphir/Elm/Frontend.elm b/src/Morphir/Elm/Frontend.elm index f677dfc46..b1e1706ac 100644 --- a/src/Morphir/Elm/Frontend.elm +++ b/src/Morphir/Elm/Frontend.elm @@ -322,13 +322,13 @@ mapProcessedFile currentPackagePath processedFile modulesSoFar = modulesSoFar |> Dict.map (\path def -> - Module.definitionToDeclaration def - |> Module.eraseDeclarationExtra + Module.definitionToSpecification def + |> Module.eraseSpecificationExtra ) dependencies = Dict.fromList - [ ( [ [ "morphir" ], [ "s", "d", "k" ] ], SDK.packageDeclaration ) + [ ( [ [ "morphir" ], [ "s", "d", "k" ] ], SDK.packageSpec ) ] moduleResolver : ModuleResolver diff --git a/src/Morphir/Elm/Frontend/Resolve.elm b/src/Morphir/Elm/Frontend/Resolve.elm index d39d22612..1643c5fde 100644 --- a/src/Morphir/Elm/Frontend/Resolve.elm +++ b/src/Morphir/Elm/Frontend/Resolve.elm @@ -121,10 +121,10 @@ defaultImports = ] -createPackageResolver : Dict Path (Package.Declaration a) -> Path -> Dict Path (Module.Declaration a) -> PackageResolver +createPackageResolver : Dict Path (Package.Specification a) -> Path -> Dict Path (Module.Specification a) -> PackageResolver createPackageResolver dependencies currentPackagePath currentPackageModules = let - lookupModule : Path -> Path -> Result Error (Module.Declaration a) + lookupModule : Path -> Path -> Result Error (Module.Specification a) lookupModule packagePath modulePath = let modulesResult = @@ -165,7 +165,7 @@ createPackageResolver dependencies currentPackagePath currentPackageModules = |> Result.map (\typeDecl -> typeDecl - |> Type.matchCustomTypeDeclaration matchAny matchAny + |> Type.matchCustomTypeSpecification matchAny matchAny |> Maybe.map (\( _, ctors ) -> ctors diff --git a/src/Morphir/IR/Advanced/Module.elm b/src/Morphir/IR/Advanced/Module.elm index f26c2d92a..9a13bebf5 100644 --- a/src/Morphir/IR/Advanced/Module.elm +++ b/src/Morphir/IR/Advanced/Module.elm @@ -1,14 +1,14 @@ module Morphir.IR.Advanced.Module exposing - ( Declaration, Definition - , encodeDeclaration, encodeDefinition - , definitionToDeclaration, eraseDeclarationExtra, mapDeclaration, mapDefinition + ( Specification, Definition + , encodeSpecification, encodeDefinition + , definitionToSpecification, eraseSpecificationExtra, mapDefinition, mapSpecification ) {-| Modules are groups of types and values that belong together. -@docs Declaration, Definition +@docs Specification, Definition -@docs encodeDeclaration, encodeDefinition +@docs encodeSpecification, encodeDefinition -} @@ -22,16 +22,16 @@ import Morphir.IR.Name exposing (Name, encodeName) import Morphir.ResultList as ResultList -{-| Type that represents a module declaration. +{-| Type that represents a module specification. -} -type alias Declaration extra = - { types : Dict Name (Type.Declaration extra) - , values : Dict Name (Value.Declaration extra) +type alias Specification extra = + { types : Dict Name (Type.Specification extra) + , values : Dict Name (Value.Specification extra) } -emptyDeclaration : Declaration extra -emptyDeclaration = +emptySpecification : Specification extra +emptySpecification = { types = Dict.empty , values = Dict.empty } @@ -45,8 +45,8 @@ type alias Definition extra = } -definitionToDeclaration : Definition extra -> Declaration extra -definitionToDeclaration def = +definitionToSpecification : Definition extra -> Specification extra +definitionToSpecification def = { types = def.types |> Dict.toList @@ -56,7 +56,7 @@ definitionToDeclaration def = |> withPublicAccess |> Maybe.map (\typeDef -> - ( path, Type.definitionToDeclaration typeDef ) + ( path, Type.definitionToSpecification typeDef ) ) ) |> Dict.fromList @@ -71,83 +71,83 @@ definitionToDeclaration def = -- |> withPublicAccess -- |> Maybe.map -- (\valueDef -> - -- ( path, Value.definitionToDeclaration valueDef ) + -- ( path, Value.definitionToSpecification valueDef ) -- ) -- ) -- |> Dict.fromList } -eraseDeclarationExtra : Declaration a -> Declaration () -eraseDeclarationExtra decl = - decl - |> mapDeclaration +eraseSpecificationExtra : Specification a -> Specification () +eraseSpecificationExtra spec = + spec + |> mapSpecification (Type.mapTypeExtra (\_ -> ()) >> Ok) (Value.mapValueExtra (\_ -> ())) - |> Result.withDefault emptyDeclaration + |> Result.withDefault emptySpecification {-| -} -encodeDeclaration : (extra -> Encode.Value) -> Declaration extra -> Encode.Value -encodeDeclaration encodeExtra decl = +encodeSpecification : (extra -> Encode.Value) -> Specification extra -> Encode.Value +encodeSpecification encodeExtra spec = Encode.object [ ( "types" - , decl.types + , spec.types |> Dict.toList |> Encode.list - (\( name, typeDecl ) -> + (\( name, typeSpec ) -> Encode.object [ ( "name", encodeName name ) - , ( "decl", Type.encodeDeclaration encodeExtra typeDecl ) + , ( "spec", Type.encodeSpecification encodeExtra typeSpec ) ] ) ) , ( "values" - , decl.values + , spec.values |> Dict.toList |> Encode.list - (\( name, valueDecl ) -> + (\( name, valueSpec ) -> Encode.object [ ( "name", encodeName name ) - , ( "decl", Value.encodeDeclaration encodeExtra valueDecl ) + , ( "spec", Value.encodeSpecification encodeExtra valueSpec ) ] ) ) ] -mapDeclaration : (Type a -> Result e (Type b)) -> (Value a -> Value b) -> Declaration a -> Result (List e) (Declaration b) -mapDeclaration mapType mapValue decl = +mapSpecification : (Type a -> Result e (Type b)) -> (Value a -> Value b) -> Specification a -> Result (List e) (Specification b) +mapSpecification mapType mapValue spec = let - typesResult : Result (List e) (Dict Name (Type.Declaration b)) + typesResult : Result (List e) (Dict Name (Type.Specification b)) typesResult = - decl.types + spec.types |> Dict.toList |> List.map - (\( typeName, typeDecl ) -> - typeDecl - |> Type.mapDeclaration mapType + (\( typeName, typeSpec ) -> + typeSpec + |> Type.mapSpecification mapType |> Result.map (Tuple.pair typeName) ) |> ResultList.toResult |> Result.map Dict.fromList |> Result.mapError List.concat - valuesResult : Result (List e) (Dict Name (Value.Declaration b)) + valuesResult : Result (List e) (Dict Name (Value.Specification b)) valuesResult = - decl.values + spec.values |> Dict.toList |> List.map - (\( valueName, valueDecl ) -> - valueDecl - |> Value.mapDeclaration mapType mapValue + (\( valueName, valueSpec ) -> + valueSpec + |> Value.mapSpecification mapType mapValue |> Result.map (Tuple.pair valueName) ) |> ResultList.toResult |> Result.map Dict.fromList |> Result.mapError List.concat in - Result.map2 Declaration + Result.map2 Specification typesResult valuesResult diff --git a/src/Morphir/IR/Advanced/Package.elm b/src/Morphir/IR/Advanced/Package.elm index 958cfd473..785c32e83 100644 --- a/src/Morphir/IR/Advanced/Package.elm +++ b/src/Morphir/IR/Advanced/Package.elm @@ -1,12 +1,12 @@ module Morphir.IR.Advanced.Package exposing - ( Declaration + ( Specification , Definition, emptyDefinition - , definitionToDeclaration, encodeDefinition, eraseDeclarationExtra, eraseDefinitionExtra + , definitionToSpecification, encodeDefinition, eraseDefinitionExtra, eraseSpecificationExtra ) {-| Tools to work with packages. -@docs Declaration +@docs Specification @docs Definition, emptyDefinition @@ -24,15 +24,15 @@ import Morphir.IR.QName exposing (QName, encodeQName) import Morphir.ResultList as ResultList -{-| Type that represents a package declaration. +{-| Type that represents a package specification. -} -type alias Declaration extra = - { modules : Dict Path (Module.Declaration extra) +type alias Specification extra = + { modules : Dict Path (Module.Specification extra) } -emptyDeclaration : Declaration extra -emptyDeclaration = +emptySpecification : Specification extra +emptySpecification = { modules = Dict.empty } @@ -40,7 +40,7 @@ emptyDeclaration = {-| Type that represents a package definition. -} type alias Definition extra = - { dependencies : Dict Path (Declaration extra) + { dependencies : Dict Path (Specification extra) , modules : Dict Path (AccessControlled (Module.Definition extra)) } @@ -54,8 +54,8 @@ emptyDefinition = } -definitionToDeclaration : Definition extra -> Declaration extra -definitionToDeclaration def = +definitionToSpecification : Definition extra -> Specification extra +definitionToSpecification def = { modules = def.modules |> Dict.toList @@ -65,53 +65,53 @@ definitionToDeclaration def = |> withPublicAccess |> Maybe.map (\moduleDef -> - ( path, Module.definitionToDeclaration moduleDef ) + ( path, Module.definitionToSpecification moduleDef ) ) ) |> Dict.fromList } -mapDeclaration : (Type a -> Result e (Type b)) -> (Value a -> Value b) -> Declaration a -> Result (List e) (Declaration b) -mapDeclaration mapType mapValue decl = +mapSpecification : (Type a -> Result e (Type b)) -> (Value a -> Value b) -> Specification a -> Result (List e) (Specification b) +mapSpecification mapType mapValue spec = let - modulesResult : Result (List e) (Dict Path (Module.Declaration b)) + modulesResult : Result (List e) (Dict Path (Module.Specification b)) modulesResult = - decl.modules + spec.modules |> Dict.toList |> List.map - (\( modulePath, moduleDecl ) -> - moduleDecl - |> Module.mapDeclaration mapType mapValue + (\( modulePath, moduleSpec ) -> + moduleSpec + |> Module.mapSpecification mapType mapValue |> Result.map (Tuple.pair modulePath) ) |> ResultList.toResult |> Result.map Dict.fromList |> Result.mapError List.concat in - Result.map Declaration modulesResult + Result.map Specification modulesResult -eraseDeclarationExtra : Declaration a -> Declaration () -eraseDeclarationExtra decl = - decl - |> mapDeclaration +eraseSpecificationExtra : Specification a -> Specification () +eraseSpecificationExtra spec = + spec + |> mapSpecification (Type.mapTypeExtra (\_ -> ()) >> Ok) (Value.mapValueExtra (\_ -> ())) - |> Result.withDefault emptyDeclaration + |> Result.withDefault emptySpecification mapDefinition : (Type a -> Result e (Type b)) -> (Value a -> Value b) -> Definition a -> Result (List e) (Definition b) mapDefinition mapType mapValue def = let - dependenciesResult : Result (List e) (Dict Path (Declaration b)) + dependenciesResult : Result (List e) (Dict Path (Specification b)) dependenciesResult = def.dependencies |> Dict.toList |> List.map - (\( packagePath, packageDecl ) -> - packageDecl - |> mapDeclaration mapType mapValue + (\( packagePath, packageSpec ) -> + packageSpec + |> mapSpecification mapType mapValue |> Result.map (Tuple.pair packagePath) ) |> ResultList.toResult @@ -147,17 +147,17 @@ eraseDefinitionExtra def = |> Result.withDefault emptyDefinition -encodeDeclaration : (extra -> Encode.Value) -> Declaration extra -> Encode.Value -encodeDeclaration encodeExtra decl = +encodeSpecification : (extra -> Encode.Value) -> Specification extra -> Encode.Value +encodeSpecification encodeExtra spec = Encode.object [ ( "modules" - , decl.modules + , spec.modules |> Dict.toList |> Encode.list - (\( moduleName, moduleDecl ) -> + (\( moduleName, moduleSpec ) -> Encode.object [ ( "name", encodePath moduleName ) - , ( "decl", Module.encodeDeclaration encodeExtra moduleDecl ) + , ( "spec", Module.encodeSpecification encodeExtra moduleSpec ) ] ) ) @@ -171,10 +171,10 @@ encodeDefinition encodeExtra def = , def.dependencies |> Dict.toList |> Encode.list - (\( packageName, packageDecl ) -> + (\( packageName, packageSpec ) -> Encode.object [ ( "name", encodePath packageName ) - , ( "decl", encodeDeclaration encodeExtra packageDecl ) + , ( "spec", encodeSpecification encodeExtra packageSpec ) ] ) ) diff --git a/src/Morphir/IR/Advanced/Type.elm b/src/Morphir/IR/Advanced/Type.elm index b61f6b8af..fe3fe909d 100644 --- a/src/Morphir/IR/Advanced/Type.elm +++ b/src/Morphir/IR/Advanced/Type.elm @@ -3,12 +3,12 @@ module Morphir.IR.Advanced.Type exposing , variable, reference, tuple, record, extensibleRecord, function, unit , matchVariable, matchReference, matchTuple, matchRecord, matchExtensibleRecord, matchFunction, matchUnit , Field, matchField, mapFieldName, mapFieldType - , Declaration(..), typeAliasDeclaration, opaqueTypeDeclaration, customTypeDeclaration, matchCustomTypeDeclaration + , Specification(..), typeAliasSpecification, opaqueTypeSpecification, customTypeSpecification, matchCustomTypeSpecification , Definition(..), typeAliasDefinition, customTypeDefinition , Constructors , fuzzType - , encodeType, decodeType, encodeDeclaration, encodeDefinition - , Constructor, definitionToDeclaration, mapDeclaration, mapDefinition, mapTypeExtra, rewriteType + , encodeType, decodeType, encodeSpecification, encodeDefinition + , Constructor, definitionToSpecification, mapDefinition, mapSpecification, mapTypeExtra, rewriteType ) {-| This module contains the building blocks of types in the Morphir IR. @@ -34,9 +34,9 @@ module Morphir.IR.Advanced.Type exposing @docs Field, matchField, mapFieldName, mapFieldType -# Declaration +# Specification -@docs Declaration, typeAliasDeclaration, opaqueTypeDeclaration, customTypeDeclaration, matchCustomTypeDeclaration +@docs Specification, typeAliasSpecification, opaqueTypeSpecification, customTypeSpecification, matchCustomTypeSpecification # Definition @@ -56,7 +56,7 @@ module Morphir.IR.Advanced.Type exposing # Serialization -@docs encodeType, decodeType, encodeDeclaration, encodeDefinition +@docs encodeType, decodeType, encodeSpecification, encodeDefinition -} @@ -102,10 +102,10 @@ type alias Field extra = {-| -} -type Declaration extra - = TypeAliasDeclaration (List Name) (Type extra) - | OpaqueTypeDeclaration (List Name) - | CustomTypeDeclaration (List Name) (Constructors extra) +type Specification extra + = TypeAliasSpecification (List Name) (Type extra) + | OpaqueTypeSpecification (List Name) + | CustomTypeSpecification (List Name) (Constructors extra) {-| This syntax represents a type definition. For example: @@ -132,34 +132,34 @@ type alias Constructor extra = ( Name, List ( Name, Type extra ) ) -definitionToDeclaration : Definition extra -> Declaration extra -definitionToDeclaration def = +definitionToSpecification : Definition extra -> Specification extra +definitionToSpecification def = case def of TypeAliasDefinition params exp -> - TypeAliasDeclaration params exp + TypeAliasSpecification params exp CustomTypeDefinition params accessControlledCtors -> case accessControlledCtors |> withPublicAccess of Just ctors -> - CustomTypeDeclaration params ctors + CustomTypeSpecification params ctors Nothing -> - OpaqueTypeDeclaration params + OpaqueTypeSpecification params -mapDeclaration : (Type a -> Result e (Type b)) -> Declaration a -> Result (List e) (Declaration b) -mapDeclaration f decl = - case decl of - TypeAliasDeclaration params tpe -> +mapSpecification : (Type a -> Result e (Type b)) -> Specification a -> Result (List e) (Specification b) +mapSpecification f spec = + case spec of + TypeAliasSpecification params tpe -> f tpe - |> Result.map (TypeAliasDeclaration params) + |> Result.map (TypeAliasSpecification params) |> Result.mapError List.singleton - OpaqueTypeDeclaration params -> - OpaqueTypeDeclaration params + OpaqueTypeSpecification params -> + OpaqueTypeSpecification params |> Ok - CustomTypeDeclaration params constructors -> + CustomTypeSpecification params constructors -> let ctorsResult : Result (List e) (Constructors b) ctorsResult = @@ -179,7 +179,7 @@ mapDeclaration f decl = |> Result.mapError List.concat in ctorsResult - |> Result.map (CustomTypeDeclaration params) + |> Result.map (CustomTypeSpecification params) mapDefinition : (Type a -> Result e (Type b)) -> Definition a -> Result (List e) (Definition b) @@ -522,28 +522,28 @@ customTypeDefinition typeParams ctors = {-| -} -typeAliasDeclaration : List Name -> Type extra -> Declaration extra -typeAliasDeclaration typeParams typeExp = - TypeAliasDeclaration typeParams typeExp +typeAliasSpecification : List Name -> Type extra -> Specification extra +typeAliasSpecification typeParams typeExp = + TypeAliasSpecification typeParams typeExp {-| -} -opaqueTypeDeclaration : List Name -> Declaration extra -opaqueTypeDeclaration typeParams = - OpaqueTypeDeclaration typeParams +opaqueTypeSpecification : List Name -> Specification extra +opaqueTypeSpecification typeParams = + OpaqueTypeSpecification typeParams {-| -} -customTypeDeclaration : List Name -> Constructors extra -> Declaration extra -customTypeDeclaration typeParams ctors = - CustomTypeDeclaration typeParams ctors +customTypeSpecification : List Name -> Constructors extra -> Specification extra +customTypeSpecification typeParams ctors = + CustomTypeSpecification typeParams ctors {-| -} -matchCustomTypeDeclaration : Pattern (List Name) a -> Pattern (Constructors extra) b -> Pattern (Declaration extra) ( a, b ) -matchCustomTypeDeclaration matchTypeParams matchCtors declToMatch = - case declToMatch of - CustomTypeDeclaration typeParams ctors -> +matchCustomTypeSpecification : Pattern (List Name) a -> Pattern (Constructors extra) b -> Pattern (Specification extra) ( a, b ) +matchCustomTypeSpecification matchTypeParams matchCtors specToMatch = + case specToMatch of + CustomTypeSpecification typeParams ctors -> Maybe.map2 Tuple.pair (matchTypeParams typeParams) (matchCtors ctors) @@ -870,23 +870,23 @@ decodeField decodeExtra = {-| -} -encodeDeclaration : (extra -> Encode.Value) -> Declaration extra -> Encode.Value -encodeDeclaration encodeExtra decl = - case decl of - TypeAliasDeclaration params exp -> +encodeSpecification : (extra -> Encode.Value) -> Specification extra -> Encode.Value +encodeSpecification encodeExtra spec = + case spec of + TypeAliasSpecification params exp -> Encode.object [ ( "$type", Encode.string "typeAlias" ) , ( "params", Encode.list encodeName params ) , ( "exp", encodeType encodeExtra exp ) ] - OpaqueTypeDeclaration params -> + OpaqueTypeSpecification params -> Encode.object [ ( "$type", Encode.string "opaqueType" ) , ( "params", Encode.list encodeName params ) ] - CustomTypeDeclaration params ctors -> + CustomTypeSpecification params ctors -> Encode.object [ ( "$type", Encode.string "customType" ) , ( "params", Encode.list encodeName params ) diff --git a/src/Morphir/IR/Advanced/Value.elm b/src/Morphir/IR/Advanced/Value.elm index b40fc62b1..e272c6756 100644 --- a/src/Morphir/IR/Advanced/Value.elm +++ b/src/Morphir/IR/Advanced/Value.elm @@ -3,10 +3,10 @@ module Morphir.IR.Advanced.Value exposing , tuple, variable, ifThenElse, patternMatch, update, unit , Literal(..), boolLiteral, charLiteral, stringLiteral, intLiteral, floatLiteral , Pattern(..), wildcardPattern, asPattern, tuplePattern, recordPattern, constructorPattern, emptyListPattern, headTailPattern, literalPattern - , Declaration + , Specification , Definition(..), typedDefinition, untypedDefinition - , encodeValue, encodeDeclaration, encodeDefinition - , getDefinitionBody, mapDeclaration, mapDefinition, mapValueExtra + , encodeValue, encodeSpecification, encodeDefinition + , getDefinitionBody, mapDefinition, mapSpecification, mapValueExtra ) {-| This module contains the building blocks of values in the Morphir IR. @@ -42,17 +42,17 @@ destructuring and pattern-matching. Pattern-matching is a combination of destruc @docs Pattern, wildcardPattern, asPattern, tuplePattern, recordPattern, constructorPattern, emptyListPattern, headTailPattern, literalPattern -# Declaration +# Specification -A declaration is the specification of what the value or function +The specification of what the value or function is without the actual data or logic behind it. -@docs Declaration +@docs Specification # Definition -A definition is the actual data or logic as opposed to a declaration +A definition is the actual data or logic as opposed to a specification which is just the specification of those. Value definitions can be typed or untyped. Exposed values have to be typed. @docs Definition, typedDefinition, untypedDefinition @@ -60,7 +60,7 @@ which is just the specification of those. Value definitions can be typed or unty # Serialization -@docs encodeValue, encodeDeclaration, encodeDefinition +@docs encodeValue, encodeSpecification, encodeDefinition -} @@ -88,12 +88,12 @@ type Value extra | FieldFunction Name extra | Apply (Value extra) (Value extra) extra | Lambda (Pattern extra) (Value extra) extra - | LetDef Name (Definition extra) (Value extra) extra - | LetRec (List ( Name, Definition extra )) (Value extra) extra - | LetDestruct (Pattern extra) (Value extra) (Value extra) extra + | LetDefinition Name (Definition extra) (Value extra) extra + | LetRecursion (List ( Name, Definition extra )) (Value extra) extra + | Destructure (Pattern extra) (Value extra) (Value extra) extra | IfThenElse (Value extra) (Value extra) (Value extra) extra | PatternMatch (Value extra) (List ( Pattern extra, Value extra )) extra - | Update (Value extra) (List ( Name, Value extra )) extra + | UpdateRecord (Value extra) (List ( Name, Value extra )) extra | Unit extra @@ -120,16 +120,16 @@ type Pattern extra | LiteralPattern Literal extra -{-| Type that represents a value or function declaration. A declaration is the specification of what the value or function +{-| Type that represents a value or function specification. The specification of what the value or function is without the actual data or logic behind it. -} -type alias Declaration extra = +type alias Specification extra = { inputs : List ( Name, Type extra ) , output : Type extra } -{-| Type that represents a value or function definition. A definition is the actual data or logic as opposed to a declaration +{-| Type that represents a value or function definition. A definition is the actual data or logic as opposed to a specification which is just the specification of those. Value definitions can be typed or untyped. Exposed values have to be typed. -} type Definition extra @@ -148,8 +148,8 @@ getDefinitionBody def = --- definitionToDeclaration : Definition extra -> Maybe (Declaration extra) --- definitionToDeclaration def = +-- definitionToSpecification : Definition extra -> Maybe (Specification extra) +-- definitionToSpecification def = -- case def of -- TypedDefinition valueType argNames _ -> -- let @@ -161,11 +161,11 @@ getDefinitionBody def = -- in -mapDeclaration : (Type a -> Result e (Type b)) -> (Value a -> Value b) -> Declaration a -> Result (List e) (Declaration b) -mapDeclaration mapType mapValue decl = +mapSpecification : (Type a -> Result e (Type b)) -> (Value a -> Value b) -> Specification a -> Result (List e) (Specification b) +mapSpecification mapType mapValue spec = let inputsResult = - decl.inputs + spec.inputs |> List.map (\( name, tpe ) -> mapType tpe @@ -174,10 +174,10 @@ mapDeclaration mapType mapValue decl = |> ResultList.toResult outputResult = - mapType decl.output + mapType spec.output |> Result.mapError List.singleton in - Result.map2 Declaration + Result.map2 Specification inputsResult outputResult @@ -241,11 +241,11 @@ mapValueExtra f v = Lambda argumentPattern body extra -> Lambda (mapPatternExtra f argumentPattern) (mapValueExtra f body) (f extra) - LetDef valueName valueDefinition inValue extra -> - LetDef valueName (mapDefinitionExtra f valueDefinition) (mapValueExtra f inValue) (f extra) + LetDefinition valueName valueDefinition inValue extra -> + LetDefinition valueName (mapDefinitionExtra f valueDefinition) (mapValueExtra f inValue) (f extra) - LetRec valueDefinitions inValue extra -> - LetRec + LetRecursion valueDefinitions inValue extra -> + LetRecursion (valueDefinitions |> List.map (\( name, def ) -> @@ -255,8 +255,8 @@ mapValueExtra f v = (mapValueExtra f inValue) (f extra) - LetDestruct pattern valueToDestruct inValue extra -> - LetDestruct (mapPatternExtra f pattern) (mapValueExtra f valueToDestruct) (mapValueExtra f inValue) (f extra) + Destructure pattern valueToDestruct inValue extra -> + Destructure (mapPatternExtra f pattern) (mapValueExtra f valueToDestruct) (mapValueExtra f inValue) (f extra) IfThenElse condition thenBranch elseBranch extra -> IfThenElse (mapValueExtra f condition) (mapValueExtra f thenBranch) (mapValueExtra f elseBranch) (f extra) @@ -271,8 +271,8 @@ mapValueExtra f v = ) (f extra) - Update valueToUpdate fieldsToUpdate extra -> - Update (mapValueExtra f valueToUpdate) + UpdateRecord valueToUpdate fieldsToUpdate extra -> + UpdateRecord (mapValueExtra f valueToUpdate) (fieldsToUpdate |> List.map (\( fieldName, fieldValue ) -> @@ -512,7 +512,7 @@ lambda argumentPattern body extra = -} letDef : Name -> Definition extra -> Value extra -> extra -> Value extra letDef valueName valueDefinition inValue extra = - LetDef valueName valueDefinition inValue extra + LetDefinition valueName valueDefinition inValue extra {-| Represents a let expression with one or many recursive definitions. @@ -534,7 +534,7 @@ letDef valueName valueDefinition inValue extra = -} letRec : List ( Name, Definition extra ) -> Value extra -> extra -> Value extra letRec valueDefinitions inValue extra = - LetRec valueDefinitions inValue extra + LetRecursion valueDefinitions inValue extra {-| Represents a let expression that extracts values using a pattern. @@ -551,7 +551,7 @@ letRec valueDefinitions inValue extra = -} letDestruct : Pattern extra -> Value extra -> Value extra -> extra -> Value extra letDestruct pattern valueToDestruct inValue extra = - LetDestruct pattern valueToDestruct inValue extra + Destructure pattern valueToDestruct inValue extra {-| Represents and if/then/else expression. @@ -596,7 +596,7 @@ patternMatch branchOutOn cases extra = -} update : Value extra -> List ( Name, Value extra ) -> extra -> Value extra update valueToUpdate fieldsToUpdate extra = - Update valueToUpdate fieldsToUpdate extra + UpdateRecord valueToUpdate fieldsToUpdate extra {-| Represents the unit value. @@ -912,7 +912,7 @@ encodeValue encodeExtra v = , ( "extra", encodeExtra extra ) ] - LetDef valueName valueDefinition inValue extra -> + LetDefinition valueName valueDefinition inValue extra -> Encode.object [ typeTag "letDef" , ( "valueName", encodeName valueName ) @@ -921,7 +921,7 @@ encodeValue encodeExtra v = , ( "extra", encodeExtra extra ) ] - LetRec valueDefinitions inValue extra -> + LetRecursion valueDefinitions inValue extra -> Encode.object [ typeTag "letRec" , ( "valueDefintions" @@ -938,7 +938,7 @@ encodeValue encodeExtra v = , ( "extra", encodeExtra extra ) ] - LetDestruct pattern valueToDestruct inValue extra -> + Destructure pattern valueToDestruct inValue extra -> Encode.object [ typeTag "letDestruct" , ( "pattern", encodePattern encodeExtra pattern ) @@ -973,7 +973,7 @@ encodeValue encodeExtra v = , ( "extra", encodeExtra extra ) ] - Update valueToUpdate fieldsToUpdate extra -> + UpdateRecord valueToUpdate fieldsToUpdate extra -> Encode.object [ typeTag "update" , ( "valueToUpdate", encodeValue encodeExtra valueToUpdate ) @@ -1075,14 +1075,14 @@ decodeValue decodeExtra = (Decode.field "extra" decodeExtra) "letDef" -> - Decode.map4 LetDef + Decode.map4 LetDefinition (Decode.field "valueName" decodeName) (Decode.field "valueDefintion" <| decodeDefinition decodeExtra) (Decode.field "inValue" <| decodeValue decodeExtra) (Decode.field "extra" decodeExtra) "letRec" -> - Decode.map3 LetRec + Decode.map3 LetRecursion (Decode.field "valueDefintions" (Decode.list (Decode.map2 Tuple.pair @@ -1095,7 +1095,7 @@ decodeValue decodeExtra = (Decode.field "extra" decodeExtra) "letDestruct" -> - Decode.map4 LetDestruct + Decode.map4 Destructure (Decode.field "pattern" <| decodePattern decodeExtra) (Decode.field "valueToDestruct" <| decodeValue decodeExtra) (Decode.field "inValue" <| decodeValue decodeExtra) @@ -1121,7 +1121,7 @@ decodeValue decodeExtra = (Decode.field "extra" decodeExtra) "update" -> - Decode.map3 Update + Decode.map3 UpdateRecord (Decode.field "valueToUpdate" <| decodeValue decodeExtra) (Decode.field "fieldsToUpdate" <| Decode.list <| @@ -1337,11 +1337,11 @@ decodeLiteral = ) -encodeDeclaration : (extra -> Encode.Value) -> Declaration extra -> Encode.Value -encodeDeclaration encodeExtra decl = +encodeSpecification : (extra -> Encode.Value) -> Specification extra -> Encode.Value +encodeSpecification encodeExtra spec = Encode.object [ ( "inputs" - , decl.inputs + , spec.inputs |> Encode.list (\( argName, argType ) -> Encode.object @@ -1350,7 +1350,7 @@ encodeDeclaration encodeExtra decl = ] ) ) - , ( "output", encodeType encodeExtra decl.output ) + , ( "output", encodeType encodeExtra spec.output ) ] diff --git a/src/Morphir/IR/Package.elm b/src/Morphir/IR/Package.elm index 7c5dad0f6..4bf9124eb 100644 --- a/src/Morphir/IR/Package.elm +++ b/src/Morphir/IR/Package.elm @@ -1,11 +1,11 @@ module Morphir.IR.Package exposing - ( Declaration + ( Specification , Definition ) {-| Tools to work with packages. -@docs Declaration +@docs Specification @docs Definition @@ -14,10 +14,10 @@ module Morphir.IR.Package exposing import Morphir.IR.Advanced.Package as Advanced -{-| Type that represents a package declaration. +{-| Type that represents a package specification. -} -type alias Declaration = - Advanced.Declaration () +type alias Specification = + Advanced.Specification () {-| Type that represents a package definition. diff --git a/src/Morphir/IR/SDK.elm b/src/Morphir/IR/SDK.elm index b8e45fe5a..4f4c7790c 100644 --- a/src/Morphir/IR/SDK.elm +++ b/src/Morphir/IR/SDK.elm @@ -12,17 +12,17 @@ import Morphir.IR.SDK.Result as Result import Morphir.IR.SDK.String as String -packageDeclaration : Package.Declaration () -packageDeclaration = +packageSpec : Package.Specification () +packageSpec = { modules = Dict.fromList - [ ( [ [ "bool" ] ], Bool.moduleDeclaration ) - , ( [ [ "char" ] ], Char.moduleDeclaration ) - , ( [ [ "int" ] ], Int.moduleDeclaration ) - , ( [ [ "float" ] ], Float.moduleDeclaration ) - , ( [ [ "string" ] ], String.moduleDeclaration ) - , ( [ [ "maybe" ] ], Maybe.moduleDeclaration ) - , ( [ [ "result" ] ], Result.moduleDeclaration ) - , ( [ [ "list" ] ], List.moduleDeclaration ) + [ ( [ [ "bool" ] ], Bool.moduleSpec ) + , ( [ [ "char" ] ], Char.moduleSpec ) + , ( [ [ "int" ] ], Int.moduleSpec ) + , ( [ [ "float" ] ], Float.moduleSpec ) + , ( [ [ "string" ] ], String.moduleSpec ) + , ( [ [ "maybe" ] ], Maybe.moduleSpec ) + , ( [ [ "result" ] ], Result.moduleSpec ) + , ( [ [ "list" ] ], List.moduleSpec ) ] } diff --git a/src/Morphir/IR/SDK/Bool.elm b/src/Morphir/IR/SDK/Bool.elm index ecda1f068..d747e9faa 100644 --- a/src/Morphir/IR/SDK/Bool.elm +++ b/src/Morphir/IR/SDK/Bool.elm @@ -2,7 +2,7 @@ module Morphir.IR.SDK.Bool exposing (..) import Dict import Morphir.IR.Advanced.Module as Module -import Morphir.IR.Advanced.Type exposing (Declaration(..), Type(..)) +import Morphir.IR.Advanced.Type exposing (Specification(..), Type(..)) import Morphir.IR.FQName as FQName exposing (FQName) import Morphir.IR.Name as Name import Morphir.IR.Path exposing (Path) @@ -15,11 +15,11 @@ moduleName = [ [ "bool" ] ] -moduleDeclaration : Module.Declaration () -moduleDeclaration = +moduleSpec : Module.Specification () +moduleSpec = { types = Dict.fromList - [ ( [ "bool" ], OpaqueTypeDeclaration [] ) + [ ( [ "bool" ], OpaqueTypeSpecification [] ) ] , values = Dict.empty diff --git a/src/Morphir/IR/SDK/Char.elm b/src/Morphir/IR/SDK/Char.elm index 29d2383a7..8782a4724 100644 --- a/src/Morphir/IR/SDK/Char.elm +++ b/src/Morphir/IR/SDK/Char.elm @@ -2,7 +2,7 @@ module Morphir.IR.SDK.Char exposing (..) import Dict import Morphir.IR.Advanced.Module as Module -import Morphir.IR.Advanced.Type exposing (Declaration(..), Type(..)) +import Morphir.IR.Advanced.Type exposing (Specification(..), Type(..)) import Morphir.IR.FQName as FQName exposing (FQName) import Morphir.IR.Name as Name import Morphir.IR.Path exposing (Path) @@ -15,11 +15,11 @@ moduleName = [ [ "char" ] ] -moduleDeclaration : Module.Declaration () -moduleDeclaration = +moduleSpec : Module.Specification () +moduleSpec = { types = Dict.fromList - [ ( [ "char" ], OpaqueTypeDeclaration [] ) + [ ( [ "char" ], OpaqueTypeSpecification [] ) ] , values = Dict.empty diff --git a/src/Morphir/IR/SDK/Float.elm b/src/Morphir/IR/SDK/Float.elm index 14062ef0c..54a2a8c9a 100644 --- a/src/Morphir/IR/SDK/Float.elm +++ b/src/Morphir/IR/SDK/Float.elm @@ -2,7 +2,7 @@ module Morphir.IR.SDK.Float exposing (..) import Dict import Morphir.IR.Advanced.Module as Module -import Morphir.IR.Advanced.Type exposing (Declaration(..), Type(..)) +import Morphir.IR.Advanced.Type exposing (Specification(..), Type(..)) import Morphir.IR.FQName as FQName exposing (FQName) import Morphir.IR.Name as Name import Morphir.IR.Path exposing (Path) @@ -15,11 +15,11 @@ moduleName = [ [ "float" ] ] -moduleDeclaration : Module.Declaration () -moduleDeclaration = +moduleSpec : Module.Specification () +moduleSpec = { types = Dict.fromList - [ ( [ "float" ], OpaqueTypeDeclaration [] ) + [ ( [ "float" ], OpaqueTypeSpecification [] ) ] , values = Dict.empty diff --git a/src/Morphir/IR/SDK/Int.elm b/src/Morphir/IR/SDK/Int.elm index 2b8097184..cd285bdfa 100644 --- a/src/Morphir/IR/SDK/Int.elm +++ b/src/Morphir/IR/SDK/Int.elm @@ -2,7 +2,7 @@ module Morphir.IR.SDK.Int exposing (..) import Dict import Morphir.IR.Advanced.Module as Module -import Morphir.IR.Advanced.Type exposing (Declaration(..), Type(..)) +import Morphir.IR.Advanced.Type exposing (Specification(..), Type(..)) import Morphir.IR.FQName as FQName exposing (FQName) import Morphir.IR.Name as Name import Morphir.IR.Path exposing (Path) @@ -15,11 +15,11 @@ moduleName = [ [ "int" ] ] -moduleDeclaration : Module.Declaration () -moduleDeclaration = +moduleSpec : Module.Specification () +moduleSpec = { types = Dict.fromList - [ ( [ "int" ], OpaqueTypeDeclaration [] ) + [ ( [ "int" ], OpaqueTypeSpecification [] ) ] , values = Dict.empty diff --git a/src/Morphir/IR/SDK/List.elm b/src/Morphir/IR/SDK/List.elm index ab7e973dd..7471ec386 100644 --- a/src/Morphir/IR/SDK/List.elm +++ b/src/Morphir/IR/SDK/List.elm @@ -2,7 +2,7 @@ module Morphir.IR.SDK.List exposing (..) import Dict import Morphir.IR.Advanced.Module as Module -import Morphir.IR.Advanced.Type exposing (Declaration(..), Type(..)) +import Morphir.IR.Advanced.Type exposing (Specification(..), Type(..)) import Morphir.IR.FQName as FQName exposing (FQName) import Morphir.IR.Name as Name import Morphir.IR.Path exposing (Path) @@ -15,11 +15,11 @@ moduleName = [ [ "list" ] ] -moduleDeclaration : Module.Declaration () -moduleDeclaration = +moduleSpec : Module.Specification () +moduleSpec = { types = Dict.fromList - [ ( [ "list" ], OpaqueTypeDeclaration [ [ "a" ] ] ) + [ ( [ "list" ], OpaqueTypeSpecification [ [ "a" ] ] ) ] , values = Dict.empty diff --git a/src/Morphir/IR/SDK/Maybe.elm b/src/Morphir/IR/SDK/Maybe.elm index 281087162..d5ae7d8f9 100644 --- a/src/Morphir/IR/SDK/Maybe.elm +++ b/src/Morphir/IR/SDK/Maybe.elm @@ -2,7 +2,7 @@ module Morphir.IR.SDK.Maybe exposing (..) import Dict import Morphir.IR.Advanced.Module as Module -import Morphir.IR.Advanced.Type as Type exposing (Declaration(..), Type(..)) +import Morphir.IR.Advanced.Type as Type exposing (Specification(..), Type(..)) import Morphir.IR.FQName as FQName exposing (FQName) import Morphir.IR.Name as Name import Morphir.IR.Path exposing (Path) @@ -15,12 +15,12 @@ moduleName = [ [ "maybe" ] ] -moduleDeclaration : Module.Declaration () -moduleDeclaration = +moduleSpec : Module.Specification () +moduleSpec = { types = Dict.fromList [ ( [ "maybe" ] - , CustomTypeDeclaration [ [ "a" ] ] + , CustomTypeSpecification [ [ "a" ] ] [ ( [ "just" ], [ ( [ "value" ], Type.Variable [ "a" ] () ) ] ) , ( [ "nothing" ], [] ) ] diff --git a/src/Morphir/IR/SDK/Result.elm b/src/Morphir/IR/SDK/Result.elm index d15d93f20..9899c029a 100644 --- a/src/Morphir/IR/SDK/Result.elm +++ b/src/Morphir/IR/SDK/Result.elm @@ -2,7 +2,7 @@ module Morphir.IR.SDK.Result exposing (..) import Dict import Morphir.IR.Advanced.Module as Module -import Morphir.IR.Advanced.Type as Type exposing (Declaration(..), Type(..)) +import Morphir.IR.Advanced.Type as Type exposing (Specification(..), Type(..)) import Morphir.IR.FQName as FQName exposing (FQName) import Morphir.IR.Name as Name import Morphir.IR.Path exposing (Path) @@ -15,12 +15,12 @@ moduleName = [ [ "result" ] ] -moduleDeclaration : Module.Declaration () -moduleDeclaration = +moduleSpec : Module.Specification () +moduleSpec = { types = Dict.fromList [ ( [ "result" ] - , CustomTypeDeclaration [ [ "e" ], [ "a" ] ] + , CustomTypeSpecification [ [ "e" ], [ "a" ] ] [ ( [ "ok" ], [ ( [ "value" ], Type.Variable [ "a" ] () ) ] ) , ( [ "err" ], [ ( [ "error" ], Type.Variable [ "e" ] () ) ] ) ] diff --git a/src/Morphir/IR/SDK/String.elm b/src/Morphir/IR/SDK/String.elm index d46b9df82..0e2091158 100644 --- a/src/Morphir/IR/SDK/String.elm +++ b/src/Morphir/IR/SDK/String.elm @@ -2,7 +2,7 @@ module Morphir.IR.SDK.String exposing (..) import Dict import Morphir.IR.Advanced.Module as Module -import Morphir.IR.Advanced.Type exposing (Declaration(..), Type(..)) +import Morphir.IR.Advanced.Type exposing (Specification(..), Type(..)) import Morphir.IR.FQName as FQName exposing (FQName) import Morphir.IR.Name as Name import Morphir.IR.Path exposing (Path) @@ -15,11 +15,11 @@ moduleName = [ [ "string" ] ] -moduleDeclaration : Module.Declaration () -moduleDeclaration = +moduleSpec : Module.Specification () +moduleSpec = { types = Dict.fromList - [ ( [ "string" ], OpaqueTypeDeclaration [] ) + [ ( [ "string" ], OpaqueTypeSpecification [] ) ] , values = Dict.empty diff --git a/src/Morphir/IR/Type.elm b/src/Morphir/IR/Type.elm index 54c497e82..e7bbbd44a 100644 --- a/src/Morphir/IR/Type.elm +++ b/src/Morphir/IR/Type.elm @@ -3,7 +3,7 @@ module Morphir.IR.Type exposing , variable, reference, tuple, record, extensibleRecord, function, unit , matchVariable, matchReference, matchTuple, matchRecord, matchExtensibleRecord, matchFunction, matchUnit , Field, field, matchField - , Declaration + , Specification , Definition ) @@ -30,9 +30,9 @@ module Morphir.IR.Type exposing @docs Field, field, matchField -# Declaration +# Specification -@docs Declaration +@docs Specification # Definition @@ -72,8 +72,8 @@ type alias Field = {-| -} -type alias Declaration = - Advanced.Declaration () +type alias Specification = + Advanced.Specification () {-| -} diff --git a/src/Morphir/IR/Value.elm b/src/Morphir/IR/Value.elm index 36e7e2662..3df152a5b 100644 --- a/src/Morphir/IR/Value.elm +++ b/src/Morphir/IR/Value.elm @@ -3,7 +3,7 @@ module Morphir.IR.Value exposing , tuple, variable, ifThenElse, patternMatch, update, unit , Literal, boolLiteral, charLiteral, stringLiteral, intLiteral, floatLiteral , Pattern, wildcardPattern, asPattern, tuplePattern, recordPattern, constructorPattern, emptyListPattern, headTailPattern, literalPattern - , Declaration + , Specification , Definition, typedDefinition, untypedDefinition ) @@ -40,17 +40,17 @@ destructuring and pattern-matching. Pattern-matching is a combination of destruc @docs Pattern, wildcardPattern, asPattern, tuplePattern, recordPattern, constructorPattern, emptyListPattern, headTailPattern, literalPattern -# Declaration +# Specification -A declaration is the specification of what the value or function +The specification of what the value or function is without the actual data or logic behind it. -@docs Declaration +@docs Specification # Definition -A definition is the actual data or logic as opposed to a declaration +A definition is the actual data or logic as opposed to a specification which is just the specification of those. Value definitions can be typed or untyped. Exposed values have to be typed. @docs Definition, typedDefinition, untypedDefinition @@ -81,14 +81,14 @@ type alias Pattern = Advanced.Pattern () -{-| Type that represents a value or function declaration. A declaration is the specification of what the value or function +{-| Type that represents a value or function specification. The specification of what the value or function is without the actual data or logic behind it. -} -type alias Declaration = - Advanced.Declaration () +type alias Specification = + Advanced.Specification () -{-| Type that represents a value or function definition. A definition is the actual data or logic as opposed to a declaration +{-| Type that represents a value or function definition. A definition is the actual data or logic as opposed to a specification which is just the specification of those. Value definitions can be typed or untyped. Exposed values have to be typed. -} type alias Definition = @@ -550,8 +550,11 @@ arguments. The examples below try to visualize the process. body -- the above is logically translated to the below - - myFun : Int -> Int -> { foo : Int } -> Int -- the value type does not change in the process + myFun : + Int + -> Int + -> { foo : Int } + -> Int -- the value type does not change in the process myFun a b = \{ foo } -> body @@ -575,7 +578,6 @@ arguments. The examples below try to visualize the process. body -- the above is logically translated to the below - myFun a b = \{ foo } -> body From 74185340252b4809a100c0df0aa11165defd5660 Mon Sep 17 00:00:00 2001 From: Attila Mihaly Date: Sat, 28 Mar 2020 14:28:07 -0400 Subject: [PATCH 04/42] Moved Advanced module up a level. #43 --- elm.json | 3 - src/Morphir/Elm/Backend/Codec/DecoderGen.elm | 2 +- src/Morphir/Elm/Backend/Codec/EncoderGen.elm | 4 +- .../Elm/Backend/Dapr/Stateful/ElmGen.elm | 4 +- src/Morphir/Elm/Frontend.elm | 8 +- src/Morphir/Elm/Frontend/Resolve.elm | 6 +- src/Morphir/IR/Advanced/Module.elm | 219 --- src/Morphir/IR/Advanced/Package.elm | 192 --- src/Morphir/IR/Advanced/Type.elm | 934 ----------- src/Morphir/IR/Advanced/Value.elm | 1395 ----------------- src/Morphir/IR/Module.elm | 216 ++- src/Morphir/IR/Package.elm | 180 ++- src/Morphir/IR/SDK.elm | 2 +- src/Morphir/IR/SDK/Bool.elm | 4 +- src/Morphir/IR/SDK/Char.elm | 4 +- src/Morphir/IR/SDK/Float.elm | 4 +- src/Morphir/IR/SDK/Int.elm | 4 +- src/Morphir/IR/SDK/List.elm | 4 +- src/Morphir/IR/SDK/Maybe.elm | 4 +- src/Morphir/IR/SDK/Result.elm | 4 +- src/Morphir/IR/SDK/String.elm | 4 +- src/Morphir/IR/Type.elm | 809 ++++++++-- src/Morphir/IR/Value.elm | 1017 ++++++++++-- tests/Morphir/Elm/FrontendTests.elm | 5 +- 24 files changed, 2037 insertions(+), 2991 deletions(-) delete mode 100644 src/Morphir/IR/Advanced/Module.elm delete mode 100644 src/Morphir/IR/Advanced/Package.elm delete mode 100644 src/Morphir/IR/Advanced/Type.elm delete mode 100644 src/Morphir/IR/Advanced/Value.elm diff --git a/elm.json b/elm.json index a00d0dc4d..53a4ae801 100644 --- a/elm.json +++ b/elm.json @@ -10,15 +10,12 @@ "Morphir.Rewrite", "Morphir.IR.AccessControlled", "Morphir.IR.Package", - "Morphir.IR.Advanced.Package", "Morphir.IR.Module", - "Morphir.IR.Advanced.Module", "Morphir.IR.Name", "Morphir.IR.Path", "Morphir.IR.QName", "Morphir.IR.FQName", "Morphir.IR.Type", - "Morphir.IR.Advanced.Type", "Morphir.IR.Value" ], "elm-version": "0.19.0 <= v < 0.20.0", diff --git a/src/Morphir/Elm/Backend/Codec/DecoderGen.elm b/src/Morphir/Elm/Backend/Codec/DecoderGen.elm index bc07c3c05..d1b79446f 100644 --- a/src/Morphir/Elm/Backend/Codec/DecoderGen.elm +++ b/src/Morphir/Elm/Backend/Codec/DecoderGen.elm @@ -6,9 +6,9 @@ import Elm.Syntax.ModuleName exposing (ModuleName) import Elm.Syntax.Pattern exposing (Pattern(..)) import Morphir.Elm.Backend.Utils as Utils exposing (emptyRangeNode) import Morphir.IR.AccessControlled exposing (Access(..), AccessControlled) -import Morphir.IR.Advanced.Type as Type exposing (Constructor, Definition(..), Field, Type(..)) import Morphir.IR.FQName exposing (FQName(..)) import Morphir.IR.Name as Name exposing (Name) +import Morphir.IR.Type as Type exposing (Constructor, Definition(..), Field, Type(..)) typeDefToDecoder : extra -> Name -> AccessControlled (Type.Definition extra) -> Declaration diff --git a/src/Morphir/Elm/Backend/Codec/EncoderGen.elm b/src/Morphir/Elm/Backend/Codec/EncoderGen.elm index d7a14cf40..77659e8f4 100644 --- a/src/Morphir/Elm/Backend/Codec/EncoderGen.elm +++ b/src/Morphir/Elm/Backend/Codec/EncoderGen.elm @@ -8,10 +8,10 @@ import Elm.Syntax.Pattern exposing (Pattern(..), QualifiedNameRef) import Elm.Syntax.Range exposing (emptyRange) import Morphir.Elm.Backend.Utils as Utils exposing (emptyRangeNode) import Morphir.IR.AccessControlled exposing (Access(..), AccessControlled) -import Morphir.IR.Advanced.Type exposing (Constructor, Definition(..), Field, Type(..), record) import Morphir.IR.FQName exposing (FQName(..)) import Morphir.IR.Name as Name exposing (Name, fromString, toCamelCase, toTitleCase) import Morphir.IR.Path as Path exposing (toString) +import Morphir.IR.Type exposing (Constructor, Definition(..), Field, Type(..), record) typeDefToEncoder : extra -> Name -> AccessControlled (Definition extra) -> Declaration @@ -275,7 +275,7 @@ deconsPattern ctorName fields = constructorToRecord : extra -> Constructor extra -> Type extra constructorToRecord e ( _, types ) = let - fields : List (Morphir.IR.Advanced.Type.Field extra) + fields : List (Morphir.IR.Type.Field extra) fields = types |> List.map (\t -> Field (Tuple.first t) (Tuple.second t)) diff --git a/src/Morphir/Elm/Backend/Dapr/Stateful/ElmGen.elm b/src/Morphir/Elm/Backend/Dapr/Stateful/ElmGen.elm index 8d51cd169..4fd5778db 100644 --- a/src/Morphir/Elm/Backend/Dapr/Stateful/ElmGen.elm +++ b/src/Morphir/Elm/Backend/Dapr/Stateful/ElmGen.elm @@ -16,10 +16,10 @@ import Morphir.Elm.Backend.Codec.DecoderGen as DecoderGen exposing (typeDefToDec import Morphir.Elm.Backend.Codec.EncoderGen as EncoderGen exposing (typeDefToEncoder) import Morphir.Elm.Backend.Utils as Utils exposing (emptyRangeNode) import Morphir.Elm.Frontend as Frontend exposing (ContentLocation, ContentRange, SourceFile, SourceLocation, mapDeclarationsToType) -import Morphir.IR.Advanced.Type exposing (Field, Type(..)) import Morphir.IR.FQName exposing (FQName(..)) import Morphir.IR.Name as Name exposing (Name, toCamelCase) import Morphir.IR.Path exposing (Path) +import Morphir.IR.Type exposing (Field, Type(..)) gen : Path -> Name -> Type extra -> Maybe File @@ -529,7 +529,7 @@ morphirToElmTypeDef tpe = (( moduleName, typeName ) |> Utils.emptyRangeNode) innerTypes - Morphir.IR.Advanced.Type.Record fields _ -> + Morphir.IR.Type.Record fields _ -> let morphirToElmField : Field extra -> ( Node String, Node TypeAnnotation ) morphirToElmField field = diff --git a/src/Morphir/Elm/Frontend.elm b/src/Morphir/Elm/Frontend.elm index b1e1706ac..1e5d59654 100644 --- a/src/Morphir/Elm/Frontend.elm +++ b/src/Morphir/Elm/Frontend.elm @@ -16,14 +16,14 @@ import Json.Encode as Encode import Morphir.Elm.Frontend.Resolve as Resolve exposing (ModuleResolver, PackageResolver) import Morphir.Graph as Graph exposing (Graph) import Morphir.IR.AccessControlled exposing (AccessControlled, private, public) -import Morphir.IR.Advanced.Module as Module -import Morphir.IR.Advanced.Package as Package -import Morphir.IR.Advanced.Type as Type exposing (Type) -import Morphir.IR.Advanced.Value as Value exposing (Value) import Morphir.IR.FQName as FQName exposing (FQName, fQName) +import Morphir.IR.Module as Module import Morphir.IR.Name as Name exposing (Name) +import Morphir.IR.Package as Package import Morphir.IR.Path as Path exposing (Path) import Morphir.IR.SDK as SDK +import Morphir.IR.Type as Type exposing (Type) +import Morphir.IR.Value as Value exposing (Value) import Morphir.JsonExtra as JsonExtra import Morphir.ResultList as ResultList import Morphir.Rewrite as Rewrite diff --git a/src/Morphir/Elm/Frontend/Resolve.elm b/src/Morphir/Elm/Frontend/Resolve.elm index 1643c5fde..45392219f 100644 --- a/src/Morphir/Elm/Frontend/Resolve.elm +++ b/src/Morphir/Elm/Frontend/Resolve.elm @@ -6,12 +6,12 @@ import Elm.Syntax.Import exposing (Import) import Elm.Syntax.Node as Node exposing (Node(..)) import Elm.Syntax.Range exposing (emptyRange) import Json.Encode as Encode -import Morphir.IR.Advanced.Module as Module -import Morphir.IR.Advanced.Package as Package -import Morphir.IR.Advanced.Type as Type import Morphir.IR.FQName exposing (FQName, fQName) +import Morphir.IR.Module as Module import Morphir.IR.Name as Name exposing (Name) +import Morphir.IR.Package as Package import Morphir.IR.Path as Path exposing (Path) +import Morphir.IR.Type as Type import Morphir.JsonExtra as JsonExtra import Morphir.Pattern exposing (matchAny) import Set exposing (Set) diff --git a/src/Morphir/IR/Advanced/Module.elm b/src/Morphir/IR/Advanced/Module.elm deleted file mode 100644 index 9a13bebf5..000000000 --- a/src/Morphir/IR/Advanced/Module.elm +++ /dev/null @@ -1,219 +0,0 @@ -module Morphir.IR.Advanced.Module exposing - ( Specification, Definition - , encodeSpecification, encodeDefinition - , definitionToSpecification, eraseSpecificationExtra, mapDefinition, mapSpecification - ) - -{-| Modules are groups of types and values that belong together. - -@docs Specification, Definition - -@docs encodeSpecification, encodeDefinition - --} - -import Dict exposing (Dict) -import Json.Decode as Decode -import Json.Encode as Encode -import Morphir.IR.AccessControlled as AccessControlled exposing (AccessControlled, encodeAccessControlled, withPublicAccess) -import Morphir.IR.Advanced.Type as Type exposing (Type) -import Morphir.IR.Advanced.Value as Value exposing (Value) -import Morphir.IR.Name exposing (Name, encodeName) -import Morphir.ResultList as ResultList - - -{-| Type that represents a module specification. --} -type alias Specification extra = - { types : Dict Name (Type.Specification extra) - , values : Dict Name (Value.Specification extra) - } - - -emptySpecification : Specification extra -emptySpecification = - { types = Dict.empty - , values = Dict.empty - } - - -{-| Type that represents a module definition. It includes types and values. --} -type alias Definition extra = - { types : Dict Name (AccessControlled (Type.Definition extra)) - , values : Dict Name (AccessControlled (Value.Definition extra)) - } - - -definitionToSpecification : Definition extra -> Specification extra -definitionToSpecification def = - { types = - def.types - |> Dict.toList - |> List.filterMap - (\( path, accessControlledType ) -> - accessControlledType - |> withPublicAccess - |> Maybe.map - (\typeDef -> - ( path, Type.definitionToSpecification typeDef ) - ) - ) - |> Dict.fromList - , values = Dict.empty - - -- TODO: implement for values - -- def.values - -- |> Dict.toList - -- |> List.filterMap - -- (\( path, accessControlledValue ) -> - -- accessControlledValue - -- |> withPublicAccess - -- |> Maybe.map - -- (\valueDef -> - -- ( path, Value.definitionToSpecification valueDef ) - -- ) - -- ) - -- |> Dict.fromList - } - - -eraseSpecificationExtra : Specification a -> Specification () -eraseSpecificationExtra spec = - spec - |> mapSpecification - (Type.mapTypeExtra (\_ -> ()) >> Ok) - (Value.mapValueExtra (\_ -> ())) - |> Result.withDefault emptySpecification - - -{-| -} -encodeSpecification : (extra -> Encode.Value) -> Specification extra -> Encode.Value -encodeSpecification encodeExtra spec = - Encode.object - [ ( "types" - , spec.types - |> Dict.toList - |> Encode.list - (\( name, typeSpec ) -> - Encode.object - [ ( "name", encodeName name ) - , ( "spec", Type.encodeSpecification encodeExtra typeSpec ) - ] - ) - ) - , ( "values" - , spec.values - |> Dict.toList - |> Encode.list - (\( name, valueSpec ) -> - Encode.object - [ ( "name", encodeName name ) - , ( "spec", Value.encodeSpecification encodeExtra valueSpec ) - ] - ) - ) - ] - - -mapSpecification : (Type a -> Result e (Type b)) -> (Value a -> Value b) -> Specification a -> Result (List e) (Specification b) -mapSpecification mapType mapValue spec = - let - typesResult : Result (List e) (Dict Name (Type.Specification b)) - typesResult = - spec.types - |> Dict.toList - |> List.map - (\( typeName, typeSpec ) -> - typeSpec - |> Type.mapSpecification mapType - |> Result.map (Tuple.pair typeName) - ) - |> ResultList.toResult - |> Result.map Dict.fromList - |> Result.mapError List.concat - - valuesResult : Result (List e) (Dict Name (Value.Specification b)) - valuesResult = - spec.values - |> Dict.toList - |> List.map - (\( valueName, valueSpec ) -> - valueSpec - |> Value.mapSpecification mapType mapValue - |> Result.map (Tuple.pair valueName) - ) - |> ResultList.toResult - |> Result.map Dict.fromList - |> Result.mapError List.concat - in - Result.map2 Specification - typesResult - valuesResult - - -mapDefinition : (Type a -> Result e (Type b)) -> (Value a -> Value b) -> Definition a -> Result (List e) (Definition b) -mapDefinition mapType mapValue def = - let - typesResult : Result (List e) (Dict Name (AccessControlled (Type.Definition b))) - typesResult = - def.types - |> Dict.toList - |> List.map - (\( typeName, typeDef ) -> - typeDef.value - |> Type.mapDefinition mapType - |> Result.map (AccessControlled typeDef.access) - |> Result.map (Tuple.pair typeName) - ) - |> ResultList.toResult - |> Result.map Dict.fromList - |> Result.mapError List.concat - - valuesResult : Result (List e) (Dict Name (AccessControlled (Value.Definition b))) - valuesResult = - def.values - |> Dict.toList - |> List.map - (\( valueName, valueDef ) -> - valueDef.value - |> Value.mapDefinition mapType mapValue - |> Result.map (AccessControlled valueDef.access) - |> Result.map (Tuple.pair valueName) - ) - |> ResultList.toResult - |> Result.map Dict.fromList - |> Result.mapError List.concat - in - Result.map2 Definition - typesResult - valuesResult - - -{-| -} -encodeDefinition : (extra -> Encode.Value) -> Definition extra -> Encode.Value -encodeDefinition encodeExtra def = - Encode.object - [ ( "types" - , def.types - |> Dict.toList - |> Encode.list - (\( name, typeDef ) -> - Encode.object - [ ( "name", encodeName name ) - , ( "def", encodeAccessControlled (Type.encodeDefinition encodeExtra) typeDef ) - ] - ) - ) - , ( "values" - , def.values - |> Dict.toList - |> Encode.list - (\( name, valueDef ) -> - Encode.object - [ ( "name", encodeName name ) - , ( "def", encodeAccessControlled (Value.encodeDefinition encodeExtra) valueDef ) - ] - ) - ) - ] diff --git a/src/Morphir/IR/Advanced/Package.elm b/src/Morphir/IR/Advanced/Package.elm deleted file mode 100644 index 785c32e83..000000000 --- a/src/Morphir/IR/Advanced/Package.elm +++ /dev/null @@ -1,192 +0,0 @@ -module Morphir.IR.Advanced.Package exposing - ( Specification - , Definition, emptyDefinition - , definitionToSpecification, encodeDefinition, eraseDefinitionExtra, eraseSpecificationExtra - ) - -{-| Tools to work with packages. - -@docs Specification - -@docs Definition, emptyDefinition - --} - -import Dict exposing (Dict) -import Json.Decode as Decode -import Json.Encode as Encode -import Morphir.IR.AccessControlled as AccessControlled exposing (AccessControlled, encodeAccessControlled, withPublicAccess) -import Morphir.IR.Advanced.Module as Module -import Morphir.IR.Advanced.Type as Type exposing (Type) -import Morphir.IR.Advanced.Value as Value exposing (Value) -import Morphir.IR.Path exposing (Path, encodePath) -import Morphir.IR.QName exposing (QName, encodeQName) -import Morphir.ResultList as ResultList - - -{-| Type that represents a package specification. --} -type alias Specification extra = - { modules : Dict Path (Module.Specification extra) - } - - -emptySpecification : Specification extra -emptySpecification = - { modules = Dict.empty - } - - -{-| Type that represents a package definition. --} -type alias Definition extra = - { dependencies : Dict Path (Specification extra) - , modules : Dict Path (AccessControlled (Module.Definition extra)) - } - - -{-| An empty package definition. --} -emptyDefinition : Definition extra -emptyDefinition = - { dependencies = Dict.empty - , modules = Dict.empty - } - - -definitionToSpecification : Definition extra -> Specification extra -definitionToSpecification def = - { modules = - def.modules - |> Dict.toList - |> List.filterMap - (\( path, accessControlledModule ) -> - accessControlledModule - |> withPublicAccess - |> Maybe.map - (\moduleDef -> - ( path, Module.definitionToSpecification moduleDef ) - ) - ) - |> Dict.fromList - } - - -mapSpecification : (Type a -> Result e (Type b)) -> (Value a -> Value b) -> Specification a -> Result (List e) (Specification b) -mapSpecification mapType mapValue spec = - let - modulesResult : Result (List e) (Dict Path (Module.Specification b)) - modulesResult = - spec.modules - |> Dict.toList - |> List.map - (\( modulePath, moduleSpec ) -> - moduleSpec - |> Module.mapSpecification mapType mapValue - |> Result.map (Tuple.pair modulePath) - ) - |> ResultList.toResult - |> Result.map Dict.fromList - |> Result.mapError List.concat - in - Result.map Specification modulesResult - - -eraseSpecificationExtra : Specification a -> Specification () -eraseSpecificationExtra spec = - spec - |> mapSpecification - (Type.mapTypeExtra (\_ -> ()) >> Ok) - (Value.mapValueExtra (\_ -> ())) - |> Result.withDefault emptySpecification - - -mapDefinition : (Type a -> Result e (Type b)) -> (Value a -> Value b) -> Definition a -> Result (List e) (Definition b) -mapDefinition mapType mapValue def = - let - dependenciesResult : Result (List e) (Dict Path (Specification b)) - dependenciesResult = - def.dependencies - |> Dict.toList - |> List.map - (\( packagePath, packageSpec ) -> - packageSpec - |> mapSpecification mapType mapValue - |> Result.map (Tuple.pair packagePath) - ) - |> ResultList.toResult - |> Result.map Dict.fromList - |> Result.mapError List.concat - - modulesResult : Result (List e) (Dict Path (AccessControlled (Module.Definition b))) - modulesResult = - def.modules - |> Dict.toList - |> List.map - (\( modulePath, moduleDef ) -> - moduleDef.value - |> Module.mapDefinition mapType mapValue - |> Result.map (AccessControlled moduleDef.access) - |> Result.map (Tuple.pair modulePath) - ) - |> ResultList.toResult - |> Result.map Dict.fromList - |> Result.mapError List.concat - in - Result.map2 Definition - dependenciesResult - modulesResult - - -eraseDefinitionExtra : Definition a -> Definition () -eraseDefinitionExtra def = - def - |> mapDefinition - (Type.mapTypeExtra (\_ -> ()) >> Ok) - (Value.mapValueExtra (\_ -> ())) - |> Result.withDefault emptyDefinition - - -encodeSpecification : (extra -> Encode.Value) -> Specification extra -> Encode.Value -encodeSpecification encodeExtra spec = - Encode.object - [ ( "modules" - , spec.modules - |> Dict.toList - |> Encode.list - (\( moduleName, moduleSpec ) -> - Encode.object - [ ( "name", encodePath moduleName ) - , ( "spec", Module.encodeSpecification encodeExtra moduleSpec ) - ] - ) - ) - ] - - -encodeDefinition : (extra -> Encode.Value) -> Definition extra -> Encode.Value -encodeDefinition encodeExtra def = - Encode.object - [ ( "dependencies" - , def.dependencies - |> Dict.toList - |> Encode.list - (\( packageName, packageSpec ) -> - Encode.object - [ ( "name", encodePath packageName ) - , ( "spec", encodeSpecification encodeExtra packageSpec ) - ] - ) - ) - , ( "modules" - , def.modules - |> Dict.toList - |> Encode.list - (\( moduleName, moduleDef ) -> - Encode.object - [ ( "name", encodePath moduleName ) - , ( "def", encodeAccessControlled (Module.encodeDefinition encodeExtra) moduleDef ) - ] - ) - ) - ] diff --git a/src/Morphir/IR/Advanced/Type.elm b/src/Morphir/IR/Advanced/Type.elm deleted file mode 100644 index fe3fe909d..000000000 --- a/src/Morphir/IR/Advanced/Type.elm +++ /dev/null @@ -1,934 +0,0 @@ -module Morphir.IR.Advanced.Type exposing - ( Type(..) - , variable, reference, tuple, record, extensibleRecord, function, unit - , matchVariable, matchReference, matchTuple, matchRecord, matchExtensibleRecord, matchFunction, matchUnit - , Field, matchField, mapFieldName, mapFieldType - , Specification(..), typeAliasSpecification, opaqueTypeSpecification, customTypeSpecification, matchCustomTypeSpecification - , Definition(..), typeAliasDefinition, customTypeDefinition - , Constructors - , fuzzType - , encodeType, decodeType, encodeSpecification, encodeDefinition - , Constructor, definitionToSpecification, mapDefinition, mapSpecification, mapTypeExtra, rewriteType - ) - -{-| This module contains the building blocks of types in the Morphir IR. - - -# Type Expression - -@docs Type - - -## Creation - -@docs variable, reference, tuple, record, extensibleRecord, function, unit - - -## Matching - -@docs matchVariable, matchReference, matchTuple, matchRecord, matchExtensibleRecord, matchFunction, matchUnit - - -# Record Field - -@docs Field, matchField, mapFieldName, mapFieldType - - -# Specification - -@docs Specification, typeAliasSpecification, opaqueTypeSpecification, customTypeSpecification, matchCustomTypeSpecification - - -# Definition - -@docs Definition, typeAliasDefinition, customTypeDefinition - - -# Constructors - -@docs Constructors - - -# Property Testing - -@docs fuzzType - - -# Serialization - -@docs encodeType, decodeType, encodeSpecification, encodeDefinition - --} - -import Fuzz exposing (Fuzzer) -import Json.Decode as Decode -import Json.Encode as Encode -import Morphir.IR.AccessControlled as AccessControlled exposing (AccessControlled, encodeAccessControlled, withPublicAccess) -import Morphir.IR.FQName exposing (FQName, decodeFQName, encodeFQName, fuzzFQName) -import Morphir.IR.Name exposing (Name, decodeName, encodeName, fuzzName) -import Morphir.Pattern exposing (Pattern) -import Morphir.ResultList as ResultList -import Morphir.Rewrite exposing (Rewrite) - - -{-| An opaque representation of a type. Check out the docs for each building blocks -for more details: - - - type variable: [creation](#variable), [matching](#matchVariable) - - type reference: [creation](#reference), [matching](#matchReference) - - tuple type: [creation](#tuple), [matching](#matchTuple) - - record type: [creation](#record), [matching](#matchRecord) - - extensible record type: [creation](#extensibleRecord), [matching](#matchExtensibleRecord) - - function type: [creation](#function), [matching](#matchFunction) - - unit type: [creation](#unit), [matching](#matchUnit) - --} -type Type extra - = Variable Name extra - | Reference FQName (List (Type extra)) extra - | Tuple (List (Type extra)) extra - | Record (List (Field extra)) extra - | ExtensibleRecord Name (List (Field extra)) extra - | Function (Type extra) (Type extra) extra - | Unit extra - - -{-| An opaque representation of a field. It's made up of a name and a type. --} -type alias Field extra = - { name : Name - , tpe : Type extra - } - - -{-| -} -type Specification extra - = TypeAliasSpecification (List Name) (Type extra) - | OpaqueTypeSpecification (List Name) - | CustomTypeSpecification (List Name) (Constructors extra) - - -{-| This syntax represents a type definition. For example: - - - `type alias Foo a = {bar : Maybe a, qux : Int}` - - `type MyList a = End | Cons a (MyList a)` - -In the definition, the `List Name` refers to type parameters on the LHS -and `Type extra` refers to the RHS - --} -type Definition extra - = TypeAliasDefinition (List Name) (Type extra) - | CustomTypeDefinition (List Name) (AccessControlled (Constructors extra)) - - -{-| -} -type alias Constructors extra = - List (Constructor extra) - - -{-| -} -type alias Constructor extra = - ( Name, List ( Name, Type extra ) ) - - -definitionToSpecification : Definition extra -> Specification extra -definitionToSpecification def = - case def of - TypeAliasDefinition params exp -> - TypeAliasSpecification params exp - - CustomTypeDefinition params accessControlledCtors -> - case accessControlledCtors |> withPublicAccess of - Just ctors -> - CustomTypeSpecification params ctors - - Nothing -> - OpaqueTypeSpecification params - - -mapSpecification : (Type a -> Result e (Type b)) -> Specification a -> Result (List e) (Specification b) -mapSpecification f spec = - case spec of - TypeAliasSpecification params tpe -> - f tpe - |> Result.map (TypeAliasSpecification params) - |> Result.mapError List.singleton - - OpaqueTypeSpecification params -> - OpaqueTypeSpecification params - |> Ok - - CustomTypeSpecification params constructors -> - let - ctorsResult : Result (List e) (Constructors b) - ctorsResult = - constructors - |> List.map - (\( ctorName, ctorArgs ) -> - ctorArgs - |> List.map - (\( argName, argType ) -> - f argType - |> Result.map (Tuple.pair argName) - ) - |> ResultList.toResult - |> Result.map (Tuple.pair ctorName) - ) - |> ResultList.toResult - |> Result.mapError List.concat - in - ctorsResult - |> Result.map (CustomTypeSpecification params) - - -mapDefinition : (Type a -> Result e (Type b)) -> Definition a -> Result (List e) (Definition b) -mapDefinition f def = - case def of - TypeAliasDefinition params tpe -> - f tpe - |> Result.map (TypeAliasDefinition params) - |> Result.mapError List.singleton - - CustomTypeDefinition params constructors -> - let - ctorsResult : Result (List e) (AccessControlled (Constructors b)) - ctorsResult = - constructors.value - |> List.map - (\( ctorName, ctorArgs ) -> - ctorArgs - |> List.map - (\( argName, argType ) -> - f argType - |> Result.map (Tuple.pair argName) - ) - |> ResultList.toResult - |> Result.map (Tuple.pair ctorName) - ) - |> ResultList.toResult - |> Result.map (AccessControlled constructors.access) - |> Result.mapError List.concat - in - ctorsResult - |> Result.map (CustomTypeDefinition params) - - -mapTypeExtra : (a -> b) -> Type a -> Type b -mapTypeExtra f tpe = - case tpe of - Variable name extra -> - Variable name (f extra) - - Reference fQName argTypes extra -> - Reference fQName (argTypes |> List.map (mapTypeExtra f)) (f extra) - - Tuple elemTypes extra -> - Tuple (elemTypes |> List.map (mapTypeExtra f)) (f extra) - - Record fields extra -> - Record (fields |> List.map (mapFieldType (mapTypeExtra f))) (f extra) - - ExtensibleRecord name fields extra -> - ExtensibleRecord name (fields |> List.map (mapFieldType (mapTypeExtra f))) (f extra) - - Function argType returnType extra -> - Function (argType |> mapTypeExtra f) (returnType |> mapTypeExtra f) (f extra) - - Unit extra -> - Unit (f extra) - - -typeExtra : Type a -> a -typeExtra tpe = - case tpe of - Variable name extra -> - extra - - Reference fQName argTypes extra -> - extra - - Tuple elemTypes extra -> - extra - - Record fields extra -> - extra - - ExtensibleRecord name fields extra -> - extra - - Function argType returnType extra -> - extra - - Unit extra -> - extra - - -{-| Creates a type variable. - - toIR a == variable [ "a" ] () - - toIR fooBar == variable [ "foo", "bar" ] () - --} -variable : Name -> extra -> Type extra -variable name extra = - Variable name extra - - -{-| -} -matchVariable : Pattern Name a -> Pattern extra b -> Pattern (Type extra) ( a, b ) -matchVariable matchName matchExtra typeToMatch = - case typeToMatch of - Variable name extra -> - Maybe.map2 Tuple.pair - (matchName name) - (matchExtra extra) - - _ -> - Nothing - - -{-| Creates a fully-qualified reference to a type. - - toIR (List Int) - == reference SDK.List.listType [ intType ] - - toIR Foo.Bar - == reference - ( [ [ "my" ], [ "lib" ] ], [ [ "foo" ] ], [ "bar" ] ) - [] - --} -reference : FQName -> List (Type extra) -> extra -> Type extra -reference typeName typeParameters extra = - Reference typeName typeParameters extra - - -{-| -} -matchReference : Pattern FQName a -> Pattern (List (Type extra)) b -> Pattern extra c -> Pattern (Type extra) ( a, b, c ) -matchReference matchTypeName matchTypeParameters matchExtra typeToMatch = - case typeToMatch of - Reference typeName typeParameters extra -> - Maybe.map3 (\a b c -> ( a, b, c )) - (matchTypeName typeName) - (matchTypeParameters typeParameters) - (matchExtra extra) - - _ -> - Nothing - - -{-| Creates a tuple type. - - toIR ( Int, Bool ) - == tuple [ basic intType, basic boolType ] - --} -tuple : List (Type extra) -> extra -> Type extra -tuple elementTypes extra = - Tuple elementTypes extra - - -{-| Matches a tuple type and extracts element types. - - tpe = - tuple [ SDK.Basics.intType, SDK.Basics.boolType ] - - pattern = - matchTuple (list [ matchBasic any, matchBasic any ]) - - pattern tpe == - [ SDK.Basics.intType, SDK.Basics.boolType ] - --} -matchTuple : Pattern (List (Type extra)) a -> Pattern extra b -> Pattern (Type extra) ( a, b ) -matchTuple matchElementTypes matchExtra typeToMatch = - case typeToMatch of - Tuple elementTypes extra -> - Maybe.map2 Tuple.pair - (matchElementTypes elementTypes) - (matchExtra extra) - - _ -> - Nothing - - -{-| Creates a record type. - - toIR {} == record [] - - toIR { foo = Int } - == record - [ field [ "foo" ] SDK.Basics.intType - ] - - toIR { foo = Int, bar = Bool } - == record - [ field [ "foo" ] SDK.Basics.intType - , field [ "bar" ] SDK.Basics.boolType - ] - --} -record : List (Field extra) -> extra -> Type extra -record fieldTypes extra = - Record fieldTypes extra - - -{-| Match a record type. - - matchRecordFooBar = - matchRecord - (matchList - [ matchField - (matchValue ["foo"]) - matchAny - , matchField - (matchValue ["bar"]) - matchAny - ] - ) - - matchRecordFooBar <| - record - [ field ["foo"] SDK.Basics.intType - , field ["bar"] SDK.Basics.boolType - ] - --> Just ( SDK.Basics.intType, SDK.Basics.boolType ) - --} -matchRecord : Pattern (List (Field extra)) a -> Pattern extra b -> Pattern (Type extra) ( a, b ) -matchRecord matchFieldTypes matchExtra typeToMatch = - case typeToMatch of - Record fieldTypes extra -> - Maybe.map2 Tuple.pair - (matchFieldTypes fieldTypes) - (matchExtra extra) - - _ -> - Nothing - - -{-| Creates an extensible record type. - - toIR { e | foo = Int } - == extensibleRecord (variable [ "e" ]) - [ field [ "foo" ] intType - ] - - toIR { f | foo = Int, bar = Bool } - == extensibleRecord (variable [ "f" ]) - [ field [ "foo" ] intType - , field [ "bar" ] boolType - ] - --} -extensibleRecord : Name -> List (Field extra) -> extra -> Type extra -extensibleRecord variableName fieldTypes extra = - ExtensibleRecord variableName fieldTypes extra - - -{-| -} -matchExtensibleRecord : Pattern Name a -> Pattern (List (Field extra)) b -> Pattern extra c -> Pattern (Type extra) ( a, b, c ) -matchExtensibleRecord matchVariableName matchFieldTypes matchExtra typeToMatch = - case typeToMatch of - ExtensibleRecord variableName fieldTypes extra -> - Maybe.map3 (\a b c -> ( a, b, c )) - (matchVariableName variableName) - (matchFieldTypes fieldTypes) - (matchExtra extra) - - _ -> - Nothing - - -{-| Creates a function type. Use currying to create functions with more than one argument. - - toIR (Int -> Bool) == - function - SDK.Basics.intType - SDK.Basics.boolType - - toIR (Int -> Bool -> Char) == - function - intType - (function - SDK.Basics.boolType - SDK.Basics.charType - ) - --} -function : Type extra -> Type extra -> extra -> Type extra -function argumentType returnType extra = - Function argumentType returnType extra - - -{-| Matches a function type. - - tpe = - function SDK.Basics.intType SDK.Basics.boolType - - pattern = - matchFunction matchAny matchAny - - pattern tpe == - ( SDK.Basics.intType, SDK.Basics.boolType ) - --} -matchFunction : Pattern (Type extra) a -> Pattern (Type extra) b -> Pattern extra c -> Pattern (Type extra) ( a, b, c ) -matchFunction matchArgType matchReturnType matchExtra typeToMatch = - case typeToMatch of - Function argType returnType extra -> - Maybe.map3 (\a b c -> ( a, b, c )) - (matchArgType argType) - (matchReturnType returnType) - (matchExtra extra) - - _ -> - Nothing - - -{-| Creates a unit type. - - toIR () == unit - --} -unit : extra -> Type extra -unit extra = - Unit extra - - -{-| -} -matchUnit : Pattern extra a -> Pattern (Type extra) a -matchUnit matchExtra typeToMatch = - case typeToMatch of - Unit extra -> - matchExtra extra - - _ -> - Nothing - - -{-| -} -typeAliasDefinition : List Name -> Type extra -> Definition extra -typeAliasDefinition typeParams typeExp = - TypeAliasDefinition typeParams typeExp - - -{-| -} -customTypeDefinition : List Name -> AccessControlled (Constructors extra) -> Definition extra -customTypeDefinition typeParams ctors = - CustomTypeDefinition typeParams ctors - - -{-| -} -typeAliasSpecification : List Name -> Type extra -> Specification extra -typeAliasSpecification typeParams typeExp = - TypeAliasSpecification typeParams typeExp - - -{-| -} -opaqueTypeSpecification : List Name -> Specification extra -opaqueTypeSpecification typeParams = - OpaqueTypeSpecification typeParams - - -{-| -} -customTypeSpecification : List Name -> Constructors extra -> Specification extra -customTypeSpecification typeParams ctors = - CustomTypeSpecification typeParams ctors - - -{-| -} -matchCustomTypeSpecification : Pattern (List Name) a -> Pattern (Constructors extra) b -> Pattern (Specification extra) ( a, b ) -matchCustomTypeSpecification matchTypeParams matchCtors specToMatch = - case specToMatch of - CustomTypeSpecification typeParams ctors -> - Maybe.map2 Tuple.pair - (matchTypeParams typeParams) - (matchCtors ctors) - - _ -> - Nothing - - -rewriteType : Rewrite e (Type extra) -rewriteType rewriteBranch rewriteLeaf typeToRewrite = - case typeToRewrite of - Reference fQName argTypes extra -> - argTypes - |> List.foldr - (\nextArg resultSoFar -> - Result.map2 (::) - (rewriteBranch nextArg) - resultSoFar - ) - (Ok []) - |> Result.map - (\args -> - Reference fQName args extra - ) - - Tuple elemTypes extra -> - elemTypes - |> List.foldr - (\nextArg resultSoFar -> - Result.map2 (::) - (rewriteBranch nextArg) - resultSoFar - ) - (Ok []) - |> Result.map - (\elems -> - Tuple elems extra - ) - - Record fieldTypes extra -> - fieldTypes - |> List.foldr - (\field resultSoFar -> - Result.map2 (::) - (rewriteBranch field.tpe - |> Result.map (Field field.name) - ) - resultSoFar - ) - (Ok []) - |> Result.map - (\fields -> - Record fields extra - ) - - ExtensibleRecord varName fieldTypes extra -> - fieldTypes - |> List.foldr - (\field resultSoFar -> - Result.map2 (::) - (rewriteBranch field.tpe - |> Result.map (Field field.name) - ) - resultSoFar - ) - (Ok []) - |> Result.map - (\fields -> - ExtensibleRecord varName fields extra - ) - - Function argType returnType extra -> - Result.map2 (\arg return -> Function arg return extra) - (rewriteBranch argType) - (rewriteBranch returnType) - - _ -> - rewriteLeaf typeToRewrite - - -{-| Matches a field. - - let - field = - field [ "foo" ] SDK.Basics.intType - - pattern = - matchField matchAny matchAny - in - pattern field - == Just ( [ "foo" ], SDK.Basics.intType ) - --} -matchField : Pattern Name a -> Pattern (Type extra) b -> Pattern (Field extra) ( a, b ) -matchField matchFieldName matchFieldType field = - Maybe.map2 Tuple.pair - (matchFieldName field.name) - (matchFieldType field.tpe) - - -{-| Map the name of the field to get a new field. --} -mapFieldName : (Name -> Name) -> Field extra -> Field extra -mapFieldName f field = - Field (f field.name) field.tpe - - -{-| Map the type of the field to get a new field. --} -mapFieldType : (Type a -> Type b) -> Field a -> Field b -mapFieldType f field = - Field field.name (f field.tpe) - - -{-| Generate random types. --} -fuzzType : Int -> Fuzzer extra -> Fuzzer (Type extra) -fuzzType maxDepth fuzzExtra = - let - fuzzField depth = - Fuzz.map2 Field - fuzzName - (fuzzType depth fuzzExtra) - - fuzzVariable = - Fuzz.map2 Variable - fuzzName - fuzzExtra - - fuzzReference depth = - Fuzz.map3 Reference - fuzzFQName - (Fuzz.list (fuzzType depth fuzzExtra) |> Fuzz.map (List.take depth)) - fuzzExtra - - fuzzTuple depth = - Fuzz.map2 Tuple - (Fuzz.list (fuzzType depth fuzzExtra) |> Fuzz.map (List.take depth)) - fuzzExtra - - fuzzRecord depth = - Fuzz.map2 Record - (Fuzz.list (fuzzField (depth - 1)) |> Fuzz.map (List.take depth)) - fuzzExtra - - fuzzExtensibleRecord depth = - Fuzz.map3 ExtensibleRecord - fuzzName - (Fuzz.list (fuzzField (depth - 1)) |> Fuzz.map (List.take depth)) - fuzzExtra - - fuzzFunction depth = - Fuzz.map3 Function - (fuzzType depth fuzzExtra) - (fuzzType depth fuzzExtra) - fuzzExtra - - fuzzUnit = - Fuzz.map Unit - fuzzExtra - - fuzzLeaf = - Fuzz.oneOf - [ fuzzVariable - , fuzzUnit - ] - - fuzzBranch depth = - Fuzz.oneOf - [ fuzzFunction depth - , fuzzReference depth - , fuzzTuple depth - , fuzzRecord depth - , fuzzExtensibleRecord depth - ] - in - if maxDepth <= 0 then - fuzzLeaf - - else - Fuzz.oneOf - [ fuzzLeaf - , fuzzBranch (maxDepth - 1) - ] - - -{-| Encode a type into JSON. --} -encodeType : (extra -> Encode.Value) -> Type extra -> Encode.Value -encodeType encodeExtra tpe = - let - typeTag tag = - ( "@type", Encode.string tag ) - in - case tpe of - Variable name extra -> - Encode.object - [ typeTag "variable" - , ( "name", encodeName name ) - , ( "extra", encodeExtra extra ) - ] - - Reference typeName typeParameters extra -> - Encode.object - [ typeTag "reference" - , ( "typeName", encodeFQName typeName ) - , ( "typeParameters", Encode.list (encodeType encodeExtra) typeParameters ) - , ( "extra", encodeExtra extra ) - ] - - Tuple elementTypes extra -> - Encode.object - [ typeTag "tuple" - , ( "elementTypes", Encode.list (encodeType encodeExtra) elementTypes ) - , ( "extra", encodeExtra extra ) - ] - - Record fieldTypes extra -> - Encode.object - [ typeTag "record" - , ( "fieldTypes", Encode.list (encodeField encodeExtra) fieldTypes ) - , ( "extra", encodeExtra extra ) - ] - - ExtensibleRecord variableName fieldTypes extra -> - Encode.object - [ typeTag "extensibleRecord" - , ( "variableName", encodeName variableName ) - , ( "fieldTypes", Encode.list (encodeField encodeExtra) fieldTypes ) - , ( "extra", encodeExtra extra ) - ] - - Function argumentType returnType extra -> - Encode.object - [ typeTag "function" - , ( "argumentType", encodeType encodeExtra argumentType ) - , ( "returnType", encodeType encodeExtra returnType ) - , ( "extra", encodeExtra extra ) - ] - - Unit extra -> - Encode.object - [ typeTag "unit" - , ( "extra", encodeExtra extra ) - ] - - -{-| Decode a type from JSON. --} -decodeType : Decode.Decoder extra -> Decode.Decoder (Type extra) -decodeType decodeExtra = - let - lazyDecodeType = - Decode.lazy - (\_ -> - decodeType decodeExtra - ) - - lazyDecodeField = - Decode.lazy - (\_ -> - decodeField decodeExtra - ) - in - Decode.field "@type" Decode.string - |> Decode.andThen - (\kind -> - case kind of - "variable" -> - Decode.map2 Variable - (Decode.field "name" decodeName) - (Decode.field "extra" decodeExtra) - - "reference" -> - Decode.map3 Reference - (Decode.field "typeName" decodeFQName) - (Decode.field "typeParameters" (Decode.list (Decode.lazy (\_ -> decodeType decodeExtra)))) - (Decode.field "extra" decodeExtra) - - "tuple" -> - Decode.map2 Tuple - (Decode.field "elementTypes" (Decode.list lazyDecodeType)) - (Decode.field "extra" decodeExtra) - - "record" -> - Decode.map2 Record - (Decode.field "fieldTypes" (Decode.list lazyDecodeField)) - (Decode.field "extra" decodeExtra) - - "extensibleRecord" -> - Decode.map3 ExtensibleRecord - (Decode.field "variableName" decodeName) - (Decode.field "fieldTypes" (Decode.list lazyDecodeField)) - (Decode.field "extra" decodeExtra) - - "function" -> - Decode.map3 Function - (Decode.field "argumentType" lazyDecodeType) - (Decode.field "returnType" lazyDecodeType) - (Decode.field "extra" decodeExtra) - - "unit" -> - Decode.map Unit - (Decode.field "extra" decodeExtra) - - _ -> - Decode.fail ("Unknown kind: " ++ kind) - ) - - -encodeField : (extra -> Encode.Value) -> Field extra -> Encode.Value -encodeField encodeExtra field = - Encode.list identity - [ encodeName field.name - , encodeType encodeExtra field.tpe - ] - - -decodeField : Decode.Decoder extra -> Decode.Decoder (Field extra) -decodeField decodeExtra = - Decode.map2 Field - (Decode.index 0 decodeName) - (Decode.index 1 (decodeType decodeExtra)) - - -{-| -} -encodeSpecification : (extra -> Encode.Value) -> Specification extra -> Encode.Value -encodeSpecification encodeExtra spec = - case spec of - TypeAliasSpecification params exp -> - Encode.object - [ ( "$type", Encode.string "typeAlias" ) - , ( "params", Encode.list encodeName params ) - , ( "exp", encodeType encodeExtra exp ) - ] - - OpaqueTypeSpecification params -> - Encode.object - [ ( "$type", Encode.string "opaqueType" ) - , ( "params", Encode.list encodeName params ) - ] - - CustomTypeSpecification params ctors -> - Encode.object - [ ( "$type", Encode.string "customType" ) - , ( "params", Encode.list encodeName params ) - , ( "ctors", encodeConstructors encodeExtra ctors ) - ] - - -{-| -} -encodeDefinition : (extra -> Encode.Value) -> Definition extra -> Encode.Value -encodeDefinition encodeExtra def = - case def of - TypeAliasDefinition params exp -> - Encode.object - [ ( "$type", Encode.string "typeAlias" ) - , ( "params", Encode.list encodeName params ) - , ( "exp", encodeType encodeExtra exp ) - ] - - CustomTypeDefinition params ctors -> - Encode.object - [ ( "$type", Encode.string "customType" ) - , ( "params", Encode.list encodeName params ) - , ( "ctors", encodeAccessControlled (encodeConstructors encodeExtra) ctors ) - ] - - -encodeConstructors : (extra -> Encode.Value) -> Constructors extra -> Encode.Value -encodeConstructors encodeExtra ctors = - ctors - |> Encode.list - (\( ctorName, ctorArgs ) -> - Encode.object - [ ( "name", encodeName ctorName ) - , ( "args" - , ctorArgs - |> Encode.list - (\( argName, argType ) -> - Encode.list identity - [ encodeName argName - , encodeType encodeExtra argType - ] - ) - ) - ] - ) diff --git a/src/Morphir/IR/Advanced/Value.elm b/src/Morphir/IR/Advanced/Value.elm deleted file mode 100644 index e272c6756..000000000 --- a/src/Morphir/IR/Advanced/Value.elm +++ /dev/null @@ -1,1395 +0,0 @@ -module Morphir.IR.Advanced.Value exposing - ( Value(..), literal, constructor, apply, field, fieldFunction, lambda, letDef, letDestruct, letRec, list, record, reference - , tuple, variable, ifThenElse, patternMatch, update, unit - , Literal(..), boolLiteral, charLiteral, stringLiteral, intLiteral, floatLiteral - , Pattern(..), wildcardPattern, asPattern, tuplePattern, recordPattern, constructorPattern, emptyListPattern, headTailPattern, literalPattern - , Specification - , Definition(..), typedDefinition, untypedDefinition - , encodeValue, encodeSpecification, encodeDefinition - , getDefinitionBody, mapDefinition, mapSpecification, mapValueExtra - ) - -{-| This module contains the building blocks of values in the Morphir IR. - - -# Value - -Value is the top level building block for data and logic. See the constructor functions below for details on each node type. - -@docs Value, literal, constructor, apply, field, fieldFunction, lambda, letDef, letDestruct, letRec, list, record, reference -@docs tuple, variable, ifThenElse, patternMatch, update, unit - - -# Literal - -Literals represent fixed values in the IR. We support the same set of basic types as Elm which almost matches JSON's supported values: - - - Bool - - Char - - String - - Int - - Float - -@docs Literal, boolLiteral, charLiteral, stringLiteral, intLiteral, floatLiteral - - -# Pattern - -Patterns are used in multiple ways in the IR: they can take apart a structured value into smaller pieces (destructure) and they -can also filter values. The combination of these two features creates a very powerful method tool that can be used in two ways: -destructuring and pattern-matching. Pattern-matching is a combination of destructuring, filtering and branching. - -@docs Pattern, wildcardPattern, asPattern, tuplePattern, recordPattern, constructorPattern, emptyListPattern, headTailPattern, literalPattern - - -# Specification - -The specification of what the value or function -is without the actual data or logic behind it. - -@docs Specification - - -# Definition - -A definition is the actual data or logic as opposed to a specification -which is just the specification of those. Value definitions can be typed or untyped. Exposed values have to be typed. - -@docs Definition, typedDefinition, untypedDefinition - - -# Serialization - -@docs encodeValue, encodeSpecification, encodeDefinition - --} - -import Fuzz exposing (Fuzzer) -import Json.Decode as Decode -import Json.Encode as Encode -import Morphir.IR.Advanced.Type as Type exposing (Type, decodeType, encodeType) -import Morphir.IR.FQName exposing (FQName, decodeFQName, encodeFQName) -import Morphir.IR.Name exposing (Name, decodeName, encodeName) -import Morphir.ResultList as ResultList -import String - - -{-| Type that represents a value. --} -type Value extra - = Literal Literal extra - | Constructor FQName extra - | Tuple (List (Value extra)) extra - | List (List (Value extra)) extra - | Record (List ( Name, Value extra )) extra - | Variable Name extra - | Reference FQName extra - | Field (Value extra) Name extra - | FieldFunction Name extra - | Apply (Value extra) (Value extra) extra - | Lambda (Pattern extra) (Value extra) extra - | LetDefinition Name (Definition extra) (Value extra) extra - | LetRecursion (List ( Name, Definition extra )) (Value extra) extra - | Destructure (Pattern extra) (Value extra) (Value extra) extra - | IfThenElse (Value extra) (Value extra) (Value extra) extra - | PatternMatch (Value extra) (List ( Pattern extra, Value extra )) extra - | UpdateRecord (Value extra) (List ( Name, Value extra )) extra - | Unit extra - - -{-| Type that represents a literal value. --} -type Literal - = BoolLiteral Bool - | CharLiteral Char - | StringLiteral String - | IntLiteral Int - | FloatLiteral Float - - -{-| Type that represents a pattern. --} -type Pattern extra - = WildcardPattern extra - | AsPattern (Pattern extra) Name extra - | TuplePattern (List (Pattern extra)) extra - | RecordPattern (List Name) extra - | ConstructorPattern FQName (List (Pattern extra)) extra - | EmptyListPattern extra - | HeadTailPattern (Pattern extra) (Pattern extra) extra - | LiteralPattern Literal extra - - -{-| Type that represents a value or function specification. The specification of what the value or function -is without the actual data or logic behind it. --} -type alias Specification extra = - { inputs : List ( Name, Type extra ) - , output : Type extra - } - - -{-| Type that represents a value or function definition. A definition is the actual data or logic as opposed to a specification -which is just the specification of those. Value definitions can be typed or untyped. Exposed values have to be typed. --} -type Definition extra - = TypedDefinition (Type extra) (List Name) (Value extra) - | UntypedDefinition (List Name) (Value extra) - - -getDefinitionBody : Definition extra -> Value extra -getDefinitionBody def = - case def of - TypedDefinition _ _ body -> - body - - UntypedDefinition _ body -> - body - - - --- definitionToSpecification : Definition extra -> Maybe (Specification extra) --- definitionToSpecification def = --- case def of --- TypedDefinition valueType argNames _ -> --- let --- extractArgTypes tpe names = --- case ( names, tpe ) of --- ( [], returnType ) -> --- ( [], returnType ) --- ( nextArgName :: restOfArgNames, -> --- in - - -mapSpecification : (Type a -> Result e (Type b)) -> (Value a -> Value b) -> Specification a -> Result (List e) (Specification b) -mapSpecification mapType mapValue spec = - let - inputsResult = - spec.inputs - |> List.map - (\( name, tpe ) -> - mapType tpe - |> Result.map (Tuple.pair name) - ) - |> ResultList.toResult - - outputResult = - mapType spec.output - |> Result.mapError List.singleton - in - Result.map2 Specification - inputsResult - outputResult - - -mapDefinition : (Type a -> Result e (Type b)) -> (Value a -> Value b) -> Definition a -> Result (List e) (Definition b) -mapDefinition mapType mapValue def = - case def of - TypedDefinition tpe args body -> - mapType tpe - |> Result.map - (\t -> - TypedDefinition t args (mapValue body) - ) - |> Result.mapError List.singleton - - UntypedDefinition args body -> - UntypedDefinition args (mapValue body) - |> Ok - - -mapValueExtra : (a -> b) -> Value a -> Value b -mapValueExtra f v = - case v of - Literal value extra -> - Literal value (f extra) - - Constructor fullyQualifiedName extra -> - Constructor fullyQualifiedName (f extra) - - Tuple elements extra -> - Tuple (elements |> List.map (mapValueExtra f)) (f extra) - - List items extra -> - List (items |> List.map (mapValueExtra f)) (f extra) - - Record fields extra -> - Record - (fields - |> List.map - (\( fieldName, fieldValue ) -> - ( fieldName, mapValueExtra f fieldValue ) - ) - ) - (f extra) - - Variable name extra -> - Variable name (f extra) - - Reference fullyQualifiedName extra -> - Reference fullyQualifiedName (f extra) - - Field subjectValue fieldName extra -> - Field (mapValueExtra f subjectValue) fieldName (f extra) - - FieldFunction fieldName extra -> - FieldFunction fieldName (f extra) - - Apply function argument extra -> - Apply (mapValueExtra f function) (mapValueExtra f argument) (f extra) - - Lambda argumentPattern body extra -> - Lambda (mapPatternExtra f argumentPattern) (mapValueExtra f body) (f extra) - - LetDefinition valueName valueDefinition inValue extra -> - LetDefinition valueName (mapDefinitionExtra f valueDefinition) (mapValueExtra f inValue) (f extra) - - LetRecursion valueDefinitions inValue extra -> - LetRecursion - (valueDefinitions - |> List.map - (\( name, def ) -> - ( name, mapDefinitionExtra f def ) - ) - ) - (mapValueExtra f inValue) - (f extra) - - Destructure pattern valueToDestruct inValue extra -> - Destructure (mapPatternExtra f pattern) (mapValueExtra f valueToDestruct) (mapValueExtra f inValue) (f extra) - - IfThenElse condition thenBranch elseBranch extra -> - IfThenElse (mapValueExtra f condition) (mapValueExtra f thenBranch) (mapValueExtra f elseBranch) (f extra) - - PatternMatch branchOutOn cases extra -> - PatternMatch (mapValueExtra f branchOutOn) - (cases - |> List.map - (\( pattern, body ) -> - ( mapPatternExtra f pattern, mapValueExtra f body ) - ) - ) - (f extra) - - UpdateRecord valueToUpdate fieldsToUpdate extra -> - UpdateRecord (mapValueExtra f valueToUpdate) - (fieldsToUpdate - |> List.map - (\( fieldName, fieldValue ) -> - ( fieldName, mapValueExtra f fieldValue ) - ) - ) - (f extra) - - Unit extra -> - Unit (f extra) - - -mapPatternExtra : (a -> b) -> Pattern a -> Pattern b -mapPatternExtra f p = - case p of - WildcardPattern extra -> - WildcardPattern (f extra) - - AsPattern p2 name extra -> - AsPattern (mapPatternExtra f p2) name (f extra) - - TuplePattern elementPatterns extra -> - TuplePattern (elementPatterns |> List.map (mapPatternExtra f)) (f extra) - - RecordPattern fieldNames extra -> - RecordPattern fieldNames (f extra) - - ConstructorPattern constructorName argumentPatterns extra -> - ConstructorPattern constructorName (argumentPatterns |> List.map (mapPatternExtra f)) (f extra) - - EmptyListPattern extra -> - EmptyListPattern (f extra) - - HeadTailPattern headPattern tailPattern extra -> - HeadTailPattern (mapPatternExtra f headPattern) (mapPatternExtra f tailPattern) (f extra) - - LiteralPattern value extra -> - LiteralPattern value (f extra) - - -mapDefinitionExtra : (a -> b) -> Definition a -> Definition b -mapDefinitionExtra f d = - case d of - TypedDefinition tpe args body -> - TypedDefinition (Type.mapTypeExtra f tpe) args (mapValueExtra f body) - - UntypedDefinition args body -> - UntypedDefinition args (mapValueExtra f body) - - -{-| A [literal][lit] represents a fixed value in the IR. We only allow values of basic types: bool, char, string, int, float. - - True -- Literal (BoolLiteral True) - - 'a' -- Literal (CharLiteral 'a') - - "foo" -- Literal (StringLiteral "foo") - - 13 -- Literal (IntLiteral 13) - - 15.4 -- Literal (FloatLiteral 15.4) - -[lit]: https://en.wikipedia.org/wiki/Literal_(computer_programming) - --} -literal : Literal -> extra -> Value extra -literal value extra = - Literal value extra - - -{-| A reference to a constructor of a custom type. - - Nothing -- Constructor ( ..., [ [ "maybe" ] ], [ "nothing" ] ) - - Foo.Bar -- Constructor ( ..., [ [ "foo" ] ], [ "bar" ] ) - --} -constructor : FQName -> extra -> Value extra -constructor fullyQualifiedName extra = - Constructor fullyQualifiedName extra - - -{-| A [tuple] represents an ordered list of values where each value can be of a different type. - -**Note**: Tuples with zero values are considered to be the special value [`Unit`](#unit) - - ( 1, True ) -- Tuple [ Literal (IntLiteral 1), Literal (BoolLiteral True) ] - - ( "foo", True, 3 ) -- Tuple [ Literal (StringLiteral "foo"), Literal (BoolLiteral True), Literal (IntLiteral 3) ] - - () -- Unit - -[tuple]: https://en.wikipedia.org/wiki/Tuple - --} -tuple : List (Value extra) -> extra -> Value extra -tuple elements extra = - Tuple elements extra - - -{-| A [list] represents an ordered list of values where every value has to be of the same type. - - [ 1, 3, 5 ] -- List [ Literal (IntLiteral 1), Literal (IntLiteral 3), Literal (IntLiteral 5) ] - - [] -- List [] - -[list]: https://en.wikipedia.org/wiki/List_(abstract_data_type) - --} -list : List (Value extra) -> extra -> Value extra -list items extra = - List items extra - - -{-| A [record] represents a list of fields where each field has a name and a value. - - { foo = "bar" } -- Record [ ( [ "foo" ], Literal (StringLiteral "bar") ) ] - - { foo = "bar", baz = 1 } -- Record [ ( [ "foo" ], Literal (StringLiteral "bar") ), ( [ "baz" ], Literal (IntLiteral 1) ) ] - - {} -- Record [] - -[record]: https://en.wikipedia.org/wiki/Record_(computer_science) - --} -record : List ( Name, Value extra ) -> extra -> Value extra -record fields extra = - Record fields extra - - -{-| A [variable] represents a reference to a named value in the scope. - - a -- Variable [ "a" ] - - fooBar15 -- Variable [ "foo", "bar", "15" ] - -[variable]: https://en.wikipedia.org/wiki/Variable_(computer_science) - --} -variable : Name -> extra -> Value extra -variable name extra = - Variable name extra - - -{-| A reference that refers to a function or a value with its fully-qualified name. - - List.map -- Reference ( [ ..., [ [ "list" ] ], [ "map" ] ) - --} -reference : FQName -> extra -> Value extra -reference fullyQualifiedName extra = - Reference fullyQualifiedName extra - - -{-| Extracts the value of a record's field. - - a.foo -- Field (Variable [ "a" ]) [ "foo" ] - --} -field : Value extra -> Name -> extra -> Value extra -field subjectValue fieldName extra = - Field subjectValue fieldName extra - - -{-| Represents a function that extract a field from a record value passed to it. - - .foo -- FieldFunction [ "foo" ] - --} -fieldFunction : Name -> extra -> Value extra -fieldFunction fieldName extra = - FieldFunction fieldName extra - - -{-| Represents a function invocation. We use currying to represent function invocations with multiple arguments. - -**Note**: Operators are mapped to well-known function names. - - not True -- Apply (Reference ( ..., [ [ "basics" ] ], [ "not" ])) (Literal (BoolLiteral True)) - - True || False -- Apply (Apply (Reference ( ..., [ [ "basics" ] ], [ "and" ]))) (Literal (BoolLiteral True)) (Literal (BoolLiteral True)) - --} -apply : Value extra -> Value extra -> extra -> Value extra -apply function argument extra = - Apply function argument extra - - -{-| Represents a lambda abstraction. - -**Note**: - - - We use currying to represent lambda abstractions with multiple arguments. - - Arguments are not just names, they are patterns. - -``` -\a -> a -- Lambda (AsPattern WildcardPattern [ "a" ]) (Variable [ "a" ]) - -\a b -> a -- Lambda (AsPattern WildcardPattern [ "a" ]) (Lambda (AsPattern WildcardPattern [ "b" ]) (Variable [ "a" ])) -``` - --} -lambda : Pattern extra -> Value extra -> extra -> Value extra -lambda argumentPattern body extra = - Lambda argumentPattern body extra - - -{-| Represents a let expression that assigns a value (and optionally type) to a name. - -**Note**: We use currying to represent let expressions with multiple name bindings. - - let - a = - b - in - a - -- LetDef [ "a" ] - -- (UntypedDefinition [] (Variable [ "b" ])) - -- (Variable [ "a" ]) - - let - a : Bool - a = - b - - c x = - a - in - c - -- LetDef [ "a" ] - -- (TypedDefinition (Basic BoolType) [] (Variable [ "b" ])) - -- (LetDef [ "c" ] - -- (UntypedDefinition [ [ "x" ] ] (Variable [ "a" ])) - -- (Variable [ "c" ]) - -- ) - --} -letDef : Name -> Definition extra -> Value extra -> extra -> Value extra -letDef valueName valueDefinition inValue extra = - LetDefinition valueName valueDefinition inValue extra - - -{-| Represents a let expression with one or many recursive definitions. - - let - a = - b - - b = - a - in - a - -- LetRec - -- [ ( [ "a" ], UntypedDefinition [] (Variable [ "b" ]) ) - -- , ( [ "b" ], UntypedDefinition [] (Variable [ "a" ]) ) - -- ] - -- (Variable [ "a" ]) - --} -letRec : List ( Name, Definition extra ) -> Value extra -> extra -> Value extra -letRec valueDefinitions inValue extra = - LetRecursion valueDefinitions inValue extra - - -{-| Represents a let expression that extracts values using a pattern. - - let - ( a, b ) = - c - in - a - -- LetDestruct - -- (TuplePattern [ AsPattern WildcardPattern ["a"], AsPattern WildcardPattern ["b"] ]) - -- (Variable ["a"]) - --} -letDestruct : Pattern extra -> Value extra -> Value extra -> extra -> Value extra -letDestruct pattern valueToDestruct inValue extra = - Destructure pattern valueToDestruct inValue extra - - -{-| Represents and if/then/else expression. - - if a then - b - else - c - -- IfThenElse (Variable ["a"]) - -- (Variable ["b"]) - -- (Variable ["c"]) - --} -ifThenElse : Value extra -> Value extra -> Value extra -> extra -> Value extra -ifThenElse condition thenBranch elseBranch extra = - IfThenElse condition thenBranch elseBranch extra - - -{-| Represents a pattern-match. - - case a of - 1 -> - "yea" - - _ -> - "nay" - -- PatternMatch (Variable ["a"]) - -- [ ( LiteralPattern (IntLiteral 1), Literal (StringLiteral "yea") ) - -- , ( WildcardPattern, Literal (StringLiteral "nay") ) - -- ] - --} -patternMatch : Value extra -> List ( Pattern extra, Value extra ) -> extra -> Value extra -patternMatch branchOutOn cases extra = - PatternMatch branchOutOn cases extra - - -{-| Update one or many fields of a record value. - - { a | foo = 1 } -- Update (Variable ["a"]) [ ( ["foo"], Literal (IntLiteral 1) ) ] - --} -update : Value extra -> List ( Name, Value extra ) -> extra -> Value extra -update valueToUpdate fieldsToUpdate extra = - UpdateRecord valueToUpdate fieldsToUpdate extra - - -{-| Represents the unit value. - - () -- Unit - --} -unit : extra -> Value extra -unit extra = - Unit extra - - -{-| Represents a boolean value. Only possible values are: `True`, `False` --} -boolLiteral : Bool -> Literal -boolLiteral value = - BoolLiteral value - - -{-| Represents a character value. Some possible values: `'a'`, `'Z'`, `'3'` --} -charLiteral : Char -> Literal -charLiteral value = - CharLiteral value - - -{-| Represents a string value. Some possible values: `""`, `"foo"`, `"Bar baz: 123"` --} -stringLiteral : String -> Literal -stringLiteral value = - StringLiteral value - - -{-| Represents an integer value. Some possible values: `0`, `-1`, `9832479` --} -intLiteral : Int -> Literal -intLiteral value = - IntLiteral value - - -{-| Represents a floating-point number. Some possible values: `1.25`, `-13.4` --} -floatLiteral : Float -> Literal -floatLiteral value = - FloatLiteral value - - -{-| Matches any value and ignores it (assigns no variable name). - - _ -- WildcardPattern - --} -wildcardPattern : extra -> Pattern extra -wildcardPattern extra = - WildcardPattern extra - - -{-| Assigns a variable name to a pattern. - - _ as foo -- AsPattern WildcardPattern ["foo"] - - foo -- AsPattern WildcardPattern ["foo"] - - [] as foo -- AsPattern EmptyListPattern ["foo"] - --} -asPattern : Pattern extra -> Name -> extra -> Pattern extra -asPattern pattern name extra = - AsPattern pattern name extra - - -{-| Destructures a tuple using a pattern for every element. - - ( _, foo ) -- TuplePattern [ WildcardPattern, AsPattern WildcardPattern ["foo"] ] - --} -tuplePattern : List (Pattern extra) -> extra -> Pattern extra -tuplePattern elementPatterns extra = - TuplePattern elementPatterns extra - - -{-| Pulls out the values of some fields from a record value. - - { foo, bar } -- RecordPattern [ ["foo"], ["bar"] ] - --} -recordPattern : List Name -> extra -> Pattern extra -recordPattern fieldNames extra = - RecordPattern fieldNames extra - - -{-| Matches on a custom type's constructor. - -**Note**: When the custom type has a single constructor this can be used for destructuring. -When there are multiple constructors it also does filtering so it cannot be used in a -[`LetDestruct`](#letDestruct) but it can be used in a [pattern-match](#patternMatch). - - Just _ -- ConstructorPattern ( ..., [["maybe"]], ["just"]) [ WildcardPattern ] - --} -constructorPattern : FQName -> List (Pattern extra) -> extra -> Pattern extra -constructorPattern constructorName argumentPatterns extra = - ConstructorPattern constructorName argumentPatterns extra - - -{-| Matches an empty list. Can be used standalon but frequently used as a terminal pattern -in a [`HeadTailPattern`](#headTailPattern). - - [] -- EmptyListPattern - - [ _ ] - -- HeadTailPattern - -- WildcardPattern - -- EmptyListPattern - --} -emptyListPattern : extra -> Pattern extra -emptyListPattern extra = - EmptyListPattern extra - - -{-| Matches the head and the tail of a list. It can be used to match lists of at least N items -by nesting this pattern N times and terminating with [`EmptyListPattern`](#emptyListPattern). - - [ a ] - -- HeadTailPattern - -- (AsPattern WildcardPattern ["a"]) - -- EmptyListPattern - - a :: b - -- HeadTailPattern - -- (AsPattern WildcardPattern ["a"]) - -- (AsPattern WildcardPattern ["b"]) - - [ a, b ] - -- HeadTailPattern - -- (AsPattern WildcardPattern ["a"]) - -- (HeadTailPattern - -- (AsPattern WildcardPattern ["b"]) - -- EmptyListPattern - -- ) - --} -headTailPattern : Pattern extra -> Pattern extra -> extra -> Pattern extra -headTailPattern headPattern tailPattern extra = - HeadTailPattern headPattern tailPattern extra - - -{-| Matches a specific literal value. This pattern can only be used in a [pattern-match](#patternMatch) -since it always filters. - - True -- LiteralPattern (BoolLiteral True) - - 'a' -- LiteralPattern (CharLiteral 'a') - - "foo" -- LiteralPattern (StringLiteral "foo") - - 13 -- LiteralPattern (IntLiteral 13) - - 15.4 -- LiteralPattern (FloatLiteral 15.4) - --} -literalPattern : Literal -> extra -> Pattern extra -literalPattern value extra = - LiteralPattern value extra - - -{-| Typed value or function definition. - -**Note**: Elm uses patterns instead of argument names which is flexible but makes it more -difficult to understand the model. Since most business models will actually use names which -is represented as `AsPattern WildcardPattern name` in the IR we will extract those into the -definition. This is a best-efforts process and stops when it runs into a more complex pattern. -When that happens the rest of the argument patterns will be pushed down to the body as lambda -arguments. The examples below try to visualize the process. - - myFun : Int -> Int -> { foo : Int } -> Int - myFun a b { foo } = - body - - -- the above is logically translated to the below - myFun : - Int - -> Int - -> { foo : Int } - -> Int -- the value type does not change in the process - myFun a b = - \{ foo } -> - body - --} -typedDefinition : Type extra -> List Name -> Value extra -> Definition extra -typedDefinition valueType argumentNames body = - TypedDefinition valueType argumentNames body - - -{-| Untyped value or function definition. - -**Note**: Elm uses patterns instead of argument names which is flexible but makes it more -difficult to understand the model. Since most business models will actually use names which -is represented as `AsPattern WildcardPattern name` in the IR we will extract those into the -definition. This is a best-efforts process and stops when it runs into a more complex pattern. -When that happens the rest of the argument patterns will be pushed down to the body as lambda -arguments. The examples below try to visualize the process. - - myFun a b { foo } = - body - - -- the above is logically translated to the below - myFun a b = - \{ foo } -> - body - --} -untypedDefinition : List Name -> Value extra -> Definition extra -untypedDefinition argumentNames body = - UntypedDefinition argumentNames body - - -encodeValue : (extra -> Encode.Value) -> Value extra -> Encode.Value -encodeValue encodeExtra v = - let - typeTag tag = - ( "@type", Encode.string tag ) - in - case v of - Literal value extra -> - Encode.object - [ typeTag "literal" - , ( "value", encodeLiteral value ) - , ( "extra", encodeExtra extra ) - ] - - Constructor fullyQualifiedName extra -> - Encode.object - [ typeTag "constructor" - , ( "fullyQualifiedName", encodeFQName fullyQualifiedName ) - , ( "extra", encodeExtra extra ) - ] - - Tuple elements extra -> - Encode.object - [ typeTag "tuple" - , ( "elements", elements |> Encode.list (encodeValue encodeExtra) ) - , ( "extra", encodeExtra extra ) - ] - - List items extra -> - Encode.object - [ typeTag "list" - , ( "items", items |> Encode.list (encodeValue encodeExtra) ) - , ( "extra", encodeExtra extra ) - ] - - Record fields extra -> - Encode.object - [ typeTag "record" - , ( "fields" - , fields - |> Encode.list - (\( fieldName, fieldValue ) -> - Encode.list identity - [ encodeName fieldName - , encodeValue encodeExtra fieldValue - ] - ) - ) - , ( "extra", encodeExtra extra ) - ] - - Variable name extra -> - Encode.object - [ typeTag "variable" - , ( "name", encodeName name ) - , ( "extra", encodeExtra extra ) - ] - - Reference fullyQualifiedName extra -> - Encode.object - [ typeTag "reference" - , ( "fullyQualifiedName", encodeFQName fullyQualifiedName ) - , ( "extra", encodeExtra extra ) - ] - - Field subjectValue fieldName extra -> - Encode.object - [ typeTag "field" - , ( "subjectValue", encodeValue encodeExtra subjectValue ) - , ( "fieldName", encodeName fieldName ) - , ( "extra", encodeExtra extra ) - ] - - FieldFunction fieldName extra -> - Encode.object - [ typeTag "fieldFunction" - , ( "fieldName", encodeName fieldName ) - , ( "extra", encodeExtra extra ) - ] - - Apply function argument extra -> - Encode.object - [ typeTag "apply" - , ( "function", encodeValue encodeExtra function ) - , ( "argument", encodeValue encodeExtra argument ) - , ( "extra", encodeExtra extra ) - ] - - Lambda argumentPattern body extra -> - Encode.object - [ typeTag "lambda" - , ( "argumentPattern", encodePattern encodeExtra argumentPattern ) - , ( "body", encodeValue encodeExtra body ) - , ( "extra", encodeExtra extra ) - ] - - LetDefinition valueName valueDefinition inValue extra -> - Encode.object - [ typeTag "letDef" - , ( "valueName", encodeName valueName ) - , ( "valueDefintion", encodeDefinition encodeExtra valueDefinition ) - , ( "inValue", encodeValue encodeExtra inValue ) - , ( "extra", encodeExtra extra ) - ] - - LetRecursion valueDefinitions inValue extra -> - Encode.object - [ typeTag "letRec" - , ( "valueDefintions" - , valueDefinitions - |> Encode.list - (\( name, def ) -> - Encode.list identity - [ encodeName name - , encodeDefinition encodeExtra def - ] - ) - ) - , ( "inValue", encodeValue encodeExtra inValue ) - , ( "extra", encodeExtra extra ) - ] - - Destructure pattern valueToDestruct inValue extra -> - Encode.object - [ typeTag "letDestruct" - , ( "pattern", encodePattern encodeExtra pattern ) - , ( "valueToDestruct", encodeValue encodeExtra valueToDestruct ) - , ( "inValue", encodeValue encodeExtra inValue ) - , ( "extra", encodeExtra extra ) - ] - - IfThenElse condition thenBranch elseBranch extra -> - Encode.object - [ typeTag "ifThenElse" - , ( "condition", encodeValue encodeExtra condition ) - , ( "thenBranch", encodeValue encodeExtra thenBranch ) - , ( "elseBranch", encodeValue encodeExtra elseBranch ) - , ( "extra", encodeExtra extra ) - ] - - PatternMatch branchOutOn cases extra -> - Encode.object - [ typeTag "patternMatch" - , ( "branchOutOn", encodeValue encodeExtra branchOutOn ) - , ( "cases" - , cases - |> Encode.list - (\( pattern, body ) -> - Encode.list identity - [ encodePattern encodeExtra pattern - , encodeValue encodeExtra body - ] - ) - ) - , ( "extra", encodeExtra extra ) - ] - - UpdateRecord valueToUpdate fieldsToUpdate extra -> - Encode.object - [ typeTag "update" - , ( "valueToUpdate", encodeValue encodeExtra valueToUpdate ) - , ( "fieldsToUpdate" - , fieldsToUpdate - |> Encode.list - (\( fieldName, fieldValue ) -> - Encode.list identity - [ encodeName fieldName - , encodeValue encodeExtra fieldValue - ] - ) - ) - , ( "extra", encodeExtra extra ) - ] - - Unit extra -> - Encode.object - [ typeTag "unit" - , ( "extra", encodeExtra extra ) - ] - - -decodeValue : Decode.Decoder extra -> Decode.Decoder (Value extra) -decodeValue decodeExtra = - let - lazyDecodeValue = - Decode.lazy <| - \_ -> - decodeValue decodeExtra - in - Decode.field "@type" Decode.string - |> Decode.andThen - (\kind -> - case kind of - "literal" -> - Decode.map2 Literal - (Decode.field "value" decodeLiteral) - (Decode.field "extra" decodeExtra) - - "constructor" -> - Decode.map2 Constructor - (Decode.field "fullyQualifiedName" decodeFQName) - (Decode.field "extra" decodeExtra) - - "tuple" -> - Decode.map2 Tuple - (Decode.field "elements" <| Decode.list lazyDecodeValue) - (Decode.field "extra" decodeExtra) - - "list" -> - Decode.map2 List - (Decode.field "items" <| Decode.list lazyDecodeValue) - (Decode.field "extra" decodeExtra) - - "record" -> - Decode.map2 Record - (Decode.field "fields" - (Decode.list - (Decode.map2 Tuple.pair - (Decode.index 0 decodeName) - (Decode.index 1 <| decodeValue decodeExtra) - ) - ) - ) - (Decode.field "extra" decodeExtra) - - "variable" -> - Decode.map2 Variable - (Decode.field "name" decodeName) - (Decode.field "extra" decodeExtra) - - "reference" -> - Decode.map2 Reference - (Decode.field "fullyQualifiedName" decodeFQName) - (Decode.field "extra" decodeExtra) - - "field" -> - Decode.map3 Field - (Decode.field "subjectValue" <| decodeValue decodeExtra) - (Decode.field "fieldName" decodeName) - (Decode.field "extra" decodeExtra) - - "fieldFunction" -> - Decode.map2 FieldFunction - (Decode.field "fieldName" decodeName) - (Decode.field "extra" decodeExtra) - - "apply" -> - Decode.map3 Apply - (Decode.field "function" <| decodeValue decodeExtra) - (Decode.field "argument" <| decodeValue decodeExtra) - (Decode.field "extra" decodeExtra) - - "lambda" -> - Decode.map3 Lambda - (Decode.field "argumentPattern" <| decodePattern decodeExtra) - (Decode.field "body" <| decodeValue decodeExtra) - (Decode.field "extra" decodeExtra) - - "letDef" -> - Decode.map4 LetDefinition - (Decode.field "valueName" decodeName) - (Decode.field "valueDefintion" <| decodeDefinition decodeExtra) - (Decode.field "inValue" <| decodeValue decodeExtra) - (Decode.field "extra" decodeExtra) - - "letRec" -> - Decode.map3 LetRecursion - (Decode.field "valueDefintions" - (Decode.list - (Decode.map2 Tuple.pair - (Decode.index 0 decodeName) - (Decode.index 1 <| decodeDefinition decodeExtra) - ) - ) - ) - (Decode.field "inValue" <| decodeValue decodeExtra) - (Decode.field "extra" decodeExtra) - - "letDestruct" -> - Decode.map4 Destructure - (Decode.field "pattern" <| decodePattern decodeExtra) - (Decode.field "valueToDestruct" <| decodeValue decodeExtra) - (Decode.field "inValue" <| decodeValue decodeExtra) - (Decode.field "extra" decodeExtra) - - "ifThenElse" -> - Decode.map4 IfThenElse - (Decode.field "condition" <| decodeValue decodeExtra) - (Decode.field "thenBranch" <| decodeValue decodeExtra) - (Decode.field "elseBranch" <| decodeValue decodeExtra) - (Decode.field "extra" decodeExtra) - - "patternMatch" -> - Decode.map3 PatternMatch - (Decode.field "branchOutOn" <| decodeValue decodeExtra) - (Decode.field "cases" <| - Decode.list - (Decode.map2 Tuple.pair - (decodePattern decodeExtra) - (decodeValue decodeExtra) - ) - ) - (Decode.field "extra" decodeExtra) - - "update" -> - Decode.map3 UpdateRecord - (Decode.field "valueToUpdate" <| decodeValue decodeExtra) - (Decode.field "fieldsToUpdate" <| - Decode.list <| - Decode.map2 Tuple.pair - decodeName - (decodeValue decodeExtra) - ) - (Decode.field "extra" decodeExtra) - - "unit" -> - Decode.map Unit - (Decode.field "extra" decodeExtra) - - other -> - Decode.fail <| "Unknown value type: " ++ other - ) - - -encodePattern : (extra -> Encode.Value) -> Pattern extra -> Encode.Value -encodePattern encodeExtra pattern = - let - typeTag tag = - ( "@type", Encode.string tag ) - in - case pattern of - WildcardPattern extra -> - Encode.object - [ typeTag "wildcardPattern" - , ( "extra", encodeExtra extra ) - ] - - AsPattern p name extra -> - Encode.object - [ typeTag "asPattern" - , ( "pattern", encodePattern encodeExtra p ) - , ( "name", encodeName name ) - , ( "extra", encodeExtra extra ) - ] - - TuplePattern elementPatterns extra -> - Encode.object - [ typeTag "tuplePattern" - , ( "elementPatterns", elementPatterns |> Encode.list (encodePattern encodeExtra) ) - , ( "extra", encodeExtra extra ) - ] - - RecordPattern fieldNames extra -> - Encode.object - [ typeTag "recordPattern" - , ( "fieldNames", fieldNames |> Encode.list encodeName ) - , ( "extra", encodeExtra extra ) - ] - - ConstructorPattern constructorName argumentPatterns extra -> - Encode.object - [ typeTag "constructorPattern" - , ( "constructorName", encodeFQName constructorName ) - , ( "argumentPatterns", argumentPatterns |> Encode.list (encodePattern encodeExtra) ) - , ( "extra", encodeExtra extra ) - ] - - EmptyListPattern extra -> - Encode.object - [ typeTag "emptyListPattern" - , ( "extra", encodeExtra extra ) - ] - - HeadTailPattern headPattern tailPattern extra -> - Encode.object - [ typeTag "headTailPattern" - , ( "headPattern", encodePattern encodeExtra headPattern ) - , ( "tailPattern", encodePattern encodeExtra tailPattern ) - , ( "extra", encodeExtra extra ) - ] - - LiteralPattern value extra -> - Encode.object - [ typeTag "literalPattern" - , ( "value", encodeLiteral value ) - , ( "extra", encodeExtra extra ) - ] - - -decodePattern : Decode.Decoder extra -> Decode.Decoder (Pattern extra) -decodePattern decodeExtra = - let - lazyDecodePattern = - Decode.lazy <| - \_ -> - decodePattern decodeExtra - in - Decode.field "@type" Decode.string - |> Decode.andThen - (\kind -> - case kind of - "wildcardPattern" -> - Decode.map WildcardPattern - (Decode.field "extra" decodeExtra) - - "asPattern" -> - Decode.map3 AsPattern - (Decode.field "pattern" lazyDecodePattern) - (Decode.field "name" decodeName) - (Decode.field "extra" decodeExtra) - - "tuplePattern" -> - Decode.map2 TuplePattern - (Decode.field "elementPatterns" <| Decode.list lazyDecodePattern) - (Decode.field "extra" decodeExtra) - - "recordPattern" -> - Decode.map2 RecordPattern - (Decode.field "fieldNames" <| Decode.list decodeName) - (Decode.field "extra" decodeExtra) - - "constructorPattern" -> - Decode.map3 ConstructorPattern - (Decode.field "constructorName" decodeFQName) - (Decode.field "argumentPatterns" <| Decode.list lazyDecodePattern) - (Decode.field "extra" decodeExtra) - - "emptyListPattern" -> - Decode.map EmptyListPattern - (Decode.field "extra" decodeExtra) - - "headTailPattern" -> - Decode.map3 HeadTailPattern - (Decode.field "headPattern" lazyDecodePattern) - (Decode.field "tailPattern" lazyDecodePattern) - (Decode.field "extra" decodeExtra) - - other -> - Decode.fail <| "Unknown pattern type: " ++ other - ) - - -encodeLiteral : Literal -> Encode.Value -encodeLiteral l = - let - typeTag tag = - ( "@type", Encode.string tag ) - in - case l of - BoolLiteral v -> - Encode.object - [ typeTag "boolLiteral" - , ( "value", Encode.bool v ) - ] - - CharLiteral v -> - Encode.object - [ typeTag "charLiteral" - , ( "value", Encode.string (String.fromChar v) ) - ] - - StringLiteral v -> - Encode.object - [ typeTag "stringLiteral" - , ( "value", Encode.string v ) - ] - - IntLiteral v -> - Encode.object - [ typeTag "intLiteral" - , ( "value", Encode.int v ) - ] - - FloatLiteral v -> - Encode.object - [ typeTag "floatLiteral" - , ( "value", Encode.float v ) - ] - - -decodeLiteral : Decode.Decoder Literal -decodeLiteral = - Decode.field "@type" Decode.string - |> Decode.andThen - (\kind -> - case kind of - "boolLiteral" -> - Decode.map BoolLiteral - (Decode.field "value" Decode.bool) - - "charLiteral" -> - Decode.map CharLiteral - (Decode.field "value" Decode.string - |> Decode.andThen - (\str -> - case String.uncons str of - Just ( ch, _ ) -> - Decode.succeed ch - - Nothing -> - Decode.fail "Single char expected" - ) - ) - - "stringLiteral" -> - Decode.map StringLiteral - (Decode.field "value" Decode.string) - - "intLiteral" -> - Decode.map IntLiteral - (Decode.field "value" Decode.int) - - "floatLiteral" -> - Decode.map FloatLiteral - (Decode.field "value" Decode.float) - - other -> - Decode.fail <| "Unknown literal type: " ++ other - ) - - -encodeSpecification : (extra -> Encode.Value) -> Specification extra -> Encode.Value -encodeSpecification encodeExtra spec = - Encode.object - [ ( "inputs" - , spec.inputs - |> Encode.list - (\( argName, argType ) -> - Encode.object - [ ( "argName", encodeName argName ) - , ( "argType", encodeType encodeExtra argType ) - ] - ) - ) - , ( "output", encodeType encodeExtra spec.output ) - ] - - -encodeDefinition : (extra -> Encode.Value) -> Definition extra -> Encode.Value -encodeDefinition encodeExtra definition = - case definition of - TypedDefinition valueType argumentNames body -> - Encode.object - [ ( "@type", Encode.string "typedDefinition" ) - , ( "valueType", encodeType encodeExtra valueType ) - , ( "argumentNames", argumentNames |> Encode.list encodeName ) - , ( "body", encodeValue encodeExtra body ) - ] - - UntypedDefinition argumentNames body -> - Encode.object - [ ( "@type", Encode.string "untypedDefinition" ) - , ( "argumentNames", argumentNames |> Encode.list encodeName ) - , ( "body", encodeValue encodeExtra body ) - ] - - -decodeDefinition : Decode.Decoder extra -> Decode.Decoder (Definition extra) -decodeDefinition decodeExtra = - Decode.field "@type" Decode.string - |> Decode.andThen - (\kind -> - case kind of - "typedDefinition" -> - Decode.map3 TypedDefinition - (Decode.field "valueType" <| decodeType decodeExtra) - (Decode.field "argumentNames" <| Decode.list decodeName) - (Decode.field "body" <| Decode.lazy (\_ -> decodeValue decodeExtra)) - - "untypedDefinition" -> - Decode.map2 UntypedDefinition - (Decode.field "argumentNames" <| Decode.list decodeName) - (Decode.field "body" <| Decode.lazy (\_ -> decodeValue decodeExtra)) - - other -> - Decode.fail <| "Unknown definition type: " ++ other - ) diff --git a/src/Morphir/IR/Module.elm b/src/Morphir/IR/Module.elm index c20855724..35c49dfb7 100644 --- a/src/Morphir/IR/Module.elm +++ b/src/Morphir/IR/Module.elm @@ -1,15 +1,219 @@ -module Morphir.IR.Module exposing (Definition) +module Morphir.IR.Module exposing + ( Specification, Definition + , encodeSpecification, encodeDefinition + , definitionToSpecification, eraseSpecificationExtra, mapDefinition, mapSpecification + ) {-| Modules are groups of types and values that belong together. -@docs Definition +@docs Specification, Definition +@docs encodeSpecification, encodeDefinition + +-} + +import Dict exposing (Dict) +import Json.Decode as Decode +import Json.Encode as Encode +import Morphir.IR.AccessControlled as AccessControlled exposing (AccessControlled, encodeAccessControlled, withPublicAccess) +import Morphir.IR.Name exposing (Name, encodeName) +import Morphir.IR.Type as Type exposing (Type) +import Morphir.IR.Value as Value exposing (Value) +import Morphir.ResultList as ResultList + + +{-| Type that represents a module specification. -} +type alias Specification extra = + { types : Dict Name (Type.Specification extra) + , values : Dict Name (Value.Specification extra) + } + -import Morphir.IR.Advanced.Module as Advanced +emptySpecification : Specification extra +emptySpecification = + { types = Dict.empty + , values = Dict.empty + } -{-| Type that represents a module defintion. It includes types and values. +{-| Type that represents a module definition. It includes types and values. -} -type alias Definition = - Advanced.Definition () +type alias Definition extra = + { types : Dict Name (AccessControlled (Type.Definition extra)) + , values : Dict Name (AccessControlled (Value.Definition extra)) + } + + +definitionToSpecification : Definition extra -> Specification extra +definitionToSpecification def = + { types = + def.types + |> Dict.toList + |> List.filterMap + (\( path, accessControlledType ) -> + accessControlledType + |> withPublicAccess + |> Maybe.map + (\typeDef -> + ( path, Type.definitionToSpecification typeDef ) + ) + ) + |> Dict.fromList + , values = Dict.empty + + -- TODO: implement for values + -- def.values + -- |> Dict.toList + -- |> List.filterMap + -- (\( path, accessControlledValue ) -> + -- accessControlledValue + -- |> withPublicAccess + -- |> Maybe.map + -- (\valueDef -> + -- ( path, Value.definitionToSpecification valueDef ) + -- ) + -- ) + -- |> Dict.fromList + } + + +eraseSpecificationExtra : Specification a -> Specification () +eraseSpecificationExtra spec = + spec + |> mapSpecification + (Type.mapTypeExtra (\_ -> ()) >> Ok) + (Value.mapValueExtra (\_ -> ())) + |> Result.withDefault emptySpecification + + +{-| -} +encodeSpecification : (extra -> Encode.Value) -> Specification extra -> Encode.Value +encodeSpecification encodeExtra spec = + Encode.object + [ ( "types" + , spec.types + |> Dict.toList + |> Encode.list + (\( name, typeSpec ) -> + Encode.object + [ ( "name", encodeName name ) + , ( "spec", Type.encodeSpecification encodeExtra typeSpec ) + ] + ) + ) + , ( "values" + , spec.values + |> Dict.toList + |> Encode.list + (\( name, valueSpec ) -> + Encode.object + [ ( "name", encodeName name ) + , ( "spec", Value.encodeSpecification encodeExtra valueSpec ) + ] + ) + ) + ] + + +mapSpecification : (Type a -> Result e (Type b)) -> (Value a -> Value b) -> Specification a -> Result (List e) (Specification b) +mapSpecification mapType mapValue spec = + let + typesResult : Result (List e) (Dict Name (Type.Specification b)) + typesResult = + spec.types + |> Dict.toList + |> List.map + (\( typeName, typeSpec ) -> + typeSpec + |> Type.mapSpecification mapType + |> Result.map (Tuple.pair typeName) + ) + |> ResultList.toResult + |> Result.map Dict.fromList + |> Result.mapError List.concat + + valuesResult : Result (List e) (Dict Name (Value.Specification b)) + valuesResult = + spec.values + |> Dict.toList + |> List.map + (\( valueName, valueSpec ) -> + valueSpec + |> Value.mapSpecification mapType mapValue + |> Result.map (Tuple.pair valueName) + ) + |> ResultList.toResult + |> Result.map Dict.fromList + |> Result.mapError List.concat + in + Result.map2 Specification + typesResult + valuesResult + + +mapDefinition : (Type a -> Result e (Type b)) -> (Value a -> Value b) -> Definition a -> Result (List e) (Definition b) +mapDefinition mapType mapValue def = + let + typesResult : Result (List e) (Dict Name (AccessControlled (Type.Definition b))) + typesResult = + def.types + |> Dict.toList + |> List.map + (\( typeName, typeDef ) -> + typeDef.value + |> Type.mapDefinition mapType + |> Result.map (AccessControlled typeDef.access) + |> Result.map (Tuple.pair typeName) + ) + |> ResultList.toResult + |> Result.map Dict.fromList + |> Result.mapError List.concat + + valuesResult : Result (List e) (Dict Name (AccessControlled (Value.Definition b))) + valuesResult = + def.values + |> Dict.toList + |> List.map + (\( valueName, valueDef ) -> + valueDef.value + |> Value.mapDefinition mapType mapValue + |> Result.map (AccessControlled valueDef.access) + |> Result.map (Tuple.pair valueName) + ) + |> ResultList.toResult + |> Result.map Dict.fromList + |> Result.mapError List.concat + in + Result.map2 Definition + typesResult + valuesResult + + +{-| -} +encodeDefinition : (extra -> Encode.Value) -> Definition extra -> Encode.Value +encodeDefinition encodeExtra def = + Encode.object + [ ( "types" + , def.types + |> Dict.toList + |> Encode.list + (\( name, typeDef ) -> + Encode.object + [ ( "name", encodeName name ) + , ( "def", encodeAccessControlled (Type.encodeDefinition encodeExtra) typeDef ) + ] + ) + ) + , ( "values" + , def.values + |> Dict.toList + |> Encode.list + (\( name, valueDef ) -> + Encode.object + [ ( "name", encodeName name ) + , ( "def", encodeAccessControlled (Value.encodeDefinition encodeExtra) valueDef ) + ] + ) + ) + ] diff --git a/src/Morphir/IR/Package.elm b/src/Morphir/IR/Package.elm index 4bf9124eb..8a03987a6 100644 --- a/src/Morphir/IR/Package.elm +++ b/src/Morphir/IR/Package.elm @@ -1,26 +1,192 @@ module Morphir.IR.Package exposing ( Specification - , Definition + , Definition, emptyDefinition + , definitionToSpecification, encodeDefinition, eraseDefinitionExtra, eraseSpecificationExtra ) {-| Tools to work with packages. @docs Specification -@docs Definition +@docs Definition, emptyDefinition -} -import Morphir.IR.Advanced.Package as Advanced +import Dict exposing (Dict) +import Json.Decode as Decode +import Json.Encode as Encode +import Morphir.IR.AccessControlled as AccessControlled exposing (AccessControlled, encodeAccessControlled, withPublicAccess) +import Morphir.IR.Module as Module +import Morphir.IR.Path exposing (Path, encodePath) +import Morphir.IR.QName exposing (QName, encodeQName) +import Morphir.IR.Type as Type exposing (Type) +import Morphir.IR.Value as Value exposing (Value) +import Morphir.ResultList as ResultList {-| Type that represents a package specification. -} -type alias Specification = - Advanced.Specification () +type alias Specification extra = + { modules : Dict Path (Module.Specification extra) + } + + +emptySpecification : Specification extra +emptySpecification = + { modules = Dict.empty + } {-| Type that represents a package definition. -} -type alias Definition = - Advanced.Definition () +type alias Definition extra = + { dependencies : Dict Path (Specification extra) + , modules : Dict Path (AccessControlled (Module.Definition extra)) + } + + +{-| An empty package definition. +-} +emptyDefinition : Definition extra +emptyDefinition = + { dependencies = Dict.empty + , modules = Dict.empty + } + + +definitionToSpecification : Definition extra -> Specification extra +definitionToSpecification def = + { modules = + def.modules + |> Dict.toList + |> List.filterMap + (\( path, accessControlledModule ) -> + accessControlledModule + |> withPublicAccess + |> Maybe.map + (\moduleDef -> + ( path, Module.definitionToSpecification moduleDef ) + ) + ) + |> Dict.fromList + } + + +mapSpecification : (Type a -> Result e (Type b)) -> (Value a -> Value b) -> Specification a -> Result (List e) (Specification b) +mapSpecification mapType mapValue spec = + let + modulesResult : Result (List e) (Dict Path (Module.Specification b)) + modulesResult = + spec.modules + |> Dict.toList + |> List.map + (\( modulePath, moduleSpec ) -> + moduleSpec + |> Module.mapSpecification mapType mapValue + |> Result.map (Tuple.pair modulePath) + ) + |> ResultList.toResult + |> Result.map Dict.fromList + |> Result.mapError List.concat + in + Result.map Specification modulesResult + + +eraseSpecificationExtra : Specification a -> Specification () +eraseSpecificationExtra spec = + spec + |> mapSpecification + (Type.mapTypeExtra (\_ -> ()) >> Ok) + (Value.mapValueExtra (\_ -> ())) + |> Result.withDefault emptySpecification + + +mapDefinition : (Type a -> Result e (Type b)) -> (Value a -> Value b) -> Definition a -> Result (List e) (Definition b) +mapDefinition mapType mapValue def = + let + dependenciesResult : Result (List e) (Dict Path (Specification b)) + dependenciesResult = + def.dependencies + |> Dict.toList + |> List.map + (\( packagePath, packageSpec ) -> + packageSpec + |> mapSpecification mapType mapValue + |> Result.map (Tuple.pair packagePath) + ) + |> ResultList.toResult + |> Result.map Dict.fromList + |> Result.mapError List.concat + + modulesResult : Result (List e) (Dict Path (AccessControlled (Module.Definition b))) + modulesResult = + def.modules + |> Dict.toList + |> List.map + (\( modulePath, moduleDef ) -> + moduleDef.value + |> Module.mapDefinition mapType mapValue + |> Result.map (AccessControlled moduleDef.access) + |> Result.map (Tuple.pair modulePath) + ) + |> ResultList.toResult + |> Result.map Dict.fromList + |> Result.mapError List.concat + in + Result.map2 Definition + dependenciesResult + modulesResult + + +eraseDefinitionExtra : Definition a -> Definition () +eraseDefinitionExtra def = + def + |> mapDefinition + (Type.mapTypeExtra (\_ -> ()) >> Ok) + (Value.mapValueExtra (\_ -> ())) + |> Result.withDefault emptyDefinition + + +encodeSpecification : (extra -> Encode.Value) -> Specification extra -> Encode.Value +encodeSpecification encodeExtra spec = + Encode.object + [ ( "modules" + , spec.modules + |> Dict.toList + |> Encode.list + (\( moduleName, moduleSpec ) -> + Encode.object + [ ( "name", encodePath moduleName ) + , ( "spec", Module.encodeSpecification encodeExtra moduleSpec ) + ] + ) + ) + ] + + +encodeDefinition : (extra -> Encode.Value) -> Definition extra -> Encode.Value +encodeDefinition encodeExtra def = + Encode.object + [ ( "dependencies" + , def.dependencies + |> Dict.toList + |> Encode.list + (\( packageName, packageSpec ) -> + Encode.object + [ ( "name", encodePath packageName ) + , ( "spec", encodeSpecification encodeExtra packageSpec ) + ] + ) + ) + , ( "modules" + , def.modules + |> Dict.toList + |> Encode.list + (\( moduleName, moduleDef ) -> + Encode.object + [ ( "name", encodePath moduleName ) + , ( "def", encodeAccessControlled (Module.encodeDefinition encodeExtra) moduleDef ) + ] + ) + ) + ] diff --git a/src/Morphir/IR/SDK.elm b/src/Morphir/IR/SDK.elm index 4f4c7790c..d8e3bcecd 100644 --- a/src/Morphir/IR/SDK.elm +++ b/src/Morphir/IR/SDK.elm @@ -1,7 +1,7 @@ module Morphir.IR.SDK exposing (..) import Dict -import Morphir.IR.Advanced.Package as Package +import Morphir.IR.Package as Package import Morphir.IR.SDK.Bool as Bool import Morphir.IR.SDK.Char as Char import Morphir.IR.SDK.Float as Float diff --git a/src/Morphir/IR/SDK/Bool.elm b/src/Morphir/IR/SDK/Bool.elm index d747e9faa..ca113b7e8 100644 --- a/src/Morphir/IR/SDK/Bool.elm +++ b/src/Morphir/IR/SDK/Bool.elm @@ -1,13 +1,13 @@ module Morphir.IR.SDK.Bool exposing (..) import Dict -import Morphir.IR.Advanced.Module as Module -import Morphir.IR.Advanced.Type exposing (Specification(..), Type(..)) import Morphir.IR.FQName as FQName exposing (FQName) +import Morphir.IR.Module as Module import Morphir.IR.Name as Name import Morphir.IR.Path exposing (Path) import Morphir.IR.QName as QName import Morphir.IR.SDK.Common exposing (packageName) +import Morphir.IR.Type exposing (Specification(..), Type(..)) moduleName : Path diff --git a/src/Morphir/IR/SDK/Char.elm b/src/Morphir/IR/SDK/Char.elm index 8782a4724..4497aef85 100644 --- a/src/Morphir/IR/SDK/Char.elm +++ b/src/Morphir/IR/SDK/Char.elm @@ -1,13 +1,13 @@ module Morphir.IR.SDK.Char exposing (..) import Dict -import Morphir.IR.Advanced.Module as Module -import Morphir.IR.Advanced.Type exposing (Specification(..), Type(..)) import Morphir.IR.FQName as FQName exposing (FQName) +import Morphir.IR.Module as Module import Morphir.IR.Name as Name import Morphir.IR.Path exposing (Path) import Morphir.IR.QName as QName import Morphir.IR.SDK.Common exposing (packageName) +import Morphir.IR.Type exposing (Specification(..), Type(..)) moduleName : Path diff --git a/src/Morphir/IR/SDK/Float.elm b/src/Morphir/IR/SDK/Float.elm index 54a2a8c9a..45f83d3cb 100644 --- a/src/Morphir/IR/SDK/Float.elm +++ b/src/Morphir/IR/SDK/Float.elm @@ -1,13 +1,13 @@ module Morphir.IR.SDK.Float exposing (..) import Dict -import Morphir.IR.Advanced.Module as Module -import Morphir.IR.Advanced.Type exposing (Specification(..), Type(..)) import Morphir.IR.FQName as FQName exposing (FQName) +import Morphir.IR.Module as Module import Morphir.IR.Name as Name import Morphir.IR.Path exposing (Path) import Morphir.IR.QName as QName import Morphir.IR.SDK.Common exposing (packageName) +import Morphir.IR.Type exposing (Specification(..), Type(..)) moduleName : Path diff --git a/src/Morphir/IR/SDK/Int.elm b/src/Morphir/IR/SDK/Int.elm index cd285bdfa..2630a61c8 100644 --- a/src/Morphir/IR/SDK/Int.elm +++ b/src/Morphir/IR/SDK/Int.elm @@ -1,13 +1,13 @@ module Morphir.IR.SDK.Int exposing (..) import Dict -import Morphir.IR.Advanced.Module as Module -import Morphir.IR.Advanced.Type exposing (Specification(..), Type(..)) import Morphir.IR.FQName as FQName exposing (FQName) +import Morphir.IR.Module as Module import Morphir.IR.Name as Name import Morphir.IR.Path exposing (Path) import Morphir.IR.QName as QName import Morphir.IR.SDK.Common exposing (packageName) +import Morphir.IR.Type exposing (Specification(..), Type(..)) moduleName : Path diff --git a/src/Morphir/IR/SDK/List.elm b/src/Morphir/IR/SDK/List.elm index 7471ec386..995802bab 100644 --- a/src/Morphir/IR/SDK/List.elm +++ b/src/Morphir/IR/SDK/List.elm @@ -1,13 +1,13 @@ module Morphir.IR.SDK.List exposing (..) import Dict -import Morphir.IR.Advanced.Module as Module -import Morphir.IR.Advanced.Type exposing (Specification(..), Type(..)) import Morphir.IR.FQName as FQName exposing (FQName) +import Morphir.IR.Module as Module import Morphir.IR.Name as Name import Morphir.IR.Path exposing (Path) import Morphir.IR.QName as QName import Morphir.IR.SDK.Common exposing (packageName) +import Morphir.IR.Type exposing (Specification(..), Type(..)) moduleName : Path diff --git a/src/Morphir/IR/SDK/Maybe.elm b/src/Morphir/IR/SDK/Maybe.elm index d5ae7d8f9..9f7683e2e 100644 --- a/src/Morphir/IR/SDK/Maybe.elm +++ b/src/Morphir/IR/SDK/Maybe.elm @@ -1,13 +1,13 @@ module Morphir.IR.SDK.Maybe exposing (..) import Dict -import Morphir.IR.Advanced.Module as Module -import Morphir.IR.Advanced.Type as Type exposing (Specification(..), Type(..)) import Morphir.IR.FQName as FQName exposing (FQName) +import Morphir.IR.Module as Module import Morphir.IR.Name as Name import Morphir.IR.Path exposing (Path) import Morphir.IR.QName as QName import Morphir.IR.SDK.Common exposing (packageName) +import Morphir.IR.Type as Type exposing (Specification(..), Type(..)) moduleName : Path diff --git a/src/Morphir/IR/SDK/Result.elm b/src/Morphir/IR/SDK/Result.elm index 9899c029a..541785416 100644 --- a/src/Morphir/IR/SDK/Result.elm +++ b/src/Morphir/IR/SDK/Result.elm @@ -1,13 +1,13 @@ module Morphir.IR.SDK.Result exposing (..) import Dict -import Morphir.IR.Advanced.Module as Module -import Morphir.IR.Advanced.Type as Type exposing (Specification(..), Type(..)) import Morphir.IR.FQName as FQName exposing (FQName) +import Morphir.IR.Module as Module import Morphir.IR.Name as Name import Morphir.IR.Path exposing (Path) import Morphir.IR.QName as QName import Morphir.IR.SDK.Common exposing (packageName) +import Morphir.IR.Type as Type exposing (Specification(..), Type(..)) moduleName : Path diff --git a/src/Morphir/IR/SDK/String.elm b/src/Morphir/IR/SDK/String.elm index 0e2091158..4ae22a52d 100644 --- a/src/Morphir/IR/SDK/String.elm +++ b/src/Morphir/IR/SDK/String.elm @@ -1,13 +1,13 @@ module Morphir.IR.SDK.String exposing (..) import Dict -import Morphir.IR.Advanced.Module as Module -import Morphir.IR.Advanced.Type exposing (Specification(..), Type(..)) import Morphir.IR.FQName as FQName exposing (FQName) +import Morphir.IR.Module as Module import Morphir.IR.Name as Name import Morphir.IR.Path exposing (Path) import Morphir.IR.QName as QName import Morphir.IR.SDK.Common exposing (packageName) +import Morphir.IR.Type exposing (Specification(..), Type(..)) moduleName : Path diff --git a/src/Morphir/IR/Type.elm b/src/Morphir/IR/Type.elm index e7bbbd44a..92d4606ce 100644 --- a/src/Morphir/IR/Type.elm +++ b/src/Morphir/IR/Type.elm @@ -1,10 +1,14 @@ module Morphir.IR.Type exposing - ( Type + ( Type(..) , variable, reference, tuple, record, extensibleRecord, function, unit , matchVariable, matchReference, matchTuple, matchRecord, matchExtensibleRecord, matchFunction, matchUnit - , Field, field, matchField - , Specification - , Definition + , Field, matchField, mapFieldName, mapFieldType + , Specification(..), typeAliasSpecification, opaqueTypeSpecification, customTypeSpecification, matchCustomTypeSpecification + , Definition(..), typeAliasDefinition, customTypeDefinition + , Constructors + , fuzzType + , encodeType, decodeType, encodeSpecification, encodeDefinition + , Constructor, definitionToSpecification, mapDefinition, mapSpecification, mapTypeExtra, rewriteType ) {-| This module contains the building blocks of types in the Morphir IR. @@ -27,25 +31,43 @@ module Morphir.IR.Type exposing # Record Field -@docs Field, field, matchField +@docs Field, matchField, mapFieldName, mapFieldType # Specification -@docs Specification +@docs Specification, typeAliasSpecification, opaqueTypeSpecification, customTypeSpecification, matchCustomTypeSpecification # Definition -@docs Definition +@docs Definition, typeAliasDefinition, customTypeDefinition + + +# Constructors + +@docs Constructors + + +# Property Testing + +@docs fuzzType + + +# Serialization + +@docs encodeType, decodeType, encodeSpecification, encodeDefinition -} -import Morphir.IR.AccessControlled exposing (AccessControlled) -import Morphir.IR.Advanced.Type as Advanced -import Morphir.IR.FQName exposing (FQName) -import Morphir.IR.Name exposing (Name) -import Morphir.Pattern as Pattern exposing (Pattern, matchAny) +import Fuzz exposing (Fuzzer) +import Json.Decode as Decode +import Json.Encode as Encode +import Morphir.IR.AccessControlled as AccessControlled exposing (AccessControlled, encodeAccessControlled, withPublicAccess) +import Morphir.IR.FQName exposing (FQName, decodeFQName, encodeFQName, fuzzFQName) +import Morphir.IR.Name exposing (Name, decodeName, encodeName, fuzzName) +import Morphir.Pattern exposing (Pattern) +import Morphir.ResultList as ResultList import Morphir.Rewrite exposing (Rewrite) @@ -61,48 +83,210 @@ for more details: - unit type: [creation](#unit), [matching](#matchUnit) -} -type alias Type = - Advanced.Type () +type Type extra + = Variable Name extra + | Reference FQName (List (Type extra)) extra + | Tuple (List (Type extra)) extra + | Record (List (Field extra)) extra + | ExtensibleRecord Name (List (Field extra)) extra + | Function (Type extra) (Type extra) extra + | Unit extra {-| An opaque representation of a field. It's made up of a name and a type. -} -type alias Field = - Advanced.Field () +type alias Field extra = + { name : Name + , tpe : Type extra + } {-| -} -type alias Specification = - Advanced.Specification () +type Specification extra + = TypeAliasSpecification (List Name) (Type extra) + | OpaqueTypeSpecification (List Name) + | CustomTypeSpecification (List Name) (Constructors extra) + + +{-| This syntax represents a type definition. For example: + + - `type alias Foo a = {bar : Maybe a, qux : Int}` + - `type MyList a = End | Cons a (MyList a)` + +In the definition, the `List Name` refers to type parameters on the LHS +and `Type extra` refers to the RHS + +-} +type Definition extra + = TypeAliasDefinition (List Name) (Type extra) + | CustomTypeDefinition (List Name) (AccessControlled (Constructors extra)) {-| -} -type alias Definition = - Advanced.Definition () +type alias Constructors extra = + List (Constructor extra) {-| -} -type alias Constructors = - Advanced.Constructors () +type alias Constructor extra = + ( Name, List ( Name, Type extra ) ) + + +definitionToSpecification : Definition extra -> Specification extra +definitionToSpecification def = + case def of + TypeAliasDefinition params exp -> + TypeAliasSpecification params exp + + CustomTypeDefinition params accessControlledCtors -> + case accessControlledCtors |> withPublicAccess of + Just ctors -> + CustomTypeSpecification params ctors + + Nothing -> + OpaqueTypeSpecification params + + +mapSpecification : (Type a -> Result e (Type b)) -> Specification a -> Result (List e) (Specification b) +mapSpecification f spec = + case spec of + TypeAliasSpecification params tpe -> + f tpe + |> Result.map (TypeAliasSpecification params) + |> Result.mapError List.singleton + + OpaqueTypeSpecification params -> + OpaqueTypeSpecification params + |> Ok + + CustomTypeSpecification params constructors -> + let + ctorsResult : Result (List e) (Constructors b) + ctorsResult = + constructors + |> List.map + (\( ctorName, ctorArgs ) -> + ctorArgs + |> List.map + (\( argName, argType ) -> + f argType + |> Result.map (Tuple.pair argName) + ) + |> ResultList.toResult + |> Result.map (Tuple.pair ctorName) + ) + |> ResultList.toResult + |> Result.mapError List.concat + in + ctorsResult + |> Result.map (CustomTypeSpecification params) + + +mapDefinition : (Type a -> Result e (Type b)) -> Definition a -> Result (List e) (Definition b) +mapDefinition f def = + case def of + TypeAliasDefinition params tpe -> + f tpe + |> Result.map (TypeAliasDefinition params) + |> Result.mapError List.singleton + + CustomTypeDefinition params constructors -> + let + ctorsResult : Result (List e) (AccessControlled (Constructors b)) + ctorsResult = + constructors.value + |> List.map + (\( ctorName, ctorArgs ) -> + ctorArgs + |> List.map + (\( argName, argType ) -> + f argType + |> Result.map (Tuple.pair argName) + ) + |> ResultList.toResult + |> Result.map (Tuple.pair ctorName) + ) + |> ResultList.toResult + |> Result.map (AccessControlled constructors.access) + |> Result.mapError List.concat + in + ctorsResult + |> Result.map (CustomTypeDefinition params) + + +mapTypeExtra : (a -> b) -> Type a -> Type b +mapTypeExtra f tpe = + case tpe of + Variable name extra -> + Variable name (f extra) + + Reference fQName argTypes extra -> + Reference fQName (argTypes |> List.map (mapTypeExtra f)) (f extra) + + Tuple elemTypes extra -> + Tuple (elemTypes |> List.map (mapTypeExtra f)) (f extra) + + Record fields extra -> + Record (fields |> List.map (mapFieldType (mapTypeExtra f))) (f extra) + + ExtensibleRecord name fields extra -> + ExtensibleRecord name (fields |> List.map (mapFieldType (mapTypeExtra f))) (f extra) + + Function argType returnType extra -> + Function (argType |> mapTypeExtra f) (returnType |> mapTypeExtra f) (f extra) + + Unit extra -> + Unit (f extra) + + +typeExtra : Type a -> a +typeExtra tpe = + case tpe of + Variable name extra -> + extra + + Reference fQName argTypes extra -> + extra + + Tuple elemTypes extra -> + extra + + Record fields extra -> + extra + + ExtensibleRecord name fields extra -> + extra + + Function argType returnType extra -> + extra + + Unit extra -> + extra {-| Creates a type variable. - toIR a == variable [ "a" ] + toIR a == variable [ "a" ] () - toIR fooBar == variable [ "foo", "bar" ] + toIR fooBar == variable [ "foo", "bar" ] () -} -variable : Name -> Type -variable name = - Advanced.variable name () +variable : Name -> extra -> Type extra +variable name extra = + Variable name extra {-| -} -matchVariable : Pattern Name a -> Pattern Type a -matchVariable matchName = - Advanced.matchVariable matchName matchAny - |> Pattern.map Tuple.first +matchVariable : Pattern Name a -> Pattern extra b -> Pattern (Type extra) ( a, b ) +matchVariable matchName matchExtra typeToMatch = + case typeToMatch of + Variable name extra -> + Maybe.map2 Tuple.pair + (matchName name) + (matchExtra extra) + + _ -> + Nothing {-| Creates a fully-qualified reference to a type. @@ -116,16 +300,23 @@ matchVariable matchName = [] -} -reference : FQName -> List Type -> Type -reference typeName typeParameters = - Advanced.reference typeName typeParameters () +reference : FQName -> List (Type extra) -> extra -> Type extra +reference typeName typeParameters extra = + Reference typeName typeParameters extra {-| -} -matchReference : Pattern FQName a -> Pattern (List Type) b -> Pattern Type ( a, b ) -matchReference matchTypeName matchTypeParameters = - Advanced.matchReference matchTypeName matchTypeParameters matchAny - |> Pattern.map (\( a, b, _ ) -> ( a, b )) +matchReference : Pattern FQName a -> Pattern (List (Type extra)) b -> Pattern extra c -> Pattern (Type extra) ( a, b, c ) +matchReference matchTypeName matchTypeParameters matchExtra typeToMatch = + case typeToMatch of + Reference typeName typeParameters extra -> + Maybe.map3 (\a b c -> ( a, b, c )) + (matchTypeName typeName) + (matchTypeParameters typeParameters) + (matchExtra extra) + + _ -> + Nothing {-| Creates a tuple type. @@ -134,20 +325,33 @@ matchReference matchTypeName matchTypeParameters = == tuple [ basic intType, basic boolType ] -} -tuple : List Type -> Type -tuple elementTypes = - Advanced.tuple elementTypes () +tuple : List (Type extra) -> extra -> Type extra +tuple elementTypes extra = + Tuple elementTypes extra {-| Matches a tuple type and extracts element types. - matchTuple (list [ matchBasic any, matchBasic any ]) (tuple [ basic intType, basic boolType ]) -- [ IntType, IntType ] + tpe = + tuple [ SDK.Basics.intType, SDK.Basics.boolType ] + + pattern = + matchTuple (list [ matchBasic any, matchBasic any ]) + + pattern tpe == + [ SDK.Basics.intType, SDK.Basics.boolType ] -} -matchTuple : Pattern (List Type) a -> Pattern Type a -matchTuple matchElementTypes = - Advanced.matchTuple matchElementTypes matchAny - |> Pattern.map Tuple.first +matchTuple : Pattern (List (Type extra)) a -> Pattern extra b -> Pattern (Type extra) ( a, b ) +matchTuple matchElementTypes matchExtra typeToMatch = + case typeToMatch of + Tuple elementTypes extra -> + Maybe.map2 Tuple.pair + (matchElementTypes elementTypes) + (matchExtra extra) + + _ -> + Nothing {-| Creates a record type. @@ -166,20 +370,14 @@ matchTuple matchElementTypes = ] -} -record : List Field -> Type -record fieldTypes = - Advanced.record fieldTypes () +record : List (Field extra) -> extra -> Type extra +record fieldTypes extra = + Record fieldTypes extra {-| Match a record type. - tpe = - record - [ field ["foo"] SDK.Basics.intType - , field ["bar"] SDK.Basics.boolType - ] - - pattern = + matchRecordFooBar = matchRecord (matchList [ matchField @@ -191,14 +389,24 @@ record fieldTypes = ] ) - pattern tpe == - ( SDK.Basics.intType, SDK.Basics.boolType ) + matchRecordFooBar <| + record + [ field ["foo"] SDK.Basics.intType + , field ["bar"] SDK.Basics.boolType + ] + --> Just ( SDK.Basics.intType, SDK.Basics.boolType ) -} -matchRecord : Pattern (List Field) a -> Pattern Type a -matchRecord matchFieldTypes = - Advanced.matchRecord matchFieldTypes matchAny - |> Pattern.map Tuple.first +matchRecord : Pattern (List (Field extra)) a -> Pattern extra b -> Pattern (Type extra) ( a, b ) +matchRecord matchFieldTypes matchExtra typeToMatch = + case typeToMatch of + Record fieldTypes extra -> + Maybe.map2 Tuple.pair + (matchFieldTypes fieldTypes) + (matchExtra extra) + + _ -> + Nothing {-| Creates an extensible record type. @@ -215,16 +423,23 @@ matchRecord matchFieldTypes = ] -} -extensibleRecord : Name -> List Field -> Type -extensibleRecord variableName fieldTypes = - Advanced.extensibleRecord variableName fieldTypes () +extensibleRecord : Name -> List (Field extra) -> extra -> Type extra +extensibleRecord variableName fieldTypes extra = + ExtensibleRecord variableName fieldTypes extra {-| -} -matchExtensibleRecord : Pattern Name a -> Pattern (List Field) b -> Pattern Type ( a, b ) -matchExtensibleRecord matchVariableName matchFieldTypes = - Advanced.matchExtensibleRecord matchVariableName matchFieldTypes matchAny - |> Pattern.map (\( a, b, _ ) -> ( a, b )) +matchExtensibleRecord : Pattern Name a -> Pattern (List (Field extra)) b -> Pattern extra c -> Pattern (Type extra) ( a, b, c ) +matchExtensibleRecord matchVariableName matchFieldTypes matchExtra typeToMatch = + case typeToMatch of + ExtensibleRecord variableName fieldTypes extra -> + Maybe.map3 (\a b c -> ( a, b, c )) + (matchVariableName variableName) + (matchFieldTypes fieldTypes) + (matchExtra extra) + + _ -> + Nothing {-| Creates a function type. Use currying to create functions with more than one argument. @@ -243,9 +458,9 @@ matchExtensibleRecord matchVariableName matchFieldTypes = ) -} -function : Type -> Type -> Type -function argumentType returnType = - Advanced.function argumentType returnType () +function : Type extra -> Type extra -> extra -> Type extra +function argumentType returnType extra = + Function argumentType returnType extra {-| Matches a function type. @@ -260,10 +475,17 @@ function argumentType returnType = ( SDK.Basics.intType, SDK.Basics.boolType ) -} -matchFunction : Pattern Type a -> Pattern Type b -> Pattern Type ( a, b ) -matchFunction matchArgType matchReturnType = - Advanced.matchFunction matchArgType matchReturnType matchAny - |> Pattern.map (\( a, b, _ ) -> ( a, b )) +matchFunction : Pattern (Type extra) a -> Pattern (Type extra) b -> Pattern extra c -> Pattern (Type extra) ( a, b, c ) +matchFunction matchArgType matchReturnType matchExtra typeToMatch = + case typeToMatch of + Function argType returnType extra -> + Maybe.map3 (\a b c -> ( a, b, c )) + (matchArgType argType) + (matchReturnType returnType) + (matchExtra extra) + + _ -> + Nothing {-| Creates a unit type. @@ -271,26 +493,135 @@ matchFunction matchArgType matchReturnType = toIR () == unit -} -unit : Type -unit = - Advanced.unit () +unit : extra -> Type extra +unit extra = + Unit extra {-| -} -matchUnit : Pattern Type () -matchUnit = - Advanced.matchUnit matchAny +matchUnit : Pattern extra a -> Pattern (Type extra) a +matchUnit matchExtra typeToMatch = + case typeToMatch of + Unit extra -> + matchExtra extra + _ -> + Nothing -{-| Creates a field. - toIR { foo = Int } - == record [ field [ "foo" ] SDK.Basics.intType ] +{-| -} +typeAliasDefinition : List Name -> Type extra -> Definition extra +typeAliasDefinition typeParams typeExp = + TypeAliasDefinition typeParams typeExp --} -field : Name -> Type -> Field -field fieldName fieldType = - Advanced.Field fieldName fieldType + +{-| -} +customTypeDefinition : List Name -> AccessControlled (Constructors extra) -> Definition extra +customTypeDefinition typeParams ctors = + CustomTypeDefinition typeParams ctors + + +{-| -} +typeAliasSpecification : List Name -> Type extra -> Specification extra +typeAliasSpecification typeParams typeExp = + TypeAliasSpecification typeParams typeExp + + +{-| -} +opaqueTypeSpecification : List Name -> Specification extra +opaqueTypeSpecification typeParams = + OpaqueTypeSpecification typeParams + + +{-| -} +customTypeSpecification : List Name -> Constructors extra -> Specification extra +customTypeSpecification typeParams ctors = + CustomTypeSpecification typeParams ctors + + +{-| -} +matchCustomTypeSpecification : Pattern (List Name) a -> Pattern (Constructors extra) b -> Pattern (Specification extra) ( a, b ) +matchCustomTypeSpecification matchTypeParams matchCtors specToMatch = + case specToMatch of + CustomTypeSpecification typeParams ctors -> + Maybe.map2 Tuple.pair + (matchTypeParams typeParams) + (matchCtors ctors) + + _ -> + Nothing + + +rewriteType : Rewrite e (Type extra) +rewriteType rewriteBranch rewriteLeaf typeToRewrite = + case typeToRewrite of + Reference fQName argTypes extra -> + argTypes + |> List.foldr + (\nextArg resultSoFar -> + Result.map2 (::) + (rewriteBranch nextArg) + resultSoFar + ) + (Ok []) + |> Result.map + (\args -> + Reference fQName args extra + ) + + Tuple elemTypes extra -> + elemTypes + |> List.foldr + (\nextArg resultSoFar -> + Result.map2 (::) + (rewriteBranch nextArg) + resultSoFar + ) + (Ok []) + |> Result.map + (\elems -> + Tuple elems extra + ) + + Record fieldTypes extra -> + fieldTypes + |> List.foldr + (\field resultSoFar -> + Result.map2 (::) + (rewriteBranch field.tpe + |> Result.map (Field field.name) + ) + resultSoFar + ) + (Ok []) + |> Result.map + (\fields -> + Record fields extra + ) + + ExtensibleRecord varName fieldTypes extra -> + fieldTypes + |> List.foldr + (\field resultSoFar -> + Result.map2 (::) + (rewriteBranch field.tpe + |> Result.map (Field field.name) + ) + resultSoFar + ) + (Ok []) + |> Result.map + (\fields -> + ExtensibleRecord varName fields extra + ) + + Function argType returnType extra -> + Result.map2 (\arg return -> Function arg return extra) + (rewriteBranch argType) + (rewriteBranch returnType) + + _ -> + rewriteLeaf typeToRewrite {-| Matches a field. @@ -306,16 +637,298 @@ field fieldName fieldType = == Just ( [ "foo" ], SDK.Basics.intType ) -} -matchField : (Name -> Maybe a) -> (Type -> Maybe b) -> Pattern Field ( a, b ) -matchField matchFieldName matchFieldType = - Advanced.matchField matchFieldName matchFieldType +matchField : Pattern Name a -> Pattern (Type extra) b -> Pattern (Field extra) ( a, b ) +matchField matchFieldName matchFieldType field = + Maybe.map2 Tuple.pair + (matchFieldName field.name) + (matchFieldType field.tpe) + + +{-| Map the name of the field to get a new field. +-} +mapFieldName : (Name -> Name) -> Field extra -> Field extra +mapFieldName f field = + Field (f field.name) field.tpe + + +{-| Map the type of the field to get a new field. +-} +mapFieldType : (Type a -> Type b) -> Field a -> Field b +mapFieldType f field = + Field field.name (f field.tpe) + + +{-| Generate random types. +-} +fuzzType : Int -> Fuzzer extra -> Fuzzer (Type extra) +fuzzType maxDepth fuzzExtra = + let + fuzzField depth = + Fuzz.map2 Field + fuzzName + (fuzzType depth fuzzExtra) + + fuzzVariable = + Fuzz.map2 Variable + fuzzName + fuzzExtra + + fuzzReference depth = + Fuzz.map3 Reference + fuzzFQName + (Fuzz.list (fuzzType depth fuzzExtra) |> Fuzz.map (List.take depth)) + fuzzExtra + + fuzzTuple depth = + Fuzz.map2 Tuple + (Fuzz.list (fuzzType depth fuzzExtra) |> Fuzz.map (List.take depth)) + fuzzExtra + + fuzzRecord depth = + Fuzz.map2 Record + (Fuzz.list (fuzzField (depth - 1)) |> Fuzz.map (List.take depth)) + fuzzExtra + + fuzzExtensibleRecord depth = + Fuzz.map3 ExtensibleRecord + fuzzName + (Fuzz.list (fuzzField (depth - 1)) |> Fuzz.map (List.take depth)) + fuzzExtra + + fuzzFunction depth = + Fuzz.map3 Function + (fuzzType depth fuzzExtra) + (fuzzType depth fuzzExtra) + fuzzExtra + + fuzzUnit = + Fuzz.map Unit + fuzzExtra + + fuzzLeaf = + Fuzz.oneOf + [ fuzzVariable + , fuzzUnit + ] + + fuzzBranch depth = + Fuzz.oneOf + [ fuzzFunction depth + , fuzzReference depth + , fuzzTuple depth + , fuzzRecord depth + , fuzzExtensibleRecord depth + ] + in + if maxDepth <= 0 then + fuzzLeaf + + else + Fuzz.oneOf + [ fuzzLeaf + , fuzzBranch (maxDepth - 1) + ] + + +{-| Encode a type into JSON. +-} +encodeType : (extra -> Encode.Value) -> Type extra -> Encode.Value +encodeType encodeExtra tpe = + let + typeTag tag = + ( "@type", Encode.string tag ) + in + case tpe of + Variable name extra -> + Encode.object + [ typeTag "variable" + , ( "name", encodeName name ) + , ( "extra", encodeExtra extra ) + ] + + Reference typeName typeParameters extra -> + Encode.object + [ typeTag "reference" + , ( "typeName", encodeFQName typeName ) + , ( "typeParameters", Encode.list (encodeType encodeExtra) typeParameters ) + , ( "extra", encodeExtra extra ) + ] + + Tuple elementTypes extra -> + Encode.object + [ typeTag "tuple" + , ( "elementTypes", Encode.list (encodeType encodeExtra) elementTypes ) + , ( "extra", encodeExtra extra ) + ] + + Record fieldTypes extra -> + Encode.object + [ typeTag "record" + , ( "fieldTypes", Encode.list (encodeField encodeExtra) fieldTypes ) + , ( "extra", encodeExtra extra ) + ] + + ExtensibleRecord variableName fieldTypes extra -> + Encode.object + [ typeTag "extensibleRecord" + , ( "variableName", encodeName variableName ) + , ( "fieldTypes", Encode.list (encodeField encodeExtra) fieldTypes ) + , ( "extra", encodeExtra extra ) + ] + + Function argumentType returnType extra -> + Encode.object + [ typeTag "function" + , ( "argumentType", encodeType encodeExtra argumentType ) + , ( "returnType", encodeType encodeExtra returnType ) + , ( "extra", encodeExtra extra ) + ] + + Unit extra -> + Encode.object + [ typeTag "unit" + , ( "extra", encodeExtra extra ) + ] + + +{-| Decode a type from JSON. +-} +decodeType : Decode.Decoder extra -> Decode.Decoder (Type extra) +decodeType decodeExtra = + let + lazyDecodeType = + Decode.lazy + (\_ -> + decodeType decodeExtra + ) + + lazyDecodeField = + Decode.lazy + (\_ -> + decodeField decodeExtra + ) + in + Decode.field "@type" Decode.string + |> Decode.andThen + (\kind -> + case kind of + "variable" -> + Decode.map2 Variable + (Decode.field "name" decodeName) + (Decode.field "extra" decodeExtra) + + "reference" -> + Decode.map3 Reference + (Decode.field "typeName" decodeFQName) + (Decode.field "typeParameters" (Decode.list (Decode.lazy (\_ -> decodeType decodeExtra)))) + (Decode.field "extra" decodeExtra) + + "tuple" -> + Decode.map2 Tuple + (Decode.field "elementTypes" (Decode.list lazyDecodeType)) + (Decode.field "extra" decodeExtra) + + "record" -> + Decode.map2 Record + (Decode.field "fieldTypes" (Decode.list lazyDecodeField)) + (Decode.field "extra" decodeExtra) + + "extensibleRecord" -> + Decode.map3 ExtensibleRecord + (Decode.field "variableName" decodeName) + (Decode.field "fieldTypes" (Decode.list lazyDecodeField)) + (Decode.field "extra" decodeExtra) + + "function" -> + Decode.map3 Function + (Decode.field "argumentType" lazyDecodeType) + (Decode.field "returnType" lazyDecodeType) + (Decode.field "extra" decodeExtra) + + "unit" -> + Decode.map Unit + (Decode.field "extra" decodeExtra) + + _ -> + Decode.fail ("Unknown kind: " ++ kind) + ) -mapFieldName : (Name -> Name) -> Field -> Field -mapFieldName f = - Advanced.mapFieldName f +encodeField : (extra -> Encode.Value) -> Field extra -> Encode.Value +encodeField encodeExtra field = + Encode.list identity + [ encodeName field.name + , encodeType encodeExtra field.tpe + ] -mapFieldType : (Type -> Type) -> Field -> Field -mapFieldType f = - Advanced.mapFieldType f +decodeField : Decode.Decoder extra -> Decode.Decoder (Field extra) +decodeField decodeExtra = + Decode.map2 Field + (Decode.index 0 decodeName) + (Decode.index 1 (decodeType decodeExtra)) + + +{-| -} +encodeSpecification : (extra -> Encode.Value) -> Specification extra -> Encode.Value +encodeSpecification encodeExtra spec = + case spec of + TypeAliasSpecification params exp -> + Encode.object + [ ( "$type", Encode.string "typeAlias" ) + , ( "params", Encode.list encodeName params ) + , ( "exp", encodeType encodeExtra exp ) + ] + + OpaqueTypeSpecification params -> + Encode.object + [ ( "$type", Encode.string "opaqueType" ) + , ( "params", Encode.list encodeName params ) + ] + + CustomTypeSpecification params ctors -> + Encode.object + [ ( "$type", Encode.string "customType" ) + , ( "params", Encode.list encodeName params ) + , ( "ctors", encodeConstructors encodeExtra ctors ) + ] + + +{-| -} +encodeDefinition : (extra -> Encode.Value) -> Definition extra -> Encode.Value +encodeDefinition encodeExtra def = + case def of + TypeAliasDefinition params exp -> + Encode.object + [ ( "$type", Encode.string "typeAlias" ) + , ( "params", Encode.list encodeName params ) + , ( "exp", encodeType encodeExtra exp ) + ] + + CustomTypeDefinition params ctors -> + Encode.object + [ ( "$type", Encode.string "customType" ) + , ( "params", Encode.list encodeName params ) + , ( "ctors", encodeAccessControlled (encodeConstructors encodeExtra) ctors ) + ] + + +encodeConstructors : (extra -> Encode.Value) -> Constructors extra -> Encode.Value +encodeConstructors encodeExtra ctors = + ctors + |> Encode.list + (\( ctorName, ctorArgs ) -> + Encode.object + [ ( "name", encodeName ctorName ) + , ( "args" + , ctorArgs + |> Encode.list + (\( argName, argType ) -> + Encode.list identity + [ encodeName argName + , encodeType encodeExtra argType + ] + ) + ) + ] + ) diff --git a/src/Morphir/IR/Value.elm b/src/Morphir/IR/Value.elm index 3df152a5b..99fc72279 100644 --- a/src/Morphir/IR/Value.elm +++ b/src/Morphir/IR/Value.elm @@ -1,10 +1,12 @@ module Morphir.IR.Value exposing - ( Value, literal, constructor, apply, field, fieldFunction, lambda, letDef, letDestruct, letRec, list, record, reference + ( Value(..), literal, constructor, apply, field, fieldFunction, lambda, letDef, letDestruct, letRec, list, record, reference , tuple, variable, ifThenElse, patternMatch, update, unit - , Literal, boolLiteral, charLiteral, stringLiteral, intLiteral, floatLiteral - , Pattern, wildcardPattern, asPattern, tuplePattern, recordPattern, constructorPattern, emptyListPattern, headTailPattern, literalPattern + , Literal(..), boolLiteral, charLiteral, stringLiteral, intLiteral, floatLiteral + , Pattern(..), wildcardPattern, asPattern, tuplePattern, recordPattern, constructorPattern, emptyListPattern, headTailPattern, literalPattern , Specification - , Definition, typedDefinition, untypedDefinition + , Definition(..), typedDefinition, untypedDefinition + , encodeValue, encodeSpecification, encodeDefinition + , getDefinitionBody, mapDefinition, mapSpecification, mapValueExtra ) {-| This module contains the building blocks of values in the Morphir IR. @@ -55,44 +57,270 @@ which is just the specification of those. Value definitions can be typed or unty @docs Definition, typedDefinition, untypedDefinition + +# Serialization + +@docs encodeValue, encodeSpecification, encodeDefinition + -} -import Morphir.IR.Advanced.Value as Advanced -import Morphir.IR.FQName exposing (FQName) -import Morphir.IR.Name exposing (Name) -import Morphir.IR.Type exposing (Type) +import Fuzz exposing (Fuzzer) +import Json.Decode as Decode +import Json.Encode as Encode +import Morphir.IR.FQName exposing (FQName, decodeFQName, encodeFQName) +import Morphir.IR.Name exposing (Name, decodeName, encodeName) +import Morphir.IR.Type as Type exposing (Type, decodeType, encodeType) +import Morphir.ResultList as ResultList +import String {-| Type that represents a value. -} -type alias Value = - Advanced.Value () +type Value extra + = Literal Literal extra + | Constructor FQName extra + | Tuple (List (Value extra)) extra + | List (List (Value extra)) extra + | Record (List ( Name, Value extra )) extra + | Variable Name extra + | Reference FQName extra + | Field (Value extra) Name extra + | FieldFunction Name extra + | Apply (Value extra) (Value extra) extra + | Lambda (Pattern extra) (Value extra) extra + | LetDefinition Name (Definition extra) (Value extra) extra + | LetRecursion (List ( Name, Definition extra )) (Value extra) extra + | Destructure (Pattern extra) (Value extra) (Value extra) extra + | IfThenElse (Value extra) (Value extra) (Value extra) extra + | PatternMatch (Value extra) (List ( Pattern extra, Value extra )) extra + | UpdateRecord (Value extra) (List ( Name, Value extra )) extra + | Unit extra {-| Type that represents a literal value. -} -type alias Literal = - Advanced.Literal +type Literal + = BoolLiteral Bool + | CharLiteral Char + | StringLiteral String + | IntLiteral Int + | FloatLiteral Float {-| Type that represents a pattern. -} -type alias Pattern = - Advanced.Pattern () +type Pattern extra + = WildcardPattern extra + | AsPattern (Pattern extra) Name extra + | TuplePattern (List (Pattern extra)) extra + | RecordPattern (List Name) extra + | ConstructorPattern FQName (List (Pattern extra)) extra + | EmptyListPattern extra + | HeadTailPattern (Pattern extra) (Pattern extra) extra + | LiteralPattern Literal extra {-| Type that represents a value or function specification. The specification of what the value or function is without the actual data or logic behind it. -} -type alias Specification = - Advanced.Specification () +type alias Specification extra = + { inputs : List ( Name, Type extra ) + , output : Type extra + } {-| Type that represents a value or function definition. A definition is the actual data or logic as opposed to a specification which is just the specification of those. Value definitions can be typed or untyped. Exposed values have to be typed. -} -type alias Definition = - Advanced.Definition () +type Definition extra + = TypedDefinition (Type extra) (List Name) (Value extra) + | UntypedDefinition (List Name) (Value extra) + + +getDefinitionBody : Definition extra -> Value extra +getDefinitionBody def = + case def of + TypedDefinition _ _ body -> + body + + UntypedDefinition _ body -> + body + + + +-- definitionToSpecification : Definition extra -> Maybe (Specification extra) +-- definitionToSpecification def = +-- case def of +-- TypedDefinition valueType argNames _ -> +-- let +-- extractArgTypes tpe names = +-- case ( names, tpe ) of +-- ( [], returnType ) -> +-- ( [], returnType ) +-- ( nextArgName :: restOfArgNames, -> +-- in + + +mapSpecification : (Type a -> Result e (Type b)) -> (Value a -> Value b) -> Specification a -> Result (List e) (Specification b) +mapSpecification mapType mapValue spec = + let + inputsResult = + spec.inputs + |> List.map + (\( name, tpe ) -> + mapType tpe + |> Result.map (Tuple.pair name) + ) + |> ResultList.toResult + + outputResult = + mapType spec.output + |> Result.mapError List.singleton + in + Result.map2 Specification + inputsResult + outputResult + + +mapDefinition : (Type a -> Result e (Type b)) -> (Value a -> Value b) -> Definition a -> Result (List e) (Definition b) +mapDefinition mapType mapValue def = + case def of + TypedDefinition tpe args body -> + mapType tpe + |> Result.map + (\t -> + TypedDefinition t args (mapValue body) + ) + |> Result.mapError List.singleton + + UntypedDefinition args body -> + UntypedDefinition args (mapValue body) + |> Ok + + +mapValueExtra : (a -> b) -> Value a -> Value b +mapValueExtra f v = + case v of + Literal value extra -> + Literal value (f extra) + + Constructor fullyQualifiedName extra -> + Constructor fullyQualifiedName (f extra) + + Tuple elements extra -> + Tuple (elements |> List.map (mapValueExtra f)) (f extra) + + List items extra -> + List (items |> List.map (mapValueExtra f)) (f extra) + + Record fields extra -> + Record + (fields + |> List.map + (\( fieldName, fieldValue ) -> + ( fieldName, mapValueExtra f fieldValue ) + ) + ) + (f extra) + + Variable name extra -> + Variable name (f extra) + + Reference fullyQualifiedName extra -> + Reference fullyQualifiedName (f extra) + + Field subjectValue fieldName extra -> + Field (mapValueExtra f subjectValue) fieldName (f extra) + + FieldFunction fieldName extra -> + FieldFunction fieldName (f extra) + + Apply function argument extra -> + Apply (mapValueExtra f function) (mapValueExtra f argument) (f extra) + + Lambda argumentPattern body extra -> + Lambda (mapPatternExtra f argumentPattern) (mapValueExtra f body) (f extra) + + LetDefinition valueName valueDefinition inValue extra -> + LetDefinition valueName (mapDefinitionExtra f valueDefinition) (mapValueExtra f inValue) (f extra) + + LetRecursion valueDefinitions inValue extra -> + LetRecursion + (valueDefinitions + |> List.map + (\( name, def ) -> + ( name, mapDefinitionExtra f def ) + ) + ) + (mapValueExtra f inValue) + (f extra) + + Destructure pattern valueToDestruct inValue extra -> + Destructure (mapPatternExtra f pattern) (mapValueExtra f valueToDestruct) (mapValueExtra f inValue) (f extra) + + IfThenElse condition thenBranch elseBranch extra -> + IfThenElse (mapValueExtra f condition) (mapValueExtra f thenBranch) (mapValueExtra f elseBranch) (f extra) + + PatternMatch branchOutOn cases extra -> + PatternMatch (mapValueExtra f branchOutOn) + (cases + |> List.map + (\( pattern, body ) -> + ( mapPatternExtra f pattern, mapValueExtra f body ) + ) + ) + (f extra) + + UpdateRecord valueToUpdate fieldsToUpdate extra -> + UpdateRecord (mapValueExtra f valueToUpdate) + (fieldsToUpdate + |> List.map + (\( fieldName, fieldValue ) -> + ( fieldName, mapValueExtra f fieldValue ) + ) + ) + (f extra) + + Unit extra -> + Unit (f extra) + + +mapPatternExtra : (a -> b) -> Pattern a -> Pattern b +mapPatternExtra f p = + case p of + WildcardPattern extra -> + WildcardPattern (f extra) + + AsPattern p2 name extra -> + AsPattern (mapPatternExtra f p2) name (f extra) + + TuplePattern elementPatterns extra -> + TuplePattern (elementPatterns |> List.map (mapPatternExtra f)) (f extra) + + RecordPattern fieldNames extra -> + RecordPattern fieldNames (f extra) + + ConstructorPattern constructorName argumentPatterns extra -> + ConstructorPattern constructorName (argumentPatterns |> List.map (mapPatternExtra f)) (f extra) + + EmptyListPattern extra -> + EmptyListPattern (f extra) + + HeadTailPattern headPattern tailPattern extra -> + HeadTailPattern (mapPatternExtra f headPattern) (mapPatternExtra f tailPattern) (f extra) + + LiteralPattern value extra -> + LiteralPattern value (f extra) + + +mapDefinitionExtra : (a -> b) -> Definition a -> Definition b +mapDefinitionExtra f d = + case d of + TypedDefinition tpe args body -> + TypedDefinition (Type.mapTypeExtra f tpe) args (mapValueExtra f body) + + UntypedDefinition args body -> + UntypedDefinition args (mapValueExtra f body) {-| A [literal][lit] represents a fixed value in the IR. We only allow values of basic types: bool, char, string, int, float. @@ -110,9 +338,9 @@ type alias Definition = [lit]: https://en.wikipedia.org/wiki/Literal_(computer_programming) -} -literal : Literal -> Value -literal value = - Advanced.literal value () +literal : Literal -> extra -> Value extra +literal value extra = + Literal value extra {-| A reference to a constructor of a custom type. @@ -122,9 +350,9 @@ literal value = Foo.Bar -- Constructor ( ..., [ [ "foo" ] ], [ "bar" ] ) -} -constructor : FQName -> Value -constructor fullyQualifiedName = - Advanced.constructor fullyQualifiedName () +constructor : FQName -> extra -> Value extra +constructor fullyQualifiedName extra = + Constructor fullyQualifiedName extra {-| A [tuple] represents an ordered list of values where each value can be of a different type. @@ -140,9 +368,9 @@ constructor fullyQualifiedName = [tuple]: https://en.wikipedia.org/wiki/Tuple -} -tuple : List Value -> Value -tuple elements = - Advanced.tuple elements () +tuple : List (Value extra) -> extra -> Value extra +tuple elements extra = + Tuple elements extra {-| A [list] represents an ordered list of values where every value has to be of the same type. @@ -154,9 +382,9 @@ tuple elements = [list]: https://en.wikipedia.org/wiki/List_(abstract_data_type) -} -list : List Value -> Value -list items = - Advanced.list items () +list : List (Value extra) -> extra -> Value extra +list items extra = + List items extra {-| A [record] represents a list of fields where each field has a name and a value. @@ -170,9 +398,9 @@ list items = [record]: https://en.wikipedia.org/wiki/Record_(computer_science) -} -record : List ( Name, Value ) -> Value -record fields = - Advanced.record fields () +record : List ( Name, Value extra ) -> extra -> Value extra +record fields extra = + Record fields extra {-| A [variable] represents a reference to a named value in the scope. @@ -184,9 +412,9 @@ record fields = [variable]: https://en.wikipedia.org/wiki/Variable_(computer_science) -} -variable : Name -> Value -variable name = - Advanced.variable name () +variable : Name -> extra -> Value extra +variable name extra = + Variable name extra {-| A reference that refers to a function or a value with its fully-qualified name. @@ -194,9 +422,9 @@ variable name = List.map -- Reference ( [ ..., [ [ "list" ] ], [ "map" ] ) -} -reference : FQName -> Value -reference fullyQualifiedName = - Advanced.reference fullyQualifiedName () +reference : FQName -> extra -> Value extra +reference fullyQualifiedName extra = + Reference fullyQualifiedName extra {-| Extracts the value of a record's field. @@ -204,9 +432,9 @@ reference fullyQualifiedName = a.foo -- Field (Variable [ "a" ]) [ "foo" ] -} -field : Value -> Name -> Value -field subjectValue fieldName = - Advanced.field subjectValue fieldName () +field : Value extra -> Name -> extra -> Value extra +field subjectValue fieldName extra = + Field subjectValue fieldName extra {-| Represents a function that extract a field from a record value passed to it. @@ -214,9 +442,9 @@ field subjectValue fieldName = .foo -- FieldFunction [ "foo" ] -} -fieldFunction : Name -> Value -fieldFunction fieldName = - Advanced.fieldFunction fieldName () +fieldFunction : Name -> extra -> Value extra +fieldFunction fieldName extra = + FieldFunction fieldName extra {-| Represents a function invocation. We use currying to represent function invocations with multiple arguments. @@ -228,9 +456,9 @@ fieldFunction fieldName = True || False -- Apply (Apply (Reference ( ..., [ [ "basics" ] ], [ "and" ]))) (Literal (BoolLiteral True)) (Literal (BoolLiteral True)) -} -apply : Value -> Value -> Value -apply function argument = - Advanced.apply function argument () +apply : Value extra -> Value extra -> extra -> Value extra +apply function argument extra = + Apply function argument extra {-| Represents a lambda abstraction. @@ -247,9 +475,9 @@ apply function argument = ``` -} -lambda : Pattern -> Value -> Value -lambda argumentPattern body = - Advanced.lambda argumentPattern body () +lambda : Pattern extra -> Value extra -> extra -> Value extra +lambda argumentPattern body extra = + Lambda argumentPattern body extra {-| Represents a let expression that assigns a value (and optionally type) to a name. @@ -282,9 +510,9 @@ lambda argumentPattern body = -- ) -} -letDef : Name -> Definition -> Value -> Value -letDef valueName valueDefinition inValue = - Advanced.letDef valueName valueDefinition inValue () +letDef : Name -> Definition extra -> Value extra -> extra -> Value extra +letDef valueName valueDefinition inValue extra = + LetDefinition valueName valueDefinition inValue extra {-| Represents a let expression with one or many recursive definitions. @@ -304,9 +532,9 @@ letDef valueName valueDefinition inValue = -- (Variable [ "a" ]) -} -letRec : List ( Name, Definition ) -> Value -> Value -letRec valueDefinitions inValue = - Advanced.letRec valueDefinitions inValue () +letRec : List ( Name, Definition extra ) -> Value extra -> extra -> Value extra +letRec valueDefinitions inValue extra = + LetRecursion valueDefinitions inValue extra {-| Represents a let expression that extracts values using a pattern. @@ -321,9 +549,9 @@ letRec valueDefinitions inValue = -- (Variable ["a"]) -} -letDestruct : Pattern -> Value -> Value -> Value -letDestruct pattern valueToDestruct inValue = - Advanced.letDestruct pattern valueToDestruct inValue () +letDestruct : Pattern extra -> Value extra -> Value extra -> extra -> Value extra +letDestruct pattern valueToDestruct inValue extra = + Destructure pattern valueToDestruct inValue extra {-| Represents and if/then/else expression. @@ -337,9 +565,9 @@ letDestruct pattern valueToDestruct inValue = -- (Variable ["c"]) -} -ifThenElse : Value -> Value -> Value -> Value -ifThenElse condition thenBranch elseBranch = - Advanced.ifThenElse condition thenBranch elseBranch () +ifThenElse : Value extra -> Value extra -> Value extra -> extra -> Value extra +ifThenElse condition thenBranch elseBranch extra = + IfThenElse condition thenBranch elseBranch extra {-| Represents a pattern-match. @@ -356,9 +584,9 @@ ifThenElse condition thenBranch elseBranch = -- ] -} -patternMatch : Value -> List ( Pattern, Value ) -> Value -patternMatch branchOutOn cases = - Advanced.patternMatch branchOutOn cases () +patternMatch : Value extra -> List ( Pattern extra, Value extra ) -> extra -> Value extra +patternMatch branchOutOn cases extra = + PatternMatch branchOutOn cases extra {-| Update one or many fields of a record value. @@ -366,9 +594,9 @@ patternMatch branchOutOn cases = { a | foo = 1 } -- Update (Variable ["a"]) [ ( ["foo"], Literal (IntLiteral 1) ) ] -} -update : Value -> List ( Name, Value ) -> Value -update valueToUpdate fieldsToUpdate = - Advanced.update valueToUpdate fieldsToUpdate () +update : Value extra -> List ( Name, Value extra ) -> extra -> Value extra +update valueToUpdate fieldsToUpdate extra = + UpdateRecord valueToUpdate fieldsToUpdate extra {-| Represents the unit value. @@ -376,44 +604,44 @@ update valueToUpdate fieldsToUpdate = () -- Unit -} -unit : Value -unit = - Advanced.unit () +unit : extra -> Value extra +unit extra = + Unit extra {-| Represents a boolean value. Only possible values are: `True`, `False` -} boolLiteral : Bool -> Literal boolLiteral value = - Advanced.boolLiteral value + BoolLiteral value {-| Represents a character value. Some possible values: `'a'`, `'Z'`, `'3'` -} charLiteral : Char -> Literal charLiteral value = - Advanced.charLiteral value + CharLiteral value {-| Represents a string value. Some possible values: `""`, `"foo"`, `"Bar baz: 123"` -} stringLiteral : String -> Literal stringLiteral value = - Advanced.stringLiteral value + StringLiteral value {-| Represents an integer value. Some possible values: `0`, `-1`, `9832479` -} intLiteral : Int -> Literal intLiteral value = - Advanced.intLiteral value + IntLiteral value {-| Represents a floating-point number. Some possible values: `1.25`, `-13.4` -} floatLiteral : Float -> Literal floatLiteral value = - Advanced.floatLiteral value + FloatLiteral value {-| Matches any value and ignores it (assigns no variable name). @@ -421,9 +649,9 @@ floatLiteral value = _ -- WildcardPattern -} -wildcardPattern : Pattern -wildcardPattern = - Advanced.wildcardPattern () +wildcardPattern : extra -> Pattern extra +wildcardPattern extra = + WildcardPattern extra {-| Assigns a variable name to a pattern. @@ -435,9 +663,9 @@ wildcardPattern = [] as foo -- AsPattern EmptyListPattern ["foo"] -} -asPattern : Pattern -> Name -> Pattern -asPattern pattern name = - Advanced.asPattern pattern name () +asPattern : Pattern extra -> Name -> extra -> Pattern extra +asPattern pattern name extra = + AsPattern pattern name extra {-| Destructures a tuple using a pattern for every element. @@ -445,9 +673,9 @@ asPattern pattern name = ( _, foo ) -- TuplePattern [ WildcardPattern, AsPattern WildcardPattern ["foo"] ] -} -tuplePattern : List Pattern -> Pattern -tuplePattern elementPatterns = - Advanced.tuplePattern elementPatterns () +tuplePattern : List (Pattern extra) -> extra -> Pattern extra +tuplePattern elementPatterns extra = + TuplePattern elementPatterns extra {-| Pulls out the values of some fields from a record value. @@ -455,9 +683,9 @@ tuplePattern elementPatterns = { foo, bar } -- RecordPattern [ ["foo"], ["bar"] ] -} -recordPattern : List Name -> Pattern -recordPattern fieldNames = - Advanced.recordPattern fieldNames () +recordPattern : List Name -> extra -> Pattern extra +recordPattern fieldNames extra = + RecordPattern fieldNames extra {-| Matches on a custom type's constructor. @@ -469,9 +697,9 @@ When there are multiple constructors it also does filtering so it cannot be used Just _ -- ConstructorPattern ( ..., [["maybe"]], ["just"]) [ WildcardPattern ] -} -constructorPattern : FQName -> List Pattern -> Pattern -constructorPattern constructorName argumentPatterns = - Advanced.constructorPattern constructorName argumentPatterns () +constructorPattern : FQName -> List (Pattern extra) -> extra -> Pattern extra +constructorPattern constructorName argumentPatterns extra = + ConstructorPattern constructorName argumentPatterns extra {-| Matches an empty list. Can be used standalon but frequently used as a terminal pattern @@ -485,9 +713,9 @@ in a [`HeadTailPattern`](#headTailPattern). -- EmptyListPattern -} -emptyListPattern : Pattern -emptyListPattern = - Advanced.emptyListPattern () +emptyListPattern : extra -> Pattern extra +emptyListPattern extra = + EmptyListPattern extra {-| Matches the head and the tail of a list. It can be used to match lists of at least N items @@ -512,9 +740,9 @@ by nesting this pattern N times and terminating with [`EmptyListPattern`](#empty -- ) -} -headTailPattern : Pattern -> Pattern -> Pattern -headTailPattern headPattern tailPattern = - Advanced.headTailPattern headPattern tailPattern () +headTailPattern : Pattern extra -> Pattern extra -> extra -> Pattern extra +headTailPattern headPattern tailPattern extra = + HeadTailPattern headPattern tailPattern extra {-| Matches a specific literal value. This pattern can only be used in a [pattern-match](#patternMatch) @@ -531,9 +759,9 @@ since it always filters. 15.4 -- LiteralPattern (FloatLiteral 15.4) -} -literalPattern : Literal -> Pattern -literalPattern value = - Advanced.literalPattern value () +literalPattern : Literal -> extra -> Pattern extra +literalPattern value extra = + LiteralPattern value extra {-| Typed value or function definition. @@ -560,9 +788,9 @@ arguments. The examples below try to visualize the process. body -} -typedDefinition : Type -> List Name -> Value -> Definition +typedDefinition : Type extra -> List Name -> Value extra -> Definition extra typedDefinition valueType argumentNames body = - Advanced.typedDefinition valueType argumentNames body + TypedDefinition valueType argumentNames body {-| Untyped value or function definition. @@ -583,6 +811,585 @@ arguments. The examples below try to visualize the process. body -} -untypedDefinition : List Name -> Value -> Definition +untypedDefinition : List Name -> Value extra -> Definition extra untypedDefinition argumentNames body = - Advanced.untypedDefinition argumentNames body + UntypedDefinition argumentNames body + + +encodeValue : (extra -> Encode.Value) -> Value extra -> Encode.Value +encodeValue encodeExtra v = + let + typeTag tag = + ( "@type", Encode.string tag ) + in + case v of + Literal value extra -> + Encode.object + [ typeTag "literal" + , ( "value", encodeLiteral value ) + , ( "extra", encodeExtra extra ) + ] + + Constructor fullyQualifiedName extra -> + Encode.object + [ typeTag "constructor" + , ( "fullyQualifiedName", encodeFQName fullyQualifiedName ) + , ( "extra", encodeExtra extra ) + ] + + Tuple elements extra -> + Encode.object + [ typeTag "tuple" + , ( "elements", elements |> Encode.list (encodeValue encodeExtra) ) + , ( "extra", encodeExtra extra ) + ] + + List items extra -> + Encode.object + [ typeTag "list" + , ( "items", items |> Encode.list (encodeValue encodeExtra) ) + , ( "extra", encodeExtra extra ) + ] + + Record fields extra -> + Encode.object + [ typeTag "record" + , ( "fields" + , fields + |> Encode.list + (\( fieldName, fieldValue ) -> + Encode.list identity + [ encodeName fieldName + , encodeValue encodeExtra fieldValue + ] + ) + ) + , ( "extra", encodeExtra extra ) + ] + + Variable name extra -> + Encode.object + [ typeTag "variable" + , ( "name", encodeName name ) + , ( "extra", encodeExtra extra ) + ] + + Reference fullyQualifiedName extra -> + Encode.object + [ typeTag "reference" + , ( "fullyQualifiedName", encodeFQName fullyQualifiedName ) + , ( "extra", encodeExtra extra ) + ] + + Field subjectValue fieldName extra -> + Encode.object + [ typeTag "field" + , ( "subjectValue", encodeValue encodeExtra subjectValue ) + , ( "fieldName", encodeName fieldName ) + , ( "extra", encodeExtra extra ) + ] + + FieldFunction fieldName extra -> + Encode.object + [ typeTag "fieldFunction" + , ( "fieldName", encodeName fieldName ) + , ( "extra", encodeExtra extra ) + ] + + Apply function argument extra -> + Encode.object + [ typeTag "apply" + , ( "function", encodeValue encodeExtra function ) + , ( "argument", encodeValue encodeExtra argument ) + , ( "extra", encodeExtra extra ) + ] + + Lambda argumentPattern body extra -> + Encode.object + [ typeTag "lambda" + , ( "argumentPattern", encodePattern encodeExtra argumentPattern ) + , ( "body", encodeValue encodeExtra body ) + , ( "extra", encodeExtra extra ) + ] + + LetDefinition valueName valueDefinition inValue extra -> + Encode.object + [ typeTag "letDef" + , ( "valueName", encodeName valueName ) + , ( "valueDefintion", encodeDefinition encodeExtra valueDefinition ) + , ( "inValue", encodeValue encodeExtra inValue ) + , ( "extra", encodeExtra extra ) + ] + + LetRecursion valueDefinitions inValue extra -> + Encode.object + [ typeTag "letRec" + , ( "valueDefintions" + , valueDefinitions + |> Encode.list + (\( name, def ) -> + Encode.list identity + [ encodeName name + , encodeDefinition encodeExtra def + ] + ) + ) + , ( "inValue", encodeValue encodeExtra inValue ) + , ( "extra", encodeExtra extra ) + ] + + Destructure pattern valueToDestruct inValue extra -> + Encode.object + [ typeTag "letDestruct" + , ( "pattern", encodePattern encodeExtra pattern ) + , ( "valueToDestruct", encodeValue encodeExtra valueToDestruct ) + , ( "inValue", encodeValue encodeExtra inValue ) + , ( "extra", encodeExtra extra ) + ] + + IfThenElse condition thenBranch elseBranch extra -> + Encode.object + [ typeTag "ifThenElse" + , ( "condition", encodeValue encodeExtra condition ) + , ( "thenBranch", encodeValue encodeExtra thenBranch ) + , ( "elseBranch", encodeValue encodeExtra elseBranch ) + , ( "extra", encodeExtra extra ) + ] + + PatternMatch branchOutOn cases extra -> + Encode.object + [ typeTag "patternMatch" + , ( "branchOutOn", encodeValue encodeExtra branchOutOn ) + , ( "cases" + , cases + |> Encode.list + (\( pattern, body ) -> + Encode.list identity + [ encodePattern encodeExtra pattern + , encodeValue encodeExtra body + ] + ) + ) + , ( "extra", encodeExtra extra ) + ] + + UpdateRecord valueToUpdate fieldsToUpdate extra -> + Encode.object + [ typeTag "update" + , ( "valueToUpdate", encodeValue encodeExtra valueToUpdate ) + , ( "fieldsToUpdate" + , fieldsToUpdate + |> Encode.list + (\( fieldName, fieldValue ) -> + Encode.list identity + [ encodeName fieldName + , encodeValue encodeExtra fieldValue + ] + ) + ) + , ( "extra", encodeExtra extra ) + ] + + Unit extra -> + Encode.object + [ typeTag "unit" + , ( "extra", encodeExtra extra ) + ] + + +decodeValue : Decode.Decoder extra -> Decode.Decoder (Value extra) +decodeValue decodeExtra = + let + lazyDecodeValue = + Decode.lazy <| + \_ -> + decodeValue decodeExtra + in + Decode.field "@type" Decode.string + |> Decode.andThen + (\kind -> + case kind of + "literal" -> + Decode.map2 Literal + (Decode.field "value" decodeLiteral) + (Decode.field "extra" decodeExtra) + + "constructor" -> + Decode.map2 Constructor + (Decode.field "fullyQualifiedName" decodeFQName) + (Decode.field "extra" decodeExtra) + + "tuple" -> + Decode.map2 Tuple + (Decode.field "elements" <| Decode.list lazyDecodeValue) + (Decode.field "extra" decodeExtra) + + "list" -> + Decode.map2 List + (Decode.field "items" <| Decode.list lazyDecodeValue) + (Decode.field "extra" decodeExtra) + + "record" -> + Decode.map2 Record + (Decode.field "fields" + (Decode.list + (Decode.map2 Tuple.pair + (Decode.index 0 decodeName) + (Decode.index 1 <| decodeValue decodeExtra) + ) + ) + ) + (Decode.field "extra" decodeExtra) + + "variable" -> + Decode.map2 Variable + (Decode.field "name" decodeName) + (Decode.field "extra" decodeExtra) + + "reference" -> + Decode.map2 Reference + (Decode.field "fullyQualifiedName" decodeFQName) + (Decode.field "extra" decodeExtra) + + "field" -> + Decode.map3 Field + (Decode.field "subjectValue" <| decodeValue decodeExtra) + (Decode.field "fieldName" decodeName) + (Decode.field "extra" decodeExtra) + + "fieldFunction" -> + Decode.map2 FieldFunction + (Decode.field "fieldName" decodeName) + (Decode.field "extra" decodeExtra) + + "apply" -> + Decode.map3 Apply + (Decode.field "function" <| decodeValue decodeExtra) + (Decode.field "argument" <| decodeValue decodeExtra) + (Decode.field "extra" decodeExtra) + + "lambda" -> + Decode.map3 Lambda + (Decode.field "argumentPattern" <| decodePattern decodeExtra) + (Decode.field "body" <| decodeValue decodeExtra) + (Decode.field "extra" decodeExtra) + + "letDef" -> + Decode.map4 LetDefinition + (Decode.field "valueName" decodeName) + (Decode.field "valueDefintion" <| decodeDefinition decodeExtra) + (Decode.field "inValue" <| decodeValue decodeExtra) + (Decode.field "extra" decodeExtra) + + "letRec" -> + Decode.map3 LetRecursion + (Decode.field "valueDefintions" + (Decode.list + (Decode.map2 Tuple.pair + (Decode.index 0 decodeName) + (Decode.index 1 <| decodeDefinition decodeExtra) + ) + ) + ) + (Decode.field "inValue" <| decodeValue decodeExtra) + (Decode.field "extra" decodeExtra) + + "letDestruct" -> + Decode.map4 Destructure + (Decode.field "pattern" <| decodePattern decodeExtra) + (Decode.field "valueToDestruct" <| decodeValue decodeExtra) + (Decode.field "inValue" <| decodeValue decodeExtra) + (Decode.field "extra" decodeExtra) + + "ifThenElse" -> + Decode.map4 IfThenElse + (Decode.field "condition" <| decodeValue decodeExtra) + (Decode.field "thenBranch" <| decodeValue decodeExtra) + (Decode.field "elseBranch" <| decodeValue decodeExtra) + (Decode.field "extra" decodeExtra) + + "patternMatch" -> + Decode.map3 PatternMatch + (Decode.field "branchOutOn" <| decodeValue decodeExtra) + (Decode.field "cases" <| + Decode.list + (Decode.map2 Tuple.pair + (decodePattern decodeExtra) + (decodeValue decodeExtra) + ) + ) + (Decode.field "extra" decodeExtra) + + "update" -> + Decode.map3 UpdateRecord + (Decode.field "valueToUpdate" <| decodeValue decodeExtra) + (Decode.field "fieldsToUpdate" <| + Decode.list <| + Decode.map2 Tuple.pair + decodeName + (decodeValue decodeExtra) + ) + (Decode.field "extra" decodeExtra) + + "unit" -> + Decode.map Unit + (Decode.field "extra" decodeExtra) + + other -> + Decode.fail <| "Unknown value type: " ++ other + ) + + +encodePattern : (extra -> Encode.Value) -> Pattern extra -> Encode.Value +encodePattern encodeExtra pattern = + let + typeTag tag = + ( "@type", Encode.string tag ) + in + case pattern of + WildcardPattern extra -> + Encode.object + [ typeTag "wildcardPattern" + , ( "extra", encodeExtra extra ) + ] + + AsPattern p name extra -> + Encode.object + [ typeTag "asPattern" + , ( "pattern", encodePattern encodeExtra p ) + , ( "name", encodeName name ) + , ( "extra", encodeExtra extra ) + ] + + TuplePattern elementPatterns extra -> + Encode.object + [ typeTag "tuplePattern" + , ( "elementPatterns", elementPatterns |> Encode.list (encodePattern encodeExtra) ) + , ( "extra", encodeExtra extra ) + ] + + RecordPattern fieldNames extra -> + Encode.object + [ typeTag "recordPattern" + , ( "fieldNames", fieldNames |> Encode.list encodeName ) + , ( "extra", encodeExtra extra ) + ] + + ConstructorPattern constructorName argumentPatterns extra -> + Encode.object + [ typeTag "constructorPattern" + , ( "constructorName", encodeFQName constructorName ) + , ( "argumentPatterns", argumentPatterns |> Encode.list (encodePattern encodeExtra) ) + , ( "extra", encodeExtra extra ) + ] + + EmptyListPattern extra -> + Encode.object + [ typeTag "emptyListPattern" + , ( "extra", encodeExtra extra ) + ] + + HeadTailPattern headPattern tailPattern extra -> + Encode.object + [ typeTag "headTailPattern" + , ( "headPattern", encodePattern encodeExtra headPattern ) + , ( "tailPattern", encodePattern encodeExtra tailPattern ) + , ( "extra", encodeExtra extra ) + ] + + LiteralPattern value extra -> + Encode.object + [ typeTag "literalPattern" + , ( "value", encodeLiteral value ) + , ( "extra", encodeExtra extra ) + ] + + +decodePattern : Decode.Decoder extra -> Decode.Decoder (Pattern extra) +decodePattern decodeExtra = + let + lazyDecodePattern = + Decode.lazy <| + \_ -> + decodePattern decodeExtra + in + Decode.field "@type" Decode.string + |> Decode.andThen + (\kind -> + case kind of + "wildcardPattern" -> + Decode.map WildcardPattern + (Decode.field "extra" decodeExtra) + + "asPattern" -> + Decode.map3 AsPattern + (Decode.field "pattern" lazyDecodePattern) + (Decode.field "name" decodeName) + (Decode.field "extra" decodeExtra) + + "tuplePattern" -> + Decode.map2 TuplePattern + (Decode.field "elementPatterns" <| Decode.list lazyDecodePattern) + (Decode.field "extra" decodeExtra) + + "recordPattern" -> + Decode.map2 RecordPattern + (Decode.field "fieldNames" <| Decode.list decodeName) + (Decode.field "extra" decodeExtra) + + "constructorPattern" -> + Decode.map3 ConstructorPattern + (Decode.field "constructorName" decodeFQName) + (Decode.field "argumentPatterns" <| Decode.list lazyDecodePattern) + (Decode.field "extra" decodeExtra) + + "emptyListPattern" -> + Decode.map EmptyListPattern + (Decode.field "extra" decodeExtra) + + "headTailPattern" -> + Decode.map3 HeadTailPattern + (Decode.field "headPattern" lazyDecodePattern) + (Decode.field "tailPattern" lazyDecodePattern) + (Decode.field "extra" decodeExtra) + + other -> + Decode.fail <| "Unknown pattern type: " ++ other + ) + + +encodeLiteral : Literal -> Encode.Value +encodeLiteral l = + let + typeTag tag = + ( "@type", Encode.string tag ) + in + case l of + BoolLiteral v -> + Encode.object + [ typeTag "boolLiteral" + , ( "value", Encode.bool v ) + ] + + CharLiteral v -> + Encode.object + [ typeTag "charLiteral" + , ( "value", Encode.string (String.fromChar v) ) + ] + + StringLiteral v -> + Encode.object + [ typeTag "stringLiteral" + , ( "value", Encode.string v ) + ] + + IntLiteral v -> + Encode.object + [ typeTag "intLiteral" + , ( "value", Encode.int v ) + ] + + FloatLiteral v -> + Encode.object + [ typeTag "floatLiteral" + , ( "value", Encode.float v ) + ] + + +decodeLiteral : Decode.Decoder Literal +decodeLiteral = + Decode.field "@type" Decode.string + |> Decode.andThen + (\kind -> + case kind of + "boolLiteral" -> + Decode.map BoolLiteral + (Decode.field "value" Decode.bool) + + "charLiteral" -> + Decode.map CharLiteral + (Decode.field "value" Decode.string + |> Decode.andThen + (\str -> + case String.uncons str of + Just ( ch, _ ) -> + Decode.succeed ch + + Nothing -> + Decode.fail "Single char expected" + ) + ) + + "stringLiteral" -> + Decode.map StringLiteral + (Decode.field "value" Decode.string) + + "intLiteral" -> + Decode.map IntLiteral + (Decode.field "value" Decode.int) + + "floatLiteral" -> + Decode.map FloatLiteral + (Decode.field "value" Decode.float) + + other -> + Decode.fail <| "Unknown literal type: " ++ other + ) + + +encodeSpecification : (extra -> Encode.Value) -> Specification extra -> Encode.Value +encodeSpecification encodeExtra spec = + Encode.object + [ ( "inputs" + , spec.inputs + |> Encode.list + (\( argName, argType ) -> + Encode.object + [ ( "argName", encodeName argName ) + , ( "argType", encodeType encodeExtra argType ) + ] + ) + ) + , ( "output", encodeType encodeExtra spec.output ) + ] + + +encodeDefinition : (extra -> Encode.Value) -> Definition extra -> Encode.Value +encodeDefinition encodeExtra definition = + case definition of + TypedDefinition valueType argumentNames body -> + Encode.object + [ ( "@type", Encode.string "typedDefinition" ) + , ( "valueType", encodeType encodeExtra valueType ) + , ( "argumentNames", argumentNames |> Encode.list encodeName ) + , ( "body", encodeValue encodeExtra body ) + ] + + UntypedDefinition argumentNames body -> + Encode.object + [ ( "@type", Encode.string "untypedDefinition" ) + , ( "argumentNames", argumentNames |> Encode.list encodeName ) + , ( "body", encodeValue encodeExtra body ) + ] + + +decodeDefinition : Decode.Decoder extra -> Decode.Decoder (Definition extra) +decodeDefinition decodeExtra = + Decode.field "@type" Decode.string + |> Decode.andThen + (\kind -> + case kind of + "typedDefinition" -> + Decode.map3 TypedDefinition + (Decode.field "valueType" <| decodeType decodeExtra) + (Decode.field "argumentNames" <| Decode.list decodeName) + (Decode.field "body" <| Decode.lazy (\_ -> decodeValue decodeExtra)) + + "untypedDefinition" -> + Decode.map2 UntypedDefinition + (Decode.field "argumentNames" <| Decode.list decodeName) + (Decode.field "body" <| Decode.lazy (\_ -> decodeValue decodeExtra)) + + other -> + Decode.fail <| "Unknown definition type: " ++ other + ) diff --git a/tests/Morphir/Elm/FrontendTests.elm b/tests/Morphir/Elm/FrontendTests.elm index 2e067ba88..2ff8fd7a6 100644 --- a/tests/Morphir/Elm/FrontendTests.elm +++ b/tests/Morphir/Elm/FrontendTests.elm @@ -4,10 +4,8 @@ import Dict import Expect import Morphir.Elm.Frontend as Frontend exposing (Errors, SourceFile, SourceLocation) import Morphir.IR.AccessControlled exposing (AccessControlled, private, public) -import Morphir.IR.Advanced.Package as Package -import Morphir.IR.Advanced.Type as Type -import Morphir.IR.Advanced.Value as Value exposing (Definition(..), Literal(..), Value(..)) import Morphir.IR.FQName exposing (fQName) +import Morphir.IR.Package as Package import Morphir.IR.Path as Path import Morphir.IR.SDK.Bool as Bool import Morphir.IR.SDK.Float as Float @@ -15,6 +13,7 @@ import Morphir.IR.SDK.Int as Int import Morphir.IR.SDK.List as List import Morphir.IR.SDK.Maybe as Maybe import Morphir.IR.SDK.String as String +import Morphir.IR.Type as Type import Set import Test exposing (..) From 0fbc836080e072e2a7fe33016002e1808499f737 Mon Sep 17 00:00:00 2001 From: Attila Mihaly Date: Mon, 30 Mar 2020 15:34:14 -0400 Subject: [PATCH 05/42] Removed unused unindent function. --- tests/Morphir/Elm/FrontendTests.elm | 66 +++++++++++++---------------- 1 file changed, 30 insertions(+), 36 deletions(-) diff --git a/tests/Morphir/Elm/FrontendTests.elm b/tests/Morphir/Elm/FrontendTests.elm index 2ff8fd7a6..87fc8c1cf 100644 --- a/tests/Morphir/Elm/FrontendTests.elm +++ b/tests/Morphir/Elm/FrontendTests.elm @@ -24,46 +24,46 @@ frontendTest = sourceA = { path = "My/Package/A.elm" , content = - unindent """ -module My.Package.A exposing (..) - -import My.Package.B exposing (Bee) - -type Foo = Foo Bee - -type alias Bar = Foo - -type alias Rec = - { field1 : Foo - , field2 : Bar - , field3 : Bool - , field4 : Int - , field5 : Float - , field6 : String - , field7 : Maybe Int - , field8 : List Float - } - """ + String.join "\n" + [ "module My.Package.A exposing (..)" + , "" + , "import My.Package.B exposing (Bee)" + , "" + , "type Foo = Foo Bee" + , "" + , "type alias Bar = Foo" + , "" + , "type alias Rec =" + , " { field1 : Foo" + , " , field2 : Bar" + , " , field3 : Bool" + , " , field4 : Int" + , " , field5 : Float" + , " , field6 : String" + , " , field7 : Maybe Int" + , " , field8 : List Float" + , " }" + ] } sourceB = { path = "My/Package/B.elm" , content = - unindent """ -module My.Package.B exposing (..) - -type Bee = Bee - """ + String.join "\n" + [ "module My.Package.B exposing (..)" + , "" + , "type Bee = Bee" + ] } sourceC = { path = "My/Package/C.elm" , content = - unindent """ -module My.Package.C exposing (..) - -type Cee = Cee - """ + String.join "\n" + [ "module My.Package.C exposing (..)" + , "" + , "type Cee = Cee" + ] } packageName = @@ -210,9 +210,3 @@ type Cee = Cee -- describe "Values are mapped correctly" -- [ checkIR "1" <| Literal (IntLiteral 1) () -- ] --- - - -unindent : String -> String -unindent text = - text From adf092913a06ffb171843aadea8a47145a05414c Mon Sep 17 00:00:00 2001 From: Attila Mihaly Date: Mon, 30 Mar 2020 15:38:03 -0400 Subject: [PATCH 06/42] Moved name to SDK. --- src/Morphir/Elm/Frontend.elm | 2 +- src/Morphir/IR/SDK.elm | 6 ++++++ 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/src/Morphir/Elm/Frontend.elm b/src/Morphir/Elm/Frontend.elm index 1e5d59654..7b207b356 100644 --- a/src/Morphir/Elm/Frontend.elm +++ b/src/Morphir/Elm/Frontend.elm @@ -328,7 +328,7 @@ mapProcessedFile currentPackagePath processedFile modulesSoFar = dependencies = Dict.fromList - [ ( [ [ "morphir" ], [ "s", "d", "k" ] ], SDK.packageSpec ) + [ ( SDK.packageName, SDK.packageSpec ) ] moduleResolver : ModuleResolver diff --git a/src/Morphir/IR/SDK.elm b/src/Morphir/IR/SDK.elm index d8e3bcecd..ea3d0addb 100644 --- a/src/Morphir/IR/SDK.elm +++ b/src/Morphir/IR/SDK.elm @@ -2,6 +2,7 @@ module Morphir.IR.SDK exposing (..) import Dict import Morphir.IR.Package as Package +import Morphir.IR.Path exposing (Path) import Morphir.IR.SDK.Bool as Bool import Morphir.IR.SDK.Char as Char import Morphir.IR.SDK.Float as Float @@ -12,6 +13,11 @@ import Morphir.IR.SDK.Result as Result import Morphir.IR.SDK.String as String +packageName : Path +packageName = + [ [ "morphir" ], [ "s", "d", "k" ] ] + + packageSpec : Package.Specification () packageSpec = { modules = From 8ea37ba2441b34aef7f63e2e3bb96ebbdf30eccd Mon Sep 17 00:00:00 2001 From: Attila Mihaly Date: Tue, 31 Mar 2020 13:43:45 -0400 Subject: [PATCH 07/42] Added missing module to SDK. --- src/Morphir/IR/SDK/Number.elm | 43 +++++++++++++++++++++++++++++++++++ 1 file changed, 43 insertions(+) create mode 100644 src/Morphir/IR/SDK/Number.elm diff --git a/src/Morphir/IR/SDK/Number.elm b/src/Morphir/IR/SDK/Number.elm new file mode 100644 index 000000000..8c6623643 --- /dev/null +++ b/src/Morphir/IR/SDK/Number.elm @@ -0,0 +1,43 @@ +module Morphir.IR.SDK.Number exposing (..) + +import Dict +import Morphir.IR.FQName as FQName exposing (FQName) +import Morphir.IR.Module as Module +import Morphir.IR.Name as Name +import Morphir.IR.Path exposing (Path) +import Morphir.IR.QName as QName +import Morphir.IR.SDK.Common exposing (packageName) +import Morphir.IR.Type exposing (Specification(..), Type(..)) +import Morphir.IR.Value as Value exposing (Value) + + +moduleName : Path +moduleName = + [ [ "number" ] ] + + +moduleSpec : Module.Specification () +moduleSpec = + { types = + Dict.empty + , values = + Dict.empty + } + + +fromLocalName : String -> FQName +fromLocalName name = + name + |> Name.fromString + |> QName.fromName moduleName + |> FQName.fromQName packageName + + +numberClass : extra -> Type extra +numberClass extra = + Variable [ "number" ] extra + + +negate : extra -> extra -> Value extra -> Value extra +negate refExtra valueExtra arg = + Value.Apply (Value.Reference (fromLocalName "negate") refExtra) arg valueExtra From dac383226ce91c9de433027be88c9d30cd532e19 Mon Sep 17 00:00:00 2001 From: Attila Mihaly Date: Tue, 31 Mar 2020 13:47:18 -0400 Subject: [PATCH 08/42] Partial implementation of value mapping. --- src/Morphir/Elm/Frontend.elm | 172 ++++++++++++++++++++++++++++ tests/Morphir/Elm/FrontendTests.elm | 117 ++++++++++++------- 2 files changed, 245 insertions(+), 44 deletions(-) diff --git a/src/Morphir/Elm/Frontend.elm b/src/Morphir/Elm/Frontend.elm index 7b207b356..61ff6aad0 100644 --- a/src/Morphir/Elm/Frontend.elm +++ b/src/Morphir/Elm/Frontend.elm @@ -6,10 +6,13 @@ import Elm.Processing as Processing import Elm.RawFile as RawFile exposing (RawFile) import Elm.Syntax.Declaration exposing (Declaration(..)) import Elm.Syntax.Exposing as Exposing exposing (Exposing) +import Elm.Syntax.Expression as Expression exposing (Expression, FunctionImplementation) import Elm.Syntax.File exposing (File) import Elm.Syntax.Module as ElmModule import Elm.Syntax.ModuleName exposing (ModuleName) import Elm.Syntax.Node as Node exposing (Node(..)) +import Elm.Syntax.Pattern exposing (Pattern(..)) +import Elm.Syntax.Range exposing (Range) import Elm.Syntax.TypeAnnotation exposing (TypeAnnotation(..)) import Json.Decode as Decode import Json.Encode as Encode @@ -22,6 +25,7 @@ import Morphir.IR.Name as Name exposing (Name) import Morphir.IR.Package as Package import Morphir.IR.Path as Path exposing (Path) import Morphir.IR.SDK as SDK +import Morphir.IR.SDK.Number as Number import Morphir.IR.Type as Type exposing (Type) import Morphir.IR.Value as Value exposing (Value) import Morphir.JsonExtra as JsonExtra @@ -126,6 +130,8 @@ type Error = ParseError String (List Parser.DeadEnd) | CyclicModules (Graph (List String)) | ResolveError SourceLocation Resolve.Error + | EmptyApply SourceLocation + | NotSupported SourceLocation String encodeError : Error -> Encode.Value @@ -147,6 +153,17 @@ encodeError error = , Resolve.encodeError resolveError ] + EmptyApply sourceLocation -> + JsonExtra.encodeConstructor "EmptyApply" + [ encodeSourceLocation sourceLocation + ] + + NotSupported sourceLocation message -> + JsonExtra.encodeConstructor "NotSupported" + [ encodeSourceLocation sourceLocation + , Encode.string message + ] + type alias Imports = { lookupByExposedCtor : String -> Maybe Import @@ -512,6 +529,29 @@ mapDeclarationsToValue sourceFile expose decls = |> List.filterMap (\decl -> case decl of + FunctionDeclaration function -> + let + valueName : Name + valueName = + function.declaration + |> Node.value + |> .name + |> Node.value + |> Name.fromString + + valueDef : Result Errors (AccessControlled (Value.Definition SourceLocation)) + valueDef = + function.declaration + |> Node.value + |> (\funImpl -> + mapFunctionImplementation sourceFile funImpl.arguments funImpl.expression + ) + |> Result.map public + in + valueDef + |> Result.map (Tuple.pair valueName) + |> Just + _ -> Nothing ) @@ -589,6 +629,138 @@ mapTypeAnnotation sourceFile (Node range typeAnnotation) = (mapTypeAnnotation sourceFile returnTypeNode) +mapFunctionImplementation : SourceFile -> List (Node Pattern) -> Node Expression -> Result Errors (Value.Definition SourceLocation) +mapFunctionImplementation sourceFile argumentNodes expression = + let + sourceLocation : Range -> SourceLocation + sourceLocation range = + range |> SourceLocation sourceFile + + extractNamedParams : List Name -> List (Node Pattern) -> ( List Name, List (Node Pattern) ) + extractNamedParams namedParams patternParams = + case patternParams of + [] -> + ( namedParams, patternParams ) + + (Node _ firstParam) :: restOfParams -> + case firstParam of + VarPattern paramName -> + extractNamedParams (namedParams ++ [ Name.fromString paramName ]) restOfParams + + _ -> + ( namedParams, patternParams ) + + ( paramNames, lambdaArgPatterns ) = + extractNamedParams [] argumentNodes + + bodyResult : Result Errors (Value.Value SourceLocation) + bodyResult = + let + lambdaWithParams : List (Node Pattern) -> Node Expression -> Result Errors (Value.Value SourceLocation) + lambdaWithParams params body = + case params of + [] -> + mapExpression sourceFile body + + (Node range firstParam) :: restOfParams -> + Result.map2 (\lambdaArg lambdaBody -> Value.Lambda lambdaArg lambdaBody (sourceLocation range)) + (mapPattern sourceFile (Node range firstParam)) + (lambdaWithParams restOfParams body) + in + lambdaWithParams lambdaArgPatterns expression + in + bodyResult + |> Result.map (Value.UntypedDefinition paramNames) + + +mapExpression : SourceFile -> Node Expression -> Result Errors (Value.Value SourceLocation) +mapExpression sourceFile (Node range exp) = + let + sourceLocation = + range |> SourceLocation sourceFile + in + case exp of + Expression.UnitExpr -> + Ok (Value.Unit sourceLocation) + + Expression.Application expNodes -> + let + toApply : List (Value.Value SourceLocation) -> Result Errors (Value.Value SourceLocation) + toApply valuesReversed = + case valuesReversed of + [] -> + Err [ EmptyApply sourceLocation ] + + [ singleValue ] -> + Ok singleValue + + lastValue :: restOfValuesReversed -> + toApply restOfValuesReversed + |> Result.map + (\funValue -> + Value.Apply funValue lastValue sourceLocation + ) + in + expNodes + |> List.map (mapExpression sourceFile) + |> ResultList.toResult + |> Result.mapError List.concat + |> Result.andThen (List.reverse >> toApply) + + Expression.FunctionOrValue moduleName valueName -> + case ( moduleName, valueName ) of + ( [], "True" ) -> + Ok (Value.Literal (Value.BoolLiteral True) sourceLocation) + + ( [], "False" ) -> + Ok (Value.Literal (Value.BoolLiteral False) sourceLocation) + + _ -> + Ok (Value.Reference (fQName [] (moduleName |> List.map Name.fromString) (valueName |> Name.fromString)) sourceLocation) + + Expression.Integer value -> + Ok (Value.Literal (Value.IntLiteral value) sourceLocation) + + Expression.Hex value -> + Ok (Value.Literal (Value.IntLiteral value) sourceLocation) + + Expression.Negation arg -> + mapExpression sourceFile arg + |> Result.map (Number.negate sourceLocation sourceLocation) + + Expression.Floatable value -> + Ok (Value.Literal (Value.FloatLiteral value) sourceLocation) + + Expression.Literal value -> + Ok (Value.Literal (Value.StringLiteral value) sourceLocation) + + Expression.CharLiteral value -> + Ok (Value.Literal (Value.CharLiteral value) sourceLocation) + + Expression.TupledExpression expNodes -> + expNodes + |> List.map (mapExpression sourceFile) + |> ResultList.toResult + |> Result.mapError List.concat + |> Result.map (\elems -> Value.Tuple elems sourceLocation) + + other -> + Ok (Value.Literal (Value.StringLiteral (Debug.toString other)) sourceLocation) + + + +--Err [ NotSupported sourceLocation "unknown" ] + + +mapPattern : SourceFile -> Node Pattern -> Result Errors (Value.Pattern SourceLocation) +mapPattern sourceFile (Node range patternNode) = + let + sourceLocation = + range |> SourceLocation sourceFile + in + Ok (Value.WildcardPattern sourceLocation) + + resolveLocalTypes : Path -> Path -> ModuleResolver -> Module.Definition SourceLocation -> Result Errors (Module.Definition SourceLocation) resolveLocalTypes packagePath modulePath moduleResolver moduleDef = let diff --git a/tests/Morphir/Elm/FrontendTests.elm b/tests/Morphir/Elm/FrontendTests.elm index 87fc8c1cf..f989631dd 100644 --- a/tests/Morphir/Elm/FrontendTests.elm +++ b/tests/Morphir/Elm/FrontendTests.elm @@ -1,7 +1,7 @@ module Morphir.Elm.FrontendTests exposing (..) import Dict -import Expect +import Expect exposing (Expectation) import Morphir.Elm.Frontend as Frontend exposing (Errors, SourceFile, SourceLocation) import Morphir.IR.AccessControlled exposing (AccessControlled, private, public) import Morphir.IR.FQName exposing (fQName) @@ -12,8 +12,10 @@ import Morphir.IR.SDK.Float as Float import Morphir.IR.SDK.Int as Int import Morphir.IR.SDK.List as List import Morphir.IR.SDK.Maybe as Maybe +import Morphir.IR.SDK.Number as Number import Morphir.IR.SDK.String as String import Morphir.IR.Type as Type +import Morphir.IR.Value as Value exposing (Literal(..), Value(..)) import Set import Test exposing (..) @@ -166,47 +168,74 @@ frontendTest = |> Expect.equal (Ok expected) +valueTests : Test +valueTests = + let + packageInfo = + { name = [] + , exposedModules = Set.fromList [ [ [ "test" ] ] ] + } + + moduleSource : String -> SourceFile + moduleSource sourceValue = + { path = "Test.elm" + , content = + String.join "\n" + [ "module Test exposing (..)" + , "" + , "testValue = " ++ sourceValue + ] + } + + checkIR : String -> Value () -> Test + checkIR valueSource expectedValueIR = + test valueSource <| + \_ -> + Frontend.packageDefinitionFromSource packageInfo [ moduleSource valueSource ] + |> Result.map Package.eraseDefinitionExtra + |> Result.mapError (\error -> "Error while reading model") + |> Result.andThen + (\packageDef -> + packageDef.modules + |> Dict.get [ [ "test" ] ] + |> Result.fromMaybe "Could not find test module" + |> Result.andThen + (\moduleDef -> + moduleDef.value.values + |> Dict.get [ "test", "value" ] + |> Result.fromMaybe "Could not find test value" + |> Result.map (.value >> Value.getDefinitionBody) + ) + ) + |> resultToExpectation expectedValueIR + + ref : String -> Value () + ref name = + Reference (fQName [] [] [ name ]) () + in + describe "Values are mapped correctly" + [ checkIR "()" <| Unit () + , checkIR "1" <| Literal (IntLiteral 1) () + , checkIR "0x20" <| Literal (IntLiteral 32) () + , checkIR "1.5" <| Literal (FloatLiteral 1.5) () + , checkIR "\"foo\"" <| Literal (StringLiteral "foo") () + , checkIR "True" <| Literal (BoolLiteral True) () + , checkIR "False" <| Literal (BoolLiteral False) () + , checkIR "'A'" <| Literal (CharLiteral 'A') () + , checkIR "foo" <| ref "foo" + , checkIR "Bar.foo" <| Reference (fQName [] [ [ "bar" ] ] [ "foo" ]) () + , checkIR "MyPack.Bar.foo" <| Reference (fQName [] [ [ "my", "pack" ], [ "bar" ] ] [ "foo" ]) () + , checkIR "foo bar" <| Apply (ref "foo") (ref "bar") () + , checkIR "foo bar baz" <| Apply (Apply (ref "foo") (ref "bar") ()) (ref "baz") () + , checkIR "-1" <| Number.negate () () (Literal (IntLiteral 1) ()) + ] + + +resultToExpectation : a -> Result String a -> Expectation +resultToExpectation expectedValue result = + case result of + Ok actualValue -> + Expect.equal expectedValue actualValue ---valueTests : Test ---valueTests = --- let --- packageInfo = --- { name = [] --- , exposedModules = Set.empty --- } --- --- moduleSource : String -> SourceFile --- moduleSource sourceValue = --- { path = "Test.elm" --- , content = --- String.join "\n" --- [ "module Test exposing (..)" --- , "" --- , "testValue = " ++ sourceValue --- ] --- } --- --- checkIR : String -> Value () -> Test --- checkIR valueSource expectedValueIR = --- test valueSource <| --- \_ -> --- Frontend.packageDefinitionFromSource packageInfo [ moduleSource valueSource ] --- |> Result.map Package.eraseDefinitionExtra --- |> Result.toMaybe --- |> Maybe.andThen --- (\packageDef -> --- packageDef.modules --- |> Dict.get [ [ "test" ] ] --- |> Maybe.andThen --- (\moduleDef -> --- moduleDef.value.values --- |> Dict.get [ "test", "value" ] --- |> Maybe.map (.value >> Value.getDefinitionBody) --- ) --- ) --- |> Maybe.map (Expect.equal expectedValueIR) --- |> Maybe.withDefault (Expect.fail "Could not find the value in the IR") --- in --- describe "Values are mapped correctly" --- [ checkIR "1" <| Literal (IntLiteral 1) () --- ] + Err error -> + Expect.fail error From e9845201610fec1695d7bd69fa373b267b685e15 Mon Sep 17 00:00:00 2001 From: Attila Mihaly Date: Tue, 31 Mar 2020 14:20:51 -0400 Subject: [PATCH 09/42] Ignore all generated JS. --- cli/.gitignore | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/cli/.gitignore b/cli/.gitignore index cf3d32d2d..6dfc96e8b 100644 --- a/cli/.gitignore +++ b/cli/.gitignore @@ -1,2 +1 @@ -Morphir.Elm.CLI.js -Morphir.Elm.EncodersCLI.js \ No newline at end of file +Morphir.*.js \ No newline at end of file From 8c336bf26524d59bf5c4442ea40bfb48a25d435f Mon Sep 17 00:00:00 2001 From: Attila Mihaly Date: Tue, 31 Mar 2020 15:02:52 -0400 Subject: [PATCH 10/42] Change extra arg position and naming. #46, #25 --- src/Morphir/Elm/Frontend.elm | 24 +- src/Morphir/IR/SDK/Number.elm | 2 +- src/Morphir/IR/Value.elm | 903 ++++++++++++++-------------- tests/Morphir/Elm/FrontendTests.elm | 26 +- 4 files changed, 468 insertions(+), 487 deletions(-) diff --git a/src/Morphir/Elm/Frontend.elm b/src/Morphir/Elm/Frontend.elm index 61ff6aad0..5b98865ea 100644 --- a/src/Morphir/Elm/Frontend.elm +++ b/src/Morphir/Elm/Frontend.elm @@ -663,7 +663,7 @@ mapFunctionImplementation sourceFile argumentNodes expression = mapExpression sourceFile body (Node range firstParam) :: restOfParams -> - Result.map2 (\lambdaArg lambdaBody -> Value.Lambda lambdaArg lambdaBody (sourceLocation range)) + Result.map2 (\lambdaArg lambdaBody -> Value.Lambda (sourceLocation range) lambdaArg lambdaBody) (mapPattern sourceFile (Node range firstParam)) (lambdaWithParams restOfParams body) in @@ -698,7 +698,7 @@ mapExpression sourceFile (Node range exp) = toApply restOfValuesReversed |> Result.map (\funValue -> - Value.Apply funValue lastValue sourceLocation + Value.Apply sourceLocation funValue lastValue ) in expNodes @@ -710,42 +710,42 @@ mapExpression sourceFile (Node range exp) = Expression.FunctionOrValue moduleName valueName -> case ( moduleName, valueName ) of ( [], "True" ) -> - Ok (Value.Literal (Value.BoolLiteral True) sourceLocation) + Ok (Value.Literal sourceLocation (Value.BoolLiteral True)) ( [], "False" ) -> - Ok (Value.Literal (Value.BoolLiteral False) sourceLocation) + Ok (Value.Literal sourceLocation (Value.BoolLiteral False)) _ -> - Ok (Value.Reference (fQName [] (moduleName |> List.map Name.fromString) (valueName |> Name.fromString)) sourceLocation) + Ok (Value.Reference sourceLocation (fQName [] (moduleName |> List.map Name.fromString) (valueName |> Name.fromString))) Expression.Integer value -> - Ok (Value.Literal (Value.IntLiteral value) sourceLocation) + Ok (Value.Literal sourceLocation (Value.IntLiteral value)) Expression.Hex value -> - Ok (Value.Literal (Value.IntLiteral value) sourceLocation) + Ok (Value.Literal sourceLocation (Value.IntLiteral value)) Expression.Negation arg -> mapExpression sourceFile arg |> Result.map (Number.negate sourceLocation sourceLocation) Expression.Floatable value -> - Ok (Value.Literal (Value.FloatLiteral value) sourceLocation) + Ok (Value.Literal sourceLocation (Value.FloatLiteral value)) Expression.Literal value -> - Ok (Value.Literal (Value.StringLiteral value) sourceLocation) + Ok (Value.Literal sourceLocation (Value.StringLiteral value)) Expression.CharLiteral value -> - Ok (Value.Literal (Value.CharLiteral value) sourceLocation) + Ok (Value.Literal sourceLocation (Value.CharLiteral value)) Expression.TupledExpression expNodes -> expNodes |> List.map (mapExpression sourceFile) |> ResultList.toResult |> Result.mapError List.concat - |> Result.map (\elems -> Value.Tuple elems sourceLocation) + |> Result.map (Value.Tuple sourceLocation) other -> - Ok (Value.Literal (Value.StringLiteral (Debug.toString other)) sourceLocation) + Ok (Value.Literal sourceLocation (Value.StringLiteral (Debug.toString other))) diff --git a/src/Morphir/IR/SDK/Number.elm b/src/Morphir/IR/SDK/Number.elm index 8c6623643..424e5144c 100644 --- a/src/Morphir/IR/SDK/Number.elm +++ b/src/Morphir/IR/SDK/Number.elm @@ -40,4 +40,4 @@ numberClass extra = negate : extra -> extra -> Value extra -> Value extra negate refExtra valueExtra arg = - Value.Apply (Value.Reference (fromLocalName "negate") refExtra) arg valueExtra + Value.Apply valueExtra (Value.Reference refExtra (fromLocalName "negate")) arg diff --git a/src/Morphir/IR/Value.elm b/src/Morphir/IR/Value.elm index 99fc72279..e74faf2e0 100644 --- a/src/Morphir/IR/Value.elm +++ b/src/Morphir/IR/Value.elm @@ -64,7 +64,6 @@ which is just the specification of those. Value definitions can be typed or unty -} -import Fuzz exposing (Fuzzer) import Json.Decode as Decode import Json.Encode as Encode import Morphir.IR.FQName exposing (FQName, decodeFQName, encodeFQName) @@ -76,25 +75,25 @@ import String {-| Type that represents a value. -} -type Value extra - = Literal Literal extra - | Constructor FQName extra - | Tuple (List (Value extra)) extra - | List (List (Value extra)) extra - | Record (List ( Name, Value extra )) extra - | Variable Name extra - | Reference FQName extra - | Field (Value extra) Name extra - | FieldFunction Name extra - | Apply (Value extra) (Value extra) extra - | Lambda (Pattern extra) (Value extra) extra - | LetDefinition Name (Definition extra) (Value extra) extra - | LetRecursion (List ( Name, Definition extra )) (Value extra) extra - | Destructure (Pattern extra) (Value extra) (Value extra) extra - | IfThenElse (Value extra) (Value extra) (Value extra) extra - | PatternMatch (Value extra) (List ( Pattern extra, Value extra )) extra - | UpdateRecord (Value extra) (List ( Name, Value extra )) extra - | Unit extra +type Value a + = Literal a Literal + | Constructor a FQName + | Tuple a (List (Value a)) + | List a (List (Value a)) + | Record a (List ( Name, Value a )) + | Variable a Name + | Reference a FQName + | Field a (Value a) Name + | FieldFunction a Name + | Apply a (Value a) (Value a) + | Lambda a (Pattern a) (Value a) + | LetDefinition a Name (Definition a) (Value a) + | LetRecursion a (List ( Name, Definition a )) (Value a) + | Destructure a (Pattern a) (Value a) (Value a) + | IfThenElse a (Value a) (Value a) (Value a) + | PatternMatch a (Value a) (List ( Pattern a, Value a )) + | UpdateRecord a (Value a) (List ( Name, Value a )) + | Unit a {-| Type that represents a literal value. @@ -109,35 +108,35 @@ type Literal {-| Type that represents a pattern. -} -type Pattern extra - = WildcardPattern extra - | AsPattern (Pattern extra) Name extra - | TuplePattern (List (Pattern extra)) extra - | RecordPattern (List Name) extra - | ConstructorPattern FQName (List (Pattern extra)) extra - | EmptyListPattern extra - | HeadTailPattern (Pattern extra) (Pattern extra) extra - | LiteralPattern Literal extra +type Pattern a + = WildcardPattern a + | AsPattern a (Pattern a) Name + | TuplePattern a (List (Pattern a)) + | RecordPattern a (List Name) + | ConstructorPattern a FQName (List (Pattern a)) + | EmptyListPattern a + | HeadTailPattern a (Pattern a) (Pattern a) + | LiteralPattern a Literal {-| Type that represents a value or function specification. The specification of what the value or function is without the actual data or logic behind it. -} -type alias Specification extra = - { inputs : List ( Name, Type extra ) - , output : Type extra +type alias Specification a = + { inputs : List ( Name, Type a ) + , output : Type a } {-| Type that represents a value or function definition. A definition is the actual data or logic as opposed to a specification which is just the specification of those. Value definitions can be typed or untyped. Exposed values have to be typed. -} -type Definition extra - = TypedDefinition (Type extra) (List Name) (Value extra) - | UntypedDefinition (List Name) (Value extra) +type Definition a + = TypedDefinition (Type a) (List Name) (Value a) + | UntypedDefinition (List Name) (Value a) -getDefinitionBody : Definition extra -> Value extra +getDefinitionBody : Definition a -> Value a getDefinitionBody def = case def of TypedDefinition _ _ body -> @@ -201,51 +200,50 @@ mapDefinition mapType mapValue def = mapValueExtra : (a -> b) -> Value a -> Value b mapValueExtra f v = case v of - Literal value extra -> - Literal value (f extra) + Literal a value -> + Literal (f a) value - Constructor fullyQualifiedName extra -> - Constructor fullyQualifiedName (f extra) + Constructor a fullyQualifiedName -> + Constructor (f a) fullyQualifiedName - Tuple elements extra -> - Tuple (elements |> List.map (mapValueExtra f)) (f extra) + Tuple a elements -> + Tuple (f a) (elements |> List.map (mapValueExtra f)) - List items extra -> - List (items |> List.map (mapValueExtra f)) (f extra) + List a items -> + List (f a) (items |> List.map (mapValueExtra f)) - Record fields extra -> - Record + Record a fields -> + Record (f a) (fields |> List.map (\( fieldName, fieldValue ) -> ( fieldName, mapValueExtra f fieldValue ) ) ) - (f extra) - Variable name extra -> - Variable name (f extra) + Variable a name -> + Variable (f a) name - Reference fullyQualifiedName extra -> - Reference fullyQualifiedName (f extra) + Reference a fullyQualifiedName -> + Reference (f a) fullyQualifiedName - Field subjectValue fieldName extra -> - Field (mapValueExtra f subjectValue) fieldName (f extra) + Field a subjectValue fieldName -> + Field (f a) (mapValueExtra f subjectValue) fieldName - FieldFunction fieldName extra -> - FieldFunction fieldName (f extra) + FieldFunction a fieldName -> + FieldFunction (f a) fieldName - Apply function argument extra -> - Apply (mapValueExtra f function) (mapValueExtra f argument) (f extra) + Apply a function argument -> + Apply (f a) (mapValueExtra f function) (mapValueExtra f argument) - Lambda argumentPattern body extra -> - Lambda (mapPatternExtra f argumentPattern) (mapValueExtra f body) (f extra) + Lambda a argumentPattern body -> + Lambda (f a) (mapPatternExtra f argumentPattern) (mapValueExtra f body) - LetDefinition valueName valueDefinition inValue extra -> - LetDefinition valueName (mapDefinitionExtra f valueDefinition) (mapValueExtra f inValue) (f extra) + LetDefinition a valueName valueDefinition inValue -> + LetDefinition (f a) valueName (mapDefinitionExtra f valueDefinition) (mapValueExtra f inValue) - LetRecursion valueDefinitions inValue extra -> - LetRecursion + LetRecursion a valueDefinitions inValue -> + LetRecursion (f a) (valueDefinitions |> List.map (\( name, def ) -> @@ -253,64 +251,63 @@ mapValueExtra f v = ) ) (mapValueExtra f inValue) - (f extra) - Destructure pattern valueToDestruct inValue extra -> - Destructure (mapPatternExtra f pattern) (mapValueExtra f valueToDestruct) (mapValueExtra f inValue) (f extra) + Destructure a pattern valueToDestruct inValue -> + Destructure (f a) (mapPatternExtra f pattern) (mapValueExtra f valueToDestruct) (mapValueExtra f inValue) - IfThenElse condition thenBranch elseBranch extra -> - IfThenElse (mapValueExtra f condition) (mapValueExtra f thenBranch) (mapValueExtra f elseBranch) (f extra) + IfThenElse a condition thenBranch elseBranch -> + IfThenElse (f a) (mapValueExtra f condition) (mapValueExtra f thenBranch) (mapValueExtra f elseBranch) - PatternMatch branchOutOn cases extra -> - PatternMatch (mapValueExtra f branchOutOn) + PatternMatch a branchOutOn cases -> + PatternMatch (f a) + (mapValueExtra f branchOutOn) (cases |> List.map (\( pattern, body ) -> ( mapPatternExtra f pattern, mapValueExtra f body ) ) ) - (f extra) - UpdateRecord valueToUpdate fieldsToUpdate extra -> - UpdateRecord (mapValueExtra f valueToUpdate) + UpdateRecord a valueToUpdate fieldsToUpdate -> + UpdateRecord (f a) + (mapValueExtra f valueToUpdate) (fieldsToUpdate |> List.map (\( fieldName, fieldValue ) -> ( fieldName, mapValueExtra f fieldValue ) ) ) - (f extra) - Unit extra -> - Unit (f extra) + Unit a -> + Unit (f a) mapPatternExtra : (a -> b) -> Pattern a -> Pattern b mapPatternExtra f p = case p of - WildcardPattern extra -> - WildcardPattern (f extra) + WildcardPattern a -> + WildcardPattern (f a) - AsPattern p2 name extra -> - AsPattern (mapPatternExtra f p2) name (f extra) + AsPattern a p2 name -> + AsPattern (f a) (mapPatternExtra f p2) name - TuplePattern elementPatterns extra -> - TuplePattern (elementPatterns |> List.map (mapPatternExtra f)) (f extra) + TuplePattern a elementPatterns -> + TuplePattern (f a) (elementPatterns |> List.map (mapPatternExtra f)) - RecordPattern fieldNames extra -> - RecordPattern fieldNames (f extra) + RecordPattern a fieldNames -> + RecordPattern (f a) fieldNames - ConstructorPattern constructorName argumentPatterns extra -> - ConstructorPattern constructorName (argumentPatterns |> List.map (mapPatternExtra f)) (f extra) + ConstructorPattern a constructorName argumentPatterns -> + ConstructorPattern (f a) constructorName (argumentPatterns |> List.map (mapPatternExtra f)) - EmptyListPattern extra -> - EmptyListPattern (f extra) + EmptyListPattern a -> + EmptyListPattern (f a) - HeadTailPattern headPattern tailPattern extra -> - HeadTailPattern (mapPatternExtra f headPattern) (mapPatternExtra f tailPattern) (f extra) + HeadTailPattern a headPattern tailPattern -> + HeadTailPattern (f a) (mapPatternExtra f headPattern) (mapPatternExtra f tailPattern) - LiteralPattern value extra -> - LiteralPattern value (f extra) + LiteralPattern a value -> + LiteralPattern (f a) value mapDefinitionExtra : (a -> b) -> Definition a -> Definition b @@ -338,9 +335,9 @@ mapDefinitionExtra f d = [lit]: https://en.wikipedia.org/wiki/Literal_(computer_programming) -} -literal : Literal -> extra -> Value extra -literal value extra = - Literal value extra +literal : a -> Literal -> Value a +literal attributes value = + Literal attributes value {-| A reference to a constructor of a custom type. @@ -350,9 +347,9 @@ literal value extra = Foo.Bar -- Constructor ( ..., [ [ "foo" ] ], [ "bar" ] ) -} -constructor : FQName -> extra -> Value extra -constructor fullyQualifiedName extra = - Constructor fullyQualifiedName extra +constructor : a -> FQName -> Value a +constructor attributes fullyQualifiedName = + Constructor attributes fullyQualifiedName {-| A [tuple] represents an ordered list of values where each value can be of a different type. @@ -368,9 +365,9 @@ constructor fullyQualifiedName extra = [tuple]: https://en.wikipedia.org/wiki/Tuple -} -tuple : List (Value extra) -> extra -> Value extra -tuple elements extra = - Tuple elements extra +tuple : a -> List (Value a) -> Value a +tuple attributes elements = + Tuple attributes elements {-| A [list] represents an ordered list of values where every value has to be of the same type. @@ -382,9 +379,9 @@ tuple elements extra = [list]: https://en.wikipedia.org/wiki/List_(abstract_data_type) -} -list : List (Value extra) -> extra -> Value extra -list items extra = - List items extra +list : a -> List (Value a) -> Value a +list attributes items = + List attributes items {-| A [record] represents a list of fields where each field has a name and a value. @@ -398,9 +395,9 @@ list items extra = [record]: https://en.wikipedia.org/wiki/Record_(computer_science) -} -record : List ( Name, Value extra ) -> extra -> Value extra -record fields extra = - Record fields extra +record : a -> List ( Name, Value a ) -> Value a +record attributes fields = + Record attributes fields {-| A [variable] represents a reference to a named value in the scope. @@ -412,9 +409,9 @@ record fields extra = [variable]: https://en.wikipedia.org/wiki/Variable_(computer_science) -} -variable : Name -> extra -> Value extra -variable name extra = - Variable name extra +variable : a -> Name -> Value a +variable attributes name = + Variable attributes name {-| A reference that refers to a function or a value with its fully-qualified name. @@ -422,9 +419,9 @@ variable name extra = List.map -- Reference ( [ ..., [ [ "list" ] ], [ "map" ] ) -} -reference : FQName -> extra -> Value extra -reference fullyQualifiedName extra = - Reference fullyQualifiedName extra +reference : a -> FQName -> Value a +reference attributes fullyQualifiedName = + Reference attributes fullyQualifiedName {-| Extracts the value of a record's field. @@ -432,9 +429,9 @@ reference fullyQualifiedName extra = a.foo -- Field (Variable [ "a" ]) [ "foo" ] -} -field : Value extra -> Name -> extra -> Value extra -field subjectValue fieldName extra = - Field subjectValue fieldName extra +field : a -> Value a -> Name -> Value a +field attributes subjectValue fieldName = + Field attributes subjectValue fieldName {-| Represents a function that extract a field from a record value passed to it. @@ -442,9 +439,9 @@ field subjectValue fieldName extra = .foo -- FieldFunction [ "foo" ] -} -fieldFunction : Name -> extra -> Value extra -fieldFunction fieldName extra = - FieldFunction fieldName extra +fieldFunction : a -> Name -> Value a +fieldFunction attributes fieldName = + FieldFunction attributes fieldName {-| Represents a function invocation. We use currying to represent function invocations with multiple arguments. @@ -456,9 +453,9 @@ fieldFunction fieldName extra = True || False -- Apply (Apply (Reference ( ..., [ [ "basics" ] ], [ "and" ]))) (Literal (BoolLiteral True)) (Literal (BoolLiteral True)) -} -apply : Value extra -> Value extra -> extra -> Value extra -apply function argument extra = - Apply function argument extra +apply : a -> Value a -> Value a -> Value a +apply attributes function argument = + Apply attributes function argument {-| Represents a lambda abstraction. @@ -475,9 +472,9 @@ apply function argument extra = ``` -} -lambda : Pattern extra -> Value extra -> extra -> Value extra -lambda argumentPattern body extra = - Lambda argumentPattern body extra +lambda : a -> Pattern a -> Value a -> Value a +lambda attributes argumentPattern body = + Lambda attributes argumentPattern body {-| Represents a let expression that assigns a value (and optionally type) to a name. @@ -510,9 +507,9 @@ lambda argumentPattern body extra = -- ) -} -letDef : Name -> Definition extra -> Value extra -> extra -> Value extra -letDef valueName valueDefinition inValue extra = - LetDefinition valueName valueDefinition inValue extra +letDef : a -> Name -> Definition a -> Value a -> Value a +letDef attributes valueName valueDefinition inValue = + LetDefinition attributes valueName valueDefinition inValue {-| Represents a let expression with one or many recursive definitions. @@ -532,9 +529,9 @@ letDef valueName valueDefinition inValue extra = -- (Variable [ "a" ]) -} -letRec : List ( Name, Definition extra ) -> Value extra -> extra -> Value extra -letRec valueDefinitions inValue extra = - LetRecursion valueDefinitions inValue extra +letRec : a -> List ( Name, Definition a ) -> Value a -> Value a +letRec attributes valueDefinitions inValue = + LetRecursion attributes valueDefinitions inValue {-| Represents a let expression that extracts values using a pattern. @@ -549,9 +546,9 @@ letRec valueDefinitions inValue extra = -- (Variable ["a"]) -} -letDestruct : Pattern extra -> Value extra -> Value extra -> extra -> Value extra -letDestruct pattern valueToDestruct inValue extra = - Destructure pattern valueToDestruct inValue extra +letDestruct : a -> Pattern a -> Value a -> Value a -> Value a +letDestruct attributes pattern valueToDestruct inValue = + Destructure attributes pattern valueToDestruct inValue {-| Represents and if/then/else expression. @@ -565,9 +562,9 @@ letDestruct pattern valueToDestruct inValue extra = -- (Variable ["c"]) -} -ifThenElse : Value extra -> Value extra -> Value extra -> extra -> Value extra -ifThenElse condition thenBranch elseBranch extra = - IfThenElse condition thenBranch elseBranch extra +ifThenElse : a -> Value a -> Value a -> Value a -> Value a +ifThenElse attributes condition thenBranch elseBranch = + IfThenElse attributes condition thenBranch elseBranch {-| Represents a pattern-match. @@ -584,9 +581,9 @@ ifThenElse condition thenBranch elseBranch extra = -- ] -} -patternMatch : Value extra -> List ( Pattern extra, Value extra ) -> extra -> Value extra -patternMatch branchOutOn cases extra = - PatternMatch branchOutOn cases extra +patternMatch : a -> Value a -> List ( Pattern a, Value a ) -> Value a +patternMatch attributes branchOutOn cases = + PatternMatch attributes branchOutOn cases {-| Update one or many fields of a record value. @@ -594,9 +591,9 @@ patternMatch branchOutOn cases extra = { a | foo = 1 } -- Update (Variable ["a"]) [ ( ["foo"], Literal (IntLiteral 1) ) ] -} -update : Value extra -> List ( Name, Value extra ) -> extra -> Value extra -update valueToUpdate fieldsToUpdate extra = - UpdateRecord valueToUpdate fieldsToUpdate extra +update : a -> Value a -> List ( Name, Value a ) -> Value a +update attributes valueToUpdate fieldsToUpdate = + UpdateRecord attributes valueToUpdate fieldsToUpdate {-| Represents the unit value. @@ -604,9 +601,9 @@ update valueToUpdate fieldsToUpdate extra = () -- Unit -} -unit : extra -> Value extra -unit extra = - Unit extra +unit : a -> Value a +unit attributes = + Unit attributes {-| Represents a boolean value. Only possible values are: `True`, `False` @@ -649,9 +646,9 @@ floatLiteral value = _ -- WildcardPattern -} -wildcardPattern : extra -> Pattern extra -wildcardPattern extra = - WildcardPattern extra +wildcardPattern : a -> Pattern a +wildcardPattern attributes = + WildcardPattern attributes {-| Assigns a variable name to a pattern. @@ -663,9 +660,9 @@ wildcardPattern extra = [] as foo -- AsPattern EmptyListPattern ["foo"] -} -asPattern : Pattern extra -> Name -> extra -> Pattern extra -asPattern pattern name extra = - AsPattern pattern name extra +asPattern : a -> Pattern a -> Name -> Pattern a +asPattern attributes pattern name = + AsPattern attributes pattern name {-| Destructures a tuple using a pattern for every element. @@ -673,9 +670,9 @@ asPattern pattern name extra = ( _, foo ) -- TuplePattern [ WildcardPattern, AsPattern WildcardPattern ["foo"] ] -} -tuplePattern : List (Pattern extra) -> extra -> Pattern extra -tuplePattern elementPatterns extra = - TuplePattern elementPatterns extra +tuplePattern : a -> List (Pattern a) -> Pattern a +tuplePattern attributes elementPatterns = + TuplePattern attributes elementPatterns {-| Pulls out the values of some fields from a record value. @@ -683,9 +680,9 @@ tuplePattern elementPatterns extra = { foo, bar } -- RecordPattern [ ["foo"], ["bar"] ] -} -recordPattern : List Name -> extra -> Pattern extra -recordPattern fieldNames extra = - RecordPattern fieldNames extra +recordPattern : a -> List Name -> Pattern a +recordPattern attributes fieldNames = + RecordPattern attributes fieldNames {-| Matches on a custom type's constructor. @@ -697,9 +694,9 @@ When there are multiple constructors it also does filtering so it cannot be used Just _ -- ConstructorPattern ( ..., [["maybe"]], ["just"]) [ WildcardPattern ] -} -constructorPattern : FQName -> List (Pattern extra) -> extra -> Pattern extra -constructorPattern constructorName argumentPatterns extra = - ConstructorPattern constructorName argumentPatterns extra +constructorPattern : a -> FQName -> List (Pattern a) -> Pattern a +constructorPattern attributes constructorName argumentPatterns = + ConstructorPattern attributes constructorName argumentPatterns {-| Matches an empty list. Can be used standalon but frequently used as a terminal pattern @@ -713,9 +710,9 @@ in a [`HeadTailPattern`](#headTailPattern). -- EmptyListPattern -} -emptyListPattern : extra -> Pattern extra -emptyListPattern extra = - EmptyListPattern extra +emptyListPattern : a -> Pattern a +emptyListPattern attributes = + EmptyListPattern attributes {-| Matches the head and the tail of a list. It can be used to match lists of at least N items @@ -740,9 +737,9 @@ by nesting this pattern N times and terminating with [`EmptyListPattern`](#empty -- ) -} -headTailPattern : Pattern extra -> Pattern extra -> extra -> Pattern extra -headTailPattern headPattern tailPattern extra = - HeadTailPattern headPattern tailPattern extra +headTailPattern : a -> Pattern a -> Pattern a -> Pattern a +headTailPattern attributes headPattern tailPattern = + HeadTailPattern attributes headPattern tailPattern {-| Matches a specific literal value. This pattern can only be used in a [pattern-match](#patternMatch) @@ -759,9 +756,9 @@ since it always filters. 15.4 -- LiteralPattern (FloatLiteral 15.4) -} -literalPattern : Literal -> extra -> Pattern extra -literalPattern value extra = - LiteralPattern value extra +literalPattern : a -> Literal -> Pattern a +literalPattern attributes value = + LiteralPattern attributes value {-| Typed value or function definition. @@ -788,7 +785,7 @@ arguments. The examples below try to visualize the process. body -} -typedDefinition : Type extra -> List Name -> Value extra -> Definition extra +typedDefinition : Type a -> List Name -> Value a -> Definition a typedDefinition valueType argumentNames body = TypedDefinition valueType argumentNames body @@ -811,447 +808,431 @@ arguments. The examples below try to visualize the process. body -} -untypedDefinition : List Name -> Value extra -> Definition extra +untypedDefinition : List Name -> Value a -> Definition a untypedDefinition argumentNames body = UntypedDefinition argumentNames body -encodeValue : (extra -> Encode.Value) -> Value extra -> Encode.Value -encodeValue encodeExtra v = - let - typeTag tag = - ( "@type", Encode.string tag ) - in +encodeValue : (a -> Encode.Value) -> Value a -> Encode.Value +encodeValue encodeAttributes v = case v of - Literal value extra -> - Encode.object - [ typeTag "literal" - , ( "value", encodeLiteral value ) - , ( "extra", encodeExtra extra ) + Literal a value -> + Encode.list identity + [ Encode.string "Literal" + , encodeAttributes a + , encodeLiteral value ] - Constructor fullyQualifiedName extra -> - Encode.object - [ typeTag "constructor" - , ( "fullyQualifiedName", encodeFQName fullyQualifiedName ) - , ( "extra", encodeExtra extra ) + Constructor a fullyQualifiedName -> + Encode.list identity + [ Encode.string "Constructor" + , encodeAttributes a + , encodeFQName fullyQualifiedName ] - Tuple elements extra -> - Encode.object - [ typeTag "tuple" - , ( "elements", elements |> Encode.list (encodeValue encodeExtra) ) - , ( "extra", encodeExtra extra ) + Tuple a elements -> + Encode.list identity + [ Encode.string "Tuple" + , encodeAttributes a + , elements |> Encode.list (encodeValue encodeAttributes) ] - List items extra -> - Encode.object - [ typeTag "list" - , ( "items", items |> Encode.list (encodeValue encodeExtra) ) - , ( "extra", encodeExtra extra ) + List a items -> + Encode.list identity + [ Encode.string "List" + , encodeAttributes a + , items |> Encode.list (encodeValue encodeAttributes) ] - Record fields extra -> - Encode.object - [ typeTag "record" - , ( "fields" - , fields - |> Encode.list - (\( fieldName, fieldValue ) -> - Encode.list identity - [ encodeName fieldName - , encodeValue encodeExtra fieldValue - ] - ) - ) - , ( "extra", encodeExtra extra ) + Record a fields -> + Encode.list identity + [ Encode.string "Record" + , encodeAttributes a + , fields + |> Encode.list + (\( fieldName, fieldValue ) -> + Encode.list identity + [ encodeName fieldName + , encodeValue encodeAttributes fieldValue + ] + ) ] - Variable name extra -> - Encode.object - [ typeTag "variable" - , ( "name", encodeName name ) - , ( "extra", encodeExtra extra ) + Variable a name -> + Encode.list identity + [ Encode.string "Variable" + , encodeAttributes a + , encodeName name ] - Reference fullyQualifiedName extra -> - Encode.object - [ typeTag "reference" - , ( "fullyQualifiedName", encodeFQName fullyQualifiedName ) - , ( "extra", encodeExtra extra ) + Reference a fullyQualifiedName -> + Encode.list identity + [ Encode.string "Reference" + , encodeAttributes a + , encodeFQName fullyQualifiedName ] - Field subjectValue fieldName extra -> - Encode.object - [ typeTag "field" - , ( "subjectValue", encodeValue encodeExtra subjectValue ) - , ( "fieldName", encodeName fieldName ) - , ( "extra", encodeExtra extra ) + Field a subjectValue fieldName -> + Encode.list identity + [ Encode.string "Field" + , encodeAttributes a + , encodeValue encodeAttributes subjectValue + , encodeName fieldName ] - FieldFunction fieldName extra -> - Encode.object - [ typeTag "fieldFunction" - , ( "fieldName", encodeName fieldName ) - , ( "extra", encodeExtra extra ) + FieldFunction a fieldName -> + Encode.list identity + [ Encode.string "FieldFunction" + , encodeAttributes a + , encodeName fieldName ] - Apply function argument extra -> - Encode.object - [ typeTag "apply" - , ( "function", encodeValue encodeExtra function ) - , ( "argument", encodeValue encodeExtra argument ) - , ( "extra", encodeExtra extra ) + Apply a function argument -> + Encode.list identity + [ Encode.string "Apply" + , encodeAttributes a + , encodeValue encodeAttributes function + , encodeValue encodeAttributes argument ] - Lambda argumentPattern body extra -> - Encode.object - [ typeTag "lambda" - , ( "argumentPattern", encodePattern encodeExtra argumentPattern ) - , ( "body", encodeValue encodeExtra body ) - , ( "extra", encodeExtra extra ) + Lambda a argumentPattern body -> + Encode.list identity + [ Encode.string "Lambda" + , encodeAttributes a + , encodePattern encodeAttributes argumentPattern + , encodeValue encodeAttributes body ] - LetDefinition valueName valueDefinition inValue extra -> - Encode.object - [ typeTag "letDef" - , ( "valueName", encodeName valueName ) - , ( "valueDefintion", encodeDefinition encodeExtra valueDefinition ) - , ( "inValue", encodeValue encodeExtra inValue ) - , ( "extra", encodeExtra extra ) + LetDefinition a valueName valueDefinition inValue -> + Encode.list identity + [ Encode.string "LetDefinition" + , encodeAttributes a + , encodeName valueName + , encodeDefinition encodeAttributes valueDefinition + , encodeValue encodeAttributes inValue ] - LetRecursion valueDefinitions inValue extra -> - Encode.object - [ typeTag "letRec" - , ( "valueDefintions" - , valueDefinitions - |> Encode.list - (\( name, def ) -> - Encode.list identity - [ encodeName name - , encodeDefinition encodeExtra def - ] - ) - ) - , ( "inValue", encodeValue encodeExtra inValue ) - , ( "extra", encodeExtra extra ) + LetRecursion a valueDefinitions inValue -> + Encode.list identity + [ Encode.string "LetRecursion" + , encodeAttributes a + , valueDefinitions + |> Encode.list + (\( name, def ) -> + Encode.list identity + [ encodeName name + , encodeDefinition encodeAttributes def + ] + ) + , encodeValue encodeAttributes inValue ] - Destructure pattern valueToDestruct inValue extra -> - Encode.object - [ typeTag "letDestruct" - , ( "pattern", encodePattern encodeExtra pattern ) - , ( "valueToDestruct", encodeValue encodeExtra valueToDestruct ) - , ( "inValue", encodeValue encodeExtra inValue ) - , ( "extra", encodeExtra extra ) + Destructure a pattern valueToDestruct inValue -> + Encode.list identity + [ Encode.string "Destructure" + , encodeAttributes a + , encodePattern encodeAttributes pattern + , encodeValue encodeAttributes valueToDestruct + , encodeValue encodeAttributes inValue ] - IfThenElse condition thenBranch elseBranch extra -> - Encode.object - [ typeTag "ifThenElse" - , ( "condition", encodeValue encodeExtra condition ) - , ( "thenBranch", encodeValue encodeExtra thenBranch ) - , ( "elseBranch", encodeValue encodeExtra elseBranch ) - , ( "extra", encodeExtra extra ) + IfThenElse a condition thenBranch elseBranch -> + Encode.list identity + [ Encode.string "IfThenElse" + , encodeAttributes a + , encodeValue encodeAttributes condition + , encodeValue encodeAttributes thenBranch + , encodeValue encodeAttributes elseBranch ] - PatternMatch branchOutOn cases extra -> - Encode.object - [ typeTag "patternMatch" - , ( "branchOutOn", encodeValue encodeExtra branchOutOn ) - , ( "cases" - , cases - |> Encode.list - (\( pattern, body ) -> - Encode.list identity - [ encodePattern encodeExtra pattern - , encodeValue encodeExtra body - ] - ) - ) - , ( "extra", encodeExtra extra ) + PatternMatch a branchOutOn cases -> + Encode.list identity + [ Encode.string "PatternMatch" + , encodeAttributes a + , encodeValue encodeAttributes branchOutOn + , cases + |> Encode.list + (\( pattern, body ) -> + Encode.list identity + [ encodePattern encodeAttributes pattern + , encodeValue encodeAttributes body + ] + ) ] - UpdateRecord valueToUpdate fieldsToUpdate extra -> - Encode.object - [ typeTag "update" - , ( "valueToUpdate", encodeValue encodeExtra valueToUpdate ) - , ( "fieldsToUpdate" - , fieldsToUpdate - |> Encode.list - (\( fieldName, fieldValue ) -> - Encode.list identity - [ encodeName fieldName - , encodeValue encodeExtra fieldValue - ] - ) - ) - , ( "extra", encodeExtra extra ) + UpdateRecord a valueToUpdate fieldsToUpdate -> + Encode.list identity + [ Encode.string "Update" + , encodeAttributes a + , encodeValue encodeAttributes valueToUpdate + , fieldsToUpdate + |> Encode.list + (\( fieldName, fieldValue ) -> + Encode.list identity + [ encodeName fieldName + , encodeValue encodeAttributes fieldValue + ] + ) ] - Unit extra -> - Encode.object - [ typeTag "unit" - , ( "extra", encodeExtra extra ) + Unit a -> + Encode.list identity + [ Encode.string "Unit" + , encodeAttributes a ] -decodeValue : Decode.Decoder extra -> Decode.Decoder (Value extra) -decodeValue decodeExtra = +decodeValue : Decode.Decoder a -> Decode.Decoder (Value a) +decodeValue decodeAttributes = let lazyDecodeValue = Decode.lazy <| \_ -> - decodeValue decodeExtra + decodeValue decodeAttributes in - Decode.field "@type" Decode.string + Decode.index 0 Decode.string |> Decode.andThen (\kind -> case kind of - "literal" -> + "Literal" -> Decode.map2 Literal - (Decode.field "value" decodeLiteral) - (Decode.field "extra" decodeExtra) + (Decode.index 1 decodeAttributes) + (Decode.index 2 decodeLiteral) - "constructor" -> + "Constructor" -> Decode.map2 Constructor - (Decode.field "fullyQualifiedName" decodeFQName) - (Decode.field "extra" decodeExtra) + (Decode.index 1 decodeAttributes) + (Decode.index 2 decodeFQName) - "tuple" -> + "Tuple" -> Decode.map2 Tuple - (Decode.field "elements" <| Decode.list lazyDecodeValue) - (Decode.field "extra" decodeExtra) + (Decode.index 1 decodeAttributes) + (Decode.index 2 <| Decode.list lazyDecodeValue) - "list" -> + "List" -> Decode.map2 List - (Decode.field "items" <| Decode.list lazyDecodeValue) - (Decode.field "extra" decodeExtra) + (Decode.index 1 decodeAttributes) + (Decode.index 2 <| Decode.list lazyDecodeValue) - "record" -> + "Record" -> Decode.map2 Record - (Decode.field "fields" + (Decode.index 1 decodeAttributes) + (Decode.index 2 (Decode.list (Decode.map2 Tuple.pair (Decode.index 0 decodeName) - (Decode.index 1 <| decodeValue decodeExtra) + (Decode.index 1 <| decodeValue decodeAttributes) ) ) ) - (Decode.field "extra" decodeExtra) - "variable" -> + "Variable" -> Decode.map2 Variable - (Decode.field "name" decodeName) - (Decode.field "extra" decodeExtra) + (Decode.index 1 decodeAttributes) + (Decode.index 2 decodeName) - "reference" -> + "Reference" -> Decode.map2 Reference - (Decode.field "fullyQualifiedName" decodeFQName) - (Decode.field "extra" decodeExtra) + (Decode.index 1 decodeAttributes) + (Decode.index 2 decodeFQName) - "field" -> + "Field" -> Decode.map3 Field - (Decode.field "subjectValue" <| decodeValue decodeExtra) - (Decode.field "fieldName" decodeName) - (Decode.field "extra" decodeExtra) + (Decode.index 1 decodeAttributes) + (Decode.index 2 <| decodeValue decodeAttributes) + (Decode.index 3 decodeName) - "fieldFunction" -> + "FieldFunction" -> Decode.map2 FieldFunction - (Decode.field "fieldName" decodeName) - (Decode.field "extra" decodeExtra) + (Decode.index 1 decodeAttributes) + (Decode.index 2 decodeName) - "apply" -> + "Apply" -> Decode.map3 Apply - (Decode.field "function" <| decodeValue decodeExtra) - (Decode.field "argument" <| decodeValue decodeExtra) - (Decode.field "extra" decodeExtra) + (Decode.index 1 decodeAttributes) + (Decode.index 2 <| decodeValue decodeAttributes) + (Decode.index 3 <| decodeValue decodeAttributes) - "lambda" -> + "Lambda" -> Decode.map3 Lambda - (Decode.field "argumentPattern" <| decodePattern decodeExtra) - (Decode.field "body" <| decodeValue decodeExtra) - (Decode.field "extra" decodeExtra) + (Decode.index 1 decodeAttributes) + (Decode.index 2 <| decodePattern decodeAttributes) + (Decode.index 3 <| decodeValue decodeAttributes) - "letDef" -> + "LetDefinition" -> Decode.map4 LetDefinition - (Decode.field "valueName" decodeName) - (Decode.field "valueDefintion" <| decodeDefinition decodeExtra) - (Decode.field "inValue" <| decodeValue decodeExtra) - (Decode.field "extra" decodeExtra) + (Decode.index 1 decodeAttributes) + (Decode.index 2 decodeName) + (Decode.index 3 <| decodeDefinition decodeAttributes) + (Decode.index 4 <| decodeValue decodeAttributes) - "letRec" -> + "LetRecursion" -> Decode.map3 LetRecursion - (Decode.field "valueDefintions" + (Decode.index 1 decodeAttributes) + (Decode.index 2 (Decode.list (Decode.map2 Tuple.pair (Decode.index 0 decodeName) - (Decode.index 1 <| decodeDefinition decodeExtra) + (Decode.index 1 <| decodeDefinition decodeAttributes) ) ) ) - (Decode.field "inValue" <| decodeValue decodeExtra) - (Decode.field "extra" decodeExtra) + (Decode.index 3 <| decodeValue decodeAttributes) - "letDestruct" -> + "Destructure" -> Decode.map4 Destructure - (Decode.field "pattern" <| decodePattern decodeExtra) - (Decode.field "valueToDestruct" <| decodeValue decodeExtra) - (Decode.field "inValue" <| decodeValue decodeExtra) - (Decode.field "extra" decodeExtra) + (Decode.index 1 decodeAttributes) + (Decode.index 2 <| decodePattern decodeAttributes) + (Decode.index 3 <| decodeValue decodeAttributes) + (Decode.index 4 <| decodeValue decodeAttributes) - "ifThenElse" -> + "IfThenElse" -> Decode.map4 IfThenElse - (Decode.field "condition" <| decodeValue decodeExtra) - (Decode.field "thenBranch" <| decodeValue decodeExtra) - (Decode.field "elseBranch" <| decodeValue decodeExtra) - (Decode.field "extra" decodeExtra) + (Decode.index 1 decodeAttributes) + (Decode.index 2 <| decodeValue decodeAttributes) + (Decode.index 3 <| decodeValue decodeAttributes) + (Decode.index 4 <| decodeValue decodeAttributes) - "patternMatch" -> + "PatternMatch" -> Decode.map3 PatternMatch - (Decode.field "branchOutOn" <| decodeValue decodeExtra) - (Decode.field "cases" <| + (Decode.index 1 decodeAttributes) + (Decode.index 2 <| decodeValue decodeAttributes) + (Decode.index 3 <| Decode.list (Decode.map2 Tuple.pair - (decodePattern decodeExtra) - (decodeValue decodeExtra) + (decodePattern decodeAttributes) + (decodeValue decodeAttributes) ) ) - (Decode.field "extra" decodeExtra) - "update" -> + "UpdateRecord" -> Decode.map3 UpdateRecord - (Decode.field "valueToUpdate" <| decodeValue decodeExtra) - (Decode.field "fieldsToUpdate" <| + (Decode.index 1 decodeAttributes) + (Decode.index 2 <| decodeValue decodeAttributes) + (Decode.index 3 <| Decode.list <| Decode.map2 Tuple.pair decodeName - (decodeValue decodeExtra) + (decodeValue decodeAttributes) ) - (Decode.field "extra" decodeExtra) - "unit" -> + "Unit" -> Decode.map Unit - (Decode.field "extra" decodeExtra) + (Decode.index 1 decodeAttributes) other -> Decode.fail <| "Unknown value type: " ++ other ) -encodePattern : (extra -> Encode.Value) -> Pattern extra -> Encode.Value -encodePattern encodeExtra pattern = - let - typeTag tag = - ( "@type", Encode.string tag ) - in +encodePattern : (a -> Encode.Value) -> Pattern a -> Encode.Value +encodePattern encodeAttributes pattern = case pattern of - WildcardPattern extra -> - Encode.object - [ typeTag "wildcardPattern" - , ( "extra", encodeExtra extra ) + WildcardPattern a -> + Encode.list identity + [ Encode.string "WildcardPattern" + , encodeAttributes a ] - AsPattern p name extra -> - Encode.object - [ typeTag "asPattern" - , ( "pattern", encodePattern encodeExtra p ) - , ( "name", encodeName name ) - , ( "extra", encodeExtra extra ) + AsPattern a p name -> + Encode.list identity + [ Encode.string "AsPattern" + , encodeAttributes a + , encodePattern encodeAttributes p + , encodeName name ] - TuplePattern elementPatterns extra -> - Encode.object - [ typeTag "tuplePattern" - , ( "elementPatterns", elementPatterns |> Encode.list (encodePattern encodeExtra) ) - , ( "extra", encodeExtra extra ) + TuplePattern a elementPatterns -> + Encode.list identity + [ Encode.string "TuplePattern" + , encodeAttributes a + , elementPatterns |> Encode.list (encodePattern encodeAttributes) ] - RecordPattern fieldNames extra -> - Encode.object - [ typeTag "recordPattern" - , ( "fieldNames", fieldNames |> Encode.list encodeName ) - , ( "extra", encodeExtra extra ) + RecordPattern a fieldNames -> + Encode.list identity + [ Encode.string "RecordPattern" + , encodeAttributes a + , fieldNames |> Encode.list encodeName ] - ConstructorPattern constructorName argumentPatterns extra -> - Encode.object - [ typeTag "constructorPattern" - , ( "constructorName", encodeFQName constructorName ) - , ( "argumentPatterns", argumentPatterns |> Encode.list (encodePattern encodeExtra) ) - , ( "extra", encodeExtra extra ) + ConstructorPattern a constructorName argumentPatterns -> + Encode.list identity + [ Encode.string "ConstructorPattern" + , encodeAttributes a + , encodeFQName constructorName + , argumentPatterns |> Encode.list (encodePattern encodeAttributes) ] - EmptyListPattern extra -> - Encode.object - [ typeTag "emptyListPattern" - , ( "extra", encodeExtra extra ) + EmptyListPattern a -> + Encode.list identity + [ Encode.string "EmptyListPattern" + , encodeAttributes a ] - HeadTailPattern headPattern tailPattern extra -> - Encode.object - [ typeTag "headTailPattern" - , ( "headPattern", encodePattern encodeExtra headPattern ) - , ( "tailPattern", encodePattern encodeExtra tailPattern ) - , ( "extra", encodeExtra extra ) + HeadTailPattern a headPattern tailPattern -> + Encode.list identity + [ Encode.string "HeadTailPattern" + , encodeAttributes a + , encodePattern encodeAttributes headPattern + , encodePattern encodeAttributes tailPattern ] - LiteralPattern value extra -> - Encode.object - [ typeTag "literalPattern" - , ( "value", encodeLiteral value ) - , ( "extra", encodeExtra extra ) + LiteralPattern a value -> + Encode.list identity + [ Encode.string "LiteralPattern" + , encodeAttributes a + , encodeLiteral value ] decodePattern : Decode.Decoder extra -> Decode.Decoder (Pattern extra) -decodePattern decodeExtra = +decodePattern decodeAttributes = let lazyDecodePattern = Decode.lazy <| \_ -> - decodePattern decodeExtra + decodePattern decodeAttributes in - Decode.field "@type" Decode.string + Decode.index 0 Decode.string |> Decode.andThen (\kind -> case kind of - "wildcardPattern" -> + "WildcardPattern" -> Decode.map WildcardPattern - (Decode.field "extra" decodeExtra) + (Decode.index 1 decodeAttributes) - "asPattern" -> + "AsPattern" -> Decode.map3 AsPattern - (Decode.field "pattern" lazyDecodePattern) - (Decode.field "name" decodeName) - (Decode.field "extra" decodeExtra) + (Decode.index 1 decodeAttributes) + (Decode.index 2 lazyDecodePattern) + (Decode.index 3 decodeName) - "tuplePattern" -> + "TuplePattern" -> Decode.map2 TuplePattern - (Decode.field "elementPatterns" <| Decode.list lazyDecodePattern) - (Decode.field "extra" decodeExtra) + (Decode.index 1 decodeAttributes) + (Decode.index 2 <| Decode.list lazyDecodePattern) - "recordPattern" -> + "RecordPattern" -> Decode.map2 RecordPattern - (Decode.field "fieldNames" <| Decode.list decodeName) - (Decode.field "extra" decodeExtra) + (Decode.index 1 decodeAttributes) + (Decode.index 2 <| Decode.list decodeName) - "constructorPattern" -> + "ConstructorPattern" -> Decode.map3 ConstructorPattern - (Decode.field "constructorName" decodeFQName) - (Decode.field "argumentPatterns" <| Decode.list lazyDecodePattern) - (Decode.field "extra" decodeExtra) + (Decode.index 1 decodeAttributes) + (Decode.index 2 decodeFQName) + (Decode.index 3 <| Decode.list lazyDecodePattern) - "emptyListPattern" -> + "EmptyListPattern" -> Decode.map EmptyListPattern - (Decode.field "extra" decodeExtra) + (Decode.index 1 decodeAttributes) - "headTailPattern" -> + "HeadTailPattern" -> Decode.map3 HeadTailPattern - (Decode.field "headPattern" lazyDecodePattern) - (Decode.field "tailPattern" lazyDecodePattern) - (Decode.field "extra" decodeExtra) + (Decode.index 1 decodeAttributes) + (Decode.index 2 lazyDecodePattern) + (Decode.index 3 lazyDecodePattern) other -> Decode.fail <| "Unknown pattern type: " ++ other diff --git a/tests/Morphir/Elm/FrontendTests.elm b/tests/Morphir/Elm/FrontendTests.elm index f989631dd..439896237 100644 --- a/tests/Morphir/Elm/FrontendTests.elm +++ b/tests/Morphir/Elm/FrontendTests.elm @@ -211,23 +211,23 @@ valueTests = ref : String -> Value () ref name = - Reference (fQName [] [] [ name ]) () + Reference () (fQName [] [] [ name ]) in describe "Values are mapped correctly" [ checkIR "()" <| Unit () - , checkIR "1" <| Literal (IntLiteral 1) () - , checkIR "0x20" <| Literal (IntLiteral 32) () - , checkIR "1.5" <| Literal (FloatLiteral 1.5) () - , checkIR "\"foo\"" <| Literal (StringLiteral "foo") () - , checkIR "True" <| Literal (BoolLiteral True) () - , checkIR "False" <| Literal (BoolLiteral False) () - , checkIR "'A'" <| Literal (CharLiteral 'A') () + , checkIR "1" <| Literal () (IntLiteral 1) + , checkIR "0x20" <| Literal () (IntLiteral 32) + , checkIR "1.5" <| Literal () (FloatLiteral 1.5) + , checkIR "\"foo\"" <| Literal () (StringLiteral "foo") + , checkIR "True" <| Literal () (BoolLiteral True) + , checkIR "False" <| Literal () (BoolLiteral False) + , checkIR "'A'" <| Literal () (CharLiteral 'A') , checkIR "foo" <| ref "foo" - , checkIR "Bar.foo" <| Reference (fQName [] [ [ "bar" ] ] [ "foo" ]) () - , checkIR "MyPack.Bar.foo" <| Reference (fQName [] [ [ "my", "pack" ], [ "bar" ] ] [ "foo" ]) () - , checkIR "foo bar" <| Apply (ref "foo") (ref "bar") () - , checkIR "foo bar baz" <| Apply (Apply (ref "foo") (ref "bar") ()) (ref "baz") () - , checkIR "-1" <| Number.negate () () (Literal (IntLiteral 1) ()) + , checkIR "Bar.foo" <| Reference () (fQName [] [ [ "bar" ] ] [ "foo" ]) + , checkIR "MyPack.Bar.foo" <| Reference () (fQName [] [ [ "my", "pack" ], [ "bar" ] ] [ "foo" ]) + , checkIR "foo bar" <| Apply () (ref "foo") (ref "bar") + , checkIR "foo bar baz" <| Apply () (Apply () (ref "foo") (ref "bar")) (ref "baz") + , checkIR "-1" <| Number.negate () () (Literal () (IntLiteral 1)) ] From 446d79373fc3333ccc802d7b25c7c3f15e0fdb18 Mon Sep 17 00:00:00 2001 From: Attila Mihaly Date: Tue, 31 Mar 2020 20:14:42 -0400 Subject: [PATCH 11/42] Change extra arg position and naming. #46, #25 --- cli/src/Morphir/Elm/DaprCLI.elm | 2 +- src/Morphir/Elm/Backend/Dapr/StatefulApp.elm | 6 +- src/Morphir/Elm/Frontend.elm | 29 +- src/Morphir/Elm/Frontend/Resolve.elm | 15 +- src/Morphir/IR/SDK/Bool.elm | 6 +- src/Morphir/IR/SDK/Char.elm | 6 +- src/Morphir/IR/SDK/Float.elm | 6 +- src/Morphir/IR/SDK/Int.elm | 6 +- src/Morphir/IR/SDK/List.elm | 6 +- src/Morphir/IR/SDK/Maybe.elm | 8 +- src/Morphir/IR/SDK/Number.elm | 6 +- src/Morphir/IR/SDK/Result.elm | 10 +- src/Morphir/IR/SDK/String.elm | 6 +- src/Morphir/IR/Type.elm | 539 +++++++------------ tests/Morphir/Elm/FrontendTests.elm | 23 +- 15 files changed, 248 insertions(+), 426 deletions(-) diff --git a/cli/src/Morphir/Elm/DaprCLI.elm b/cli/src/Morphir/Elm/DaprCLI.elm index 8da9fe87d..46f63582a 100644 --- a/cli/src/Morphir/Elm/DaprCLI.elm +++ b/cli/src/Morphir/Elm/DaprCLI.elm @@ -138,7 +138,7 @@ daprSource pkgPath pkgDef = case acsCtrlModDef.value of { types, values } -> Dict.remove (Name.fromString "app") types - |> Dict.map (\_ acsCtrlTypeDef -> AccessControlled.map Type.eraseExtra acsCtrlTypeDef) + |> Dict.map (\_ acsCtrlTypeDef -> AccessControlled.map Type.eraseAttributes acsCtrlTypeDef) |> Dict.toList Private -> diff --git a/src/Morphir/Elm/Backend/Dapr/StatefulApp.elm b/src/Morphir/Elm/Backend/Dapr/StatefulApp.elm index 9c6abd667..f128c257c 100644 --- a/src/Morphir/Elm/Backend/Dapr/StatefulApp.elm +++ b/src/Morphir/Elm/Backend/Dapr/StatefulApp.elm @@ -21,7 +21,7 @@ import Morphir.IR.AccessControlled as AccessControlled exposing (AccessControlle import Morphir.IR.FQName exposing (FQName(..)) import Morphir.IR.Name as Name exposing (Name, toCamelCase) import Morphir.IR.Path exposing (Path) -import Morphir.IR.Type as Type exposing (Definition(..), Field, Type(..), eraseExtra) +import Morphir.IR.Type as Type exposing (Definition(..), Field, Type(..), eraseAttributes) gen : Path -> Name -> Type () -> List ( Name, AccessControlled (Type.Definition ()) ) -> Maybe File @@ -237,7 +237,7 @@ msgDecoderDecl keyType stateType cmdType = Ok (( typeName, typeDef ) :: []) -> DecoderGen.typeDefToDecoder typeName - (typeDef |> AccessControlled.map eraseExtra) + (typeDef |> AccessControlled.map eraseAttributes) _ -> emptyDecl @@ -329,7 +329,7 @@ encodeStateEventDecl keyType stateType eventType = in case morphirTypeDef of Ok (( typeName, typeDef ) :: []) -> - EncoderGen.typeDefToEncoder typeName (typeDef |> AccessControlled.map eraseExtra) + EncoderGen.typeDefToEncoder typeName (typeDef |> AccessControlled.map eraseAttributes) _ -> emptyDecl diff --git a/src/Morphir/Elm/Frontend.elm b/src/Morphir/Elm/Frontend.elm index 5b98865ea..f044ee4ec 100644 --- a/src/Morphir/Elm/Frontend.elm +++ b/src/Morphir/Elm/Frontend.elm @@ -567,13 +567,11 @@ mapTypeAnnotation sourceFile (Node range typeAnnotation) = in case typeAnnotation of GenericType varName -> - Ok (Type.variable (varName |> Name.fromString) sourceLocation) + Ok (Type.Variable sourceLocation (varName |> Name.fromString)) Typed (Node _ ( moduleName, localName )) argNodes -> Result.map - (\args -> - Type.reference (fQName [] (moduleName |> List.map Name.fromString) (Name.fromString localName)) args sourceLocation - ) + (Type.Reference sourceLocation (fQName [] (moduleName |> List.map Name.fromString) (Name.fromString localName))) (argNodes |> List.map (mapTypeAnnotation sourceFile) |> ResultList.toResult @@ -581,13 +579,13 @@ mapTypeAnnotation sourceFile (Node range typeAnnotation) = ) Unit -> - Ok (Type.unit sourceLocation) + Ok (Type.Unit sourceLocation) Tupled elemNodes -> elemNodes |> List.map (mapTypeAnnotation sourceFile) |> ResultList.toResult - |> Result.map (\elemTypes -> Type.tuple elemTypes sourceLocation) + |> Result.map (Type.Tuple sourceLocation) |> Result.mapError List.concat Record fieldNodes -> @@ -599,10 +597,7 @@ mapTypeAnnotation sourceFile (Node range typeAnnotation) = |> Result.map (Type.Field (fieldName |> Name.fromString)) ) |> ResultList.toResult - |> Result.map - (\fields -> - Type.record fields sourceLocation - ) + |> Result.map (Type.Record sourceLocation) |> Result.mapError List.concat GenericRecord (Node _ argName) (Node _ fieldNodes) -> @@ -614,17 +609,11 @@ mapTypeAnnotation sourceFile (Node range typeAnnotation) = |> Result.map (Type.Field (fieldName |> Name.fromString)) ) |> ResultList.toResult - |> Result.map - (\fields -> - Type.extensibleRecord (argName |> Name.fromString) fields sourceLocation - ) + |> Result.map (Type.ExtensibleRecord sourceLocation (argName |> Name.fromString)) |> Result.mapError List.concat FunctionTypeAnnotation argTypeNode returnTypeNode -> - Result.map2 - (\argType returnType -> - Type.function argType returnType sourceLocation - ) + Result.map2 (Type.Function sourceLocation) (mapTypeAnnotation sourceFile argTypeNode) (mapTypeAnnotation sourceFile returnTypeNode) @@ -769,7 +758,7 @@ resolveLocalTypes packagePath modulePath moduleResolver moduleDef = Rewrite.bottomUp Type.rewriteType (\tpe -> case tpe of - Type.Reference refFullName args sourceLocation -> + Type.Reference sourceLocation refFullName args -> let refModulePath : Path refModulePath = @@ -797,7 +786,7 @@ resolveLocalTypes packagePath modulePath moduleResolver moduleDef = resolvedFullNameResult |> Result.map (\resolvedFullName -> - Type.Reference resolvedFullName args sourceLocation + Type.Reference sourceLocation resolvedFullName args ) |> Result.mapError (ResolveError sourceLocation) |> Just diff --git a/src/Morphir/Elm/Frontend/Resolve.elm b/src/Morphir/Elm/Frontend/Resolve.elm index 45392219f..2ac4ed47d 100644 --- a/src/Morphir/Elm/Frontend/Resolve.elm +++ b/src/Morphir/Elm/Frontend/Resolve.elm @@ -164,14 +164,13 @@ createPackageResolver dependencies currentPackagePath currentPackageModules = ) |> Result.map (\typeDecl -> - typeDecl - |> Type.matchCustomTypeSpecification matchAny matchAny - |> Maybe.map - (\( _, ctors ) -> - ctors - |> List.map (Tuple.first >> Name.toTitleCase) - ) - |> Maybe.withDefault [] + case typeDecl of + Type.CustomTypeSpecification _ ctors -> + ctors + |> List.map (Tuple.first >> Name.toTitleCase) + + _ -> + [] ) ) diff --git a/src/Morphir/IR/SDK/Bool.elm b/src/Morphir/IR/SDK/Bool.elm index ca113b7e8..31f91928e 100644 --- a/src/Morphir/IR/SDK/Bool.elm +++ b/src/Morphir/IR/SDK/Bool.elm @@ -34,6 +34,6 @@ fromLocalName name = |> FQName.fromQName packageName -boolType : extra -> Type extra -boolType extra = - Reference (fromLocalName "bool") [] extra +boolType : a -> Type a +boolType attributes = + Reference attributes (fromLocalName "bool") [] diff --git a/src/Morphir/IR/SDK/Char.elm b/src/Morphir/IR/SDK/Char.elm index 4497aef85..69f91e9e5 100644 --- a/src/Morphir/IR/SDK/Char.elm +++ b/src/Morphir/IR/SDK/Char.elm @@ -34,6 +34,6 @@ fromLocalName name = |> FQName.fromQName packageName -charType : extra -> Type extra -charType extra = - Reference (fromLocalName "char") [] extra +charType : a -> Type a +charType attributes = + Reference attributes (fromLocalName "char") [] diff --git a/src/Morphir/IR/SDK/Float.elm b/src/Morphir/IR/SDK/Float.elm index 45f83d3cb..270654531 100644 --- a/src/Morphir/IR/SDK/Float.elm +++ b/src/Morphir/IR/SDK/Float.elm @@ -34,6 +34,6 @@ fromLocalName name = |> FQName.fromQName packageName -floatType : extra -> Type extra -floatType extra = - Reference (fromLocalName "float") [] extra +floatType : a -> Type a +floatType attributes = + Reference attributes (fromLocalName "float") [] diff --git a/src/Morphir/IR/SDK/Int.elm b/src/Morphir/IR/SDK/Int.elm index 2630a61c8..f44f47558 100644 --- a/src/Morphir/IR/SDK/Int.elm +++ b/src/Morphir/IR/SDK/Int.elm @@ -34,6 +34,6 @@ fromLocalName name = |> FQName.fromQName packageName -intType : extra -> Type extra -intType extra = - Reference (fromLocalName "int") [] extra +intType : a -> Type a +intType attributes = + Reference attributes (fromLocalName "int") [] diff --git a/src/Morphir/IR/SDK/List.elm b/src/Morphir/IR/SDK/List.elm index 995802bab..f086b2362 100644 --- a/src/Morphir/IR/SDK/List.elm +++ b/src/Morphir/IR/SDK/List.elm @@ -34,6 +34,6 @@ fromLocalName name = |> FQName.fromQName packageName -listType : Type extra -> extra -> Type extra -listType itemType extra = - Reference (fromLocalName "list") [ itemType ] extra +listType : a -> Type a -> Type a +listType attributes itemType = + Reference attributes (fromLocalName "list") [ itemType ] diff --git a/src/Morphir/IR/SDK/Maybe.elm b/src/Morphir/IR/SDK/Maybe.elm index 9f7683e2e..73f3b86c3 100644 --- a/src/Morphir/IR/SDK/Maybe.elm +++ b/src/Morphir/IR/SDK/Maybe.elm @@ -21,7 +21,7 @@ moduleSpec = Dict.fromList [ ( [ "maybe" ] , CustomTypeSpecification [ [ "a" ] ] - [ ( [ "just" ], [ ( [ "value" ], Type.Variable [ "a" ] () ) ] ) + [ ( [ "just" ], [ ( [ "value" ], Type.Variable () [ "a" ] ) ] ) , ( [ "nothing" ], [] ) ] ) @@ -39,6 +39,6 @@ fromLocalName name = |> FQName.fromQName packageName -maybeType : Type extra -> extra -> Type extra -maybeType itemType extra = - Reference (fromLocalName "maybe") [ itemType ] extra +maybeType : a -> Type a -> Type a +maybeType attributes itemType = + Reference attributes (fromLocalName "maybe") [ itemType ] diff --git a/src/Morphir/IR/SDK/Number.elm b/src/Morphir/IR/SDK/Number.elm index 424e5144c..63379a23a 100644 --- a/src/Morphir/IR/SDK/Number.elm +++ b/src/Morphir/IR/SDK/Number.elm @@ -33,9 +33,9 @@ fromLocalName name = |> FQName.fromQName packageName -numberClass : extra -> Type extra -numberClass extra = - Variable [ "number" ] extra +numberClass : a -> Type a +numberClass attributes = + Variable attributes [ "number" ] negate : extra -> extra -> Value extra -> Value extra diff --git a/src/Morphir/IR/SDK/Result.elm b/src/Morphir/IR/SDK/Result.elm index 541785416..f712af925 100644 --- a/src/Morphir/IR/SDK/Result.elm +++ b/src/Morphir/IR/SDK/Result.elm @@ -21,8 +21,8 @@ moduleSpec = Dict.fromList [ ( [ "result" ] , CustomTypeSpecification [ [ "e" ], [ "a" ] ] - [ ( [ "ok" ], [ ( [ "value" ], Type.Variable [ "a" ] () ) ] ) - , ( [ "err" ], [ ( [ "error" ], Type.Variable [ "e" ] () ) ] ) + [ ( [ "ok" ], [ ( [ "value" ], Type.Variable () [ "a" ] ) ] ) + , ( [ "err" ], [ ( [ "error" ], Type.Variable () [ "e" ] ) ] ) ] ) ] @@ -39,6 +39,6 @@ fromLocalName name = |> FQName.fromQName packageName -resultType : Type extra -> extra -> Type extra -resultType itemType extra = - Reference (fromLocalName "result") [ itemType ] extra +resultType : a -> Type a -> Type a +resultType attributes itemType = + Reference attributes (fromLocalName "result") [ itemType ] diff --git a/src/Morphir/IR/SDK/String.elm b/src/Morphir/IR/SDK/String.elm index 4ae22a52d..d5578addc 100644 --- a/src/Morphir/IR/SDK/String.elm +++ b/src/Morphir/IR/SDK/String.elm @@ -34,6 +34,6 @@ fromLocalName name = |> FQName.fromQName packageName -stringType : extra -> Type extra -stringType extra = - Reference (fromLocalName "string") [] extra +stringType : a -> Type a +stringType attributes = + Reference attributes (fromLocalName "string") [] diff --git a/src/Morphir/IR/Type.elm b/src/Morphir/IR/Type.elm index f5e1d76fb..ff5514180 100644 --- a/src/Morphir/IR/Type.elm +++ b/src/Morphir/IR/Type.elm @@ -1,14 +1,13 @@ module Morphir.IR.Type exposing ( Type(..) , variable, reference, tuple, record, extensibleRecord, function, unit - , matchVariable, matchReference, matchTuple, matchRecord, matchExtensibleRecord, matchFunction, matchUnit , Field, matchField, mapFieldName, mapFieldType - , Specification(..), typeAliasSpecification, opaqueTypeSpecification, customTypeSpecification, matchCustomTypeSpecification + , Specification(..), typeAliasSpecification, opaqueTypeSpecification, customTypeSpecification , Definition(..), typeAliasDefinition, customTypeDefinition , Constructors , fuzzType , encodeType, decodeType, encodeSpecification, encodeDefinition - , Constructor, definitionToSpecification, eraseExtra, mapDefinition, mapSpecification, mapTypeExtra, rewriteType + , Constructor, definitionToSpecification, eraseAttributes, mapDefinition, mapSpecification, mapTypeExtra, rewriteType ) {-| This module contains the building blocks of types in the Morphir IR. @@ -83,29 +82,29 @@ for more details: - unit type: [creation](#unit), [matching](#matchUnit) -} -type Type extra - = Variable Name extra - | Reference FQName (List (Type extra)) extra - | Tuple (List (Type extra)) extra - | Record (List (Field extra)) extra - | ExtensibleRecord Name (List (Field extra)) extra - | Function (Type extra) (Type extra) extra - | Unit extra +type Type a + = Variable a Name + | Reference a FQName (List (Type a)) + | Tuple a (List (Type a)) + | Record a (List (Field a)) + | ExtensibleRecord a Name (List (Field a)) + | Function a (Type a) (Type a) + | Unit a {-| An opaque representation of a field. It's made up of a name and a type. -} -type alias Field extra = +type alias Field a = { name : Name - , tpe : Type extra + , tpe : Type a } {-| -} -type Specification extra - = TypeAliasSpecification (List Name) (Type extra) +type Specification a + = TypeAliasSpecification (List Name) (Type a) | OpaqueTypeSpecification (List Name) - | CustomTypeSpecification (List Name) (Constructors extra) + | CustomTypeSpecification (List Name) (Constructors a) {-| This syntax represents a type definition. For example: @@ -117,22 +116,22 @@ In the definition, the `List Name` refers to type parameters on the LHS and `Type extra` refers to the RHS -} -type Definition extra - = TypeAliasDefinition (List Name) (Type extra) - | CustomTypeDefinition (List Name) (AccessControlled (Constructors extra)) +type Definition a + = TypeAliasDefinition (List Name) (Type a) + | CustomTypeDefinition (List Name) (AccessControlled (Constructors a)) {-| -} -type alias Constructors extra = - List (Constructor extra) +type alias Constructors a = + List (Constructor a) {-| -} -type alias Constructor extra = - ( Name, List ( Name, Type extra ) ) +type alias Constructor a = + ( Name, List ( Name, Type a ) ) -definitionToSpecification : Definition extra -> Specification extra +definitionToSpecification : Definition a -> Specification a definitionToSpecification def = case def of TypeAliasDefinition params exp -> @@ -217,55 +216,55 @@ mapDefinition f def = mapTypeExtra : (a -> b) -> Type a -> Type b mapTypeExtra f tpe = case tpe of - Variable name extra -> - Variable name (f extra) + Variable a name -> + Variable (f a) name - Reference fQName argTypes extra -> - Reference fQName (argTypes |> List.map (mapTypeExtra f)) (f extra) + Reference a fQName argTypes -> + Reference (f a) fQName (argTypes |> List.map (mapTypeExtra f)) - Tuple elemTypes extra -> - Tuple (elemTypes |> List.map (mapTypeExtra f)) (f extra) + Tuple a elemTypes -> + Tuple (f a) (elemTypes |> List.map (mapTypeExtra f)) - Record fields extra -> - Record (fields |> List.map (mapFieldType (mapTypeExtra f))) (f extra) + Record a fields -> + Record (f a) (fields |> List.map (mapFieldType (mapTypeExtra f))) - ExtensibleRecord name fields extra -> - ExtensibleRecord name (fields |> List.map (mapFieldType (mapTypeExtra f))) (f extra) + ExtensibleRecord a name fields -> + ExtensibleRecord (f a) name (fields |> List.map (mapFieldType (mapTypeExtra f))) - Function argType returnType extra -> - Function (argType |> mapTypeExtra f) (returnType |> mapTypeExtra f) (f extra) + Function a argType returnType -> + Function (f a) (argType |> mapTypeExtra f) (returnType |> mapTypeExtra f) - Unit extra -> - Unit (f extra) + Unit a -> + Unit (f a) -typeExtra : Type a -> a -typeExtra tpe = +typeAttributes : Type a -> a +typeAttributes tpe = case tpe of - Variable name extra -> - extra + Variable a name -> + a - Reference fQName argTypes extra -> - extra + Reference a fQName argTypes -> + a - Tuple elemTypes extra -> - extra + Tuple a elemTypes -> + a - Record fields extra -> - extra + Record a fields -> + a - ExtensibleRecord name fields extra -> - extra + ExtensibleRecord a name fields -> + a - Function argType returnType extra -> - extra + Function a argType returnType -> + a - Unit extra -> - extra + Unit a -> + a -eraseExtra : Definition extra -> Definition () -eraseExtra typeDef = +eraseAttributes : Definition a -> Definition () +eraseAttributes typeDef = case typeDef of TypeAliasDefinition typeVars tpe -> TypeAliasDefinition typeVars (mapTypeExtra (\_ -> ()) tpe) @@ -298,22 +297,9 @@ eraseExtra typeDef = toIR fooBar == variable [ "foo", "bar" ] () -} -variable : Name -> extra -> Type extra -variable name extra = - Variable name extra - - -{-| -} -matchVariable : Pattern Name a -> Pattern extra b -> Pattern (Type extra) ( a, b ) -matchVariable matchName matchExtra typeToMatch = - case typeToMatch of - Variable name extra -> - Maybe.map2 Tuple.pair - (matchName name) - (matchExtra extra) - - _ -> - Nothing +variable : a -> Name -> Type a +variable attributes name = + Variable attributes name {-| Creates a fully-qualified reference to a type. @@ -327,23 +313,9 @@ matchVariable matchName matchExtra typeToMatch = [] -} -reference : FQName -> List (Type extra) -> extra -> Type extra -reference typeName typeParameters extra = - Reference typeName typeParameters extra - - -{-| -} -matchReference : Pattern FQName a -> Pattern (List (Type extra)) b -> Pattern extra c -> Pattern (Type extra) ( a, b, c ) -matchReference matchTypeName matchTypeParameters matchExtra typeToMatch = - case typeToMatch of - Reference typeName typeParameters extra -> - Maybe.map3 (\a b c -> ( a, b, c )) - (matchTypeName typeName) - (matchTypeParameters typeParameters) - (matchExtra extra) - - _ -> - Nothing +reference : a -> FQName -> List (Type a) -> Type a +reference attributes typeName typeParameters = + Reference attributes typeName typeParameters {-| Creates a tuple type. @@ -352,33 +324,9 @@ matchReference matchTypeName matchTypeParameters matchExtra typeToMatch = == tuple [ basic intType, basic boolType ] -} -tuple : List (Type extra) -> extra -> Type extra -tuple elementTypes extra = - Tuple elementTypes extra - - -{-| Matches a tuple type and extracts element types. - - tpe = - tuple [ SDK.Basics.intType, SDK.Basics.boolType ] - - pattern = - matchTuple (list [ matchBasic any, matchBasic any ]) - - pattern tpe == - [ SDK.Basics.intType, SDK.Basics.boolType ] - --} -matchTuple : Pattern (List (Type extra)) a -> Pattern extra b -> Pattern (Type extra) ( a, b ) -matchTuple matchElementTypes matchExtra typeToMatch = - case typeToMatch of - Tuple elementTypes extra -> - Maybe.map2 Tuple.pair - (matchElementTypes elementTypes) - (matchExtra extra) - - _ -> - Nothing +tuple : a -> List (Type a) -> Type a +tuple attributes elementTypes = + Tuple attributes elementTypes {-| Creates a record type. @@ -397,43 +345,9 @@ matchTuple matchElementTypes matchExtra typeToMatch = ] -} -record : List (Field extra) -> extra -> Type extra -record fieldTypes extra = - Record fieldTypes extra - - -{-| Match a record type. - - matchRecordFooBar = - matchRecord - (matchList - [ matchField - (matchValue ["foo"]) - matchAny - , matchField - (matchValue ["bar"]) - matchAny - ] - ) - - matchRecordFooBar <| - record - [ field ["foo"] SDK.Basics.intType - , field ["bar"] SDK.Basics.boolType - ] - --> Just ( SDK.Basics.intType, SDK.Basics.boolType ) - --} -matchRecord : Pattern (List (Field extra)) a -> Pattern extra b -> Pattern (Type extra) ( a, b ) -matchRecord matchFieldTypes matchExtra typeToMatch = - case typeToMatch of - Record fieldTypes extra -> - Maybe.map2 Tuple.pair - (matchFieldTypes fieldTypes) - (matchExtra extra) - - _ -> - Nothing +record : a -> List (Field a) -> Type a +record attributes fieldTypes = + Record attributes fieldTypes {-| Creates an extensible record type. @@ -450,23 +364,9 @@ matchRecord matchFieldTypes matchExtra typeToMatch = ] -} -extensibleRecord : Name -> List (Field extra) -> extra -> Type extra -extensibleRecord variableName fieldTypes extra = - ExtensibleRecord variableName fieldTypes extra - - -{-| -} -matchExtensibleRecord : Pattern Name a -> Pattern (List (Field extra)) b -> Pattern extra c -> Pattern (Type extra) ( a, b, c ) -matchExtensibleRecord matchVariableName matchFieldTypes matchExtra typeToMatch = - case typeToMatch of - ExtensibleRecord variableName fieldTypes extra -> - Maybe.map3 (\a b c -> ( a, b, c )) - (matchVariableName variableName) - (matchFieldTypes fieldTypes) - (matchExtra extra) - - _ -> - Nothing +extensibleRecord : a -> Name -> List (Field a) -> Type a +extensibleRecord attributes variableName fieldTypes = + ExtensibleRecord attributes variableName fieldTypes {-| Creates a function type. Use currying to create functions with more than one argument. @@ -485,34 +385,9 @@ matchExtensibleRecord matchVariableName matchFieldTypes matchExtra typeToMatch = ) -} -function : Type extra -> Type extra -> extra -> Type extra -function argumentType returnType extra = - Function argumentType returnType extra - - -{-| Matches a function type. - - tpe = - function SDK.Basics.intType SDK.Basics.boolType - - pattern = - matchFunction matchAny matchAny - - pattern tpe == - ( SDK.Basics.intType, SDK.Basics.boolType ) - --} -matchFunction : Pattern (Type extra) a -> Pattern (Type extra) b -> Pattern extra c -> Pattern (Type extra) ( a, b, c ) -matchFunction matchArgType matchReturnType matchExtra typeToMatch = - case typeToMatch of - Function argType returnType extra -> - Maybe.map3 (\a b c -> ( a, b, c )) - (matchArgType argType) - (matchReturnType returnType) - (matchExtra extra) - - _ -> - Nothing +function : a -> Type a -> Type a -> Type a +function attributes argumentType returnType = + Function attributes argumentType returnType {-| Creates a unit type. @@ -520,20 +395,9 @@ matchFunction matchArgType matchReturnType matchExtra typeToMatch = toIR () == unit -} -unit : extra -> Type extra -unit extra = - Unit extra - - -{-| -} -matchUnit : Pattern extra a -> Pattern (Type extra) a -matchUnit matchExtra typeToMatch = - case typeToMatch of - Unit extra -> - matchExtra extra - - _ -> - Nothing +unit : a -> Type a +unit attributes = + Unit attributes {-| -} @@ -566,23 +430,10 @@ customTypeSpecification typeParams ctors = CustomTypeSpecification typeParams ctors -{-| -} -matchCustomTypeSpecification : Pattern (List Name) a -> Pattern (Constructors extra) b -> Pattern (Specification extra) ( a, b ) -matchCustomTypeSpecification matchTypeParams matchCtors specToMatch = - case specToMatch of - CustomTypeSpecification typeParams ctors -> - Maybe.map2 Tuple.pair - (matchTypeParams typeParams) - (matchCtors ctors) - - _ -> - Nothing - - -rewriteType : Rewrite e (Type extra) +rewriteType : Rewrite e (Type a) rewriteType rewriteBranch rewriteLeaf typeToRewrite = case typeToRewrite of - Reference fQName argTypes extra -> + Reference a fQName argTypes -> argTypes |> List.foldr (\nextArg resultSoFar -> @@ -591,12 +442,9 @@ rewriteType rewriteBranch rewriteLeaf typeToRewrite = resultSoFar ) (Ok []) - |> Result.map - (\args -> - Reference fQName args extra - ) + |> Result.map (Reference a fQName) - Tuple elemTypes extra -> + Tuple a elemTypes -> elemTypes |> List.foldr (\nextArg resultSoFar -> @@ -605,12 +453,9 @@ rewriteType rewriteBranch rewriteLeaf typeToRewrite = resultSoFar ) (Ok []) - |> Result.map - (\elems -> - Tuple elems extra - ) + |> Result.map (Tuple a) - Record fieldTypes extra -> + Record a fieldTypes -> fieldTypes |> List.foldr (\field resultSoFar -> @@ -621,12 +466,9 @@ rewriteType rewriteBranch rewriteLeaf typeToRewrite = resultSoFar ) (Ok []) - |> Result.map - (\fields -> - Record fields extra - ) + |> Result.map (Record a) - ExtensibleRecord varName fieldTypes extra -> + ExtensibleRecord a varName fieldTypes -> fieldTypes |> List.foldr (\field resultSoFar -> @@ -637,13 +479,10 @@ rewriteType rewriteBranch rewriteLeaf typeToRewrite = resultSoFar ) (Ok []) - |> Result.map - (\fields -> - ExtensibleRecord varName fields extra - ) + |> Result.map (ExtensibleRecord a varName) - Function argType returnType extra -> - Result.map2 (\arg return -> Function arg return extra) + Function a argType returnType -> + Result.map2 (Function a) (rewriteBranch argType) (rewriteBranch returnType) @@ -687,50 +526,50 @@ mapFieldType f field = {-| Generate random types. -} -fuzzType : Int -> Fuzzer extra -> Fuzzer (Type extra) -fuzzType maxDepth fuzzExtra = +fuzzType : Int -> Fuzzer a -> Fuzzer (Type a) +fuzzType maxDepth fuzzAttributes = let fuzzField depth = Fuzz.map2 Field fuzzName - (fuzzType depth fuzzExtra) + (fuzzType depth fuzzAttributes) fuzzVariable = Fuzz.map2 Variable + fuzzAttributes fuzzName - fuzzExtra fuzzReference depth = Fuzz.map3 Reference + fuzzAttributes fuzzFQName - (Fuzz.list (fuzzType depth fuzzExtra) |> Fuzz.map (List.take depth)) - fuzzExtra + (Fuzz.list (fuzzType depth fuzzAttributes) |> Fuzz.map (List.take depth)) fuzzTuple depth = Fuzz.map2 Tuple - (Fuzz.list (fuzzType depth fuzzExtra) |> Fuzz.map (List.take depth)) - fuzzExtra + fuzzAttributes + (Fuzz.list (fuzzType depth fuzzAttributes) |> Fuzz.map (List.take depth)) fuzzRecord depth = Fuzz.map2 Record + fuzzAttributes (Fuzz.list (fuzzField (depth - 1)) |> Fuzz.map (List.take depth)) - fuzzExtra fuzzExtensibleRecord depth = Fuzz.map3 ExtensibleRecord + fuzzAttributes fuzzName (Fuzz.list (fuzzField (depth - 1)) |> Fuzz.map (List.take depth)) - fuzzExtra fuzzFunction depth = Fuzz.map3 Function - (fuzzType depth fuzzExtra) - (fuzzType depth fuzzExtra) - fuzzExtra + fuzzAttributes + (fuzzType depth fuzzAttributes) + (fuzzType depth fuzzAttributes) fuzzUnit = Fuzz.map Unit - fuzzExtra + fuzzAttributes fuzzLeaf = Fuzz.oneOf @@ -759,122 +598,118 @@ fuzzType maxDepth fuzzExtra = {-| Encode a type into JSON. -} -encodeType : (extra -> Encode.Value) -> Type extra -> Encode.Value -encodeType encodeExtra tpe = - let - typeTag tag = - ( "@type", Encode.string tag ) - in +encodeType : (a -> Encode.Value) -> Type a -> Encode.Value +encodeType encodeAttributes tpe = case tpe of - Variable name extra -> - Encode.object - [ typeTag "variable" - , ( "name", encodeName name ) - , ( "extra", encodeExtra extra ) + Variable a name -> + Encode.list identity + [ Encode.string "Variable" + , encodeAttributes a + , encodeName name ] - Reference typeName typeParameters extra -> - Encode.object - [ typeTag "reference" - , ( "typeName", encodeFQName typeName ) - , ( "typeParameters", Encode.list (encodeType encodeExtra) typeParameters ) - , ( "extra", encodeExtra extra ) + Reference a typeName typeParameters -> + Encode.list identity + [ Encode.string "Reference" + , encodeAttributes a + , encodeFQName typeName + , Encode.list (encodeType encodeAttributes) typeParameters ] - Tuple elementTypes extra -> - Encode.object - [ typeTag "tuple" - , ( "elementTypes", Encode.list (encodeType encodeExtra) elementTypes ) - , ( "extra", encodeExtra extra ) + Tuple a elementTypes -> + Encode.list identity + [ Encode.string "Tuple" + , encodeAttributes a + , Encode.list (encodeType encodeAttributes) elementTypes ] - Record fieldTypes extra -> - Encode.object - [ typeTag "record" - , ( "fieldTypes", Encode.list (encodeField encodeExtra) fieldTypes ) - , ( "extra", encodeExtra extra ) + Record a fieldTypes -> + Encode.list identity + [ Encode.string "Record" + , encodeAttributes a + , Encode.list (encodeField encodeAttributes) fieldTypes ] - ExtensibleRecord variableName fieldTypes extra -> - Encode.object - [ typeTag "extensibleRecord" - , ( "variableName", encodeName variableName ) - , ( "fieldTypes", Encode.list (encodeField encodeExtra) fieldTypes ) - , ( "extra", encodeExtra extra ) + ExtensibleRecord a variableName fieldTypes -> + Encode.list identity + [ Encode.string "ExtensibleRecord" + , encodeAttributes a + , encodeName variableName + , Encode.list (encodeField encodeAttributes) fieldTypes ] - Function argumentType returnType extra -> - Encode.object - [ typeTag "function" - , ( "argumentType", encodeType encodeExtra argumentType ) - , ( "returnType", encodeType encodeExtra returnType ) - , ( "extra", encodeExtra extra ) + Function a argumentType returnType -> + Encode.list identity + [ Encode.string "Function" + , encodeAttributes a + , encodeType encodeAttributes argumentType + , encodeType encodeAttributes returnType ] - Unit extra -> - Encode.object - [ typeTag "unit" - , ( "extra", encodeExtra extra ) + Unit a -> + Encode.list identity + [ Encode.string "Unit" + , encodeAttributes a ] {-| Decode a type from JSON. -} -decodeType : Decode.Decoder extra -> Decode.Decoder (Type extra) -decodeType decodeExtra = +decodeType : Decode.Decoder a -> Decode.Decoder (Type a) +decodeType decodeAttributes = let lazyDecodeType = Decode.lazy (\_ -> - decodeType decodeExtra + decodeType decodeAttributes ) lazyDecodeField = Decode.lazy (\_ -> - decodeField decodeExtra + decodeField decodeAttributes ) in - Decode.field "@type" Decode.string + Decode.index 0 Decode.string |> Decode.andThen (\kind -> case kind of - "variable" -> + "Variable" -> Decode.map2 Variable - (Decode.field "name" decodeName) - (Decode.field "extra" decodeExtra) + (Decode.index 1 decodeAttributes) + (Decode.index 2 decodeName) - "reference" -> + "Reference" -> Decode.map3 Reference - (Decode.field "typeName" decodeFQName) - (Decode.field "typeParameters" (Decode.list (Decode.lazy (\_ -> decodeType decodeExtra)))) - (Decode.field "extra" decodeExtra) + (Decode.index 1 decodeAttributes) + (Decode.index 2 decodeFQName) + (Decode.index 3 (Decode.list (Decode.lazy (\_ -> decodeType decodeAttributes)))) - "tuple" -> + "Tuple" -> Decode.map2 Tuple - (Decode.field "elementTypes" (Decode.list lazyDecodeType)) - (Decode.field "extra" decodeExtra) + (Decode.index 1 decodeAttributes) + (Decode.index 2 (Decode.list lazyDecodeType)) - "record" -> + "Record" -> Decode.map2 Record - (Decode.field "fieldTypes" (Decode.list lazyDecodeField)) - (Decode.field "extra" decodeExtra) + (Decode.index 1 decodeAttributes) + (Decode.index 2 (Decode.list lazyDecodeField)) - "extensibleRecord" -> + "ExtensibleRecord" -> Decode.map3 ExtensibleRecord - (Decode.field "variableName" decodeName) - (Decode.field "fieldTypes" (Decode.list lazyDecodeField)) - (Decode.field "extra" decodeExtra) + (Decode.index 1 decodeAttributes) + (Decode.index 2 decodeName) + (Decode.index 3 (Decode.list lazyDecodeField)) - "function" -> + "Function" -> Decode.map3 Function - (Decode.field "argumentType" lazyDecodeType) - (Decode.field "returnType" lazyDecodeType) - (Decode.field "extra" decodeExtra) + (Decode.index 1 decodeAttributes) + (Decode.index 2 lazyDecodeType) + (Decode.index 3 lazyDecodeType) - "unit" -> + "Unit" -> Decode.map Unit - (Decode.field "extra" decodeExtra) + (Decode.index 1 decodeAttributes) _ -> Decode.fail ("Unknown kind: " ++ kind) @@ -901,23 +736,23 @@ encodeSpecification : (extra -> Encode.Value) -> Specification extra -> Encode.V encodeSpecification encodeExtra spec = case spec of TypeAliasSpecification params exp -> - Encode.object - [ ( "$type", Encode.string "typeAlias" ) - , ( "params", Encode.list encodeName params ) - , ( "exp", encodeType encodeExtra exp ) + Encode.list identity + [ Encode.string "TypeAliasSpecification" + , Encode.list encodeName params + , encodeType encodeExtra exp ] OpaqueTypeSpecification params -> - Encode.object - [ ( "$type", Encode.string "opaqueType" ) - , ( "params", Encode.list encodeName params ) + Encode.list identity + [ Encode.string "OpaqueTypeSpecification" + , Encode.list encodeName params ] CustomTypeSpecification params ctors -> - Encode.object - [ ( "$type", Encode.string "customType" ) - , ( "params", Encode.list encodeName params ) - , ( "ctors", encodeConstructors encodeExtra ctors ) + Encode.list identity + [ Encode.string "CustomTypeSpecification" + , Encode.list encodeName params + , encodeConstructors encodeExtra ctors ] @@ -926,17 +761,17 @@ encodeDefinition : (extra -> Encode.Value) -> Definition extra -> Encode.Value encodeDefinition encodeExtra def = case def of TypeAliasDefinition params exp -> - Encode.object - [ ( "$type", Encode.string "typeAlias" ) - , ( "params", Encode.list encodeName params ) - , ( "exp", encodeType encodeExtra exp ) + Encode.list identity + [ Encode.string "TypeAliasDefinition" + , Encode.list encodeName params + , encodeType encodeExtra exp ] CustomTypeDefinition params ctors -> - Encode.object - [ ( "$type", Encode.string "customType" ) - , ( "params", Encode.list encodeName params ) - , ( "ctors", encodeAccessControlled (encodeConstructors encodeExtra) ctors ) + Encode.list identity + [ Encode.string "CustomTypeDefinition" + , Encode.list encodeName params + , encodeAccessControlled (encodeConstructors encodeExtra) ctors ] diff --git a/tests/Morphir/Elm/FrontendTests.elm b/tests/Morphir/Elm/FrontendTests.elm index 439896237..8fbe99fd3 100644 --- a/tests/Morphir/Elm/FrontendTests.elm +++ b/tests/Morphir/Elm/FrontendTests.elm @@ -97,16 +97,16 @@ frontendTest = Dict.fromList [ ( [ "bar" ] , public - (Type.typeAliasDefinition [] - (Type.reference (fQName packageName [ [ "a" ] ] [ "foo" ]) [] ()) + (Type.TypeAliasDefinition [] + (Type.Reference () (fQName packageName [ [ "a" ] ] [ "foo" ]) []) ) ) , ( [ "foo" ] , public - (Type.customTypeDefinition [] + (Type.CustomTypeDefinition [] (public [ ( [ "foo" ] - , [ ( [ "arg", "1" ], Type.reference (fQName packageName [ [ "b" ] ] [ "bee" ]) [] () ) + , [ ( [ "arg", "1" ], Type.Reference () (fQName packageName [ [ "b" ] ] [ "bee" ]) [] ) ] ) ] @@ -115,12 +115,12 @@ frontendTest = ) , ( [ "rec" ] , public - (Type.typeAliasDefinition [] - (Type.record + (Type.TypeAliasDefinition [] + (Type.Record () [ Type.Field [ "field", "1" ] - (Type.reference (fQName packageName [ [ "a" ] ] [ "foo" ]) [] ()) + (Type.Reference () (fQName packageName [ [ "a" ] ] [ "foo" ]) []) , Type.Field [ "field", "2" ] - (Type.reference (fQName packageName [ [ "a" ] ] [ "bar" ]) [] ()) + (Type.Reference () (fQName packageName [ [ "a" ] ] [ "bar" ]) []) , Type.Field [ "field", "3" ] (Bool.boolType ()) , Type.Field [ "field", "4" ] @@ -130,11 +130,10 @@ frontendTest = , Type.Field [ "field", "6" ] (String.stringType ()) , Type.Field [ "field", "7" ] - (Maybe.maybeType (Int.intType ()) ()) + (Maybe.maybeType () (Int.intType ())) , Type.Field [ "field", "8" ] - (List.listType (Float.floatType ()) ()) + (List.listType () (Float.floatType ())) ] - () ) ) ) @@ -149,7 +148,7 @@ frontendTest = Dict.fromList [ ( [ "bee" ] , public - (Type.customTypeDefinition [] + (Type.CustomTypeDefinition [] (public [ ( [ "bee" ], [] ) ]) ) ) From 812b5e0b614df806c87461a752bce3c8aceb3d11 Mon Sep 17 00:00:00 2001 From: Attila Mihaly Date: Tue, 31 Mar 2020 20:30:26 -0400 Subject: [PATCH 12/42] Removed remaining references to extra. #5 --- src/Morphir/Elm/Frontend.elm | 2 +- src/Morphir/IR/Module.elm | 42 ++++++++--------- src/Morphir/IR/Package.elm | 48 +++++++++---------- src/Morphir/IR/SDK/Number.elm | 6 +-- src/Morphir/IR/Type.elm | 80 ++++++++++++++++---------------- src/Morphir/IR/Value.elm | 86 +++++++++++++++++------------------ 6 files changed, 132 insertions(+), 132 deletions(-) diff --git a/src/Morphir/Elm/Frontend.elm b/src/Morphir/Elm/Frontend.elm index f044ee4ec..974c0571c 100644 --- a/src/Morphir/Elm/Frontend.elm +++ b/src/Morphir/Elm/Frontend.elm @@ -340,7 +340,7 @@ mapProcessedFile currentPackagePath processedFile modulesSoFar = |> Dict.map (\path def -> Module.definitionToSpecification def - |> Module.eraseSpecificationExtra + |> Module.eraseSpecificationAttributes ) dependencies = diff --git a/src/Morphir/IR/Module.elm b/src/Morphir/IR/Module.elm index 35c49dfb7..0bb2ba94d 100644 --- a/src/Morphir/IR/Module.elm +++ b/src/Morphir/IR/Module.elm @@ -1,7 +1,7 @@ module Morphir.IR.Module exposing ( Specification, Definition , encodeSpecification, encodeDefinition - , definitionToSpecification, eraseSpecificationExtra, mapDefinition, mapSpecification + , definitionToSpecification, eraseSpecificationAttributes, mapDefinition, mapSpecification ) {-| Modules are groups of types and values that belong together. @@ -24,13 +24,13 @@ import Morphir.ResultList as ResultList {-| Type that represents a module specification. -} -type alias Specification extra = - { types : Dict Name (Type.Specification extra) - , values : Dict Name (Value.Specification extra) +type alias Specification a = + { types : Dict Name (Type.Specification a) + , values : Dict Name (Value.Specification a) } -emptySpecification : Specification extra +emptySpecification : Specification a emptySpecification = { types = Dict.empty , values = Dict.empty @@ -39,13 +39,13 @@ emptySpecification = {-| Type that represents a module definition. It includes types and values. -} -type alias Definition extra = - { types : Dict Name (AccessControlled (Type.Definition extra)) - , values : Dict Name (AccessControlled (Value.Definition extra)) +type alias Definition a = + { types : Dict Name (AccessControlled (Type.Definition a)) + , values : Dict Name (AccessControlled (Value.Definition a)) } -definitionToSpecification : Definition extra -> Specification extra +definitionToSpecification : Definition a -> Specification a definitionToSpecification def = { types = def.types @@ -78,18 +78,18 @@ definitionToSpecification def = } -eraseSpecificationExtra : Specification a -> Specification () -eraseSpecificationExtra spec = +eraseSpecificationAttributes : Specification a -> Specification () +eraseSpecificationAttributes spec = spec |> mapSpecification - (Type.mapTypeExtra (\_ -> ()) >> Ok) - (Value.mapValueExtra (\_ -> ())) + (Type.mapTypeAttributes (\_ -> ()) >> Ok) + (Value.mapValueAttributes (\_ -> ())) |> Result.withDefault emptySpecification {-| -} -encodeSpecification : (extra -> Encode.Value) -> Specification extra -> Encode.Value -encodeSpecification encodeExtra spec = +encodeSpecification : (a -> Encode.Value) -> Specification a -> Encode.Value +encodeSpecification encodeAttributes spec = Encode.object [ ( "types" , spec.types @@ -98,7 +98,7 @@ encodeSpecification encodeExtra spec = (\( name, typeSpec ) -> Encode.object [ ( "name", encodeName name ) - , ( "spec", Type.encodeSpecification encodeExtra typeSpec ) + , ( "spec", Type.encodeSpecification encodeAttributes typeSpec ) ] ) ) @@ -109,7 +109,7 @@ encodeSpecification encodeExtra spec = (\( name, valueSpec ) -> Encode.object [ ( "name", encodeName name ) - , ( "spec", Value.encodeSpecification encodeExtra valueSpec ) + , ( "spec", Value.encodeSpecification encodeAttributes valueSpec ) ] ) ) @@ -191,8 +191,8 @@ mapDefinition mapType mapValue def = {-| -} -encodeDefinition : (extra -> Encode.Value) -> Definition extra -> Encode.Value -encodeDefinition encodeExtra def = +encodeDefinition : (a -> Encode.Value) -> Definition a -> Encode.Value +encodeDefinition encodeAttributes def = Encode.object [ ( "types" , def.types @@ -201,7 +201,7 @@ encodeDefinition encodeExtra def = (\( name, typeDef ) -> Encode.object [ ( "name", encodeName name ) - , ( "def", encodeAccessControlled (Type.encodeDefinition encodeExtra) typeDef ) + , ( "def", encodeAccessControlled (Type.encodeDefinition encodeAttributes) typeDef ) ] ) ) @@ -212,7 +212,7 @@ encodeDefinition encodeExtra def = (\( name, valueDef ) -> Encode.object [ ( "name", encodeName name ) - , ( "def", encodeAccessControlled (Value.encodeDefinition encodeExtra) valueDef ) + , ( "def", encodeAccessControlled (Value.encodeDefinition encodeAttributes) valueDef ) ] ) ) diff --git a/src/Morphir/IR/Package.elm b/src/Morphir/IR/Package.elm index 8a03987a6..37f84e2a0 100644 --- a/src/Morphir/IR/Package.elm +++ b/src/Morphir/IR/Package.elm @@ -1,7 +1,7 @@ module Morphir.IR.Package exposing ( Specification , Definition, emptyDefinition - , definitionToSpecification, encodeDefinition, eraseDefinitionExtra, eraseSpecificationExtra + , definitionToSpecification, encodeDefinition, eraseDefinitionAttributes, eraseSpecificationAttributes ) {-| Tools to work with packages. @@ -26,12 +26,12 @@ import Morphir.ResultList as ResultList {-| Type that represents a package specification. -} -type alias Specification extra = - { modules : Dict Path (Module.Specification extra) +type alias Specification a = + { modules : Dict Path (Module.Specification a) } -emptySpecification : Specification extra +emptySpecification : Specification a emptySpecification = { modules = Dict.empty } @@ -39,22 +39,22 @@ emptySpecification = {-| Type that represents a package definition. -} -type alias Definition extra = - { dependencies : Dict Path (Specification extra) - , modules : Dict Path (AccessControlled (Module.Definition extra)) +type alias Definition a = + { dependencies : Dict Path (Specification a) + , modules : Dict Path (AccessControlled (Module.Definition a)) } {-| An empty package definition. -} -emptyDefinition : Definition extra +emptyDefinition : Definition a emptyDefinition = { dependencies = Dict.empty , modules = Dict.empty } -definitionToSpecification : Definition extra -> Specification extra +definitionToSpecification : Definition a -> Specification a definitionToSpecification def = { modules = def.modules @@ -92,12 +92,12 @@ mapSpecification mapType mapValue spec = Result.map Specification modulesResult -eraseSpecificationExtra : Specification a -> Specification () -eraseSpecificationExtra spec = +eraseSpecificationAttributes : Specification a -> Specification () +eraseSpecificationAttributes spec = spec |> mapSpecification - (Type.mapTypeExtra (\_ -> ()) >> Ok) - (Value.mapValueExtra (\_ -> ())) + (Type.mapTypeAttributes (\_ -> ()) >> Ok) + (Value.mapValueAttributes (\_ -> ())) |> Result.withDefault emptySpecification @@ -138,17 +138,17 @@ mapDefinition mapType mapValue def = modulesResult -eraseDefinitionExtra : Definition a -> Definition () -eraseDefinitionExtra def = +eraseDefinitionAttributes : Definition a -> Definition () +eraseDefinitionAttributes def = def |> mapDefinition - (Type.mapTypeExtra (\_ -> ()) >> Ok) - (Value.mapValueExtra (\_ -> ())) + (Type.mapTypeAttributes (\_ -> ()) >> Ok) + (Value.mapValueAttributes (\_ -> ())) |> Result.withDefault emptyDefinition -encodeSpecification : (extra -> Encode.Value) -> Specification extra -> Encode.Value -encodeSpecification encodeExtra spec = +encodeSpecification : (a -> Encode.Value) -> Specification a -> Encode.Value +encodeSpecification encodeAttributes spec = Encode.object [ ( "modules" , spec.modules @@ -157,15 +157,15 @@ encodeSpecification encodeExtra spec = (\( moduleName, moduleSpec ) -> Encode.object [ ( "name", encodePath moduleName ) - , ( "spec", Module.encodeSpecification encodeExtra moduleSpec ) + , ( "spec", Module.encodeSpecification encodeAttributes moduleSpec ) ] ) ) ] -encodeDefinition : (extra -> Encode.Value) -> Definition extra -> Encode.Value -encodeDefinition encodeExtra def = +encodeDefinition : (a -> Encode.Value) -> Definition a -> Encode.Value +encodeDefinition encodeAttributes def = Encode.object [ ( "dependencies" , def.dependencies @@ -174,7 +174,7 @@ encodeDefinition encodeExtra def = (\( packageName, packageSpec ) -> Encode.object [ ( "name", encodePath packageName ) - , ( "spec", encodeSpecification encodeExtra packageSpec ) + , ( "spec", encodeSpecification encodeAttributes packageSpec ) ] ) ) @@ -185,7 +185,7 @@ encodeDefinition encodeExtra def = (\( moduleName, moduleDef ) -> Encode.object [ ( "name", encodePath moduleName ) - , ( "def", encodeAccessControlled (Module.encodeDefinition encodeExtra) moduleDef ) + , ( "def", encodeAccessControlled (Module.encodeDefinition encodeAttributes) moduleDef ) ] ) ) diff --git a/src/Morphir/IR/SDK/Number.elm b/src/Morphir/IR/SDK/Number.elm index 63379a23a..9e714d4c3 100644 --- a/src/Morphir/IR/SDK/Number.elm +++ b/src/Morphir/IR/SDK/Number.elm @@ -38,6 +38,6 @@ numberClass attributes = Variable attributes [ "number" ] -negate : extra -> extra -> Value extra -> Value extra -negate refExtra valueExtra arg = - Value.Apply valueExtra (Value.Reference refExtra (fromLocalName "negate")) arg +negate : a -> a -> Value a -> Value a +negate refAttributes valueAttributes arg = + Value.Apply valueAttributes (Value.Reference refAttributes (fromLocalName "negate")) arg diff --git a/src/Morphir/IR/Type.elm b/src/Morphir/IR/Type.elm index ff5514180..28e28cee1 100644 --- a/src/Morphir/IR/Type.elm +++ b/src/Morphir/IR/Type.elm @@ -7,7 +7,7 @@ module Morphir.IR.Type exposing , Constructors , fuzzType , encodeType, decodeType, encodeSpecification, encodeDefinition - , Constructor, definitionToSpecification, eraseAttributes, mapDefinition, mapSpecification, mapTypeExtra, rewriteType + , Constructor, definitionToSpecification, eraseAttributes, mapDefinition, mapSpecification, mapTypeAttributes, rewriteType ) {-| This module contains the building blocks of types in the Morphir IR. @@ -213,26 +213,26 @@ mapDefinition f def = |> Result.map (CustomTypeDefinition params) -mapTypeExtra : (a -> b) -> Type a -> Type b -mapTypeExtra f tpe = +mapTypeAttributes : (a -> b) -> Type a -> Type b +mapTypeAttributes f tpe = case tpe of Variable a name -> Variable (f a) name Reference a fQName argTypes -> - Reference (f a) fQName (argTypes |> List.map (mapTypeExtra f)) + Reference (f a) fQName (argTypes |> List.map (mapTypeAttributes f)) Tuple a elemTypes -> - Tuple (f a) (elemTypes |> List.map (mapTypeExtra f)) + Tuple (f a) (elemTypes |> List.map (mapTypeAttributes f)) Record a fields -> - Record (f a) (fields |> List.map (mapFieldType (mapTypeExtra f))) + Record (f a) (fields |> List.map (mapFieldType (mapTypeAttributes f))) ExtensibleRecord a name fields -> - ExtensibleRecord (f a) name (fields |> List.map (mapFieldType (mapTypeExtra f))) + ExtensibleRecord (f a) name (fields |> List.map (mapFieldType (mapTypeAttributes f))) Function a argType returnType -> - Function (f a) (argType |> mapTypeExtra f) (returnType |> mapTypeExtra f) + Function (f a) (argType |> mapTypeAttributes f) (returnType |> mapTypeAttributes f) Unit a -> Unit (f a) @@ -267,27 +267,27 @@ eraseAttributes : Definition a -> Definition () eraseAttributes typeDef = case typeDef of TypeAliasDefinition typeVars tpe -> - TypeAliasDefinition typeVars (mapTypeExtra (\_ -> ()) tpe) + TypeAliasDefinition typeVars (mapTypeAttributes (\_ -> ()) tpe) CustomTypeDefinition typeVars acsCtrlConstructors -> let - eraseExtraCtor : Constructor extra -> Constructor () - eraseExtraCtor ( name, types ) = + eraseCtor : Constructor a -> Constructor () + eraseCtor ( name, types ) = let extraErasedTypes : List ( Name, Type () ) extraErasedTypes = types - |> List.map (\( n, t ) -> ( n, mapTypeExtra (\_ -> ()) t )) + |> List.map (\( n, t ) -> ( n, mapTypeAttributes (\_ -> ()) t )) in ( name, extraErasedTypes ) - emptyExtraCtors : AccessControlled (Constructors extra) -> AccessControlled (Constructors ()) - emptyExtraCtors acsCtrlCtors = + eraseAccessControlledCtors : AccessControlled (Constructors a) -> AccessControlled (Constructors ()) + eraseAccessControlledCtors acsCtrlCtors = AccessControlled.map - (\ctors -> ctors |> List.map eraseExtraCtor) + (\ctors -> ctors |> List.map eraseCtor) acsCtrlCtors in - CustomTypeDefinition typeVars (emptyExtraCtors acsCtrlConstructors) + CustomTypeDefinition typeVars (eraseAccessControlledCtors acsCtrlConstructors) {-| Creates a type variable. @@ -401,31 +401,31 @@ unit attributes = {-| -} -typeAliasDefinition : List Name -> Type extra -> Definition extra +typeAliasDefinition : List Name -> Type a -> Definition a typeAliasDefinition typeParams typeExp = TypeAliasDefinition typeParams typeExp {-| -} -customTypeDefinition : List Name -> AccessControlled (Constructors extra) -> Definition extra +customTypeDefinition : List Name -> AccessControlled (Constructors a) -> Definition a customTypeDefinition typeParams ctors = CustomTypeDefinition typeParams ctors {-| -} -typeAliasSpecification : List Name -> Type extra -> Specification extra +typeAliasSpecification : List Name -> Type a -> Specification a typeAliasSpecification typeParams typeExp = TypeAliasSpecification typeParams typeExp {-| -} -opaqueTypeSpecification : List Name -> Specification extra +opaqueTypeSpecification : List Name -> Specification a opaqueTypeSpecification typeParams = OpaqueTypeSpecification typeParams {-| -} -customTypeSpecification : List Name -> Constructors extra -> Specification extra +customTypeSpecification : List Name -> Constructors a -> Specification a customTypeSpecification typeParams ctors = CustomTypeSpecification typeParams ctors @@ -503,7 +503,7 @@ rewriteType rewriteBranch rewriteLeaf typeToRewrite = == Just ( [ "foo" ], SDK.Basics.intType ) -} -matchField : Pattern Name a -> Pattern (Type extra) b -> Pattern (Field extra) ( a, b ) +matchField : Pattern Name a -> Pattern (Type a) b -> Pattern (Field a) ( a, b ) matchField matchFieldName matchFieldType field = Maybe.map2 Tuple.pair (matchFieldName field.name) @@ -512,7 +512,7 @@ matchField matchFieldName matchFieldType field = {-| Map the name of the field to get a new field. -} -mapFieldName : (Name -> Name) -> Field extra -> Field extra +mapFieldName : (Name -> Name) -> Field a -> Field a mapFieldName f field = Field (f field.name) field.tpe @@ -716,30 +716,30 @@ decodeType decodeAttributes = ) -encodeField : (extra -> Encode.Value) -> Field extra -> Encode.Value -encodeField encodeExtra field = +encodeField : (a -> Encode.Value) -> Field a -> Encode.Value +encodeField encodeAttributes field = Encode.list identity [ encodeName field.name - , encodeType encodeExtra field.tpe + , encodeType encodeAttributes field.tpe ] -decodeField : Decode.Decoder extra -> Decode.Decoder (Field extra) -decodeField decodeExtra = +decodeField : Decode.Decoder a -> Decode.Decoder (Field a) +decodeField decodeAttributes = Decode.map2 Field (Decode.index 0 decodeName) - (Decode.index 1 (decodeType decodeExtra)) + (Decode.index 1 (decodeType decodeAttributes)) {-| -} -encodeSpecification : (extra -> Encode.Value) -> Specification extra -> Encode.Value -encodeSpecification encodeExtra spec = +encodeSpecification : (a -> Encode.Value) -> Specification a -> Encode.Value +encodeSpecification encodeAttributes spec = case spec of TypeAliasSpecification params exp -> Encode.list identity [ Encode.string "TypeAliasSpecification" , Encode.list encodeName params - , encodeType encodeExtra exp + , encodeType encodeAttributes exp ] OpaqueTypeSpecification params -> @@ -752,31 +752,31 @@ encodeSpecification encodeExtra spec = Encode.list identity [ Encode.string "CustomTypeSpecification" , Encode.list encodeName params - , encodeConstructors encodeExtra ctors + , encodeConstructors encodeAttributes ctors ] {-| -} -encodeDefinition : (extra -> Encode.Value) -> Definition extra -> Encode.Value -encodeDefinition encodeExtra def = +encodeDefinition : (a -> Encode.Value) -> Definition a -> Encode.Value +encodeDefinition encodeAttributes def = case def of TypeAliasDefinition params exp -> Encode.list identity [ Encode.string "TypeAliasDefinition" , Encode.list encodeName params - , encodeType encodeExtra exp + , encodeType encodeAttributes exp ] CustomTypeDefinition params ctors -> Encode.list identity [ Encode.string "CustomTypeDefinition" , Encode.list encodeName params - , encodeAccessControlled (encodeConstructors encodeExtra) ctors + , encodeAccessControlled (encodeConstructors encodeAttributes) ctors ] -encodeConstructors : (extra -> Encode.Value) -> Constructors extra -> Encode.Value -encodeConstructors encodeExtra ctors = +encodeConstructors : (a -> Encode.Value) -> Constructors a -> Encode.Value +encodeConstructors encodeAttributes ctors = ctors |> Encode.list (\( ctorName, ctorArgs ) -> @@ -788,7 +788,7 @@ encodeConstructors encodeExtra ctors = (\( argName, argType ) -> Encode.list identity [ encodeName argName - , encodeType encodeExtra argType + , encodeType encodeAttributes argType ] ) ) diff --git a/src/Morphir/IR/Value.elm b/src/Morphir/IR/Value.elm index e74faf2e0..2906f412b 100644 --- a/src/Morphir/IR/Value.elm +++ b/src/Morphir/IR/Value.elm @@ -6,7 +6,7 @@ module Morphir.IR.Value exposing , Specification , Definition(..), typedDefinition, untypedDefinition , encodeValue, encodeSpecification, encodeDefinition - , getDefinitionBody, mapDefinition, mapSpecification, mapValueExtra + , getDefinitionBody, mapDefinition, mapSpecification, mapValueAttributes ) {-| This module contains the building blocks of values in the Morphir IR. @@ -197,8 +197,8 @@ mapDefinition mapType mapValue def = |> Ok -mapValueExtra : (a -> b) -> Value a -> Value b -mapValueExtra f v = +mapValueAttributes : (a -> b) -> Value a -> Value b +mapValueAttributes f v = case v of Literal a value -> Literal (f a) value @@ -207,17 +207,17 @@ mapValueExtra f v = Constructor (f a) fullyQualifiedName Tuple a elements -> - Tuple (f a) (elements |> List.map (mapValueExtra f)) + Tuple (f a) (elements |> List.map (mapValueAttributes f)) List a items -> - List (f a) (items |> List.map (mapValueExtra f)) + List (f a) (items |> List.map (mapValueAttributes f)) Record a fields -> Record (f a) (fields |> List.map (\( fieldName, fieldValue ) -> - ( fieldName, mapValueExtra f fieldValue ) + ( fieldName, mapValueAttributes f fieldValue ) ) ) @@ -228,53 +228,53 @@ mapValueExtra f v = Reference (f a) fullyQualifiedName Field a subjectValue fieldName -> - Field (f a) (mapValueExtra f subjectValue) fieldName + Field (f a) (mapValueAttributes f subjectValue) fieldName FieldFunction a fieldName -> FieldFunction (f a) fieldName Apply a function argument -> - Apply (f a) (mapValueExtra f function) (mapValueExtra f argument) + Apply (f a) (mapValueAttributes f function) (mapValueAttributes f argument) Lambda a argumentPattern body -> - Lambda (f a) (mapPatternExtra f argumentPattern) (mapValueExtra f body) + Lambda (f a) (mapPatternAttributes f argumentPattern) (mapValueAttributes f body) LetDefinition a valueName valueDefinition inValue -> - LetDefinition (f a) valueName (mapDefinitionExtra f valueDefinition) (mapValueExtra f inValue) + LetDefinition (f a) valueName (mapDefinitionAttributes f valueDefinition) (mapValueAttributes f inValue) LetRecursion a valueDefinitions inValue -> LetRecursion (f a) (valueDefinitions |> List.map (\( name, def ) -> - ( name, mapDefinitionExtra f def ) + ( name, mapDefinitionAttributes f def ) ) ) - (mapValueExtra f inValue) + (mapValueAttributes f inValue) Destructure a pattern valueToDestruct inValue -> - Destructure (f a) (mapPatternExtra f pattern) (mapValueExtra f valueToDestruct) (mapValueExtra f inValue) + Destructure (f a) (mapPatternAttributes f pattern) (mapValueAttributes f valueToDestruct) (mapValueAttributes f inValue) IfThenElse a condition thenBranch elseBranch -> - IfThenElse (f a) (mapValueExtra f condition) (mapValueExtra f thenBranch) (mapValueExtra f elseBranch) + IfThenElse (f a) (mapValueAttributes f condition) (mapValueAttributes f thenBranch) (mapValueAttributes f elseBranch) PatternMatch a branchOutOn cases -> PatternMatch (f a) - (mapValueExtra f branchOutOn) + (mapValueAttributes f branchOutOn) (cases |> List.map (\( pattern, body ) -> - ( mapPatternExtra f pattern, mapValueExtra f body ) + ( mapPatternAttributes f pattern, mapValueAttributes f body ) ) ) UpdateRecord a valueToUpdate fieldsToUpdate -> UpdateRecord (f a) - (mapValueExtra f valueToUpdate) + (mapValueAttributes f valueToUpdate) (fieldsToUpdate |> List.map (\( fieldName, fieldValue ) -> - ( fieldName, mapValueExtra f fieldValue ) + ( fieldName, mapValueAttributes f fieldValue ) ) ) @@ -282,42 +282,42 @@ mapValueExtra f v = Unit (f a) -mapPatternExtra : (a -> b) -> Pattern a -> Pattern b -mapPatternExtra f p = +mapPatternAttributes : (a -> b) -> Pattern a -> Pattern b +mapPatternAttributes f p = case p of WildcardPattern a -> WildcardPattern (f a) AsPattern a p2 name -> - AsPattern (f a) (mapPatternExtra f p2) name + AsPattern (f a) (mapPatternAttributes f p2) name TuplePattern a elementPatterns -> - TuplePattern (f a) (elementPatterns |> List.map (mapPatternExtra f)) + TuplePattern (f a) (elementPatterns |> List.map (mapPatternAttributes f)) RecordPattern a fieldNames -> RecordPattern (f a) fieldNames ConstructorPattern a constructorName argumentPatterns -> - ConstructorPattern (f a) constructorName (argumentPatterns |> List.map (mapPatternExtra f)) + ConstructorPattern (f a) constructorName (argumentPatterns |> List.map (mapPatternAttributes f)) EmptyListPattern a -> EmptyListPattern (f a) HeadTailPattern a headPattern tailPattern -> - HeadTailPattern (f a) (mapPatternExtra f headPattern) (mapPatternExtra f tailPattern) + HeadTailPattern (f a) (mapPatternAttributes f headPattern) (mapPatternAttributes f tailPattern) LiteralPattern a value -> LiteralPattern (f a) value -mapDefinitionExtra : (a -> b) -> Definition a -> Definition b -mapDefinitionExtra f d = +mapDefinitionAttributes : (a -> b) -> Definition a -> Definition b +mapDefinitionAttributes f d = case d of TypedDefinition tpe args body -> - TypedDefinition (Type.mapTypeExtra f tpe) args (mapValueExtra f body) + TypedDefinition (Type.mapTypeAttributes f tpe) args (mapValueAttributes f body) UntypedDefinition args body -> - UntypedDefinition args (mapValueExtra f body) + UntypedDefinition args (mapValueAttributes f body) {-| A [literal][lit] represents a fixed value in the IR. We only allow values of basic types: bool, char, string, int, float. @@ -1186,7 +1186,7 @@ encodePattern encodeAttributes pattern = ] -decodePattern : Decode.Decoder extra -> Decode.Decoder (Pattern extra) +decodePattern : Decode.Decoder a -> Decode.Decoder (Pattern a) decodePattern decodeAttributes = let lazyDecodePattern = @@ -1318,8 +1318,8 @@ decodeLiteral = ) -encodeSpecification : (extra -> Encode.Value) -> Specification extra -> Encode.Value -encodeSpecification encodeExtra spec = +encodeSpecification : (a -> Encode.Value) -> Specification a -> Encode.Value +encodeSpecification encodeAttributes spec = Encode.object [ ( "inputs" , spec.inputs @@ -1327,49 +1327,49 @@ encodeSpecification encodeExtra spec = (\( argName, argType ) -> Encode.object [ ( "argName", encodeName argName ) - , ( "argType", encodeType encodeExtra argType ) + , ( "argType", encodeType encodeAttributes argType ) ] ) ) - , ( "output", encodeType encodeExtra spec.output ) + , ( "output", encodeType encodeAttributes spec.output ) ] -encodeDefinition : (extra -> Encode.Value) -> Definition extra -> Encode.Value -encodeDefinition encodeExtra definition = +encodeDefinition : (a -> Encode.Value) -> Definition a -> Encode.Value +encodeDefinition encodeAttributes definition = case definition of TypedDefinition valueType argumentNames body -> Encode.object [ ( "@type", Encode.string "typedDefinition" ) - , ( "valueType", encodeType encodeExtra valueType ) + , ( "valueType", encodeType encodeAttributes valueType ) , ( "argumentNames", argumentNames |> Encode.list encodeName ) - , ( "body", encodeValue encodeExtra body ) + , ( "body", encodeValue encodeAttributes body ) ] UntypedDefinition argumentNames body -> Encode.object [ ( "@type", Encode.string "untypedDefinition" ) , ( "argumentNames", argumentNames |> Encode.list encodeName ) - , ( "body", encodeValue encodeExtra body ) + , ( "body", encodeValue encodeAttributes body ) ] -decodeDefinition : Decode.Decoder extra -> Decode.Decoder (Definition extra) -decodeDefinition decodeExtra = +decodeDefinition : Decode.Decoder a -> Decode.Decoder (Definition a) +decodeDefinition decodeAttributes = Decode.field "@type" Decode.string |> Decode.andThen (\kind -> case kind of "typedDefinition" -> Decode.map3 TypedDefinition - (Decode.field "valueType" <| decodeType decodeExtra) + (Decode.field "valueType" <| decodeType decodeAttributes) (Decode.field "argumentNames" <| Decode.list decodeName) - (Decode.field "body" <| Decode.lazy (\_ -> decodeValue decodeExtra)) + (Decode.field "body" <| Decode.lazy (\_ -> decodeValue decodeAttributes)) "untypedDefinition" -> Decode.map2 UntypedDefinition (Decode.field "argumentNames" <| Decode.list decodeName) - (Decode.field "body" <| Decode.lazy (\_ -> decodeValue decodeExtra)) + (Decode.field "body" <| Decode.lazy (\_ -> decodeValue decodeAttributes)) other -> Decode.fail <| "Unknown definition type: " ++ other From c841efd58fdfcef6948b8e7e3c416616308285ce Mon Sep 17 00:00:00 2001 From: Attila Mihaly Date: Tue, 31 Mar 2020 20:40:58 -0400 Subject: [PATCH 13/42] Change extra arg position. #46, #25, #5 --- cli/src/Morphir/Elm/CLI.elm | 2 +- cli/src/Morphir/Elm/DaprCLI.elm | 2 +- src/Morphir/Elm/Backend/Codec/DecoderGen.elm | 6 ++-- src/Morphir/Elm/Backend/Codec/EncoderGen.elm | 6 ++-- src/Morphir/Elm/Backend/Dapr/StatefulApp.elm | 31 ++++++++------------ src/Morphir/Elm/Frontend.elm | 14 ++------- src/Morphir/IR/AccessControlled.elm | 22 +++++++------- tests/Morphir/Elm/FrontendTests.elm | 4 +-- 8 files changed, 37 insertions(+), 50 deletions(-) diff --git a/cli/src/Morphir/Elm/CLI.elm b/cli/src/Morphir/Elm/CLI.elm index 1e5b4c664..5b1f5755d 100644 --- a/cli/src/Morphir/Elm/CLI.elm +++ b/cli/src/Morphir/Elm/CLI.elm @@ -37,7 +37,7 @@ update msg model = let result = Frontend.packageDefinitionFromSource packageInfo sourceFiles - |> Result.map Package.eraseDefinitionExtra + |> Result.map Package.eraseDefinitionAttributes in ( model, result |> encodeResult (Encode.list encodeError) (Package.encodeDefinition (\_ -> Encode.null)) |> packageDefinitionFromSourceResult ) diff --git a/cli/src/Morphir/Elm/DaprCLI.elm b/cli/src/Morphir/Elm/DaprCLI.elm index 46f63582a..9c2214286 100644 --- a/cli/src/Morphir/Elm/DaprCLI.elm +++ b/cli/src/Morphir/Elm/DaprCLI.elm @@ -62,7 +62,7 @@ update msg model = packageDefResult : Result Frontend.Errors (Package.Definition ()) packageDefResult = Frontend.packageDefinitionFromSource pkgInfo sourceFiles - |> Result.map Package.eraseDefinitionExtra + |> Result.map Package.eraseDefinitionAttributes result = packageDefResult diff --git a/src/Morphir/Elm/Backend/Codec/DecoderGen.elm b/src/Morphir/Elm/Backend/Codec/DecoderGen.elm index 263e88d03..cff1089d2 100644 --- a/src/Morphir/Elm/Backend/Codec/DecoderGen.elm +++ b/src/Morphir/Elm/Backend/Codec/DecoderGen.elm @@ -100,14 +100,14 @@ constructorDecoder isSingle ( ctorName, fields ) = else [ "$type" ] in - Record (fields |> List.map ctorFieldToRecField) () + Record () (fields |> List.map ctorFieldToRecField) |> typeToDecoder ctorName topLevelFieldNames typeToDecoder : Name -> List String -> Type () -> Expression typeToDecoder typeName topLevelFieldNames tpe = case tpe of - Reference fqName typeParams _ -> + Reference _ fqName typeParams -> case fqName of FQName _ _ [ "string" ] -> FunctionOrValue decoderModuleName "string" @@ -149,7 +149,7 @@ typeToDecoder typeName topLevelFieldNames tpe = [] ("decoder" ++ (name |> Name.toTitleCase)) - Record fields _ -> + Record _ fields -> let mapFunc : Expression mapFunc = diff --git a/src/Morphir/Elm/Backend/Codec/EncoderGen.elm b/src/Morphir/Elm/Backend/Codec/EncoderGen.elm index 5627e8fa2..1bbe74dbf 100644 --- a/src/Morphir/Elm/Backend/Codec/EncoderGen.elm +++ b/src/Morphir/Elm/Backend/Codec/EncoderGen.elm @@ -134,7 +134,7 @@ typeDefToEncoder typeName typeDef = typeToEncoder : Bool -> List Name -> Type () -> Expression typeToEncoder fwdNames varName tpe = case tpe of - Reference fqName typeArgs _ -> + Reference _ fqName typeArgs -> case fqName of FQName _ _ [ "int" ] -> elmJsonEncoderApplication @@ -202,7 +202,7 @@ typeToEncoder fwdNames varName tpe = ([ "encode" ] ++ names |> Name.toCamelCase |> FunctionOrValue []) (varPathToExpr varName) - Record fields _ -> + Record _ fields -> let namesToFwd name = if fwdNames then @@ -284,7 +284,7 @@ constructorToRecord ( _, types ) = types |> List.map (\t -> Field (Tuple.first t) (Tuple.second t)) in - record fields () + record () fields customTypeTopExpr : Expression -> Expression diff --git a/src/Morphir/Elm/Backend/Dapr/StatefulApp.elm b/src/Morphir/Elm/Backend/Dapr/StatefulApp.elm index f128c257c..3003929f7 100644 --- a/src/Morphir/Elm/Backend/Dapr/StatefulApp.elm +++ b/src/Morphir/Elm/Backend/Dapr/StatefulApp.elm @@ -27,7 +27,7 @@ import Morphir.IR.Type as Type exposing (Definition(..), Field, Type(..), eraseA gen : Path -> Name -> Type () -> List ( Name, AccessControlled (Type.Definition ()) ) -> Maybe File gen fullAppPath appName appType otherTypeDefs = case appType of - Reference (FQName [ [ "morphir" ], [ "s", "d", "k" ] ] [ [ "stateful", "app" ] ] [ "stateful", "app" ]) (keyType :: cmdType :: stateType :: eventType :: []) _ -> + Reference _ (FQName [ [ "morphir" ], [ "s", "d", "k" ] ] [ [ "stateful", "app" ] ] [ "stateful", "app" ]) (keyType :: cmdType :: stateType :: eventType :: []) -> let moduleDef : Module moduleDef = @@ -553,22 +553,22 @@ subscriptions = morphirToElmTypeDef : Type () -> TypeAnnotation morphirToElmTypeDef tpe = case tpe of - Variable name _ -> + Variable _ name -> name |> Name.toCamelCase |> GenericType - Reference (FQName _ _ [ "bool" ]) [] _ -> + Reference _ (FQName _ _ [ "bool" ]) [] -> Typed (( [], "Bool" ) |> Utils.emptyRangeNode) [] - Reference (FQName _ _ [ "int" ]) [] _ -> + Reference _ (FQName _ _ [ "int" ]) [] -> Typed (( [], "Int" ) |> Utils.emptyRangeNode) [] - Reference (FQName _ _ [ "float" ]) [] _ -> + Reference _ (FQName _ _ [ "float" ]) [] -> Typed (( [], "Float" ) |> Utils.emptyRangeNode) [] - Reference (FQName _ _ [ "string" ]) [] _ -> + Reference _ (FQName _ _ [ "string" ]) [] -> Typed (( [], "String" ) |> Utils.emptyRangeNode) [] - Reference (FQName pkgPath modPath tpeName) types _ -> + Reference _ (FQName pkgPath modPath tpeName) types -> let moduleName : ModuleName moduleName = @@ -588,7 +588,7 @@ morphirToElmTypeDef tpe = (( moduleName, typeName ) |> Utils.emptyRangeNode) innerTypes - Type.Record fields _ -> + Type.Record _ fields -> let morphirToElmField : Field () -> ( Node String, Node TypeAnnotation ) morphirToElmField field = @@ -664,26 +664,21 @@ emptyFuncImpl = test : Type () test = - Reference + Reference () (FQName [ [ "morphir" ] ] [ [ "s", "d", "k" ], [ "stateful", "app" ] ] [ "stateful", "app" ]) - [ Reference + [ Reference () (FQName [] [ [ "morphir" ], [ "sdk" ] ] [ "Int" ]) [] - () - , Reference + , Reference () (FQName [] [ [ "morphir" ], [ "sdk" ] ] [ "Int" ]) [] - () - , Reference + , Reference () (FQName [] [ [ "morphir" ], [ "sdk" ] ] [ "Int" ]) [] - () - , Reference + , Reference () (FQName [] [ [ "morphir" ], [ "sdk" ] ] [ "Int" ]) [] - () ] - () testRun : Maybe String diff --git a/src/Morphir/Elm/Frontend.elm b/src/Morphir/Elm/Frontend.elm index 974c0571c..1922f5a59 100644 --- a/src/Morphir/Elm/Frontend.elm +++ b/src/Morphir/Elm/Frontend.elm @@ -138,14 +138,10 @@ encodeError : Error -> Encode.Value encodeError error = case error of ParseError _ _ -> - Encode.object - [ ( "$type", Encode.string "ParseError" ) - ] + JsonExtra.encodeConstructor "ParseError" [] CyclicModules _ -> - Encode.object - [ ( "$type", Encode.string "CyclicModules" ) - ] + JsonExtra.encodeConstructor "CyclicModules" [] ResolveError sourceLocation resolveError -> JsonExtra.encodeConstructor "ResolveError" @@ -734,11 +730,7 @@ mapExpression sourceFile (Node range exp) = |> Result.map (Value.Tuple sourceLocation) other -> - Ok (Value.Literal sourceLocation (Value.StringLiteral (Debug.toString other))) - - - ---Err [ NotSupported sourceLocation "unknown" ] + Err [ NotSupported sourceLocation "TODO" ] mapPattern : SourceFile -> Node Pattern -> Result Errors (Value.Pattern SourceLocation) diff --git a/src/Morphir/IR/AccessControlled.elm b/src/Morphir/IR/AccessControlled.elm index d46b1efc8..69987a591 100644 --- a/src/Morphir/IR/AccessControlled.elm +++ b/src/Morphir/IR/AccessControlled.elm @@ -106,15 +106,15 @@ encodeAccessControlled : (a -> Encode.Value) -> AccessControlled a -> Encode.Val encodeAccessControlled encodeValue ac = case ac.access of Public -> - Encode.object - [ ( "$type", Encode.string "public" ) - , ( "value", encodeValue ac.value ) + Encode.list identity + [ Encode.string "Public" + , encodeValue ac.value ] Private -> - Encode.object - [ ( "$type", Encode.string "private" ) - , ( "value", encodeValue ac.value ) + Encode.list identity + [ Encode.string "Private" + , encodeValue ac.value ] @@ -122,17 +122,17 @@ encodeAccessControlled encodeValue ac = -} decodeAccessControlled : Decode.Decoder a -> Decode.Decoder (AccessControlled a) decodeAccessControlled decodeValue = - Decode.field "$type" Decode.string + Decode.index 0 Decode.string |> Decode.andThen (\tag -> case tag of - "public" -> + "Public" -> Decode.map (AccessControlled Public) - (Decode.field "value" decodeValue) + (Decode.index 1 decodeValue) - "private" -> + "Private" -> Decode.map (AccessControlled Private) - (Decode.field "value" decodeValue) + (Decode.index 1 decodeValue) other -> Decode.fail <| "Unknown access controlled type: " ++ other diff --git a/tests/Morphir/Elm/FrontendTests.elm b/tests/Morphir/Elm/FrontendTests.elm index 8fbe99fd3..e818f1cf9 100644 --- a/tests/Morphir/Elm/FrontendTests.elm +++ b/tests/Morphir/Elm/FrontendTests.elm @@ -163,7 +163,7 @@ frontendTest = test "first" <| \_ -> Frontend.packageDefinitionFromSource packageInfo [ sourceA, sourceB, sourceC ] - |> Result.map Package.eraseDefinitionExtra + |> Result.map Package.eraseDefinitionAttributes |> Expect.equal (Ok expected) @@ -191,7 +191,7 @@ valueTests = test valueSource <| \_ -> Frontend.packageDefinitionFromSource packageInfo [ moduleSource valueSource ] - |> Result.map Package.eraseDefinitionExtra + |> Result.map Package.eraseDefinitionAttributes |> Result.mapError (\error -> "Error while reading model") |> Result.andThen (\packageDef -> From 9ce6d29495768cfafd2790a28cb02b05dd943942 Mon Sep 17 00:00:00 2001 From: Attila Mihaly Date: Tue, 31 Mar 2020 22:02:08 -0400 Subject: [PATCH 14/42] Added more coverage. #46, #25, #5 --- src/Morphir/Elm/Frontend.elm | 79 +++++++++++++++++++++++++++-- tests/Morphir/Elm/FrontendTests.elm | 32 +++++++++++- 2 files changed, 105 insertions(+), 6 deletions(-) diff --git a/src/Morphir/Elm/Frontend.elm b/src/Morphir/Elm/Frontend.elm index 1922f5a59..69d5138f6 100644 --- a/src/Morphir/Elm/Frontend.elm +++ b/src/Morphir/Elm/Frontend.elm @@ -692,6 +692,9 @@ mapExpression sourceFile (Node range exp) = |> Result.mapError List.concat |> Result.andThen (List.reverse >> toApply) + Expression.OperatorApplication op infixDirection leftNode rightNode -> + Err [ NotSupported sourceLocation "TODO: OperatorApplication" ] + Expression.FunctionOrValue moduleName valueName -> case ( moduleName, valueName ) of ( [], "True" ) -> @@ -703,19 +706,31 @@ mapExpression sourceFile (Node range exp) = _ -> Ok (Value.Reference sourceLocation (fQName [] (moduleName |> List.map Name.fromString) (valueName |> Name.fromString))) + Expression.IfBlock condNode thenNode elseNode -> + Result.map3 (Value.IfThenElse sourceLocation) + (mapExpression sourceFile condNode) + (mapExpression sourceFile thenNode) + (mapExpression sourceFile elseNode) + + Expression.PrefixOperator op -> + Err [ NotSupported sourceLocation "TODO: PrefixOperator" ] + + Expression.Operator op -> + Err [ NotSupported sourceLocation "TODO: Operator" ] + Expression.Integer value -> Ok (Value.Literal sourceLocation (Value.IntLiteral value)) Expression.Hex value -> Ok (Value.Literal sourceLocation (Value.IntLiteral value)) + Expression.Floatable value -> + Ok (Value.Literal sourceLocation (Value.FloatLiteral value)) + Expression.Negation arg -> mapExpression sourceFile arg |> Result.map (Number.negate sourceLocation sourceLocation) - Expression.Floatable value -> - Ok (Value.Literal sourceLocation (Value.FloatLiteral value)) - Expression.Literal value -> Ok (Value.Literal sourceLocation (Value.StringLiteral value)) @@ -729,8 +744,62 @@ mapExpression sourceFile (Node range exp) = |> Result.mapError List.concat |> Result.map (Value.Tuple sourceLocation) - other -> - Err [ NotSupported sourceLocation "TODO" ] + Expression.ParenthesizedExpression expNode -> + mapExpression sourceFile expNode + + Expression.LetExpression letBlock -> + Err [ NotSupported sourceLocation "TODO: LetExpression" ] + + Expression.CaseExpression caseBlock -> + Err [ NotSupported sourceLocation "TODO: CaseExpression" ] + + Expression.LambdaExpression lambda -> + Err [ NotSupported sourceLocation "TODO: LambdaExpression" ] + + Expression.RecordExpr fieldNodes -> + fieldNodes + |> List.map Node.value + |> List.map + (\( Node _ fieldName, fieldValue ) -> + mapExpression sourceFile fieldValue + |> Result.map (Tuple.pair (fieldName |> Name.fromString)) + ) + |> ResultList.toResult + |> Result.mapError List.concat + |> Result.map (Value.Record sourceLocation) + + Expression.ListExpr itemNodes -> + itemNodes + |> List.map (mapExpression sourceFile) + |> ResultList.toResult + |> Result.mapError List.concat + |> Result.map (Value.List sourceLocation) + + Expression.RecordAccess targetNode fieldNameNode -> + mapExpression sourceFile targetNode + |> Result.map + (\subjectValue -> + Value.Field sourceLocation subjectValue (fieldNameNode |> Node.value |> Name.fromString) + ) + + Expression.RecordAccessFunction fieldName -> + Ok (Value.FieldFunction sourceLocation (fieldName |> Name.fromString)) + + Expression.RecordUpdateExpression targetVarNameNode fieldNodes -> + fieldNodes + |> List.map Node.value + |> List.map + (\( Node _ fieldName, fieldValue ) -> + mapExpression sourceFile fieldValue + |> Result.map (Tuple.pair (fieldName |> Name.fromString)) + ) + |> ResultList.toResult + |> Result.mapError List.concat + |> Result.map + (Value.UpdateRecord sourceLocation (targetVarNameNode |> Node.value |> Name.fromString |> Value.Variable sourceLocation)) + + Expression.GLSLExpression _ -> + Err [ NotSupported sourceLocation "GLSLExpression" ] mapPattern : SourceFile -> Node Pattern -> Result Errors (Value.Pattern SourceLocation) diff --git a/tests/Morphir/Elm/FrontendTests.elm b/tests/Morphir/Elm/FrontendTests.elm index e818f1cf9..22cb2b70b 100644 --- a/tests/Morphir/Elm/FrontendTests.elm +++ b/tests/Morphir/Elm/FrontendTests.elm @@ -192,7 +192,29 @@ valueTests = \_ -> Frontend.packageDefinitionFromSource packageInfo [ moduleSource valueSource ] |> Result.map Package.eraseDefinitionAttributes - |> Result.mapError (\error -> "Error while reading model") + |> Result.mapError + (\errors -> + errors + |> List.map + (\error -> + case error of + Frontend.ParseError _ _ -> + "Parse Error" + + Frontend.CyclicModules _ -> + "Cyclic Modules" + + Frontend.ResolveError _ _ -> + "Resolve Error" + + Frontend.EmptyApply _ -> + "Empty Apply" + + Frontend.NotSupported _ expType -> + "Not Supported: " ++ expType + ) + |> String.join ", " + ) |> Result.andThen (\packageDef -> packageDef.modules @@ -227,6 +249,14 @@ valueTests = , checkIR "foo bar" <| Apply () (ref "foo") (ref "bar") , checkIR "foo bar baz" <| Apply () (Apply () (ref "foo") (ref "bar")) (ref "baz") , checkIR "-1" <| Number.negate () () (Literal () (IntLiteral 1)) + , checkIR "if foo then bar else baz" <| IfThenElse () (ref "foo") (ref "bar") (ref "baz") + , checkIR "( foo, bar, baz )" <| Tuple () [ ref "foo", ref "bar", ref "baz" ] + , checkIR "( foo )" <| ref "foo" + , checkIR "[ foo, bar, baz ]" <| List () [ ref "foo", ref "bar", ref "baz" ] + , checkIR "{ foo = foo, bar = bar, baz = baz }" <| Record () [ ( [ "foo" ], ref "foo" ), ( [ "bar" ], ref "bar" ), ( [ "baz" ], ref "baz" ) ] + , checkIR "foo.bar" <| Field () (ref "foo") [ "bar" ] + , checkIR ".bar" <| FieldFunction () [ "bar" ] + , checkIR "{ a | foo = foo, bar = bar }" <| UpdateRecord () (Variable () [ "a" ]) [ ( [ "foo" ], ref "foo" ), ( [ "bar" ], ref "bar" ) ] ] From 910d4faef72403e2edf71875914b3807ffd1646d Mon Sep 17 00:00:00 2001 From: Attila Mihaly Date: Thu, 2 Apr 2020 14:30:42 -0400 Subject: [PATCH 15/42] Changes suggested in the PR. #46, #25, #5 --- src/Morphir/Elm/Frontend.elm | 2 +- src/Morphir/Elm/Frontend/Resolve.elm | 5 ++- src/Morphir/IR/SDK.elm | 4 +-- src/Morphir/IR/SDK/Maybe.elm | 4 +-- src/Morphir/IR/SDK/Number.elm | 6 ++-- src/Morphir/IR/SDK/Result.elm | 4 +-- src/Morphir/IR/Type.elm | 47 ++++++++++++++-------------- tests/Morphir/Elm/FrontendTests.elm | 7 ++--- 8 files changed, 40 insertions(+), 39 deletions(-) diff --git a/src/Morphir/Elm/Frontend.elm b/src/Morphir/Elm/Frontend.elm index 69d5138f6..dee514d51 100644 --- a/src/Morphir/Elm/Frontend.elm +++ b/src/Morphir/Elm/Frontend.elm @@ -499,7 +499,7 @@ mapDeclarationsToType sourceFile expose decls = ctorArgsResult |> Result.map (\ctorArgs -> - ( ctorName, ctorArgs ) + Type.Constructor ctorName ctorArgs ) ) |> ResultList.toResult diff --git a/src/Morphir/Elm/Frontend/Resolve.elm b/src/Morphir/Elm/Frontend/Resolve.elm index 2ac4ed47d..c70850925 100644 --- a/src/Morphir/Elm/Frontend/Resolve.elm +++ b/src/Morphir/Elm/Frontend/Resolve.elm @@ -167,7 +167,10 @@ createPackageResolver dependencies currentPackagePath currentPackageModules = case typeDecl of Type.CustomTypeSpecification _ ctors -> ctors - |> List.map (Tuple.first >> Name.toTitleCase) + |> List.map + (\(Type.Constructor ctorName _) -> + ctorName |> Name.toTitleCase + ) _ -> [] diff --git a/src/Morphir/IR/SDK.elm b/src/Morphir/IR/SDK.elm index ea3d0addb..bccea182c 100644 --- a/src/Morphir/IR/SDK.elm +++ b/src/Morphir/IR/SDK.elm @@ -2,7 +2,7 @@ module Morphir.IR.SDK exposing (..) import Dict import Morphir.IR.Package as Package -import Morphir.IR.Path exposing (Path) +import Morphir.IR.Path as Path exposing (Path) import Morphir.IR.SDK.Bool as Bool import Morphir.IR.SDK.Char as Char import Morphir.IR.SDK.Float as Float @@ -15,7 +15,7 @@ import Morphir.IR.SDK.String as String packageName : Path packageName = - [ [ "morphir" ], [ "s", "d", "k" ] ] + Path.fromString "Morphir.SDK" packageSpec : Package.Specification () diff --git a/src/Morphir/IR/SDK/Maybe.elm b/src/Morphir/IR/SDK/Maybe.elm index 73f3b86c3..3b825b0d5 100644 --- a/src/Morphir/IR/SDK/Maybe.elm +++ b/src/Morphir/IR/SDK/Maybe.elm @@ -21,8 +21,8 @@ moduleSpec = Dict.fromList [ ( [ "maybe" ] , CustomTypeSpecification [ [ "a" ] ] - [ ( [ "just" ], [ ( [ "value" ], Type.Variable () [ "a" ] ) ] ) - , ( [ "nothing" ], [] ) + [ Type.Constructor [ "just" ] [ ( [ "value" ], Type.Variable () [ "a" ] ) ] + , Type.Constructor [ "nothing" ] [] ] ) ] diff --git a/src/Morphir/IR/SDK/Number.elm b/src/Morphir/IR/SDK/Number.elm index 9e714d4c3..3efb55c00 100644 --- a/src/Morphir/IR/SDK/Number.elm +++ b/src/Morphir/IR/SDK/Number.elm @@ -1,10 +1,10 @@ -module Morphir.IR.SDK.Number exposing (..) +module Morphir.IR.SDK.Number exposing (negate) import Dict import Morphir.IR.FQName as FQName exposing (FQName) import Morphir.IR.Module as Module import Morphir.IR.Name as Name -import Morphir.IR.Path exposing (Path) +import Morphir.IR.Path as Path exposing (Path) import Morphir.IR.QName as QName import Morphir.IR.SDK.Common exposing (packageName) import Morphir.IR.Type exposing (Specification(..), Type(..)) @@ -13,7 +13,7 @@ import Morphir.IR.Value as Value exposing (Value) moduleName : Path moduleName = - [ [ "number" ] ] + Path.fromString "Number" moduleSpec : Module.Specification () diff --git a/src/Morphir/IR/SDK/Result.elm b/src/Morphir/IR/SDK/Result.elm index f712af925..ef68d5295 100644 --- a/src/Morphir/IR/SDK/Result.elm +++ b/src/Morphir/IR/SDK/Result.elm @@ -21,8 +21,8 @@ moduleSpec = Dict.fromList [ ( [ "result" ] , CustomTypeSpecification [ [ "e" ], [ "a" ] ] - [ ( [ "ok" ], [ ( [ "value" ], Type.Variable () [ "a" ] ) ] ) - , ( [ "err" ], [ ( [ "error" ], Type.Variable () [ "e" ] ) ] ) + [ Type.Constructor [ "ok" ] [ ( [ "value" ], Type.Variable () [ "a" ] ) ] + , Type.Constructor [ "err" ] [ ( [ "error" ], Type.Variable () [ "e" ] ) ] ] ) ] diff --git a/src/Morphir/IR/Type.elm b/src/Morphir/IR/Type.elm index 28e28cee1..2a76398fb 100644 --- a/src/Morphir/IR/Type.elm +++ b/src/Morphir/IR/Type.elm @@ -4,10 +4,10 @@ module Morphir.IR.Type exposing , Field, matchField, mapFieldName, mapFieldType , Specification(..), typeAliasSpecification, opaqueTypeSpecification, customTypeSpecification , Definition(..), typeAliasDefinition, customTypeDefinition - , Constructors + , Constructors, Constructor(..) , fuzzType , encodeType, decodeType, encodeSpecification, encodeDefinition - , Constructor, definitionToSpecification, eraseAttributes, mapDefinition, mapSpecification, mapTypeAttributes, rewriteType + , definitionToSpecification, eraseAttributes, mapDefinition, mapSpecification, mapTypeAttributes, rewriteType ) {-| This module contains the building blocks of types in the Morphir IR. @@ -45,7 +45,7 @@ module Morphir.IR.Type exposing # Constructors -@docs Constructors +@docs Constructors, Constructor # Property Testing @@ -127,8 +127,8 @@ type alias Constructors a = {-| -} -type alias Constructor a = - ( Name, List ( Name, Type a ) ) +type Constructor a + = Constructor Name (List ( Name, Type a )) definitionToSpecification : Definition a -> Specification a @@ -164,7 +164,7 @@ mapSpecification f spec = ctorsResult = constructors |> List.map - (\( ctorName, ctorArgs ) -> + (\(Constructor ctorName ctorArgs) -> ctorArgs |> List.map (\( argName, argType ) -> @@ -172,7 +172,7 @@ mapSpecification f spec = |> Result.map (Tuple.pair argName) ) |> ResultList.toResult - |> Result.map (Tuple.pair ctorName) + |> Result.map (Constructor ctorName) ) |> ResultList.toResult |> Result.mapError List.concat @@ -195,7 +195,7 @@ mapDefinition f def = ctorsResult = constructors.value |> List.map - (\( ctorName, ctorArgs ) -> + (\(Constructor ctorName ctorArgs) -> ctorArgs |> List.map (\( argName, argType ) -> @@ -203,7 +203,7 @@ mapDefinition f def = |> Result.map (Tuple.pair argName) ) |> ResultList.toResult - |> Result.map (Tuple.pair ctorName) + |> Result.map (Constructor ctorName) ) |> ResultList.toResult |> Result.map (AccessControlled constructors.access) @@ -272,14 +272,14 @@ eraseAttributes typeDef = CustomTypeDefinition typeVars acsCtrlConstructors -> let eraseCtor : Constructor a -> Constructor () - eraseCtor ( name, types ) = + eraseCtor (Constructor name types) = let extraErasedTypes : List ( Name, Type () ) extraErasedTypes = types |> List.map (\( n, t ) -> ( n, mapTypeAttributes (\_ -> ()) t )) in - ( name, extraErasedTypes ) + Constructor name extraErasedTypes eraseAccessControlledCtors : AccessControlled (Constructors a) -> AccessControlled (Constructors ()) eraseAccessControlledCtors acsCtrlCtors = @@ -779,18 +779,17 @@ encodeConstructors : (a -> Encode.Value) -> Constructors a -> Encode.Value encodeConstructors encodeAttributes ctors = ctors |> Encode.list - (\( ctorName, ctorArgs ) -> - Encode.object - [ ( "name", encodeName ctorName ) - , ( "args" - , ctorArgs - |> Encode.list - (\( argName, argType ) -> - Encode.list identity - [ encodeName argName - , encodeType encodeAttributes argType - ] - ) - ) + (\(Constructor ctorName ctorArgs) -> + Encode.list identity + [ Encode.string "Constructor" + , encodeName ctorName + , ctorArgs + |> Encode.list + (\( argName, argType ) -> + Encode.list identity + [ encodeName argName + , encodeType encodeAttributes argType + ] + ) ] ) diff --git a/tests/Morphir/Elm/FrontendTests.elm b/tests/Morphir/Elm/FrontendTests.elm index 22cb2b70b..94fc88848 100644 --- a/tests/Morphir/Elm/FrontendTests.elm +++ b/tests/Morphir/Elm/FrontendTests.elm @@ -105,10 +105,9 @@ frontendTest = , public (Type.CustomTypeDefinition [] (public - [ ( [ "foo" ] - , [ ( [ "arg", "1" ], Type.Reference () (fQName packageName [ [ "b" ] ] [ "bee" ]) [] ) + [ Type.Constructor [ "foo" ] + [ ( [ "arg", "1" ], Type.Reference () (fQName packageName [ [ "b" ] ] [ "bee" ]) [] ) ] - ) ] ) ) @@ -149,7 +148,7 @@ frontendTest = [ ( [ "bee" ] , public (Type.CustomTypeDefinition [] - (public [ ( [ "bee" ], [] ) ]) + (public [ Type.Constructor [ "bee" ] [] ]) ) ) ] From c6282841dc4ef58d5fef349557237cb3db87794d Mon Sep 17 00:00:00 2001 From: Attila Mihaly Date: Fri, 3 Apr 2020 15:26:15 -0400 Subject: [PATCH 16/42] Use more explicit names. --- src/Morphir/IR/Module.elm | 7 ++++++- src/Morphir/IR/Package.elm | 14 +++++++++----- src/Morphir/IR/SDK.elm | 4 ++-- src/Morphir/IR/SDK/Bool.elm | 24 +++++++----------------- src/Morphir/IR/SDK/Char.elm | 24 +++++++----------------- src/Morphir/IR/SDK/Common.elm | 19 ++++++++++++++++--- src/Morphir/IR/SDK/Float.elm | 24 +++++++----------------- src/Morphir/IR/SDK/Int.elm | 24 +++++++----------------- src/Morphir/IR/SDK/List.elm | 26 ++++++++------------------ src/Morphir/IR/SDK/Maybe.elm | 30 ++++++++++-------------------- src/Morphir/IR/SDK/Number.elm | 19 ++++--------------- src/Morphir/IR/SDK/Result.elm | 30 ++++++++++-------------------- src/Morphir/IR/SDK/String.elm | 24 +++++++----------------- src/Morphir/IR/Value.elm | 10 ++++++++++ 14 files changed, 110 insertions(+), 169 deletions(-) diff --git a/src/Morphir/IR/Module.elm b/src/Morphir/IR/Module.elm index 0bb2ba94d..c3da58e71 100644 --- a/src/Morphir/IR/Module.elm +++ b/src/Morphir/IR/Module.elm @@ -1,7 +1,7 @@ module Morphir.IR.Module exposing ( Specification, Definition , encodeSpecification, encodeDefinition - , definitionToSpecification, eraseSpecificationAttributes, mapDefinition, mapSpecification + , ModulePath, definitionToSpecification, eraseSpecificationAttributes, mapDefinition, mapSpecification ) {-| Modules are groups of types and values that belong together. @@ -17,11 +17,16 @@ import Json.Decode as Decode import Json.Encode as Encode import Morphir.IR.AccessControlled as AccessControlled exposing (AccessControlled, encodeAccessControlled, withPublicAccess) import Morphir.IR.Name exposing (Name, encodeName) +import Morphir.IR.Path exposing (Path) import Morphir.IR.Type as Type exposing (Type) import Morphir.IR.Value as Value exposing (Value) import Morphir.ResultList as ResultList +type alias ModulePath = + Path + + {-| Type that represents a module specification. -} type alias Specification a = diff --git a/src/Morphir/IR/Package.elm b/src/Morphir/IR/Package.elm index 37f84e2a0..bd9702dcd 100644 --- a/src/Morphir/IR/Package.elm +++ b/src/Morphir/IR/Package.elm @@ -1,7 +1,7 @@ module Morphir.IR.Package exposing ( Specification , Definition, emptyDefinition - , definitionToSpecification, encodeDefinition, eraseDefinitionAttributes, eraseSpecificationAttributes + , PackagePath, definitionToSpecification, encodeDefinition, eraseDefinitionAttributes, eraseSpecificationAttributes ) {-| Tools to work with packages. @@ -16,7 +16,7 @@ import Dict exposing (Dict) import Json.Decode as Decode import Json.Encode as Encode import Morphir.IR.AccessControlled as AccessControlled exposing (AccessControlled, encodeAccessControlled, withPublicAccess) -import Morphir.IR.Module as Module +import Morphir.IR.Module as Module exposing (ModulePath) import Morphir.IR.Path exposing (Path, encodePath) import Morphir.IR.QName exposing (QName, encodeQName) import Morphir.IR.Type as Type exposing (Type) @@ -24,10 +24,14 @@ import Morphir.IR.Value as Value exposing (Value) import Morphir.ResultList as ResultList +type alias PackagePath = + Path + + {-| Type that represents a package specification. -} type alias Specification a = - { modules : Dict Path (Module.Specification a) + { modules : Dict ModulePath (Module.Specification a) } @@ -40,8 +44,8 @@ emptySpecification = {-| Type that represents a package definition. -} type alias Definition a = - { dependencies : Dict Path (Specification a) - , modules : Dict Path (AccessControlled (Module.Definition a)) + { dependencies : Dict PackagePath (Specification a) + , modules : Dict ModulePath (AccessControlled (Module.Definition a)) } diff --git a/src/Morphir/IR/SDK.elm b/src/Morphir/IR/SDK.elm index bccea182c..a99a50ee1 100644 --- a/src/Morphir/IR/SDK.elm +++ b/src/Morphir/IR/SDK.elm @@ -1,7 +1,7 @@ module Morphir.IR.SDK exposing (..) import Dict -import Morphir.IR.Package as Package +import Morphir.IR.Package as Package exposing (PackagePath) import Morphir.IR.Path as Path exposing (Path) import Morphir.IR.SDK.Bool as Bool import Morphir.IR.SDK.Char as Char @@ -13,7 +13,7 @@ import Morphir.IR.SDK.Result as Result import Morphir.IR.SDK.String as String -packageName : Path +packageName : PackagePath packageName = Path.fromString "Morphir.SDK" diff --git a/src/Morphir/IR/SDK/Bool.elm b/src/Morphir/IR/SDK/Bool.elm index 31f91928e..39628c398 100644 --- a/src/Morphir/IR/SDK/Bool.elm +++ b/src/Morphir/IR/SDK/Bool.elm @@ -1,39 +1,29 @@ module Morphir.IR.SDK.Bool exposing (..) import Dict -import Morphir.IR.FQName as FQName exposing (FQName) -import Morphir.IR.Module as Module +import Morphir.IR.Module as Module exposing (ModulePath) import Morphir.IR.Name as Name -import Morphir.IR.Path exposing (Path) -import Morphir.IR.QName as QName -import Morphir.IR.SDK.Common exposing (packageName) +import Morphir.IR.Path as Path +import Morphir.IR.SDK.Common exposing (toFQName) import Morphir.IR.Type exposing (Specification(..), Type(..)) -moduleName : Path +moduleName : ModulePath moduleName = - [ [ "bool" ] ] + Path.fromString "Bool" moduleSpec : Module.Specification () moduleSpec = { types = Dict.fromList - [ ( [ "bool" ], OpaqueTypeSpecification [] ) + [ ( Name.fromString "Bool", OpaqueTypeSpecification [] ) ] , values = Dict.empty } -fromLocalName : String -> FQName -fromLocalName name = - name - |> Name.fromString - |> QName.fromName moduleName - |> FQName.fromQName packageName - - boolType : a -> Type a boolType attributes = - Reference attributes (fromLocalName "bool") [] + Reference attributes (toFQName moduleName "Bool") [] diff --git a/src/Morphir/IR/SDK/Char.elm b/src/Morphir/IR/SDK/Char.elm index 69f91e9e5..beb3a25d4 100644 --- a/src/Morphir/IR/SDK/Char.elm +++ b/src/Morphir/IR/SDK/Char.elm @@ -1,39 +1,29 @@ module Morphir.IR.SDK.Char exposing (..) import Dict -import Morphir.IR.FQName as FQName exposing (FQName) -import Morphir.IR.Module as Module +import Morphir.IR.Module as Module exposing (ModulePath) import Morphir.IR.Name as Name -import Morphir.IR.Path exposing (Path) -import Morphir.IR.QName as QName -import Morphir.IR.SDK.Common exposing (packageName) +import Morphir.IR.Path as Path +import Morphir.IR.SDK.Common exposing (toFQName) import Morphir.IR.Type exposing (Specification(..), Type(..)) -moduleName : Path +moduleName : ModulePath moduleName = - [ [ "char" ] ] + Path.fromString "Char" moduleSpec : Module.Specification () moduleSpec = { types = Dict.fromList - [ ( [ "char" ], OpaqueTypeSpecification [] ) + [ ( Name.fromString "Char", OpaqueTypeSpecification [] ) ] , values = Dict.empty } -fromLocalName : String -> FQName -fromLocalName name = - name - |> Name.fromString - |> QName.fromName moduleName - |> FQName.fromQName packageName - - charType : a -> Type a charType attributes = - Reference attributes (fromLocalName "char") [] + Reference attributes (toFQName moduleName "Char") [] diff --git a/src/Morphir/IR/SDK/Common.elm b/src/Morphir/IR/SDK/Common.elm index 0ee209be1..70b07eabd 100644 --- a/src/Morphir/IR/SDK/Common.elm +++ b/src/Morphir/IR/SDK/Common.elm @@ -1,8 +1,21 @@ module Morphir.IR.SDK.Common exposing (..) -import Morphir.IR.Path exposing (Path) +import Morphir.IR.FQName as FQName exposing (FQName) +import Morphir.IR.Module exposing (ModulePath) +import Morphir.IR.Name as Name +import Morphir.IR.Package exposing (PackagePath) +import Morphir.IR.Path as Path +import Morphir.IR.QName as QName -packageName : Path +packageName : PackagePath packageName = - [ [ "morphir" ], [ "s", "d", "k" ] ] + Path.fromString "Morphir.SDK" + + +toFQName : ModulePath -> String -> FQName +toFQName modulePath localName = + localName + |> Name.fromString + |> QName.fromName modulePath + |> FQName.fromQName packageName diff --git a/src/Morphir/IR/SDK/Float.elm b/src/Morphir/IR/SDK/Float.elm index 270654531..68c86d876 100644 --- a/src/Morphir/IR/SDK/Float.elm +++ b/src/Morphir/IR/SDK/Float.elm @@ -1,39 +1,29 @@ module Morphir.IR.SDK.Float exposing (..) import Dict -import Morphir.IR.FQName as FQName exposing (FQName) -import Morphir.IR.Module as Module +import Morphir.IR.Module as Module exposing (ModulePath) import Morphir.IR.Name as Name -import Morphir.IR.Path exposing (Path) -import Morphir.IR.QName as QName -import Morphir.IR.SDK.Common exposing (packageName) +import Morphir.IR.Path as Path +import Morphir.IR.SDK.Common exposing (toFQName) import Morphir.IR.Type exposing (Specification(..), Type(..)) -moduleName : Path +moduleName : ModulePath moduleName = - [ [ "float" ] ] + Path.fromString "Float" moduleSpec : Module.Specification () moduleSpec = { types = Dict.fromList - [ ( [ "float" ], OpaqueTypeSpecification [] ) + [ ( Name.fromString "Float", OpaqueTypeSpecification [] ) ] , values = Dict.empty } -fromLocalName : String -> FQName -fromLocalName name = - name - |> Name.fromString - |> QName.fromName moduleName - |> FQName.fromQName packageName - - floatType : a -> Type a floatType attributes = - Reference attributes (fromLocalName "float") [] + Reference attributes (toFQName moduleName "Float") [] diff --git a/src/Morphir/IR/SDK/Int.elm b/src/Morphir/IR/SDK/Int.elm index f44f47558..5ae28093c 100644 --- a/src/Morphir/IR/SDK/Int.elm +++ b/src/Morphir/IR/SDK/Int.elm @@ -1,39 +1,29 @@ module Morphir.IR.SDK.Int exposing (..) import Dict -import Morphir.IR.FQName as FQName exposing (FQName) -import Morphir.IR.Module as Module +import Morphir.IR.Module as Module exposing (ModulePath) import Morphir.IR.Name as Name -import Morphir.IR.Path exposing (Path) -import Morphir.IR.QName as QName -import Morphir.IR.SDK.Common exposing (packageName) +import Morphir.IR.Path as Path +import Morphir.IR.SDK.Common exposing (toFQName) import Morphir.IR.Type exposing (Specification(..), Type(..)) -moduleName : Path +moduleName : ModulePath moduleName = - [ [ "int" ] ] + Path.fromString "Int" moduleSpec : Module.Specification () moduleSpec = { types = Dict.fromList - [ ( [ "int" ], OpaqueTypeSpecification [] ) + [ ( Name.fromString "Int", OpaqueTypeSpecification [] ) ] , values = Dict.empty } -fromLocalName : String -> FQName -fromLocalName name = - name - |> Name.fromString - |> QName.fromName moduleName - |> FQName.fromQName packageName - - intType : a -> Type a intType attributes = - Reference attributes (fromLocalName "int") [] + Reference attributes (toFQName moduleName "Int") [] diff --git a/src/Morphir/IR/SDK/List.elm b/src/Morphir/IR/SDK/List.elm index f086b2362..bf1e360a4 100644 --- a/src/Morphir/IR/SDK/List.elm +++ b/src/Morphir/IR/SDK/List.elm @@ -1,39 +1,29 @@ module Morphir.IR.SDK.List exposing (..) import Dict -import Morphir.IR.FQName as FQName exposing (FQName) -import Morphir.IR.Module as Module +import Morphir.IR.Module as Module exposing (ModulePath) import Morphir.IR.Name as Name -import Morphir.IR.Path exposing (Path) -import Morphir.IR.QName as QName -import Morphir.IR.SDK.Common exposing (packageName) -import Morphir.IR.Type exposing (Specification(..), Type(..)) +import Morphir.IR.Path as Path +import Morphir.IR.SDK.Common exposing (toFQName) +import Morphir.IR.Type as Type exposing (Specification(..), Type(..)) -moduleName : Path +moduleName : ModulePath moduleName = - [ [ "list" ] ] + Path.fromString "List" moduleSpec : Module.Specification () moduleSpec = { types = Dict.fromList - [ ( [ "list" ], OpaqueTypeSpecification [ [ "a" ] ] ) + [ ( Name.fromString "List", OpaqueTypeSpecification [ [ "a" ] ] ) ] , values = Dict.empty } -fromLocalName : String -> FQName -fromLocalName name = - name - |> Name.fromString - |> QName.fromName moduleName - |> FQName.fromQName packageName - - listType : a -> Type a -> Type a listType attributes itemType = - Reference attributes (fromLocalName "list") [ itemType ] + Type.Reference attributes (toFQName moduleName "List") [ itemType ] diff --git a/src/Morphir/IR/SDK/Maybe.elm b/src/Morphir/IR/SDK/Maybe.elm index 3b825b0d5..5b67f8e57 100644 --- a/src/Morphir/IR/SDK/Maybe.elm +++ b/src/Morphir/IR/SDK/Maybe.elm @@ -1,28 +1,26 @@ module Morphir.IR.SDK.Maybe exposing (..) import Dict -import Morphir.IR.FQName as FQName exposing (FQName) -import Morphir.IR.Module as Module +import Morphir.IR.Module as Module exposing (ModulePath) import Morphir.IR.Name as Name -import Morphir.IR.Path exposing (Path) -import Morphir.IR.QName as QName -import Morphir.IR.SDK.Common exposing (packageName) +import Morphir.IR.Path as Path exposing (Path) +import Morphir.IR.SDK.Common exposing (toFQName) import Morphir.IR.Type as Type exposing (Specification(..), Type(..)) -moduleName : Path +moduleName : ModulePath moduleName = - [ [ "maybe" ] ] + Path.fromString "Maybe" moduleSpec : Module.Specification () moduleSpec = { types = Dict.fromList - [ ( [ "maybe" ] - , CustomTypeSpecification [ [ "a" ] ] - [ Type.Constructor [ "just" ] [ ( [ "value" ], Type.Variable () [ "a" ] ) ] - , Type.Constructor [ "nothing" ] [] + [ ( Name.fromString "Maybe" + , CustomTypeSpecification [ Name.fromString "a" ] + [ Type.Constructor (Name.fromString "Just") [ ( [ "value" ], Type.Variable () (Name.fromString "a") ) ] + , Type.Constructor (Name.fromString "Nothing") [] ] ) ] @@ -31,14 +29,6 @@ moduleSpec = } -fromLocalName : String -> FQName -fromLocalName name = - name - |> Name.fromString - |> QName.fromName moduleName - |> FQName.fromQName packageName - - maybeType : a -> Type a -> Type a maybeType attributes itemType = - Reference attributes (fromLocalName "maybe") [ itemType ] + Reference attributes (toFQName moduleName "Maybe") [ itemType ] diff --git a/src/Morphir/IR/SDK/Number.elm b/src/Morphir/IR/SDK/Number.elm index 3efb55c00..61d4585f7 100644 --- a/src/Morphir/IR/SDK/Number.elm +++ b/src/Morphir/IR/SDK/Number.elm @@ -1,17 +1,14 @@ module Morphir.IR.SDK.Number exposing (negate) import Dict -import Morphir.IR.FQName as FQName exposing (FQName) -import Morphir.IR.Module as Module -import Morphir.IR.Name as Name +import Morphir.IR.Module as Module exposing (ModulePath) import Morphir.IR.Path as Path exposing (Path) -import Morphir.IR.QName as QName -import Morphir.IR.SDK.Common exposing (packageName) +import Morphir.IR.SDK.Common exposing (toFQName) import Morphir.IR.Type exposing (Specification(..), Type(..)) import Morphir.IR.Value as Value exposing (Value) -moduleName : Path +moduleName : ModulePath moduleName = Path.fromString "Number" @@ -25,14 +22,6 @@ moduleSpec = } -fromLocalName : String -> FQName -fromLocalName name = - name - |> Name.fromString - |> QName.fromName moduleName - |> FQName.fromQName packageName - - numberClass : a -> Type a numberClass attributes = Variable attributes [ "number" ] @@ -40,4 +29,4 @@ numberClass attributes = negate : a -> a -> Value a -> Value a negate refAttributes valueAttributes arg = - Value.Apply valueAttributes (Value.Reference refAttributes (fromLocalName "negate")) arg + Value.Apply valueAttributes (Value.Reference refAttributes (toFQName moduleName "negate")) arg diff --git a/src/Morphir/IR/SDK/Result.elm b/src/Morphir/IR/SDK/Result.elm index ef68d5295..fb9febdc6 100644 --- a/src/Morphir/IR/SDK/Result.elm +++ b/src/Morphir/IR/SDK/Result.elm @@ -1,28 +1,26 @@ module Morphir.IR.SDK.Result exposing (..) import Dict -import Morphir.IR.FQName as FQName exposing (FQName) -import Morphir.IR.Module as Module +import Morphir.IR.Module as Module exposing (ModulePath) import Morphir.IR.Name as Name -import Morphir.IR.Path exposing (Path) -import Morphir.IR.QName as QName -import Morphir.IR.SDK.Common exposing (packageName) +import Morphir.IR.Path as Path exposing (Path) +import Morphir.IR.SDK.Common exposing (toFQName) import Morphir.IR.Type as Type exposing (Specification(..), Type(..)) -moduleName : Path +moduleName : ModulePath moduleName = - [ [ "result" ] ] + Path.fromString "Result" moduleSpec : Module.Specification () moduleSpec = { types = Dict.fromList - [ ( [ "result" ] - , CustomTypeSpecification [ [ "e" ], [ "a" ] ] - [ Type.Constructor [ "ok" ] [ ( [ "value" ], Type.Variable () [ "a" ] ) ] - , Type.Constructor [ "err" ] [ ( [ "error" ], Type.Variable () [ "e" ] ) ] + [ ( Name.fromString "Result" + , CustomTypeSpecification [ Name.fromString "e", Name.fromString "a" ] + [ Type.Constructor (Name.fromString "Ok") [ ( Name.fromString "value", Type.Variable () (Name.fromString "a") ) ] + , Type.Constructor (Name.fromString "Err") [ ( Name.fromString "error", Type.Variable () (Name.fromString "e") ) ] ] ) ] @@ -31,14 +29,6 @@ moduleSpec = } -fromLocalName : String -> FQName -fromLocalName name = - name - |> Name.fromString - |> QName.fromName moduleName - |> FQName.fromQName packageName - - resultType : a -> Type a -> Type a resultType attributes itemType = - Reference attributes (fromLocalName "result") [ itemType ] + Reference attributes (toFQName moduleName "result") [ itemType ] diff --git a/src/Morphir/IR/SDK/String.elm b/src/Morphir/IR/SDK/String.elm index d5578addc..25798746e 100644 --- a/src/Morphir/IR/SDK/String.elm +++ b/src/Morphir/IR/SDK/String.elm @@ -1,39 +1,29 @@ module Morphir.IR.SDK.String exposing (..) import Dict -import Morphir.IR.FQName as FQName exposing (FQName) -import Morphir.IR.Module as Module +import Morphir.IR.Module as Module exposing (ModulePath) import Morphir.IR.Name as Name -import Morphir.IR.Path exposing (Path) -import Morphir.IR.QName as QName -import Morphir.IR.SDK.Common exposing (packageName) +import Morphir.IR.Path as Path exposing (Path) +import Morphir.IR.SDK.Common exposing (toFQName) import Morphir.IR.Type exposing (Specification(..), Type(..)) -moduleName : Path +moduleName : ModulePath moduleName = - [ [ "string" ] ] + Path.fromString "String" moduleSpec : Module.Specification () moduleSpec = { types = Dict.fromList - [ ( [ "string" ], OpaqueTypeSpecification [] ) + [ ( Name.fromString "String", OpaqueTypeSpecification [] ) ] , values = Dict.empty } -fromLocalName : String -> FQName -fromLocalName name = - name - |> Name.fromString - |> QName.fromName moduleName - |> FQName.fromQName packageName - - stringType : a -> Type a stringType attributes = - Reference attributes (fromLocalName "string") [] + Reference attributes (toFQName moduleName "String") [] diff --git a/src/Morphir/IR/Value.elm b/src/Morphir/IR/Value.elm index 2906f412b..6bf86f9fc 100644 --- a/src/Morphir/IR/Value.elm +++ b/src/Morphir/IR/Value.elm @@ -117,6 +117,7 @@ type Pattern a | EmptyListPattern a | HeadTailPattern a (Pattern a) (Pattern a) | LiteralPattern a Literal + | UnitPattern a {-| Type that represents a value or function specification. The specification of what the value or function @@ -309,6 +310,9 @@ mapPatternAttributes f p = LiteralPattern a value -> LiteralPattern (f a) value + UnitPattern a -> + UnitPattern (f a) + mapDefinitionAttributes : (a -> b) -> Definition a -> Definition b mapDefinitionAttributes f d = @@ -1185,6 +1189,12 @@ encodePattern encodeAttributes pattern = , encodeLiteral value ] + UnitPattern a -> + Encode.list identity + [ Encode.string "UnitPattern" + , encodeAttributes a + ] + decodePattern : Decode.Decoder a -> Decode.Decoder (Pattern a) decodePattern decodeAttributes = From b2ee84840b648eee653ad3dcb30caee98f52c8be Mon Sep 17 00:00:00 2001 From: Attila Mihaly Date: Fri, 3 Apr 2020 20:33:38 -0400 Subject: [PATCH 17/42] All patterns supported. --- src/Morphir/Elm/Frontend.elm | 100 ++++++++++++++++++++++++++-- tests/Morphir/Elm/FrontendTests.elm | 18 ++++- 2 files changed, 113 insertions(+), 5 deletions(-) diff --git a/src/Morphir/Elm/Frontend.elm b/src/Morphir/Elm/Frontend.elm index dee514d51..d631f1bbb 100644 --- a/src/Morphir/Elm/Frontend.elm +++ b/src/Morphir/Elm/Frontend.elm @@ -11,7 +11,7 @@ import Elm.Syntax.File exposing (File) import Elm.Syntax.Module as ElmModule import Elm.Syntax.ModuleName exposing (ModuleName) import Elm.Syntax.Node as Node exposing (Node(..)) -import Elm.Syntax.Pattern exposing (Pattern(..)) +import Elm.Syntax.Pattern as Pattern exposing (Pattern(..)) import Elm.Syntax.Range exposing (Range) import Elm.Syntax.TypeAnnotation exposing (TypeAnnotation(..)) import Json.Decode as Decode @@ -24,6 +24,7 @@ import Morphir.IR.Module as Module import Morphir.IR.Name as Name exposing (Name) import Morphir.IR.Package as Package import Morphir.IR.Path as Path exposing (Path) +import Morphir.IR.QName as QName import Morphir.IR.SDK as SDK import Morphir.IR.SDK.Number as Number import Morphir.IR.Type as Type exposing (Type) @@ -754,7 +755,19 @@ mapExpression sourceFile (Node range exp) = Err [ NotSupported sourceLocation "TODO: CaseExpression" ] Expression.LambdaExpression lambda -> - Err [ NotSupported sourceLocation "TODO: LambdaExpression" ] + let + curriedLambda : List (Node Pattern) -> Node Expression -> Result Errors (Value.Value SourceLocation) + curriedLambda argNodes bodyNode = + case argNodes of + [] -> + mapExpression sourceFile bodyNode + + firstArgNode :: restOfArgNodes -> + Result.map2 (Value.Lambda sourceLocation) + (mapPattern sourceFile firstArgNode) + (curriedLambda restOfArgNodes bodyNode) + in + curriedLambda lambda.args lambda.expression Expression.RecordExpr fieldNodes -> fieldNodes @@ -803,12 +816,91 @@ mapExpression sourceFile (Node range exp) = mapPattern : SourceFile -> Node Pattern -> Result Errors (Value.Pattern SourceLocation) -mapPattern sourceFile (Node range patternNode) = +mapPattern sourceFile (Node range pattern) = let sourceLocation = range |> SourceLocation sourceFile in - Ok (Value.WildcardPattern sourceLocation) + case pattern of + Pattern.AllPattern -> + Ok (Value.WildcardPattern sourceLocation) + + Pattern.UnitPattern -> + Ok (Value.UnitPattern sourceLocation) + + Pattern.CharPattern char -> + Ok (Value.LiteralPattern sourceLocation (Value.CharLiteral char)) + + Pattern.StringPattern string -> + Ok (Value.LiteralPattern sourceLocation (Value.StringLiteral string)) + + Pattern.IntPattern int -> + Ok (Value.LiteralPattern sourceLocation (Value.IntLiteral int)) + + Pattern.HexPattern int -> + Ok (Value.LiteralPattern sourceLocation (Value.IntLiteral int)) + + Pattern.FloatPattern float -> + Ok (Value.LiteralPattern sourceLocation (Value.FloatLiteral float)) + + Pattern.TuplePattern elemNodes -> + elemNodes + |> List.map (mapPattern sourceFile) + |> ResultList.toResult + |> Result.mapError List.concat + |> Result.map (Value.TuplePattern sourceLocation) + + Pattern.RecordPattern fieldNameNodes -> + Ok + (Value.RecordPattern sourceLocation + (fieldNameNodes + |> List.map (Node.value >> Name.fromString) + ) + ) + + Pattern.UnConsPattern headNode tailNode -> + Result.map2 (Value.HeadTailPattern sourceLocation) + (mapPattern sourceFile headNode) + (mapPattern sourceFile tailNode) + + Pattern.ListPattern itemNodes -> + let + toPattern : List (Node Pattern) -> Result Errors (Value.Pattern SourceLocation) + toPattern patternNodes = + case patternNodes of + [] -> + Ok (Value.EmptyListPattern sourceLocation) + + headNode :: tailNodes -> + Result.map2 (Value.HeadTailPattern sourceLocation) + (mapPattern sourceFile headNode) + (toPattern tailNodes) + in + toPattern itemNodes + + Pattern.VarPattern name -> + Ok (Value.AsPattern sourceLocation (Value.WildcardPattern sourceLocation) (Name.fromString name)) + + Pattern.NamedPattern qualifiedNameRef argNodes -> + let + qualifiedName = + qualifiedNameRef.name + |> Name.fromString + |> QName.fromName (qualifiedNameRef.moduleName |> List.map Name.fromString) + |> FQName.fromQName [] + in + argNodes + |> List.map (mapPattern sourceFile) + |> ResultList.toResult + |> Result.mapError List.concat + |> Result.map (Value.ConstructorPattern sourceLocation qualifiedName) + + Pattern.AsPattern subjectNode aliasNode -> + mapPattern sourceFile subjectNode + |> Result.map (\subject -> Value.AsPattern sourceLocation subject (aliasNode |> Node.value |> Name.fromString)) + + Pattern.ParenthesizedPattern childNode -> + mapPattern sourceFile childNode resolveLocalTypes : Path -> Path -> ModuleResolver -> Module.Definition SourceLocation -> Result Errors (Module.Definition SourceLocation) diff --git a/tests/Morphir/Elm/FrontendTests.elm b/tests/Morphir/Elm/FrontendTests.elm index 94fc88848..340d982ce 100644 --- a/tests/Morphir/Elm/FrontendTests.elm +++ b/tests/Morphir/Elm/FrontendTests.elm @@ -5,6 +5,7 @@ import Expect exposing (Expectation) import Morphir.Elm.Frontend as Frontend exposing (Errors, SourceFile, SourceLocation) import Morphir.IR.AccessControlled exposing (AccessControlled, private, public) import Morphir.IR.FQName exposing (fQName) +import Morphir.IR.Name as Name import Morphir.IR.Package as Package import Morphir.IR.Path as Path import Morphir.IR.SDK.Bool as Bool @@ -15,7 +16,7 @@ import Morphir.IR.SDK.Maybe as Maybe import Morphir.IR.SDK.Number as Number import Morphir.IR.SDK.String as String import Morphir.IR.Type as Type -import Morphir.IR.Value as Value exposing (Literal(..), Value(..)) +import Morphir.IR.Value as Value exposing (Literal(..), Pattern(..), Value(..)) import Set import Test exposing (..) @@ -256,6 +257,21 @@ valueTests = , checkIR "foo.bar" <| Field () (ref "foo") [ "bar" ] , checkIR ".bar" <| FieldFunction () [ "bar" ] , checkIR "{ a | foo = foo, bar = bar }" <| UpdateRecord () (Variable () [ "a" ]) [ ( [ "foo" ], ref "foo" ), ( [ "bar" ], ref "bar" ) ] + , checkIR "\\() -> foo " <| Lambda () (UnitPattern ()) (ref "foo") + , checkIR "\\() () -> foo " <| Lambda () (UnitPattern ()) (Lambda () (UnitPattern ()) (ref "foo")) + , checkIR "\\_ -> foo " <| Lambda () (WildcardPattern ()) (ref "foo") + , checkIR "\\'a' -> foo " <| Lambda () (LiteralPattern () (CharLiteral 'a')) (ref "foo") + , checkIR "\\\"foo\" -> foo " <| Lambda () (LiteralPattern () (StringLiteral "foo")) (ref "foo") + , checkIR "\\42 -> foo " <| Lambda () (LiteralPattern () (IntLiteral 42)) (ref "foo") + , checkIR "\\0x20 -> foo " <| Lambda () (LiteralPattern () (IntLiteral 32)) (ref "foo") + , checkIR "\\( 1, 2 ) -> foo " <| Lambda () (TuplePattern () [ LiteralPattern () (IntLiteral 1), LiteralPattern () (IntLiteral 2) ]) (ref "foo") + , checkIR "\\{ foo, bar } -> foo " <| Lambda () (RecordPattern () [ Name.fromString "foo", Name.fromString "bar" ]) (ref "foo") + , checkIR "\\1 :: 2 -> foo " <| Lambda () (HeadTailPattern () (LiteralPattern () (IntLiteral 1)) (LiteralPattern () (IntLiteral 2))) (ref "foo") + , checkIR "\\[] -> foo " <| Lambda () (EmptyListPattern ()) (ref "foo") + , checkIR "\\[ 1 ] -> foo " <| Lambda () (HeadTailPattern () (LiteralPattern () (IntLiteral 1)) (EmptyListPattern ())) (ref "foo") + , checkIR "\\([] as bar) -> foo " <| Lambda () (AsPattern () (EmptyListPattern ()) (Name.fromString "bar")) (ref "foo") + , checkIR "\\(Foo 1 _) -> foo " <| Lambda () (ConstructorPattern () (fQName [] [] [ "foo" ]) [ LiteralPattern () (IntLiteral 1), WildcardPattern () ]) (ref "foo") + , checkIR "\\Foo.Bar.Baz -> foo " <| Lambda () (ConstructorPattern () (fQName [] [ [ "foo" ], [ "bar" ] ] [ "baz" ]) []) (ref "foo") ] From 2710591272eeda5ced2946adaea02f455a533072 Mon Sep 17 00:00:00 2001 From: Attila Mihaly Date: Fri, 3 Apr 2020 20:45:18 -0400 Subject: [PATCH 18/42] Pattern-match supported. --- src/Morphir/Elm/Frontend.elm | 13 ++++++++++++- tests/Morphir/Elm/FrontendTests.elm | 1 + 2 files changed, 13 insertions(+), 1 deletion(-) diff --git a/src/Morphir/Elm/Frontend.elm b/src/Morphir/Elm/Frontend.elm index d631f1bbb..1b503be6f 100644 --- a/src/Morphir/Elm/Frontend.elm +++ b/src/Morphir/Elm/Frontend.elm @@ -752,7 +752,18 @@ mapExpression sourceFile (Node range exp) = Err [ NotSupported sourceLocation "TODO: LetExpression" ] Expression.CaseExpression caseBlock -> - Err [ NotSupported sourceLocation "TODO: CaseExpression" ] + Result.map2 (Value.PatternMatch sourceLocation) + (mapExpression sourceFile caseBlock.expression) + (caseBlock.cases + |> List.map + (\( patternNode, bodyNode ) -> + Result.map2 Tuple.pair + (mapPattern sourceFile patternNode) + (mapExpression sourceFile bodyNode) + ) + |> ResultList.toResult + |> Result.mapError List.concat + ) Expression.LambdaExpression lambda -> let diff --git a/tests/Morphir/Elm/FrontendTests.elm b/tests/Morphir/Elm/FrontendTests.elm index 340d982ce..2f2f34a5f 100644 --- a/tests/Morphir/Elm/FrontendTests.elm +++ b/tests/Morphir/Elm/FrontendTests.elm @@ -272,6 +272,7 @@ valueTests = , checkIR "\\([] as bar) -> foo " <| Lambda () (AsPattern () (EmptyListPattern ()) (Name.fromString "bar")) (ref "foo") , checkIR "\\(Foo 1 _) -> foo " <| Lambda () (ConstructorPattern () (fQName [] [] [ "foo" ]) [ LiteralPattern () (IntLiteral 1), WildcardPattern () ]) (ref "foo") , checkIR "\\Foo.Bar.Baz -> foo " <| Lambda () (ConstructorPattern () (fQName [] [ [ "foo" ], [ "bar" ] ] [ "baz" ]) []) (ref "foo") + , checkIR "case a of\n 1 -> foo\n _ -> bar" <| PatternMatch () (ref "a") [ ( LiteralPattern () (IntLiteral 1), ref "foo" ), ( WildcardPattern (), ref "bar" ) ] ] From 4a13c93480760b94b898a418bd89e4f7fb420766 Mon Sep 17 00:00:00 2001 From: Attila Mihaly Date: Mon, 6 Apr 2020 12:20:21 -0400 Subject: [PATCH 19/42] Added support for SDK operators. #52 --- src/Morphir/Elm/Frontend.elm | 103 ++++++++++++++++++++++++++-- src/Morphir/IR/SDK/Appending.elm | 27 ++++++++ src/Morphir/IR/SDK/Bool.elm | 13 +++- src/Morphir/IR/SDK/Common.elm | 6 ++ src/Morphir/IR/SDK/Comparison.elm | 42 ++++++++++++ src/Morphir/IR/SDK/Composition.elm | 32 +++++++++ src/Morphir/IR/SDK/Equality.elm | 32 +++++++++ src/Morphir/IR/SDK/Float.elm | 8 ++- src/Morphir/IR/SDK/Int.elm | 8 ++- src/Morphir/IR/SDK/List.elm | 8 ++- src/Morphir/IR/SDK/Number.elm | 24 ++++++- tests/Morphir/Elm/FrontendTests.elm | 24 +++++++ 12 files changed, 314 insertions(+), 13 deletions(-) create mode 100644 src/Morphir/IR/SDK/Appending.elm create mode 100644 src/Morphir/IR/SDK/Comparison.elm create mode 100644 src/Morphir/IR/SDK/Composition.elm create mode 100644 src/Morphir/IR/SDK/Equality.elm diff --git a/src/Morphir/Elm/Frontend.elm b/src/Morphir/Elm/Frontend.elm index 1b503be6f..451f9cd85 100644 --- a/src/Morphir/Elm/Frontend.elm +++ b/src/Morphir/Elm/Frontend.elm @@ -6,7 +6,7 @@ import Elm.Processing as Processing import Elm.RawFile as RawFile exposing (RawFile) import Elm.Syntax.Declaration exposing (Declaration(..)) import Elm.Syntax.Exposing as Exposing exposing (Exposing) -import Elm.Syntax.Expression as Expression exposing (Expression, FunctionImplementation) +import Elm.Syntax.Expression as Expression exposing (Expression, Function, FunctionImplementation) import Elm.Syntax.File exposing (File) import Elm.Syntax.Module as ElmModule import Elm.Syntax.ModuleName exposing (ModuleName) @@ -26,6 +26,14 @@ import Morphir.IR.Package as Package import Morphir.IR.Path as Path exposing (Path) import Morphir.IR.QName as QName import Morphir.IR.SDK as SDK +import Morphir.IR.SDK.Appending as Appending +import Morphir.IR.SDK.Bool as Bool +import Morphir.IR.SDK.Comparison as Comparison +import Morphir.IR.SDK.Composition as Composition +import Morphir.IR.SDK.Equality as Equality +import Morphir.IR.SDK.Float as Float +import Morphir.IR.SDK.Int as Int +import Morphir.IR.SDK.List as List import Morphir.IR.SDK.Number as Number import Morphir.IR.Type as Type exposing (Type) import Morphir.IR.Value as Value exposing (Value) @@ -538,11 +546,8 @@ mapDeclarationsToValue sourceFile expose decls = valueDef : Result Errors (AccessControlled (Value.Definition SourceLocation)) valueDef = - function.declaration - |> Node.value - |> (\funImpl -> - mapFunctionImplementation sourceFile funImpl.arguments funImpl.expression - ) + function + |> mapFunction sourceFile |> Result.map public in valueDef @@ -615,6 +620,15 @@ mapTypeAnnotation sourceFile (Node range typeAnnotation) = (mapTypeAnnotation sourceFile returnTypeNode) +mapFunction : SourceFile -> Function -> Result Errors (Value.Definition SourceLocation) +mapFunction sourceFile function = + function.declaration + |> Node.value + |> (\funImpl -> + mapFunctionImplementation sourceFile funImpl.arguments funImpl.expression + ) + + mapFunctionImplementation : SourceFile -> List (Node Pattern) -> Node Expression -> Result Errors (Value.Definition SourceLocation) mapFunctionImplementation sourceFile argumentNodes expression = let @@ -694,7 +708,82 @@ mapExpression sourceFile (Node range exp) = |> Result.andThen (List.reverse >> toApply) Expression.OperatorApplication op infixDirection leftNode rightNode -> - Err [ NotSupported sourceLocation "TODO: OperatorApplication" ] + let + applyBinary : (SourceLocation -> Value SourceLocation -> Value SourceLocation -> Value SourceLocation) -> Result Errors (Value.Value SourceLocation) + applyBinary fun = + Result.map2 (fun sourceLocation) + (mapExpression sourceFile leftNode) + (mapExpression sourceFile rightNode) + in + case op of + "<|" -> + -- the purpose of this operator is cleaner syntax so it's not mapped to the IR + Result.map2 (Value.Apply sourceLocation) + (mapExpression sourceFile leftNode) + (mapExpression sourceFile rightNode) + + "|>" -> + -- the purpose of this operator is cleaner syntax so it's not mapped to the IR + Result.map2 (Value.Apply sourceLocation) + (mapExpression sourceFile rightNode) + (mapExpression sourceFile leftNode) + + "||" -> + applyBinary Bool.or + + "&&" -> + applyBinary Bool.and + + "==" -> + applyBinary Equality.equal + + "/=" -> + applyBinary Equality.notEqual + + "<" -> + applyBinary Comparison.lessThan + + ">" -> + applyBinary Comparison.greaterThan + + "<=" -> + applyBinary Comparison.lessThanOrEqual + + ">=" -> + applyBinary Comparison.greaterThanOrEqual + + "++" -> + applyBinary Appending.append + + "+" -> + applyBinary Number.add + + "-" -> + applyBinary Number.subtract + + "*" -> + applyBinary Number.multiply + + "/" -> + applyBinary Float.divide + + "//" -> + applyBinary Int.divide + + "^" -> + applyBinary Number.power + + "<<" -> + applyBinary Composition.composeLeft + + ">>" -> + applyBinary Composition.composeRight + + "::" -> + applyBinary List.construct + + _ -> + Err [ NotSupported sourceLocation <| "OperatorApplication: " ++ op ] Expression.FunctionOrValue moduleName valueName -> case ( moduleName, valueName ) of diff --git a/src/Morphir/IR/SDK/Appending.elm b/src/Morphir/IR/SDK/Appending.elm new file mode 100644 index 000000000..3e2d91f8c --- /dev/null +++ b/src/Morphir/IR/SDK/Appending.elm @@ -0,0 +1,27 @@ +module Morphir.IR.SDK.Appending exposing (..) + +import Dict +import Morphir.IR.Module as Module exposing (ModulePath) +import Morphir.IR.Path as Path exposing (Path) +import Morphir.IR.SDK.Common exposing (binaryApply, toFQName) +import Morphir.IR.Type exposing (Specification(..), Type(..)) +import Morphir.IR.Value as Value exposing (Value) + + +moduleName : ModulePath +moduleName = + Path.fromString "Appending" + + +moduleSpec : Module.Specification () +moduleSpec = + { types = + Dict.empty + , values = + Dict.empty + } + + +append : a -> Value a -> Value a -> Value a +append = + binaryApply moduleName "append" diff --git a/src/Morphir/IR/SDK/Bool.elm b/src/Morphir/IR/SDK/Bool.elm index 39628c398..827cfd8b5 100644 --- a/src/Morphir/IR/SDK/Bool.elm +++ b/src/Morphir/IR/SDK/Bool.elm @@ -4,8 +4,9 @@ import Dict import Morphir.IR.Module as Module exposing (ModulePath) import Morphir.IR.Name as Name import Morphir.IR.Path as Path -import Morphir.IR.SDK.Common exposing (toFQName) +import Morphir.IR.SDK.Common exposing (binaryApply, toFQName) import Morphir.IR.Type exposing (Specification(..), Type(..)) +import Morphir.IR.Value as Value exposing (Value) moduleName : ModulePath @@ -27,3 +28,13 @@ moduleSpec = boolType : a -> Type a boolType attributes = Reference attributes (toFQName moduleName "Bool") [] + + +and : a -> Value a -> Value a -> Value a +and = + binaryApply moduleName "and" + + +or : a -> Value a -> Value a -> Value a +or = + binaryApply moduleName "or" diff --git a/src/Morphir/IR/SDK/Common.elm b/src/Morphir/IR/SDK/Common.elm index 70b07eabd..7033d3c83 100644 --- a/src/Morphir/IR/SDK/Common.elm +++ b/src/Morphir/IR/SDK/Common.elm @@ -6,6 +6,7 @@ import Morphir.IR.Name as Name import Morphir.IR.Package exposing (PackagePath) import Morphir.IR.Path as Path import Morphir.IR.QName as QName +import Morphir.IR.Value as Value exposing (Value) packageName : PackagePath @@ -19,3 +20,8 @@ toFQName modulePath localName = |> Name.fromString |> QName.fromName modulePath |> FQName.fromQName packageName + + +binaryApply : ModulePath -> String -> a -> Value a -> Value a -> Value a +binaryApply moduleName localName attributes arg1 arg2 = + Value.Apply attributes (Value.Apply attributes (Value.Reference attributes (toFQName moduleName localName)) arg1) arg2 diff --git a/src/Morphir/IR/SDK/Comparison.elm b/src/Morphir/IR/SDK/Comparison.elm new file mode 100644 index 000000000..b329d0019 --- /dev/null +++ b/src/Morphir/IR/SDK/Comparison.elm @@ -0,0 +1,42 @@ +module Morphir.IR.SDK.Comparison exposing (..) + +import Dict +import Morphir.IR.Module as Module exposing (ModulePath) +import Morphir.IR.Path as Path exposing (Path) +import Morphir.IR.SDK.Common exposing (binaryApply, toFQName) +import Morphir.IR.Type exposing (Specification(..), Type(..)) +import Morphir.IR.Value as Value exposing (Value) + + +moduleName : ModulePath +moduleName = + Path.fromString "Comparison" + + +moduleSpec : Module.Specification () +moduleSpec = + { types = + Dict.empty + , values = + Dict.empty + } + + +lessThan : a -> Value a -> Value a -> Value a +lessThan = + binaryApply moduleName "lessThan" + + +lessThanOrEqual : a -> Value a -> Value a -> Value a +lessThanOrEqual = + binaryApply moduleName "lessThanOrEqual" + + +greaterThan : a -> Value a -> Value a -> Value a +greaterThan = + binaryApply moduleName "greaterThan" + + +greaterThanOrEqual : a -> Value a -> Value a -> Value a +greaterThanOrEqual = + binaryApply moduleName "greaterThanOrEqual" diff --git a/src/Morphir/IR/SDK/Composition.elm b/src/Morphir/IR/SDK/Composition.elm new file mode 100644 index 000000000..585f7a9b0 --- /dev/null +++ b/src/Morphir/IR/SDK/Composition.elm @@ -0,0 +1,32 @@ +module Morphir.IR.SDK.Composition exposing (..) + +import Dict +import Morphir.IR.Module as Module exposing (ModulePath) +import Morphir.IR.Path as Path exposing (Path) +import Morphir.IR.SDK.Common exposing (binaryApply, toFQName) +import Morphir.IR.Type exposing (Specification(..), Type(..)) +import Morphir.IR.Value as Value exposing (Value) + + +moduleName : ModulePath +moduleName = + Path.fromString "Composition" + + +moduleSpec : Module.Specification () +moduleSpec = + { types = + Dict.empty + , values = + Dict.empty + } + + +composeLeft : a -> Value a -> Value a -> Value a +composeLeft = + binaryApply moduleName "composeLeft" + + +composeRight : a -> Value a -> Value a -> Value a +composeRight = + binaryApply moduleName "composeRight" diff --git a/src/Morphir/IR/SDK/Equality.elm b/src/Morphir/IR/SDK/Equality.elm new file mode 100644 index 000000000..e170ece01 --- /dev/null +++ b/src/Morphir/IR/SDK/Equality.elm @@ -0,0 +1,32 @@ +module Morphir.IR.SDK.Equality exposing (..) + +import Dict +import Morphir.IR.Module as Module exposing (ModulePath) +import Morphir.IR.Path as Path exposing (Path) +import Morphir.IR.SDK.Common exposing (binaryApply, toFQName) +import Morphir.IR.Type exposing (Specification(..), Type(..)) +import Morphir.IR.Value as Value exposing (Value) + + +moduleName : ModulePath +moduleName = + Path.fromString "Equality" + + +moduleSpec : Module.Specification () +moduleSpec = + { types = + Dict.empty + , values = + Dict.empty + } + + +equal : a -> Value a -> Value a -> Value a +equal = + binaryApply moduleName "equal" + + +notEqual : a -> Value a -> Value a -> Value a +notEqual = + binaryApply moduleName "notEqual" diff --git a/src/Morphir/IR/SDK/Float.elm b/src/Morphir/IR/SDK/Float.elm index 68c86d876..7087dacef 100644 --- a/src/Morphir/IR/SDK/Float.elm +++ b/src/Morphir/IR/SDK/Float.elm @@ -4,8 +4,9 @@ import Dict import Morphir.IR.Module as Module exposing (ModulePath) import Morphir.IR.Name as Name import Morphir.IR.Path as Path -import Morphir.IR.SDK.Common exposing (toFQName) +import Morphir.IR.SDK.Common exposing (binaryApply, toFQName) import Morphir.IR.Type exposing (Specification(..), Type(..)) +import Morphir.IR.Value exposing (Value) moduleName : ModulePath @@ -27,3 +28,8 @@ moduleSpec = floatType : a -> Type a floatType attributes = Reference attributes (toFQName moduleName "Float") [] + + +divide : a -> Value a -> Value a -> Value a +divide = + binaryApply moduleName "divide" diff --git a/src/Morphir/IR/SDK/Int.elm b/src/Morphir/IR/SDK/Int.elm index 5ae28093c..ecbb03ac9 100644 --- a/src/Morphir/IR/SDK/Int.elm +++ b/src/Morphir/IR/SDK/Int.elm @@ -4,8 +4,9 @@ import Dict import Morphir.IR.Module as Module exposing (ModulePath) import Morphir.IR.Name as Name import Morphir.IR.Path as Path -import Morphir.IR.SDK.Common exposing (toFQName) +import Morphir.IR.SDK.Common exposing (binaryApply, toFQName) import Morphir.IR.Type exposing (Specification(..), Type(..)) +import Morphir.IR.Value exposing (Value) moduleName : ModulePath @@ -27,3 +28,8 @@ moduleSpec = intType : a -> Type a intType attributes = Reference attributes (toFQName moduleName "Int") [] + + +divide : a -> Value a -> Value a -> Value a +divide = + binaryApply moduleName "divide" diff --git a/src/Morphir/IR/SDK/List.elm b/src/Morphir/IR/SDK/List.elm index bf1e360a4..0a0e357d7 100644 --- a/src/Morphir/IR/SDK/List.elm +++ b/src/Morphir/IR/SDK/List.elm @@ -4,8 +4,9 @@ import Dict import Morphir.IR.Module as Module exposing (ModulePath) import Morphir.IR.Name as Name import Morphir.IR.Path as Path -import Morphir.IR.SDK.Common exposing (toFQName) +import Morphir.IR.SDK.Common exposing (binaryApply, toFQName) import Morphir.IR.Type as Type exposing (Specification(..), Type(..)) +import Morphir.IR.Value exposing (Value) moduleName : ModulePath @@ -27,3 +28,8 @@ moduleSpec = listType : a -> Type a -> Type a listType attributes itemType = Type.Reference attributes (toFQName moduleName "List") [ itemType ] + + +construct : a -> Value a -> Value a -> Value a +construct = + binaryApply moduleName "construct" diff --git a/src/Morphir/IR/SDK/Number.elm b/src/Morphir/IR/SDK/Number.elm index 61d4585f7..ae908addb 100644 --- a/src/Morphir/IR/SDK/Number.elm +++ b/src/Morphir/IR/SDK/Number.elm @@ -1,9 +1,9 @@ -module Morphir.IR.SDK.Number exposing (negate) +module Morphir.IR.SDK.Number exposing (..) import Dict import Morphir.IR.Module as Module exposing (ModulePath) import Morphir.IR.Path as Path exposing (Path) -import Morphir.IR.SDK.Common exposing (toFQName) +import Morphir.IR.SDK.Common exposing (binaryApply, toFQName) import Morphir.IR.Type exposing (Specification(..), Type(..)) import Morphir.IR.Value as Value exposing (Value) @@ -30,3 +30,23 @@ numberClass attributes = negate : a -> a -> Value a -> Value a negate refAttributes valueAttributes arg = Value.Apply valueAttributes (Value.Reference refAttributes (toFQName moduleName "negate")) arg + + +add : a -> Value a -> Value a -> Value a +add = + binaryApply moduleName "add" + + +subtract : a -> Value a -> Value a -> Value a +subtract = + binaryApply moduleName "subtract" + + +multiply : a -> Value a -> Value a -> Value a +multiply = + binaryApply moduleName "multiply" + + +power : a -> Value a -> Value a -> Value a +power = + binaryApply moduleName "power" diff --git a/tests/Morphir/Elm/FrontendTests.elm b/tests/Morphir/Elm/FrontendTests.elm index 2f2f34a5f..b6517fd27 100644 --- a/tests/Morphir/Elm/FrontendTests.elm +++ b/tests/Morphir/Elm/FrontendTests.elm @@ -8,7 +8,11 @@ import Morphir.IR.FQName exposing (fQName) import Morphir.IR.Name as Name import Morphir.IR.Package as Package import Morphir.IR.Path as Path +import Morphir.IR.SDK.Appending as Appending import Morphir.IR.SDK.Bool as Bool +import Morphir.IR.SDK.Comparison as Comparison +import Morphir.IR.SDK.Composition as Composition +import Morphir.IR.SDK.Equality as Equality import Morphir.IR.SDK.Float as Float import Morphir.IR.SDK.Int as Int import Morphir.IR.SDK.List as List @@ -273,6 +277,26 @@ valueTests = , checkIR "\\(Foo 1 _) -> foo " <| Lambda () (ConstructorPattern () (fQName [] [] [ "foo" ]) [ LiteralPattern () (IntLiteral 1), WildcardPattern () ]) (ref "foo") , checkIR "\\Foo.Bar.Baz -> foo " <| Lambda () (ConstructorPattern () (fQName [] [ [ "foo" ], [ "bar" ] ] [ "baz" ]) []) (ref "foo") , checkIR "case a of\n 1 -> foo\n _ -> bar" <| PatternMatch () (ref "a") [ ( LiteralPattern () (IntLiteral 1), ref "foo" ), ( WildcardPattern (), ref "bar" ) ] + , checkIR "a <| b" <| Apply () (ref "a") (ref "b") + , checkIR "a |> b" <| Apply () (ref "b") (ref "a") + , checkIR "a || b" <| Bool.or () (ref "a") (ref "b") + , checkIR "a && b" <| Bool.and () (ref "a") (ref "b") + , checkIR "a == b" <| Equality.equal () (ref "a") (ref "b") + , checkIR "a /= b" <| Equality.notEqual () (ref "a") (ref "b") + , checkIR "a < b" <| Comparison.lessThan () (ref "a") (ref "b") + , checkIR "a > b" <| Comparison.greaterThan () (ref "a") (ref "b") + , checkIR "a <= b" <| Comparison.lessThanOrEqual () (ref "a") (ref "b") + , checkIR "a >= b" <| Comparison.greaterThanOrEqual () (ref "a") (ref "b") + , checkIR "a ++ b" <| Appending.append () (ref "a") (ref "b") + , checkIR "a + b" <| Number.add () (ref "a") (ref "b") + , checkIR "a - b" <| Number.subtract () (ref "a") (ref "b") + , checkIR "a * b" <| Number.multiply () (ref "a") (ref "b") + , checkIR "a / b" <| Float.divide () (ref "a") (ref "b") + , checkIR "a // b" <| Int.divide () (ref "a") (ref "b") + , checkIR "a ^ b" <| Number.power () (ref "a") (ref "b") + , checkIR "a << b" <| Composition.composeLeft () (ref "a") (ref "b") + , checkIR "a >> b" <| Composition.composeRight () (ref "a") (ref "b") + , checkIR "a :: b" <| List.construct () (ref "a") (ref "b") ] From f308db73f645774ed6f8e113ed99e7e39bdfa8b8 Mon Sep 17 00:00:00 2001 From: Attila Mihaly Date: Tue, 7 Apr 2020 10:11:47 -0400 Subject: [PATCH 20/42] Fix compile errors. --- src/Morphir/Elm/Backend/Codec/DecoderGen.elm | 6 +++--- src/Morphir/Elm/Backend/Codec/EncoderGen.elm | 22 ++++++++++---------- 2 files changed, 14 insertions(+), 14 deletions(-) diff --git a/src/Morphir/Elm/Backend/Codec/DecoderGen.elm b/src/Morphir/Elm/Backend/Codec/DecoderGen.elm index cff1089d2..91d33fb21 100644 --- a/src/Morphir/Elm/Backend/Codec/DecoderGen.elm +++ b/src/Morphir/Elm/Backend/Codec/DecoderGen.elm @@ -4,11 +4,11 @@ import Elm.Syntax.Declaration exposing (Declaration(..)) import Elm.Syntax.Expression exposing (Expression(..)) import Elm.Syntax.ModuleName exposing (ModuleName) import Elm.Syntax.Pattern exposing (Pattern(..)) -import Morphir.Elm.Backend.Utils as Utils exposing (emptyRangeNode) +import Morphir.Elm.Backend.Utils as Utils import Morphir.IR.AccessControlled exposing (Access(..), AccessControlled) import Morphir.IR.FQName exposing (FQName(..)) import Morphir.IR.Name as Name exposing (Name) -import Morphir.IR.Type as Type exposing (Constructor, Definition(..), Field, Type(..)) +import Morphir.IR.Type as Type exposing (Constructor(..), Definition(..), Field, Type(..)) typeDefToDecoder : Name -> AccessControlled (Type.Definition ()) -> Declaration @@ -67,7 +67,7 @@ typeDefToDecoder typeName accessCtrlTypeDef = constructorDecoder : Bool -> Constructor () -> Expression -constructorDecoder isSingle ( ctorName, fields ) = +constructorDecoder isSingle (Constructor ctorName fields) = case fields of [] -> Application diff --git a/src/Morphir/Elm/Backend/Codec/EncoderGen.elm b/src/Morphir/Elm/Backend/Codec/EncoderGen.elm index 1bbe74dbf..7eb534f6a 100644 --- a/src/Morphir/Elm/Backend/Codec/EncoderGen.elm +++ b/src/Morphir/Elm/Backend/Codec/EncoderGen.elm @@ -5,12 +5,12 @@ import Elm.Syntax.Expression exposing (Case, Expression(..), Function, FunctionI import Elm.Syntax.ModuleName exposing (ModuleName) import Elm.Syntax.Node exposing (Node(..)) import Elm.Syntax.Pattern exposing (Pattern(..), QualifiedNameRef) -import Morphir.Elm.Backend.Utils as Utils exposing (emptyRangeNode) +import Morphir.Elm.Backend.Utils as Utils import Morphir.IR.AccessControlled exposing (Access(..), AccessControlled) import Morphir.IR.FQName exposing (FQName(..)) -import Morphir.IR.Name as Name exposing (Name, fromString, toCamelCase, toTitleCase) -import Morphir.IR.Path as Path exposing (toString) -import Morphir.IR.Type exposing (Constructor, Definition(..), Field, Type(..), record) +import Morphir.IR.Name as Name exposing (Name) +import Morphir.IR.Path as Path +import Morphir.IR.Type exposing (Constructor(..), Definition(..), Field, Type(..), record) typeDefToEncoder : Name -> AccessControlled (Definition ()) -> Declaration @@ -46,7 +46,7 @@ typeDefToEncoder typeName typeDef = [] -> [] - ( ctorName, fields ) :: [] -> + (Constructor ctorName fields) :: [] -> [ deconsPattern ctorName fields |> Utils.emptyRangeNode |> ParenthesizedPattern @@ -77,10 +77,10 @@ typeDefToEncoder typeName typeDef = [] -> Literal "Types without constructors are not supported" - ctor :: [] -> + ((Constructor ctorName _) as ctor) :: [] -> ctor |> constructorToRecord - |> typeToEncoder False [ Tuple.first ctor ] + |> typeToEncoder False [ ctorName ] ctors -> let @@ -95,17 +95,17 @@ typeDefToEncoder typeName typeDef = cases = let ctorToPatternExpr : Constructor () -> ( Node Pattern, Node Expression ) - ctorToPatternExpr ctor = + ctorToPatternExpr ((Constructor ctorName ctorArgs) as ctor) = let pattern : Pattern pattern = - deconsPattern (Tuple.first ctor) (Tuple.second ctor) + deconsPattern ctorName ctorArgs expr : Expression expr = ctor |> constructorToRecord - |> typeToEncoder False [ Tuple.first ctor ] + |> typeToEncoder False [ ctorName ] |> customTypeTopExpr in ( Utils.emptyRangeNode pattern, Utils.emptyRangeNode expr ) @@ -277,7 +277,7 @@ deconsPattern ctorName fields = constructorToRecord : Constructor () -> Type () -constructorToRecord ( _, types ) = +constructorToRecord (Constructor _ types) = let fields : List (Morphir.IR.Type.Field ()) fields = From 0ebe518c68ad034c6ca5c330e51ea2620b59ec6b Mon Sep 17 00:00:00 2001 From: Attila Mihaly Date: Wed, 15 Apr 2020 15:04:43 -0400 Subject: [PATCH 21/42] Prepare Elm module publishing. #2 --- elm.json | 13 +------------ src/Morphir/SDK/StatefulApp.elm | 10 +++++++++- 2 files changed, 10 insertions(+), 13 deletions(-) diff --git a/elm.json b/elm.json index 53a4ae801..138ad68a9 100644 --- a/elm.json +++ b/elm.json @@ -5,18 +5,7 @@ "license": "Apache-2.0", "version": "1.0.0", "exposed-modules": [ - "Morphir.Pattern", - "Morphir.Rule", - "Morphir.Rewrite", - "Morphir.IR.AccessControlled", - "Morphir.IR.Package", - "Morphir.IR.Module", - "Morphir.IR.Name", - "Morphir.IR.Path", - "Morphir.IR.QName", - "Morphir.IR.FQName", - "Morphir.IR.Type", - "Morphir.IR.Value" + "Morphir.SDK.StatefulApp" ], "elm-version": "0.19.0 <= v < 0.20.0", "dependencies": { diff --git a/src/Morphir/SDK/StatefulApp.elm b/src/Morphir/SDK/StatefulApp.elm index 2ffd163ce..bebeb85c8 100644 --- a/src/Morphir/SDK/StatefulApp.elm +++ b/src/Morphir/SDK/StatefulApp.elm @@ -1,5 +1,13 @@ -module Morphir.SDK.StatefulApp exposing (..) +module Morphir.SDK.StatefulApp exposing (StatefulApp) +{-| Utilities for modeling stateful applications. +@docs StatefulApp + +-} + + +{-| Type that represents a stateful application. +-} type alias StatefulApp k c s e = { businessLogic : k -> Maybe s -> c -> ( k, Maybe s, e ) } From 08f7f2e96617295b7203a9c678bcf199d4b8e3fb Mon Sep 17 00:00:00 2001 From: Attila Mihaly Date: Wed, 15 Apr 2020 15:16:16 -0400 Subject: [PATCH 22/42] Fix repo name. #2 --- elm.json | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/elm.json b/elm.json index 138ad68a9..3f7633863 100644 --- a/elm.json +++ b/elm.json @@ -1,6 +1,6 @@ { "type": "package", - "name": "MorganStanley/morphir-elm", + "name": "Morgan-Stanley/morphir-elm", "summary": "Morphir Elm bindings", "license": "Apache-2.0", "version": "1.0.0", From 97d3280507313eed8c1d7232becb06f7ac65f4d3 Mon Sep 17 00:00:00 2001 From: Attila Mihaly Date: Thu, 16 Apr 2020 16:37:02 -0400 Subject: [PATCH 23/42] Support for let expressions. #54 --- elm.json | 1 + src/Morphir/Elm/Frontend.elm | 294 ++++++++++++++++++++++++++-- src/Morphir/Graph.elm | 64 +++--- src/Morphir/IR/Value.elm | 98 +++++++++- src/Morphir/ResultList.elm | 9 +- tests/Morphir/Elm/FrontendTests.elm | 143 +++++++++++++- tests/Morphir/GraphTests.elm | 4 +- 7 files changed, 555 insertions(+), 58 deletions(-) diff --git a/elm.json b/elm.json index 3f7633863..3b01c978b 100644 --- a/elm.json +++ b/elm.json @@ -13,6 +13,7 @@ "elm/json": "1.1.3 <= v < 2.0.0", "elm/parser": "1.1.0 <= v < 2.0.0", "elm/regex": "1.0.0 <= v < 2.0.0", + "elm-community/graph": "6.0.0 <= v < 7.0.0", "elm-explorations/test": "1.2.2 <= v < 2.0.0", "stil4m/elm-syntax": "7.1.1 <= v < 8.0.0" }, diff --git a/src/Morphir/Elm/Frontend.elm b/src/Morphir/Elm/Frontend.elm index 451f9cd85..2647b0473 100644 --- a/src/Morphir/Elm/Frontend.elm +++ b/src/Morphir/Elm/Frontend.elm @@ -14,10 +14,11 @@ import Elm.Syntax.Node as Node exposing (Node(..)) import Elm.Syntax.Pattern as Pattern exposing (Pattern(..)) import Elm.Syntax.Range exposing (Range) import Elm.Syntax.TypeAnnotation exposing (TypeAnnotation(..)) +import Graph exposing (Graph) import Json.Decode as Decode import Json.Encode as Encode import Morphir.Elm.Frontend.Resolve as Resolve exposing (ModuleResolver, PackageResolver) -import Morphir.Graph as Graph exposing (Graph) +import Morphir.Graph import Morphir.IR.AccessControlled exposing (AccessControlled, private, public) import Morphir.IR.FQName as FQName exposing (FQName, fQName) import Morphir.IR.Module as Module @@ -137,7 +138,7 @@ type alias Errors = type Error = ParseError String (List Parser.DeadEnd) - | CyclicModules (Graph (List String)) + | CyclicModules (Morphir.Graph.Graph () (List String)) | ResolveError SourceLocation Resolve.Error | EmptyApply SourceLocation | NotSupported SourceLocation String @@ -220,16 +221,15 @@ packageDefinitionFromSource packageInfo sourceFiles = allModules |> List.map (\( moduleName, parsedFile ) -> - ( moduleName + ( () + , moduleName , parsedFile.rawFile |> RawFile.imports |> List.map (.moduleName >> Node.value) - |> Set.fromList ) ) - |> Dict.fromList - |> Graph.fromDict - |> Graph.reachableNodes exposedModuleNames + |> Morphir.Graph.fromList + |> Morphir.Graph.reachableNodes exposedModuleNames in allModules |> List.filter @@ -244,18 +244,17 @@ packageDefinitionFromSource packageInfo sourceFiles = modules |> List.map (\( moduleName, parsedFile ) -> - ( moduleName + ( () + , moduleName , parsedFile.rawFile |> RawFile.imports |> List.map (.moduleName >> Node.value) - |> Set.fromList ) ) - |> Dict.fromList - |> Graph.fromDict - |> Graph.topologicalSort + |> Morphir.Graph.fromList + |> Morphir.Graph.topologicalSort in - if Graph.isEmpty cycles then + if Morphir.Graph.isEmpty cycles then Ok sortedModules else @@ -376,7 +375,7 @@ mapProcessedFile currentPackagePath processedFile modulesSoFar = valuesResult in moduleResult - |> Result.andThen (resolveLocalTypes currentPackagePath modulePath moduleResolver) + |> Result.andThen (resolveLocalNames currentPackagePath modulePath moduleResolver) |> Result.map (\m -> modulesSoFar @@ -838,7 +837,268 @@ mapExpression sourceFile (Node range exp) = mapExpression sourceFile expNode Expression.LetExpression letBlock -> - Err [ NotSupported sourceLocation "TODO: LetExpression" ] + let + namesReferredByExpression : Expression -> List String + namesReferredByExpression expression = + case expression of + Expression.Application argNodes -> + argNodes |> List.concatMap (Node.value >> namesReferredByExpression) + + Expression.OperatorApplication _ _ (Node _ leftExp) (Node _ rightExp) -> + namesReferredByExpression leftExp ++ namesReferredByExpression rightExp + + Expression.FunctionOrValue [] name -> + [ name ] + + Expression.IfBlock (Node _ condExp) (Node _ thenExp) (Node _ elseExp) -> + namesReferredByExpression condExp ++ namesReferredByExpression thenExp ++ namesReferredByExpression elseExp + + Expression.Negation (Node _ childExp) -> + namesReferredByExpression childExp + + Expression.TupledExpression argNodes -> + argNodes |> List.concatMap (Node.value >> namesReferredByExpression) + + Expression.ParenthesizedExpression (Node _ childExp) -> + namesReferredByExpression childExp + + Expression.LetExpression innerLetBlock -> + innerLetBlock.declarations + |> List.concatMap + (\(Node _ decl) -> + case decl of + Expression.LetFunction function -> + function.declaration |> Node.value |> .expression |> Node.value |> namesReferredByExpression + + Expression.LetDestructuring _ (Node _ childExp) -> + namesReferredByExpression childExp + ) + |> (++) (innerLetBlock.expression |> Node.value |> namesReferredByExpression) + + Expression.CaseExpression caseBlock -> + caseBlock.cases + |> List.concatMap + (\( _, Node _ childExp ) -> + namesReferredByExpression childExp + ) + |> (++) (caseBlock.expression |> Node.value |> namesReferredByExpression) + + Expression.LambdaExpression lambda -> + lambda.expression |> Node.value |> namesReferredByExpression + + Expression.RecordExpr setterNodes -> + setterNodes |> List.concatMap (\(Node _ ( _, Node _ childExp )) -> namesReferredByExpression childExp) + + Expression.ListExpr argNodes -> + argNodes |> List.concatMap (Node.value >> namesReferredByExpression) + + Expression.RecordAccess (Node _ childExp) _ -> + namesReferredByExpression childExp + + Expression.RecordUpdateExpression (Node _ recordRef) setterNodes -> + recordRef :: (setterNodes |> List.concatMap (\(Node _ ( _, Node _ childExp )) -> namesReferredByExpression childExp)) + + _ -> + [] + + namesBoundByPattern : Pattern -> List String + namesBoundByPattern pattern = + case pattern of + TuplePattern elemPatternNodes -> + elemPatternNodes |> List.concatMap (Node.value >> namesBoundByPattern) + + RecordPattern fieldNameNodes -> + fieldNameNodes |> List.map Node.value + + UnConsPattern (Node _ headPattern) (Node _ tailPattern) -> + namesBoundByPattern headPattern ++ namesBoundByPattern tailPattern + + ListPattern itemPatternNodes -> + itemPatternNodes |> List.concatMap (Node.value >> namesBoundByPattern) + + VarPattern name -> + [ name ] + + NamedPattern _ argPatternNodes -> + argPatternNodes |> List.concatMap (Node.value >> namesBoundByPattern) + + AsPattern (Node _ childPattern) (Node _ alias) -> + alias :: namesBoundByPattern childPattern + + ParenthesizedPattern (Node _ childPattern) -> + namesBoundByPattern childPattern + + _ -> + [] + + letBlockToValue : List (Node Expression.LetDeclaration) -> Node Expression -> Result Errors (Value.Value SourceLocation) + letBlockToValue declarationNodes inNode = + let + -- build a dictionary from variable name to declaration index + declarationIndexForName : Dict String Int + declarationIndexForName = + declarationNodes + |> List.indexedMap + (\index (Node _ decl) -> + case decl of + Expression.LetFunction function -> + [ ( function.declaration |> Node.value |> .name |> Node.value, index ) ] + + Expression.LetDestructuring (Node _ pattern) _ -> + namesBoundByPattern pattern + |> List.map (\name -> ( name, index )) + ) + |> List.concat + |> Dict.fromList + + -- build a dependency graph between declarations + declarationDependencyGraph : Graph (Node Expression.LetDeclaration) String + declarationDependencyGraph = + let + nodes : List (Graph.Node (Node Expression.LetDeclaration)) + nodes = + declarationNodes + |> List.indexedMap + (\index declNode -> + Graph.Node index declNode + ) + + edges : List (Graph.Edge String) + edges = + declarationNodes + |> List.indexedMap + (\fromIndex (Node _ decl) -> + case decl of + Expression.LetFunction function -> + function.declaration + |> Node.value + |> .expression + |> Node.value + |> namesReferredByExpression + |> List.filterMap + (\name -> + declarationIndexForName + |> Dict.get name + |> Maybe.map (\toIndex -> Graph.Edge fromIndex toIndex name) + ) + + Expression.LetDestructuring _ expression -> + expression + |> Node.value + |> namesReferredByExpression + |> List.filterMap + (\name -> + declarationIndexForName + |> Dict.get name + |> Maybe.map (\toIndex -> Graph.Edge fromIndex toIndex name) + ) + ) + |> List.concat + in + Graph.fromNodesAndEdges nodes edges + + letDeclarationToValue : Node Expression.LetDeclaration -> Result Errors (Value.Value SourceLocation) -> Result Errors (Value.Value SourceLocation) + letDeclarationToValue letDeclarationNode valueResult = + case letDeclarationNode |> Node.value of + Expression.LetFunction function -> + Result.map2 (Value.LetDefinition sourceLocation (function.declaration |> Node.value |> .name |> Node.value |> Name.fromString)) + (mapFunction sourceFile function) + valueResult + + Expression.LetDestructuring patternNode letExpressionNode -> + Result.map3 (Value.Destructure sourceLocation) + (mapPattern sourceFile patternNode) + (mapExpression sourceFile letExpressionNode) + valueResult + + componentGraphToValue : Graph (Node Expression.LetDeclaration) String -> Result Errors (Value.Value SourceLocation) -> Result Errors (Value.Value SourceLocation) + componentGraphToValue componentGraph valueResult = + case componentGraph |> Graph.checkAcyclic of + Ok acyclic -> + acyclic + |> Graph.topologicalSort + |> List.foldl + (\nodeContext innerSoFar -> + letDeclarationToValue nodeContext.node.label innerSoFar + ) + valueResult + + Err _ -> + Result.map2 (Value.LetRecursion sourceLocation) + (componentGraph + |> Graph.nodes + |> List.map + (\graphNode -> + case graphNode.label |> Node.value of + Expression.LetFunction function -> + mapFunction sourceFile function + |> Result.map (Tuple.pair (function.declaration |> Node.value |> .name |> Node.value |> Name.fromString)) + + Expression.LetDestructuring _ _ -> + Err [ NotSupported sourceLocation "Recursive destructuring" ] + ) + |> ResultList.toResult + |> Result.mapError List.concat + |> Result.map Dict.fromList + ) + valueResult + in + case declarationDependencyGraph |> Graph.stronglyConnectedComponents of + Ok acyclic -> + acyclic + |> Graph.topologicalSort + |> List.foldl + (\nodeContext soFar -> + letDeclarationToValue nodeContext.node.label soFar + ) + (mapExpression sourceFile inNode) + + Err components -> + components + |> List.foldl + componentGraphToValue + (mapExpression sourceFile inNode) + + --case declarationNodes of + -- [] -> + -- mapExpression sourceFile inNode + -- + -- firstDeclaration :: restOfDeclarations -> + -- case firstDeclaration |> Node.value of + -- Expression.LetFunction function -> + -- Result.map2 (Value.LetDefinition sourceLocation (function.declaration |> Node.value |> .name |> Node.value |> Name.fromString)) + -- (mapFunction sourceFile function) + -- (letBlockToValue restOfDeclarations inNode) + -- + -- Expression.LetDestructuring patternNode letExpressionNode -> + -- let + -- referencedNames : Set String + -- referencedNames = + -- letExpressionNode |> Node.value |> namesReferredByExpression |> Set.fromList + -- + -- ( referencedDecls, unreferencedDecls ) = + -- restOfDeclarations + -- |> List.partition + -- (\(Node _ decl) -> + -- case decl of + -- Expression.LetFunction function -> + -- referencedNames + -- |> Set.member (function.declaration |> Node.value |> .name |> Node.value) + -- + -- Expression.LetDestructuring _ (Node _ body) -> + -- Set.isEmpty + -- (Set.intersect + -- (namesReferredByExpression body |> Set.fromList) + -- referencedNames + -- ) + -- ) + -- in + -- Result.map3 (Value.Destructure sourceLocation) + -- (mapPattern sourceFile patternNode) + -- (mapExpression sourceFile letExpressionNode) + -- (letBlockToValue restOfDeclarations inNode) + in + letBlockToValue letBlock.declarations letBlock.expression Expression.CaseExpression caseBlock -> Result.map2 (Value.PatternMatch sourceLocation) @@ -1003,8 +1263,8 @@ mapPattern sourceFile (Node range pattern) = mapPattern sourceFile childNode -resolveLocalTypes : Path -> Path -> ModuleResolver -> Module.Definition SourceLocation -> Result Errors (Module.Definition SourceLocation) -resolveLocalTypes packagePath modulePath moduleResolver moduleDef = +resolveLocalNames : Path -> Path -> ModuleResolver -> Module.Definition SourceLocation -> Result Errors (Module.Definition SourceLocation) +resolveLocalNames packagePath modulePath moduleResolver moduleDef = let rewriteTypes : Type SourceLocation -> Result Error (Type SourceLocation) rewriteTypes = diff --git a/src/Morphir/Graph.elm b/src/Morphir/Graph.elm index bc93f4f16..dcaf99199 100644 --- a/src/Morphir/Graph.elm +++ b/src/Morphir/Graph.elm @@ -1,72 +1,75 @@ -module Morphir.Graph exposing (Graph, empty, fromDict, fromList, isEmpty, reachableNodes, topologicalSort) +module Morphir.Graph exposing (Graph, empty, fromList, isEmpty, reachableNodes, topologicalSort) import Dict exposing (Dict) import Set exposing (Set) -type Graph comparable - = Graph (Dict comparable (Set comparable)) +type Graph node comparable + = Graph (List ( node, comparable, Set comparable )) -fromDict : Dict comparable (Set comparable) -> Graph comparable -fromDict = - Graph - - -fromList : List ( comparable, List comparable ) -> Graph comparable +fromList : List ( node, comparable, List comparable ) -> Graph node comparable fromList list = list - |> List.map (\( from, tos ) -> ( from, Set.fromList tos )) - |> Dict.fromList + |> List.map (\( node, fromKey, toKeys ) -> ( node, fromKey, Set.fromList toKeys )) |> Graph -empty : Graph comparable +empty : Graph node comparable empty = - Graph Dict.empty + Graph [] -isEmpty : Graph comparable -> Bool +isEmpty : Graph node comparable -> Bool isEmpty (Graph edges) = - Dict.isEmpty edges + List.isEmpty edges -topologicalSort : Graph comparable -> ( List comparable, Graph comparable ) +topologicalSort : Graph node comparable -> ( List comparable, Graph node comparable ) topologicalSort (Graph edges) = let + normalize : List ( node, comparable, Set comparable ) -> List ( node, comparable, Set comparable ) normalize graphEdges = let toNodes = graphEdges - |> Dict.values + |> List.map (\( _, _, toKeys ) -> toKeys) |> List.foldl Set.union Set.empty fromNodes = graphEdges - |> Dict.keys + |> List.map (\( _, fromKey, _ ) -> fromKey) |> Set.fromList emptyFromNodes = Set.diff toNodes fromNodes |> Set.toList - |> List.map - (\from -> - ( from, Set.empty ) + |> List.concatMap + (\fromKey -> + graphEdges + |> List.filterMap + (\( node, key, _ ) -> + if key == fromKey then + Just ( node, fromKey, Set.empty ) + + else + Nothing + ) ) - |> Dict.fromList in - Dict.union graphEdges emptyFromNodes + graphEdges ++ emptyFromNodes + step : List ( node, comparable, Set comparable ) -> List comparable -> ( List comparable, Graph node comparable ) step graphEdges sorting = let toNodes = graphEdges - |> Dict.values + |> List.map (\( _, _, toKeys ) -> toKeys) |> List.foldl Set.union Set.empty fromNodes = graphEdges - |> Dict.keys + |> List.map (\( _, fromKey, _ ) -> fromKey) |> Set.fromList startNodes = @@ -77,12 +80,10 @@ topologicalSort (Graph edges) = let newGraphEdges = graphEdges - |> Dict.toList |> List.filter - (\( from, tos ) -> - from /= startNode + (\( _, fromKey, _ ) -> + fromKey /= startNode ) - |> Dict.fromList in step newGraphEdges (startNode :: sorting) @@ -92,15 +93,14 @@ topologicalSort (Graph edges) = step (normalize edges) [] -reachableNodes : Set comparable -> Graph comparable -> Set comparable +reachableNodes : Set comparable -> Graph node comparable -> Set comparable reachableNodes startNodes (Graph edges) = let directlyReachable : Set comparable -> Set comparable directlyReachable fromNodes = edges - |> Dict.toList |> List.filterMap - (\( fromNode, toNodes ) -> + (\( _, fromNode, toNodes ) -> if fromNodes |> Set.member fromNode then Just toNodes diff --git a/src/Morphir/IR/Value.elm b/src/Morphir/IR/Value.elm index 6bf86f9fc..aac114a0c 100644 --- a/src/Morphir/IR/Value.elm +++ b/src/Morphir/IR/Value.elm @@ -64,12 +64,14 @@ which is just the specification of those. Value definitions can be typed or unty -} +import Dict exposing (Dict) import Json.Decode as Decode import Json.Encode as Encode import Morphir.IR.FQName exposing (FQName, decodeFQName, encodeFQName) import Morphir.IR.Name exposing (Name, decodeName, encodeName) import Morphir.IR.Type as Type exposing (Type, decodeType, encodeType) import Morphir.ResultList as ResultList +import Morphir.Rewrite exposing (Rewrite) import String @@ -88,7 +90,7 @@ type Value a | Apply a (Value a) (Value a) | Lambda a (Pattern a) (Value a) | LetDefinition a Name (Definition a) (Value a) - | LetRecursion a (List ( Name, Definition a )) (Value a) + | LetRecursion a (Dict Name (Definition a)) (Value a) | Destructure a (Pattern a) (Value a) (Value a) | IfThenElse a (Value a) (Value a) (Value a) | PatternMatch a (Value a) (List ( Pattern a, Value a )) @@ -246,9 +248,9 @@ mapValueAttributes f v = LetRecursion a valueDefinitions inValue -> LetRecursion (f a) (valueDefinitions - |> List.map - (\( name, def ) -> - ( name, mapDefinitionAttributes f def ) + |> Dict.map + (\_ def -> + mapDefinitionAttributes f def ) ) (mapValueAttributes f inValue) @@ -324,6 +326,90 @@ mapDefinitionAttributes f d = UntypedDefinition args (mapValueAttributes f body) + +--rewriteValue : Rewrite e (Value a) +--rewriteValue rewriteBranch rewriteLeaf valueToRewrite = +-- case valueToRewrite of +-- Tuple a elements -> +-- elements +-- |> List.map rewriteBranch +-- |> ResultList.liftLastError +-- |> Result.map (Tuple a) +-- +-- List a items -> +-- items +-- |> List.map rewriteBranch +-- |> ResultList.liftLastError +-- |> Result.map (List a) +-- +-- Record a fields -> +-- fields +-- |> List.map +-- (\( fieldName, fieldValue ) -> +-- rewriteBranch fieldValue +-- |> Result.map (Tuple.pair fieldName) +-- ) +-- |> ResultList.liftLastError +-- |> Result.map (Record a) +-- +-- Field a subjectValue fieldName -> +-- rewriteBranch subjectValue +-- |> Result.map +-- (\subject -> +-- Field a subject fieldName +-- ) +-- +-- Apply a function argument -> +-- Result.map2 (Apply a) +-- (rewriteBranch function) +-- (rewriteBranch argument) +-- +-- Lambda a argumentPattern body -> +-- Lambda (f a) (mapPatternAttributes f argumentPattern) (mapValueAttributes f body) +-- +-- LetDefinition a valueName valueDefinition inValue -> +-- LetDefinition (f a) valueName (mapDefinitionAttributes f valueDefinition) (mapValueAttributes f inValue) +-- +-- LetRecursion a valueDefinitions inValue -> +-- LetRecursion (f a) +-- (valueDefinitions +-- |> List.map +-- (\( name, def ) -> +-- ( name, mapDefinitionAttributes f def ) +-- ) +-- ) +-- (mapValueAttributes f inValue) +-- +-- Destructure a pattern valueToDestruct inValue -> +-- Destructure (f a) (mapPatternAttributes f pattern) (mapValueAttributes f valueToDestruct) (mapValueAttributes f inValue) +-- +-- IfThenElse a condition thenBranch elseBranch -> +-- IfThenElse (f a) (mapValueAttributes f condition) (mapValueAttributes f thenBranch) (mapValueAttributes f elseBranch) +-- +-- PatternMatch a branchOutOn cases -> +-- PatternMatch (f a) +-- (mapValueAttributes f branchOutOn) +-- (cases +-- |> List.map +-- (\( pattern, body ) -> +-- ( mapPatternAttributes f pattern, mapValueAttributes f body ) +-- ) +-- ) +-- +-- UpdateRecord a valueToUpdate fieldsToUpdate -> +-- UpdateRecord (f a) +-- (mapValueAttributes f valueToUpdate) +-- (fieldsToUpdate +-- |> List.map +-- (\( fieldName, fieldValue ) -> +-- ( fieldName, mapValueAttributes f fieldValue ) +-- ) +-- ) +-- +-- _ -> +-- rewriteLeaf valueToRewrite + + {-| A [literal][lit] represents a fixed value in the IR. We only allow values of basic types: bool, char, string, int, float. True -- Literal (BoolLiteral True) @@ -533,7 +619,7 @@ letDef attributes valueName valueDefinition inValue = -- (Variable [ "a" ]) -} -letRec : a -> List ( Name, Definition a ) -> Value a -> Value a +letRec : a -> Dict Name (Definition a) -> Value a -> Value a letRec attributes valueDefinitions inValue = LetRecursion attributes valueDefinitions inValue @@ -921,6 +1007,7 @@ encodeValue encodeAttributes v = [ Encode.string "LetRecursion" , encodeAttributes a , valueDefinitions + |> Dict.toList |> Encode.list (\( name, def ) -> Encode.list identity @@ -1079,6 +1166,7 @@ decodeValue decodeAttributes = (Decode.index 0 decodeName) (Decode.index 1 <| decodeDefinition decodeAttributes) ) + |> Decode.map Dict.fromList ) ) (Decode.index 3 <| decodeValue decodeAttributes) diff --git a/src/Morphir/ResultList.elm b/src/Morphir/ResultList.elm index 51d46172d..12e44eaa0 100644 --- a/src/Morphir/ResultList.elm +++ b/src/Morphir/ResultList.elm @@ -1,4 +1,4 @@ -module Morphir.ResultList exposing (reduce, toResult) +module Morphir.ResultList exposing (liftLastError, reduce, toResult) reduce : (List a -> b) -> List (Result e a) -> Result e b @@ -61,3 +61,10 @@ toResult results = _ -> Err errs + + +{-| Turn a list of results into a single result of a list returning only the last error in the list. +-} +liftLastError : List (Result e a) -> Result e (List a) +liftLastError results = + List.foldr (Result.map2 (::)) (Ok []) results diff --git a/tests/Morphir/Elm/FrontendTests.elm b/tests/Morphir/Elm/FrontendTests.elm index b6517fd27..9e9f372c3 100644 --- a/tests/Morphir/Elm/FrontendTests.elm +++ b/tests/Morphir/Elm/FrontendTests.elm @@ -20,7 +20,7 @@ import Morphir.IR.SDK.Maybe as Maybe import Morphir.IR.SDK.Number as Number import Morphir.IR.SDK.String as String import Morphir.IR.Type as Type -import Morphir.IR.Value as Value exposing (Literal(..), Pattern(..), Value(..)) +import Morphir.IR.Value as Value exposing (Definition(..), Literal(..), Pattern(..), Value(..)) import Set import Test exposing (..) @@ -237,6 +237,10 @@ valueTests = ref : String -> Value () ref name = Reference () (fQName [] [] [ name ]) + + var : String -> Pattern () + var name = + AsPattern () (WildcardPattern ()) (Name.fromString name) in describe "Values are mapped correctly" [ checkIR "()" <| Unit () @@ -297,6 +301,143 @@ valueTests = , checkIR "a << b" <| Composition.composeLeft () (ref "a") (ref "b") , checkIR "a >> b" <| Composition.composeRight () (ref "a") (ref "b") , checkIR "a :: b" <| List.construct () (ref "a") (ref "b") + , checkIR + (String.join "\n" + [ " let" + , " ( a, b ) = c" + , " in" + , " d" + ] + ) + <| + Destructure () + (TuplePattern () [ var "a", var "b" ]) + (ref "c") + (ref "d") + , checkIR + (String.join "\n" + [ " let" + , " foo a = c" + , " in" + , " d" + ] + ) + <| + LetDefinition () + (Name.fromString "foo") + (UntypedDefinition [ Name.fromString "a" ] (ref "c")) + (ref "d") + , checkIR + (String.join "\n" + [ " let" + , " ( a, b ) = c" + , " ( d, e ) = a" + , " in" + , " f" + ] + ) + <| + Destructure () + (TuplePattern () [ var "a", var "b" ]) + (ref "c") + (Destructure () + (TuplePattern () [ var "d", var "e" ]) + (ref "a") + (ref "f") + ) + , checkIR + (String.join "\n" + [ " let" + , " ( d, e ) = a" + , " ( a, b ) = c" + , " in" + , " f" + ] + ) + <| + Destructure () + (TuplePattern () [ var "a", var "b" ]) + (ref "c") + (Destructure () + (TuplePattern () [ var "d", var "e" ]) + (ref "a") + (ref "f") + ) + , checkIR + (String.join "\n" + [ " let" + , " b = c" + , " a = b" + , " in" + , " a" + ] + ) + <| + LetDefinition () + (Name.fromString "b") + (UntypedDefinition [] (ref "c")) + (LetDefinition () + (Name.fromString "a") + (UntypedDefinition [] (ref "b")) + (ref "a") + ) + , checkIR + (String.join "\n" + [ " let" + , " a = b" + , " b = c" + , " in" + , " a" + ] + ) + <| + LetDefinition () + (Name.fromString "b") + (UntypedDefinition [] (ref "c")) + (LetDefinition () + (Name.fromString "a") + (UntypedDefinition [] (ref "b")) + (ref "a") + ) + , checkIR + (String.join "\n" + [ " let" + , " a = b" + , " b = a" + , " in" + , " a" + ] + ) + <| + LetRecursion () + (Dict.fromList + [ ( Name.fromString "b", UntypedDefinition [] (ref "a") ) + , ( Name.fromString "a", UntypedDefinition [] (ref "b") ) + ] + ) + (ref "a") + , checkIR + (String.join "\n" + [ " let" + , " c = d" + , " a = b" + , " b = a" + , " in" + , " a" + ] + ) + <| + LetDefinition () + (Name.fromString "c") + (UntypedDefinition [] (ref "d")) + (LetRecursion () + (Dict.fromList + [ ( Name.fromString "b", UntypedDefinition [] (ref "a") ) + , ( Name.fromString "a", UntypedDefinition [] (ref "b") ) + ] + ) + (ref "a") + ) ] diff --git a/tests/Morphir/GraphTests.elm b/tests/Morphir/GraphTests.elm index 4862e9c65..f8b521191 100644 --- a/tests/Morphir/GraphTests.elm +++ b/tests/Morphir/GraphTests.elm @@ -25,12 +25,12 @@ reachableNodesTests = |> Expect.equal Set.empty , test "unreachable node removed" <| \_ -> - Graph.fromList [ ( 1, [ 2 ] ), ( 2, [ 3 ] ), ( 4, [ 5 ] ) ] + Graph.fromList [ ( "1", 1, [ 2 ] ), ( "2", 2, [ 3 ] ), ( "4", 4, [ 5 ] ) ] |> Graph.reachableNodes (Set.fromList [ 1 ]) |> Expect.equal (Set.fromList [ 1, 2, 3 ]) , test "cycles handled gracefully" <| \_ -> - Graph.fromList [ ( 1, [ 2 ] ), ( 2, [ 1 ] ), ( 4, [ 5 ] ) ] + Graph.fromList [ ( "1", 1, [ 2 ] ), ( "2", 2, [ 1 ] ), ( "4", 4, [ 5 ] ) ] |> Graph.reachableNodes (Set.fromList [ 1 ]) |> Expect.equal (Set.fromList [ 1, 2 ]) ] From 7010d20fd21fba4805236f18a2013bf9a7e5a7af Mon Sep 17 00:00:00 2001 From: Attila Mihaly Date: Thu, 16 Apr 2020 20:57:31 -0400 Subject: [PATCH 24/42] Simple join implementations. #64 --- src/Morphir/SDK/List.elm | 68 +++++++++++++++++++++++++++++++++ tests/Morphir/SDK/ListTests.elm | 36 +++++++++++++++++ 2 files changed, 104 insertions(+) create mode 100644 src/Morphir/SDK/List.elm create mode 100644 tests/Morphir/SDK/ListTests.elm diff --git a/src/Morphir/SDK/List.elm b/src/Morphir/SDK/List.elm new file mode 100644 index 000000000..b07b5fe2b --- /dev/null +++ b/src/Morphir/SDK/List.elm @@ -0,0 +1,68 @@ +module Morphir.SDK.List exposing (..) + + +innerJoin : List b -> (a -> b -> Bool) -> List a -> List ( a, b ) +innerJoin listB onPredicate listA = + listA + |> List.concatMap + (\a -> + listB + |> List.filterMap + (\b -> + if onPredicate a b then + Just ( a, b ) + + else + Nothing + ) + ) + + +leftJoin : List b -> (a -> b -> Bool) -> List a -> List ( a, Maybe b ) +leftJoin listB onPredicate listA = + listA + |> List.concatMap + (\a -> + let + matchingRows = + listB + |> List.filterMap + (\b -> + if onPredicate a b then + Just ( a, Just b ) + + else + Nothing + ) + in + if List.isEmpty matchingRows then + [ ( a, Nothing ) ] + + else + matchingRows + ) + + +rightJoin : List b -> (a -> b -> Bool) -> List a -> List ( Maybe a, b ) +rightJoin listB onPredicate listA = + listB + |> List.concatMap + (\b -> + let + matchingRows = + listA + |> List.filterMap + (\a -> + if onPredicate a b then + Just ( Just a, b ) + + else + Nothing + ) + in + if List.isEmpty matchingRows then + [ ( Nothing, b ) ] + + else + matchingRows + ) diff --git a/tests/Morphir/SDK/ListTests.elm b/tests/Morphir/SDK/ListTests.elm new file mode 100644 index 000000000..a7703a0ee --- /dev/null +++ b/tests/Morphir/SDK/ListTests.elm @@ -0,0 +1,36 @@ +module Morphir.SDK.ListTests exposing (joinTests) + +import Expect +import Morphir.SDK.List as List +import Test exposing (..) + + +joinTests : Test +joinTests = + describe "joins" + [ test "inner filters left" <| + \_ -> + [ 1, 2, 3 ] + |> List.innerJoin [ 1, 3 ] (==) + |> Expect.equal [ ( 1, 1 ), ( 3, 3 ) ] + , test "inner filters right" <| + \_ -> + [ 1, 2 ] + |> List.innerJoin [ 1, 2, 3 ] (==) + |> Expect.equal [ ( 1, 1 ), ( 2, 2 ) ] + , test "inner filters both" <| + \_ -> + [ 1, 2 ] + |> List.innerJoin [ 1, 3 ] (==) + |> Expect.equal [ ( 1, 1 ) ] + , test "left outer keeps left" <| + \_ -> + [ 1, 2 ] + |> List.leftJoin [ 1, 3 ] (==) + |> Expect.equal [ ( 1, Just 1 ), ( 2, Nothing ) ] + , test "right outer keeps right" <| + \_ -> + [ 1, 2 ] + |> List.rightJoin [ 1, 3 ] (==) + |> Expect.equal [ ( Just 1, 1 ), ( Nothing, 3 ) ] + ] From 5cb79b3174668b18c7277318e8588b2dd1f590c9 Mon Sep 17 00:00:00 2001 From: Attila Mihaly Date: Fri, 17 Apr 2020 15:54:59 -0400 Subject: [PATCH 25/42] Refactoring to make the code more organized. --- src/Morphir/Elm/Frontend.elm | 655 +++++++++++++++++------------------ 1 file changed, 317 insertions(+), 338 deletions(-) diff --git a/src/Morphir/Elm/Frontend.elm b/src/Morphir/Elm/Frontend.elm index 2647b0473..803e1bc61 100644 --- a/src/Morphir/Elm/Frontend.elm +++ b/src/Morphir/Elm/Frontend.elm @@ -707,82 +707,7 @@ mapExpression sourceFile (Node range exp) = |> Result.andThen (List.reverse >> toApply) Expression.OperatorApplication op infixDirection leftNode rightNode -> - let - applyBinary : (SourceLocation -> Value SourceLocation -> Value SourceLocation -> Value SourceLocation) -> Result Errors (Value.Value SourceLocation) - applyBinary fun = - Result.map2 (fun sourceLocation) - (mapExpression sourceFile leftNode) - (mapExpression sourceFile rightNode) - in - case op of - "<|" -> - -- the purpose of this operator is cleaner syntax so it's not mapped to the IR - Result.map2 (Value.Apply sourceLocation) - (mapExpression sourceFile leftNode) - (mapExpression sourceFile rightNode) - - "|>" -> - -- the purpose of this operator is cleaner syntax so it's not mapped to the IR - Result.map2 (Value.Apply sourceLocation) - (mapExpression sourceFile rightNode) - (mapExpression sourceFile leftNode) - - "||" -> - applyBinary Bool.or - - "&&" -> - applyBinary Bool.and - - "==" -> - applyBinary Equality.equal - - "/=" -> - applyBinary Equality.notEqual - - "<" -> - applyBinary Comparison.lessThan - - ">" -> - applyBinary Comparison.greaterThan - - "<=" -> - applyBinary Comparison.lessThanOrEqual - - ">=" -> - applyBinary Comparison.greaterThanOrEqual - - "++" -> - applyBinary Appending.append - - "+" -> - applyBinary Number.add - - "-" -> - applyBinary Number.subtract - - "*" -> - applyBinary Number.multiply - - "/" -> - applyBinary Float.divide - - "//" -> - applyBinary Int.divide - - "^" -> - applyBinary Number.power - - "<<" -> - applyBinary Composition.composeLeft - - ">>" -> - applyBinary Composition.composeRight - - "::" -> - applyBinary List.construct - - _ -> - Err [ NotSupported sourceLocation <| "OperatorApplication: " ++ op ] + mapOperator sourceFile sourceLocation op leftNode rightNode Expression.FunctionOrValue moduleName valueName -> case ( moduleName, valueName ) of @@ -837,268 +762,7 @@ mapExpression sourceFile (Node range exp) = mapExpression sourceFile expNode Expression.LetExpression letBlock -> - let - namesReferredByExpression : Expression -> List String - namesReferredByExpression expression = - case expression of - Expression.Application argNodes -> - argNodes |> List.concatMap (Node.value >> namesReferredByExpression) - - Expression.OperatorApplication _ _ (Node _ leftExp) (Node _ rightExp) -> - namesReferredByExpression leftExp ++ namesReferredByExpression rightExp - - Expression.FunctionOrValue [] name -> - [ name ] - - Expression.IfBlock (Node _ condExp) (Node _ thenExp) (Node _ elseExp) -> - namesReferredByExpression condExp ++ namesReferredByExpression thenExp ++ namesReferredByExpression elseExp - - Expression.Negation (Node _ childExp) -> - namesReferredByExpression childExp - - Expression.TupledExpression argNodes -> - argNodes |> List.concatMap (Node.value >> namesReferredByExpression) - - Expression.ParenthesizedExpression (Node _ childExp) -> - namesReferredByExpression childExp - - Expression.LetExpression innerLetBlock -> - innerLetBlock.declarations - |> List.concatMap - (\(Node _ decl) -> - case decl of - Expression.LetFunction function -> - function.declaration |> Node.value |> .expression |> Node.value |> namesReferredByExpression - - Expression.LetDestructuring _ (Node _ childExp) -> - namesReferredByExpression childExp - ) - |> (++) (innerLetBlock.expression |> Node.value |> namesReferredByExpression) - - Expression.CaseExpression caseBlock -> - caseBlock.cases - |> List.concatMap - (\( _, Node _ childExp ) -> - namesReferredByExpression childExp - ) - |> (++) (caseBlock.expression |> Node.value |> namesReferredByExpression) - - Expression.LambdaExpression lambda -> - lambda.expression |> Node.value |> namesReferredByExpression - - Expression.RecordExpr setterNodes -> - setterNodes |> List.concatMap (\(Node _ ( _, Node _ childExp )) -> namesReferredByExpression childExp) - - Expression.ListExpr argNodes -> - argNodes |> List.concatMap (Node.value >> namesReferredByExpression) - - Expression.RecordAccess (Node _ childExp) _ -> - namesReferredByExpression childExp - - Expression.RecordUpdateExpression (Node _ recordRef) setterNodes -> - recordRef :: (setterNodes |> List.concatMap (\(Node _ ( _, Node _ childExp )) -> namesReferredByExpression childExp)) - - _ -> - [] - - namesBoundByPattern : Pattern -> List String - namesBoundByPattern pattern = - case pattern of - TuplePattern elemPatternNodes -> - elemPatternNodes |> List.concatMap (Node.value >> namesBoundByPattern) - - RecordPattern fieldNameNodes -> - fieldNameNodes |> List.map Node.value - - UnConsPattern (Node _ headPattern) (Node _ tailPattern) -> - namesBoundByPattern headPattern ++ namesBoundByPattern tailPattern - - ListPattern itemPatternNodes -> - itemPatternNodes |> List.concatMap (Node.value >> namesBoundByPattern) - - VarPattern name -> - [ name ] - - NamedPattern _ argPatternNodes -> - argPatternNodes |> List.concatMap (Node.value >> namesBoundByPattern) - - AsPattern (Node _ childPattern) (Node _ alias) -> - alias :: namesBoundByPattern childPattern - - ParenthesizedPattern (Node _ childPattern) -> - namesBoundByPattern childPattern - - _ -> - [] - - letBlockToValue : List (Node Expression.LetDeclaration) -> Node Expression -> Result Errors (Value.Value SourceLocation) - letBlockToValue declarationNodes inNode = - let - -- build a dictionary from variable name to declaration index - declarationIndexForName : Dict String Int - declarationIndexForName = - declarationNodes - |> List.indexedMap - (\index (Node _ decl) -> - case decl of - Expression.LetFunction function -> - [ ( function.declaration |> Node.value |> .name |> Node.value, index ) ] - - Expression.LetDestructuring (Node _ pattern) _ -> - namesBoundByPattern pattern - |> List.map (\name -> ( name, index )) - ) - |> List.concat - |> Dict.fromList - - -- build a dependency graph between declarations - declarationDependencyGraph : Graph (Node Expression.LetDeclaration) String - declarationDependencyGraph = - let - nodes : List (Graph.Node (Node Expression.LetDeclaration)) - nodes = - declarationNodes - |> List.indexedMap - (\index declNode -> - Graph.Node index declNode - ) - - edges : List (Graph.Edge String) - edges = - declarationNodes - |> List.indexedMap - (\fromIndex (Node _ decl) -> - case decl of - Expression.LetFunction function -> - function.declaration - |> Node.value - |> .expression - |> Node.value - |> namesReferredByExpression - |> List.filterMap - (\name -> - declarationIndexForName - |> Dict.get name - |> Maybe.map (\toIndex -> Graph.Edge fromIndex toIndex name) - ) - - Expression.LetDestructuring _ expression -> - expression - |> Node.value - |> namesReferredByExpression - |> List.filterMap - (\name -> - declarationIndexForName - |> Dict.get name - |> Maybe.map (\toIndex -> Graph.Edge fromIndex toIndex name) - ) - ) - |> List.concat - in - Graph.fromNodesAndEdges nodes edges - - letDeclarationToValue : Node Expression.LetDeclaration -> Result Errors (Value.Value SourceLocation) -> Result Errors (Value.Value SourceLocation) - letDeclarationToValue letDeclarationNode valueResult = - case letDeclarationNode |> Node.value of - Expression.LetFunction function -> - Result.map2 (Value.LetDefinition sourceLocation (function.declaration |> Node.value |> .name |> Node.value |> Name.fromString)) - (mapFunction sourceFile function) - valueResult - - Expression.LetDestructuring patternNode letExpressionNode -> - Result.map3 (Value.Destructure sourceLocation) - (mapPattern sourceFile patternNode) - (mapExpression sourceFile letExpressionNode) - valueResult - - componentGraphToValue : Graph (Node Expression.LetDeclaration) String -> Result Errors (Value.Value SourceLocation) -> Result Errors (Value.Value SourceLocation) - componentGraphToValue componentGraph valueResult = - case componentGraph |> Graph.checkAcyclic of - Ok acyclic -> - acyclic - |> Graph.topologicalSort - |> List.foldl - (\nodeContext innerSoFar -> - letDeclarationToValue nodeContext.node.label innerSoFar - ) - valueResult - - Err _ -> - Result.map2 (Value.LetRecursion sourceLocation) - (componentGraph - |> Graph.nodes - |> List.map - (\graphNode -> - case graphNode.label |> Node.value of - Expression.LetFunction function -> - mapFunction sourceFile function - |> Result.map (Tuple.pair (function.declaration |> Node.value |> .name |> Node.value |> Name.fromString)) - - Expression.LetDestructuring _ _ -> - Err [ NotSupported sourceLocation "Recursive destructuring" ] - ) - |> ResultList.toResult - |> Result.mapError List.concat - |> Result.map Dict.fromList - ) - valueResult - in - case declarationDependencyGraph |> Graph.stronglyConnectedComponents of - Ok acyclic -> - acyclic - |> Graph.topologicalSort - |> List.foldl - (\nodeContext soFar -> - letDeclarationToValue nodeContext.node.label soFar - ) - (mapExpression sourceFile inNode) - - Err components -> - components - |> List.foldl - componentGraphToValue - (mapExpression sourceFile inNode) - - --case declarationNodes of - -- [] -> - -- mapExpression sourceFile inNode - -- - -- firstDeclaration :: restOfDeclarations -> - -- case firstDeclaration |> Node.value of - -- Expression.LetFunction function -> - -- Result.map2 (Value.LetDefinition sourceLocation (function.declaration |> Node.value |> .name |> Node.value |> Name.fromString)) - -- (mapFunction sourceFile function) - -- (letBlockToValue restOfDeclarations inNode) - -- - -- Expression.LetDestructuring patternNode letExpressionNode -> - -- let - -- referencedNames : Set String - -- referencedNames = - -- letExpressionNode |> Node.value |> namesReferredByExpression |> Set.fromList - -- - -- ( referencedDecls, unreferencedDecls ) = - -- restOfDeclarations - -- |> List.partition - -- (\(Node _ decl) -> - -- case decl of - -- Expression.LetFunction function -> - -- referencedNames - -- |> Set.member (function.declaration |> Node.value |> .name |> Node.value) - -- - -- Expression.LetDestructuring _ (Node _ body) -> - -- Set.isEmpty - -- (Set.intersect - -- (namesReferredByExpression body |> Set.fromList) - -- referencedNames - -- ) - -- ) - -- in - -- Result.map3 (Value.Destructure sourceLocation) - -- (mapPattern sourceFile patternNode) - -- (mapExpression sourceFile letExpressionNode) - -- (letBlockToValue restOfDeclarations inNode) - in - letBlockToValue letBlock.declarations letBlock.expression + mapLetExpression sourceFile sourceLocation letBlock Expression.CaseExpression caseBlock -> Result.map2 (Value.PatternMatch sourceLocation) @@ -1263,6 +927,321 @@ mapPattern sourceFile (Node range pattern) = mapPattern sourceFile childNode +mapOperator : SourceFile -> SourceLocation -> String -> Node Expression -> Node Expression -> Result Errors (Value.Value SourceLocation) +mapOperator sourceFile sourceLocation op leftNode rightNode = + let + applyBinary : (SourceLocation -> Value SourceLocation -> Value SourceLocation -> Value SourceLocation) -> Result Errors (Value.Value SourceLocation) + applyBinary fun = + Result.map2 (fun sourceLocation) + (mapExpression sourceFile leftNode) + (mapExpression sourceFile rightNode) + in + case op of + "<|" -> + -- the purpose of this operator is cleaner syntax so it's not mapped to the IR + Result.map2 (Value.Apply sourceLocation) + (mapExpression sourceFile leftNode) + (mapExpression sourceFile rightNode) + + "|>" -> + -- the purpose of this operator is cleaner syntax so it's not mapped to the IR + Result.map2 (Value.Apply sourceLocation) + (mapExpression sourceFile rightNode) + (mapExpression sourceFile leftNode) + + "||" -> + applyBinary Bool.or + + "&&" -> + applyBinary Bool.and + + "==" -> + applyBinary Equality.equal + + "/=" -> + applyBinary Equality.notEqual + + "<" -> + applyBinary Comparison.lessThan + + ">" -> + applyBinary Comparison.greaterThan + + "<=" -> + applyBinary Comparison.lessThanOrEqual + + ">=" -> + applyBinary Comparison.greaterThanOrEqual + + "++" -> + applyBinary Appending.append + + "+" -> + applyBinary Number.add + + "-" -> + applyBinary Number.subtract + + "*" -> + applyBinary Number.multiply + + "/" -> + applyBinary Float.divide + + "//" -> + applyBinary Int.divide + + "^" -> + applyBinary Number.power + + "<<" -> + applyBinary Composition.composeLeft + + ">>" -> + applyBinary Composition.composeRight + + "::" -> + applyBinary List.construct + + _ -> + Err [ NotSupported sourceLocation <| "OperatorApplication: " ++ op ] + + +mapLetExpression : SourceFile -> SourceLocation -> Expression.LetBlock -> Result Errors (Value SourceLocation) +mapLetExpression sourceFile sourceLocation letBlock = + let + namesReferredByExpression : Expression -> List String + namesReferredByExpression expression = + case expression of + Expression.Application argNodes -> + argNodes |> List.concatMap (Node.value >> namesReferredByExpression) + + Expression.OperatorApplication _ _ (Node _ leftExp) (Node _ rightExp) -> + namesReferredByExpression leftExp ++ namesReferredByExpression rightExp + + Expression.FunctionOrValue [] name -> + [ name ] + + Expression.IfBlock (Node _ condExp) (Node _ thenExp) (Node _ elseExp) -> + namesReferredByExpression condExp ++ namesReferredByExpression thenExp ++ namesReferredByExpression elseExp + + Expression.Negation (Node _ childExp) -> + namesReferredByExpression childExp + + Expression.TupledExpression argNodes -> + argNodes |> List.concatMap (Node.value >> namesReferredByExpression) + + Expression.ParenthesizedExpression (Node _ childExp) -> + namesReferredByExpression childExp + + Expression.LetExpression innerLetBlock -> + innerLetBlock.declarations + |> List.concatMap + (\(Node _ decl) -> + case decl of + Expression.LetFunction function -> + function.declaration |> Node.value |> .expression |> Node.value |> namesReferredByExpression + + Expression.LetDestructuring _ (Node _ childExp) -> + namesReferredByExpression childExp + ) + |> (++) (innerLetBlock.expression |> Node.value |> namesReferredByExpression) + + Expression.CaseExpression caseBlock -> + caseBlock.cases + |> List.concatMap + (\( _, Node _ childExp ) -> + namesReferredByExpression childExp + ) + |> (++) (caseBlock.expression |> Node.value |> namesReferredByExpression) + + Expression.LambdaExpression lambda -> + lambda.expression |> Node.value |> namesReferredByExpression + + Expression.RecordExpr setterNodes -> + setterNodes |> List.concatMap (\(Node _ ( _, Node _ childExp )) -> namesReferredByExpression childExp) + + Expression.ListExpr argNodes -> + argNodes |> List.concatMap (Node.value >> namesReferredByExpression) + + Expression.RecordAccess (Node _ childExp) _ -> + namesReferredByExpression childExp + + Expression.RecordUpdateExpression (Node _ recordRef) setterNodes -> + recordRef :: (setterNodes |> List.concatMap (\(Node _ ( _, Node _ childExp )) -> namesReferredByExpression childExp)) + + _ -> + [] + + letBlockToValue : List (Node Expression.LetDeclaration) -> Node Expression -> Result Errors (Value.Value SourceLocation) + letBlockToValue declarationNodes inNode = + let + -- build a dictionary from variable name to declaration index + declarationIndexForName : Dict String Int + declarationIndexForName = + declarationNodes + |> List.indexedMap + (\index (Node _ decl) -> + case decl of + Expression.LetFunction function -> + [ ( function.declaration |> Node.value |> .name |> Node.value, index ) ] + + Expression.LetDestructuring (Node _ pattern) _ -> + namesBoundByPattern pattern + |> Set.map (\name -> ( name, index )) + |> Set.toList + ) + |> List.concat + |> Dict.fromList + + -- build a dependency graph between declarations + declarationDependencyGraph : Graph (Node Expression.LetDeclaration) String + declarationDependencyGraph = + let + nodes : List (Graph.Node (Node Expression.LetDeclaration)) + nodes = + declarationNodes + |> List.indexedMap + (\index declNode -> + Graph.Node index declNode + ) + + edges : List (Graph.Edge String) + edges = + declarationNodes + |> List.indexedMap + (\fromIndex (Node _ decl) -> + case decl of + Expression.LetFunction function -> + function.declaration + |> Node.value + |> .expression + |> Node.value + |> namesReferredByExpression + |> List.filterMap + (\name -> + declarationIndexForName + |> Dict.get name + |> Maybe.map (\toIndex -> Graph.Edge fromIndex toIndex name) + ) + + Expression.LetDestructuring _ expression -> + expression + |> Node.value + |> namesReferredByExpression + |> List.filterMap + (\name -> + declarationIndexForName + |> Dict.get name + |> Maybe.map (\toIndex -> Graph.Edge fromIndex toIndex name) + ) + ) + |> List.concat + in + Graph.fromNodesAndEdges nodes edges + + letDeclarationToValue : Node Expression.LetDeclaration -> Result Errors (Value.Value SourceLocation) -> Result Errors (Value.Value SourceLocation) + letDeclarationToValue letDeclarationNode valueResult = + case letDeclarationNode |> Node.value of + Expression.LetFunction function -> + Result.map2 (Value.LetDefinition sourceLocation (function.declaration |> Node.value |> .name |> Node.value |> Name.fromString)) + (mapFunction sourceFile function) + valueResult + + Expression.LetDestructuring patternNode letExpressionNode -> + Result.map3 (Value.Destructure sourceLocation) + (mapPattern sourceFile patternNode) + (mapExpression sourceFile letExpressionNode) + valueResult + + componentGraphToValue : Graph (Node Expression.LetDeclaration) String -> Result Errors (Value.Value SourceLocation) -> Result Errors (Value.Value SourceLocation) + componentGraphToValue componentGraph valueResult = + case componentGraph |> Graph.checkAcyclic of + Ok acyclic -> + acyclic + |> Graph.topologicalSort + |> List.foldl + (\nodeContext innerSoFar -> + letDeclarationToValue nodeContext.node.label innerSoFar + ) + valueResult + + Err _ -> + Result.map2 (Value.LetRecursion sourceLocation) + (componentGraph + |> Graph.nodes + |> List.map + (\graphNode -> + case graphNode.label |> Node.value of + Expression.LetFunction function -> + mapFunction sourceFile function + |> Result.map (Tuple.pair (function.declaration |> Node.value |> .name |> Node.value |> Name.fromString)) + + Expression.LetDestructuring _ _ -> + Err [ NotSupported sourceLocation "Recursive destructuring" ] + ) + |> ResultList.toResult + |> Result.mapError List.concat + |> Result.map Dict.fromList + ) + valueResult + in + case declarationDependencyGraph |> Graph.stronglyConnectedComponents of + Ok acyclic -> + acyclic + |> Graph.topologicalSort + |> List.foldl + (\nodeContext soFar -> + letDeclarationToValue nodeContext.node.label soFar + ) + (mapExpression sourceFile inNode) + + Err components -> + components + |> List.foldl + componentGraphToValue + (mapExpression sourceFile inNode) + in + letBlockToValue letBlock.declarations letBlock.expression + + +namesBoundByPattern : Pattern -> Set String +namesBoundByPattern p = + let + namesBound : Pattern -> List String + namesBound pattern = + case pattern of + TuplePattern elemPatternNodes -> + elemPatternNodes |> List.concatMap (Node.value >> namesBound) + + RecordPattern fieldNameNodes -> + fieldNameNodes |> List.map Node.value + + UnConsPattern (Node _ headPattern) (Node _ tailPattern) -> + namesBound headPattern ++ namesBound tailPattern + + ListPattern itemPatternNodes -> + itemPatternNodes |> List.concatMap (Node.value >> namesBound) + + VarPattern name -> + [ name ] + + NamedPattern _ argPatternNodes -> + argPatternNodes |> List.concatMap (Node.value >> namesBound) + + AsPattern (Node _ childPattern) (Node _ alias) -> + alias :: namesBound childPattern + + ParenthesizedPattern (Node _ childPattern) -> + namesBound childPattern + + _ -> + [] + in + namesBound p + |> Set.fromList + + resolveLocalNames : Path -> Path -> ModuleResolver -> Module.Definition SourceLocation -> Result Errors (Module.Definition SourceLocation) resolveLocalNames packagePath modulePath moduleResolver moduleDef = let From 1ba07e6901b32a88daba06f229e5963799a314d6 Mon Sep 17 00:00:00 2001 From: Attila Mihaly Date: Fri, 17 Apr 2020 16:11:34 -0400 Subject: [PATCH 26/42] Refactoring to make the code more organized. --- src/Morphir/Elm/Frontend.elm | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Morphir/Elm/Frontend.elm b/src/Morphir/Elm/Frontend.elm index 803e1bc61..6289d0968 100644 --- a/src/Morphir/Elm/Frontend.elm +++ b/src/Morphir/Elm/Frontend.elm @@ -342,7 +342,7 @@ mapProcessedFile currentPackagePath processedFile modulesSoFar = moduleDeclsSoFar = modulesSoFar |> Dict.map - (\path def -> + (\_ def -> Module.definitionToSpecification def |> Module.eraseSpecificationAttributes ) @@ -515,8 +515,8 @@ mapDeclarationsToType sourceFile expose decls = in ctorsResult |> Result.map - (\ctors -> - ( name, withAccessControl isTypeExposed (Type.customTypeDefinition typeParams (withAccessControl isCtorExposed ctors)) ) + (\constructors -> + ( name, withAccessControl isTypeExposed (Type.customTypeDefinition typeParams (withAccessControl isCtorExposed constructors)) ) ) |> Just @@ -706,7 +706,7 @@ mapExpression sourceFile (Node range exp) = |> Result.mapError List.concat |> Result.andThen (List.reverse >> toApply) - Expression.OperatorApplication op infixDirection leftNode rightNode -> + Expression.OperatorApplication op _ leftNode rightNode -> mapOperator sourceFile sourceLocation op leftNode rightNode Expression.FunctionOrValue moduleName valueName -> @@ -726,10 +726,10 @@ mapExpression sourceFile (Node range exp) = (mapExpression sourceFile thenNode) (mapExpression sourceFile elseNode) - Expression.PrefixOperator op -> + Expression.PrefixOperator _ -> Err [ NotSupported sourceLocation "TODO: PrefixOperator" ] - Expression.Operator op -> + Expression.Operator _ -> Err [ NotSupported sourceLocation "TODO: Operator" ] Expression.Integer value -> From b4128cabe66ccbff0e40fe64f4137c2d273718be Mon Sep 17 00:00:00 2001 From: Attila Mihaly Date: Fri, 17 Apr 2020 16:23:01 -0400 Subject: [PATCH 27/42] Prepare value mapping utils. #53 --- src/Morphir/Elm/Frontend.elm | 5 +++-- src/Morphir/IR/Module.elm | 6 +++--- src/Morphir/IR/Package.elm | 8 ++++---- src/Morphir/IR/Value.elm | 17 ++++++++--------- 4 files changed, 18 insertions(+), 18 deletions(-) diff --git a/src/Morphir/Elm/Frontend.elm b/src/Morphir/Elm/Frontend.elm index 6289d0968..6e217bceb 100644 --- a/src/Morphir/Elm/Frontend.elm +++ b/src/Morphir/Elm/Frontend.elm @@ -1287,8 +1287,9 @@ resolveLocalNames packagePath modulePath moduleResolver moduleDef = Nothing ) - rewriteValues = - identity + rewriteValues : Value SourceLocation -> Result Error (Value SourceLocation) + rewriteValues value = + Ok value in Module.mapDefinition rewriteTypes rewriteValues moduleDef diff --git a/src/Morphir/IR/Module.elm b/src/Morphir/IR/Module.elm index c3da58e71..cd1430b41 100644 --- a/src/Morphir/IR/Module.elm +++ b/src/Morphir/IR/Module.elm @@ -88,7 +88,7 @@ eraseSpecificationAttributes spec = spec |> mapSpecification (Type.mapTypeAttributes (\_ -> ()) >> Ok) - (Value.mapValueAttributes (\_ -> ())) + (Value.mapValueAttributes (\_ -> ()) >> Ok) |> Result.withDefault emptySpecification @@ -121,7 +121,7 @@ encodeSpecification encodeAttributes spec = ] -mapSpecification : (Type a -> Result e (Type b)) -> (Value a -> Value b) -> Specification a -> Result (List e) (Specification b) +mapSpecification : (Type a -> Result e (Type b)) -> (Value a -> Result e (Value b)) -> Specification a -> Result (List e) (Specification b) mapSpecification mapType mapValue spec = let typesResult : Result (List e) (Dict Name (Type.Specification b)) @@ -157,7 +157,7 @@ mapSpecification mapType mapValue spec = valuesResult -mapDefinition : (Type a -> Result e (Type b)) -> (Value a -> Value b) -> Definition a -> Result (List e) (Definition b) +mapDefinition : (Type a -> Result e (Type b)) -> (Value a -> Result e (Value b)) -> Definition a -> Result (List e) (Definition b) mapDefinition mapType mapValue def = let typesResult : Result (List e) (Dict Name (AccessControlled (Type.Definition b))) diff --git a/src/Morphir/IR/Package.elm b/src/Morphir/IR/Package.elm index bd9702dcd..7876fcd25 100644 --- a/src/Morphir/IR/Package.elm +++ b/src/Morphir/IR/Package.elm @@ -76,7 +76,7 @@ definitionToSpecification def = } -mapSpecification : (Type a -> Result e (Type b)) -> (Value a -> Value b) -> Specification a -> Result (List e) (Specification b) +mapSpecification : (Type a -> Result e (Type b)) -> (Value a -> Result e (Value b)) -> Specification a -> Result (List e) (Specification b) mapSpecification mapType mapValue spec = let modulesResult : Result (List e) (Dict Path (Module.Specification b)) @@ -101,11 +101,11 @@ eraseSpecificationAttributes spec = spec |> mapSpecification (Type.mapTypeAttributes (\_ -> ()) >> Ok) - (Value.mapValueAttributes (\_ -> ())) + (Value.mapValueAttributes (\_ -> ()) >> Ok) |> Result.withDefault emptySpecification -mapDefinition : (Type a -> Result e (Type b)) -> (Value a -> Value b) -> Definition a -> Result (List e) (Definition b) +mapDefinition : (Type a -> Result e (Type b)) -> (Value a -> Result e (Value b)) -> Definition a -> Result (List e) (Definition b) mapDefinition mapType mapValue def = let dependenciesResult : Result (List e) (Dict Path (Specification b)) @@ -147,7 +147,7 @@ eraseDefinitionAttributes def = def |> mapDefinition (Type.mapTypeAttributes (\_ -> ()) >> Ok) - (Value.mapValueAttributes (\_ -> ())) + (Value.mapValueAttributes (\_ -> ()) >> Ok) |> Result.withDefault emptyDefinition diff --git a/src/Morphir/IR/Value.elm b/src/Morphir/IR/Value.elm index aac114a0c..5caf996ab 100644 --- a/src/Morphir/IR/Value.elm +++ b/src/Morphir/IR/Value.elm @@ -163,7 +163,7 @@ getDefinitionBody def = -- in -mapSpecification : (Type a -> Result e (Type b)) -> (Value a -> Value b) -> Specification a -> Result (List e) (Specification b) +mapSpecification : (Type a -> Result e (Type b)) -> (Value a -> Result e (Value b)) -> Specification a -> Result (List e) (Specification b) mapSpecification mapType mapValue spec = let inputsResult = @@ -184,20 +184,19 @@ mapSpecification mapType mapValue spec = outputResult -mapDefinition : (Type a -> Result e (Type b)) -> (Value a -> Value b) -> Definition a -> Result (List e) (Definition b) +mapDefinition : (Type a -> Result e (Type b)) -> (Value a -> Result e (Value b)) -> Definition a -> Result (List e) (Definition b) mapDefinition mapType mapValue def = case def of TypedDefinition tpe args body -> - mapType tpe - |> Result.map - (\t -> - TypedDefinition t args (mapValue body) - ) + Result.map2 (\t v -> TypedDefinition t args v) + (mapType tpe) + (mapValue body) |> Result.mapError List.singleton UntypedDefinition args body -> - UntypedDefinition args (mapValue body) - |> Ok + mapValue body + |> Result.map (UntypedDefinition args) + |> Result.mapError List.singleton mapValueAttributes : (a -> b) -> Value a -> Value b From 2d2331798b398bc599f14f42d3415223aaa92826 Mon Sep 17 00:00:00 2001 From: Attila Mihaly Date: Fri, 17 Apr 2020 18:02:35 -0400 Subject: [PATCH 28/42] More descriptive naming. --- src/Morphir/Elm/Frontend.elm | 38 +++++++++---------- src/Morphir/IR/Module.elm | 13 +++---- src/Morphir/IR/Package.elm | 12 +++--- src/Morphir/IR/Type.elm | 10 ++--- src/Morphir/IR/Value.elm | 5 +-- .../{ResultList.elm => ListOfResults.elm} | 2 +- 6 files changed, 38 insertions(+), 42 deletions(-) rename src/Morphir/{ResultList.elm => ListOfResults.elm} (95%) diff --git a/src/Morphir/Elm/Frontend.elm b/src/Morphir/Elm/Frontend.elm index 6e217bceb..204bb44f7 100644 --- a/src/Morphir/Elm/Frontend.elm +++ b/src/Morphir/Elm/Frontend.elm @@ -39,7 +39,7 @@ import Morphir.IR.SDK.Number as Number import Morphir.IR.Type as Type exposing (Type) import Morphir.IR.Value as Value exposing (Value) import Morphir.JsonExtra as JsonExtra -import Morphir.ResultList as ResultList +import Morphir.ListOfResults as ListOfResults import Morphir.Rewrite as Rewrite import Parser import Set exposing (Set) @@ -201,7 +201,7 @@ packageDefinitionFromSource packageInfo sourceFiles = ) |> Result.mapError (ParseError sourceFile.path) ) - |> ResultList.toResult + |> ListOfResults.toResult exposedModuleNames : Set ModuleName exposedModuleNames = @@ -501,7 +501,7 @@ mapDeclarationsToType sourceFile expose decls = ) ) ) - |> ResultList.toResult + |> ListOfResults.toResult |> Result.mapError List.concat in ctorArgsResult @@ -510,7 +510,7 @@ mapDeclarationsToType sourceFile expose decls = Type.Constructor ctorName ctorArgs ) ) - |> ResultList.toResult + |> ListOfResults.toResult |> Result.mapError List.concat in ctorsResult @@ -523,7 +523,7 @@ mapDeclarationsToType sourceFile expose decls = _ -> Nothing ) - |> ResultList.toResult + |> ListOfResults.toResult |> Result.mapError List.concat @@ -556,7 +556,7 @@ mapDeclarationsToValue sourceFile expose decls = _ -> Nothing ) - |> ResultList.toResult + |> ListOfResults.toResult |> Result.mapError List.concat @@ -575,7 +575,7 @@ mapTypeAnnotation sourceFile (Node range typeAnnotation) = (Type.Reference sourceLocation (fQName [] (moduleName |> List.map Name.fromString) (Name.fromString localName))) (argNodes |> List.map (mapTypeAnnotation sourceFile) - |> ResultList.toResult + |> ListOfResults.toResult |> Result.mapError List.concat ) @@ -585,7 +585,7 @@ mapTypeAnnotation sourceFile (Node range typeAnnotation) = Tupled elemNodes -> elemNodes |> List.map (mapTypeAnnotation sourceFile) - |> ResultList.toResult + |> ListOfResults.toResult |> Result.map (Type.Tuple sourceLocation) |> Result.mapError List.concat @@ -597,7 +597,7 @@ mapTypeAnnotation sourceFile (Node range typeAnnotation) = mapTypeAnnotation sourceFile fieldTypeNode |> Result.map (Type.Field (fieldName |> Name.fromString)) ) - |> ResultList.toResult + |> ListOfResults.toResult |> Result.map (Type.Record sourceLocation) |> Result.mapError List.concat @@ -609,7 +609,7 @@ mapTypeAnnotation sourceFile (Node range typeAnnotation) = mapTypeAnnotation sourceFile fieldTypeNode |> Result.map (Type.Field (fieldName |> Name.fromString)) ) - |> ResultList.toResult + |> ListOfResults.toResult |> Result.map (Type.ExtensibleRecord sourceLocation (argName |> Name.fromString)) |> Result.mapError List.concat @@ -702,7 +702,7 @@ mapExpression sourceFile (Node range exp) = in expNodes |> List.map (mapExpression sourceFile) - |> ResultList.toResult + |> ListOfResults.toResult |> Result.mapError List.concat |> Result.andThen (List.reverse >> toApply) @@ -754,7 +754,7 @@ mapExpression sourceFile (Node range exp) = Expression.TupledExpression expNodes -> expNodes |> List.map (mapExpression sourceFile) - |> ResultList.toResult + |> ListOfResults.toResult |> Result.mapError List.concat |> Result.map (Value.Tuple sourceLocation) @@ -774,7 +774,7 @@ mapExpression sourceFile (Node range exp) = (mapPattern sourceFile patternNode) (mapExpression sourceFile bodyNode) ) - |> ResultList.toResult + |> ListOfResults.toResult |> Result.mapError List.concat ) @@ -801,14 +801,14 @@ mapExpression sourceFile (Node range exp) = mapExpression sourceFile fieldValue |> Result.map (Tuple.pair (fieldName |> Name.fromString)) ) - |> ResultList.toResult + |> ListOfResults.toResult |> Result.mapError List.concat |> Result.map (Value.Record sourceLocation) Expression.ListExpr itemNodes -> itemNodes |> List.map (mapExpression sourceFile) - |> ResultList.toResult + |> ListOfResults.toResult |> Result.mapError List.concat |> Result.map (Value.List sourceLocation) @@ -830,7 +830,7 @@ mapExpression sourceFile (Node range exp) = mapExpression sourceFile fieldValue |> Result.map (Tuple.pair (fieldName |> Name.fromString)) ) - |> ResultList.toResult + |> ListOfResults.toResult |> Result.mapError List.concat |> Result.map (Value.UpdateRecord sourceLocation (targetVarNameNode |> Node.value |> Name.fromString |> Value.Variable sourceLocation)) @@ -870,7 +870,7 @@ mapPattern sourceFile (Node range pattern) = Pattern.TuplePattern elemNodes -> elemNodes |> List.map (mapPattern sourceFile) - |> ResultList.toResult + |> ListOfResults.toResult |> Result.mapError List.concat |> Result.map (Value.TuplePattern sourceLocation) @@ -915,7 +915,7 @@ mapPattern sourceFile (Node range pattern) = in argNodes |> List.map (mapPattern sourceFile) - |> ResultList.toResult + |> ListOfResults.toResult |> Result.mapError List.concat |> Result.map (Value.ConstructorPattern sourceLocation qualifiedName) @@ -1180,7 +1180,7 @@ mapLetExpression sourceFile sourceLocation letBlock = Expression.LetDestructuring _ _ -> Err [ NotSupported sourceLocation "Recursive destructuring" ] ) - |> ResultList.toResult + |> ListOfResults.toResult |> Result.mapError List.concat |> Result.map Dict.fromList ) diff --git a/src/Morphir/IR/Module.elm b/src/Morphir/IR/Module.elm index cd1430b41..852213a1e 100644 --- a/src/Morphir/IR/Module.elm +++ b/src/Morphir/IR/Module.elm @@ -13,14 +13,13 @@ module Morphir.IR.Module exposing -} import Dict exposing (Dict) -import Json.Decode as Decode import Json.Encode as Encode -import Morphir.IR.AccessControlled as AccessControlled exposing (AccessControlled, encodeAccessControlled, withPublicAccess) +import Morphir.IR.AccessControlled exposing (AccessControlled, encodeAccessControlled, withPublicAccess) import Morphir.IR.Name exposing (Name, encodeName) import Morphir.IR.Path exposing (Path) import Morphir.IR.Type as Type exposing (Type) import Morphir.IR.Value as Value exposing (Value) -import Morphir.ResultList as ResultList +import Morphir.ListOfResults as ListOfResults type alias ModulePath = @@ -134,7 +133,7 @@ mapSpecification mapType mapValue spec = |> Type.mapSpecification mapType |> Result.map (Tuple.pair typeName) ) - |> ResultList.toResult + |> ListOfResults.toResult |> Result.map Dict.fromList |> Result.mapError List.concat @@ -148,7 +147,7 @@ mapSpecification mapType mapValue spec = |> Value.mapSpecification mapType mapValue |> Result.map (Tuple.pair valueName) ) - |> ResultList.toResult + |> ListOfResults.toResult |> Result.map Dict.fromList |> Result.mapError List.concat in @@ -171,7 +170,7 @@ mapDefinition mapType mapValue def = |> Result.map (AccessControlled typeDef.access) |> Result.map (Tuple.pair typeName) ) - |> ResultList.toResult + |> ListOfResults.toResult |> Result.map Dict.fromList |> Result.mapError List.concat @@ -186,7 +185,7 @@ mapDefinition mapType mapValue def = |> Result.map (AccessControlled valueDef.access) |> Result.map (Tuple.pair valueName) ) - |> ResultList.toResult + |> ListOfResults.toResult |> Result.map Dict.fromList |> Result.mapError List.concat in diff --git a/src/Morphir/IR/Package.elm b/src/Morphir/IR/Package.elm index 7876fcd25..9d49ae148 100644 --- a/src/Morphir/IR/Package.elm +++ b/src/Morphir/IR/Package.elm @@ -13,15 +13,13 @@ module Morphir.IR.Package exposing -} import Dict exposing (Dict) -import Json.Decode as Decode import Json.Encode as Encode -import Morphir.IR.AccessControlled as AccessControlled exposing (AccessControlled, encodeAccessControlled, withPublicAccess) +import Morphir.IR.AccessControlled exposing (AccessControlled, encodeAccessControlled, withPublicAccess) import Morphir.IR.Module as Module exposing (ModulePath) import Morphir.IR.Path exposing (Path, encodePath) -import Morphir.IR.QName exposing (QName, encodeQName) import Morphir.IR.Type as Type exposing (Type) import Morphir.IR.Value as Value exposing (Value) -import Morphir.ResultList as ResultList +import Morphir.ListOfResults as ListOfResults type alias PackagePath = @@ -89,7 +87,7 @@ mapSpecification mapType mapValue spec = |> Module.mapSpecification mapType mapValue |> Result.map (Tuple.pair modulePath) ) - |> ResultList.toResult + |> ListOfResults.toResult |> Result.map Dict.fromList |> Result.mapError List.concat in @@ -118,7 +116,7 @@ mapDefinition mapType mapValue def = |> mapSpecification mapType mapValue |> Result.map (Tuple.pair packagePath) ) - |> ResultList.toResult + |> ListOfResults.toResult |> Result.map Dict.fromList |> Result.mapError List.concat @@ -133,7 +131,7 @@ mapDefinition mapType mapValue def = |> Result.map (AccessControlled moduleDef.access) |> Result.map (Tuple.pair modulePath) ) - |> ResultList.toResult + |> ListOfResults.toResult |> Result.map Dict.fromList |> Result.mapError List.concat in diff --git a/src/Morphir/IR/Type.elm b/src/Morphir/IR/Type.elm index 2a76398fb..a8a5ab624 100644 --- a/src/Morphir/IR/Type.elm +++ b/src/Morphir/IR/Type.elm @@ -65,8 +65,8 @@ import Json.Encode as Encode import Morphir.IR.AccessControlled as AccessControlled exposing (AccessControlled, encodeAccessControlled, withPublicAccess) import Morphir.IR.FQName exposing (FQName, decodeFQName, encodeFQName, fuzzFQName) import Morphir.IR.Name exposing (Name, decodeName, encodeName, fuzzName) +import Morphir.ListOfResults as ListOfResults import Morphir.Pattern exposing (Pattern) -import Morphir.ResultList as ResultList import Morphir.Rewrite exposing (Rewrite) @@ -171,10 +171,10 @@ mapSpecification f spec = f argType |> Result.map (Tuple.pair argName) ) - |> ResultList.toResult + |> ListOfResults.toResult |> Result.map (Constructor ctorName) ) - |> ResultList.toResult + |> ListOfResults.toResult |> Result.mapError List.concat in ctorsResult @@ -202,10 +202,10 @@ mapDefinition f def = f argType |> Result.map (Tuple.pair argName) ) - |> ResultList.toResult + |> ListOfResults.toResult |> Result.map (Constructor ctorName) ) - |> ResultList.toResult + |> ListOfResults.toResult |> Result.map (AccessControlled constructors.access) |> Result.mapError List.concat in diff --git a/src/Morphir/IR/Value.elm b/src/Morphir/IR/Value.elm index 5caf996ab..eb522fec6 100644 --- a/src/Morphir/IR/Value.elm +++ b/src/Morphir/IR/Value.elm @@ -70,8 +70,7 @@ import Json.Encode as Encode import Morphir.IR.FQName exposing (FQName, decodeFQName, encodeFQName) import Morphir.IR.Name exposing (Name, decodeName, encodeName) import Morphir.IR.Type as Type exposing (Type, decodeType, encodeType) -import Morphir.ResultList as ResultList -import Morphir.Rewrite exposing (Rewrite) +import Morphir.ListOfResults as ListOfResults import String @@ -173,7 +172,7 @@ mapSpecification mapType mapValue spec = mapType tpe |> Result.map (Tuple.pair name) ) - |> ResultList.toResult + |> ListOfResults.toResult outputResult = mapType spec.output diff --git a/src/Morphir/ResultList.elm b/src/Morphir/ListOfResults.elm similarity index 95% rename from src/Morphir/ResultList.elm rename to src/Morphir/ListOfResults.elm index 12e44eaa0..ccaca5775 100644 --- a/src/Morphir/ResultList.elm +++ b/src/Morphir/ListOfResults.elm @@ -1,4 +1,4 @@ -module Morphir.ResultList exposing (liftLastError, reduce, toResult) +module Morphir.ListOfResults exposing (liftLastError, reduce, toResult) reduce : (List a -> b) -> List (Result e a) -> Result e b From f583e4c4e14906bee0b680462bc0ffd9b565802f Mon Sep 17 00:00:00 2001 From: Attila Mihaly Date: Fri, 17 Apr 2020 18:06:20 -0400 Subject: [PATCH 29/42] More descriptive naming. --- src/Morphir/Elm/Frontend.elm | 36 +++++++++++++++++------------------ src/Morphir/IR/Module.elm | 8 ++++---- src/Morphir/IR/Package.elm | 6 +++--- src/Morphir/IR/Type.elm | 8 ++++---- src/Morphir/IR/Value.elm | 2 +- src/Morphir/ListOfResults.elm | 6 +++--- 6 files changed, 33 insertions(+), 33 deletions(-) diff --git a/src/Morphir/Elm/Frontend.elm b/src/Morphir/Elm/Frontend.elm index 204bb44f7..7c6568990 100644 --- a/src/Morphir/Elm/Frontend.elm +++ b/src/Morphir/Elm/Frontend.elm @@ -201,7 +201,7 @@ packageDefinitionFromSource packageInfo sourceFiles = ) |> Result.mapError (ParseError sourceFile.path) ) - |> ListOfResults.toResult + |> ListOfResults.toResultOfList exposedModuleNames : Set ModuleName exposedModuleNames = @@ -501,7 +501,7 @@ mapDeclarationsToType sourceFile expose decls = ) ) ) - |> ListOfResults.toResult + |> ListOfResults.toResultOfList |> Result.mapError List.concat in ctorArgsResult @@ -510,7 +510,7 @@ mapDeclarationsToType sourceFile expose decls = Type.Constructor ctorName ctorArgs ) ) - |> ListOfResults.toResult + |> ListOfResults.toResultOfList |> Result.mapError List.concat in ctorsResult @@ -523,7 +523,7 @@ mapDeclarationsToType sourceFile expose decls = _ -> Nothing ) - |> ListOfResults.toResult + |> ListOfResults.toResultOfList |> Result.mapError List.concat @@ -556,7 +556,7 @@ mapDeclarationsToValue sourceFile expose decls = _ -> Nothing ) - |> ListOfResults.toResult + |> ListOfResults.toResultOfList |> Result.mapError List.concat @@ -575,7 +575,7 @@ mapTypeAnnotation sourceFile (Node range typeAnnotation) = (Type.Reference sourceLocation (fQName [] (moduleName |> List.map Name.fromString) (Name.fromString localName))) (argNodes |> List.map (mapTypeAnnotation sourceFile) - |> ListOfResults.toResult + |> ListOfResults.toResultOfList |> Result.mapError List.concat ) @@ -585,7 +585,7 @@ mapTypeAnnotation sourceFile (Node range typeAnnotation) = Tupled elemNodes -> elemNodes |> List.map (mapTypeAnnotation sourceFile) - |> ListOfResults.toResult + |> ListOfResults.toResultOfList |> Result.map (Type.Tuple sourceLocation) |> Result.mapError List.concat @@ -597,7 +597,7 @@ mapTypeAnnotation sourceFile (Node range typeAnnotation) = mapTypeAnnotation sourceFile fieldTypeNode |> Result.map (Type.Field (fieldName |> Name.fromString)) ) - |> ListOfResults.toResult + |> ListOfResults.toResultOfList |> Result.map (Type.Record sourceLocation) |> Result.mapError List.concat @@ -609,7 +609,7 @@ mapTypeAnnotation sourceFile (Node range typeAnnotation) = mapTypeAnnotation sourceFile fieldTypeNode |> Result.map (Type.Field (fieldName |> Name.fromString)) ) - |> ListOfResults.toResult + |> ListOfResults.toResultOfList |> Result.map (Type.ExtensibleRecord sourceLocation (argName |> Name.fromString)) |> Result.mapError List.concat @@ -702,7 +702,7 @@ mapExpression sourceFile (Node range exp) = in expNodes |> List.map (mapExpression sourceFile) - |> ListOfResults.toResult + |> ListOfResults.toResultOfList |> Result.mapError List.concat |> Result.andThen (List.reverse >> toApply) @@ -754,7 +754,7 @@ mapExpression sourceFile (Node range exp) = Expression.TupledExpression expNodes -> expNodes |> List.map (mapExpression sourceFile) - |> ListOfResults.toResult + |> ListOfResults.toResultOfList |> Result.mapError List.concat |> Result.map (Value.Tuple sourceLocation) @@ -774,7 +774,7 @@ mapExpression sourceFile (Node range exp) = (mapPattern sourceFile patternNode) (mapExpression sourceFile bodyNode) ) - |> ListOfResults.toResult + |> ListOfResults.toResultOfList |> Result.mapError List.concat ) @@ -801,14 +801,14 @@ mapExpression sourceFile (Node range exp) = mapExpression sourceFile fieldValue |> Result.map (Tuple.pair (fieldName |> Name.fromString)) ) - |> ListOfResults.toResult + |> ListOfResults.toResultOfList |> Result.mapError List.concat |> Result.map (Value.Record sourceLocation) Expression.ListExpr itemNodes -> itemNodes |> List.map (mapExpression sourceFile) - |> ListOfResults.toResult + |> ListOfResults.toResultOfList |> Result.mapError List.concat |> Result.map (Value.List sourceLocation) @@ -830,7 +830,7 @@ mapExpression sourceFile (Node range exp) = mapExpression sourceFile fieldValue |> Result.map (Tuple.pair (fieldName |> Name.fromString)) ) - |> ListOfResults.toResult + |> ListOfResults.toResultOfList |> Result.mapError List.concat |> Result.map (Value.UpdateRecord sourceLocation (targetVarNameNode |> Node.value |> Name.fromString |> Value.Variable sourceLocation)) @@ -870,7 +870,7 @@ mapPattern sourceFile (Node range pattern) = Pattern.TuplePattern elemNodes -> elemNodes |> List.map (mapPattern sourceFile) - |> ListOfResults.toResult + |> ListOfResults.toResultOfList |> Result.mapError List.concat |> Result.map (Value.TuplePattern sourceLocation) @@ -915,7 +915,7 @@ mapPattern sourceFile (Node range pattern) = in argNodes |> List.map (mapPattern sourceFile) - |> ListOfResults.toResult + |> ListOfResults.toResultOfList |> Result.mapError List.concat |> Result.map (Value.ConstructorPattern sourceLocation qualifiedName) @@ -1180,7 +1180,7 @@ mapLetExpression sourceFile sourceLocation letBlock = Expression.LetDestructuring _ _ -> Err [ NotSupported sourceLocation "Recursive destructuring" ] ) - |> ListOfResults.toResult + |> ListOfResults.toResultOfList |> Result.mapError List.concat |> Result.map Dict.fromList ) diff --git a/src/Morphir/IR/Module.elm b/src/Morphir/IR/Module.elm index 852213a1e..7eda1f7c6 100644 --- a/src/Morphir/IR/Module.elm +++ b/src/Morphir/IR/Module.elm @@ -133,7 +133,7 @@ mapSpecification mapType mapValue spec = |> Type.mapSpecification mapType |> Result.map (Tuple.pair typeName) ) - |> ListOfResults.toResult + |> ListOfResults.toResultOfList |> Result.map Dict.fromList |> Result.mapError List.concat @@ -147,7 +147,7 @@ mapSpecification mapType mapValue spec = |> Value.mapSpecification mapType mapValue |> Result.map (Tuple.pair valueName) ) - |> ListOfResults.toResult + |> ListOfResults.toResultOfList |> Result.map Dict.fromList |> Result.mapError List.concat in @@ -170,7 +170,7 @@ mapDefinition mapType mapValue def = |> Result.map (AccessControlled typeDef.access) |> Result.map (Tuple.pair typeName) ) - |> ListOfResults.toResult + |> ListOfResults.toResultOfList |> Result.map Dict.fromList |> Result.mapError List.concat @@ -185,7 +185,7 @@ mapDefinition mapType mapValue def = |> Result.map (AccessControlled valueDef.access) |> Result.map (Tuple.pair valueName) ) - |> ListOfResults.toResult + |> ListOfResults.toResultOfList |> Result.map Dict.fromList |> Result.mapError List.concat in diff --git a/src/Morphir/IR/Package.elm b/src/Morphir/IR/Package.elm index 9d49ae148..18fd5dec6 100644 --- a/src/Morphir/IR/Package.elm +++ b/src/Morphir/IR/Package.elm @@ -87,7 +87,7 @@ mapSpecification mapType mapValue spec = |> Module.mapSpecification mapType mapValue |> Result.map (Tuple.pair modulePath) ) - |> ListOfResults.toResult + |> ListOfResults.toResultOfList |> Result.map Dict.fromList |> Result.mapError List.concat in @@ -116,7 +116,7 @@ mapDefinition mapType mapValue def = |> mapSpecification mapType mapValue |> Result.map (Tuple.pair packagePath) ) - |> ListOfResults.toResult + |> ListOfResults.toResultOfList |> Result.map Dict.fromList |> Result.mapError List.concat @@ -131,7 +131,7 @@ mapDefinition mapType mapValue def = |> Result.map (AccessControlled moduleDef.access) |> Result.map (Tuple.pair modulePath) ) - |> ListOfResults.toResult + |> ListOfResults.toResultOfList |> Result.map Dict.fromList |> Result.mapError List.concat in diff --git a/src/Morphir/IR/Type.elm b/src/Morphir/IR/Type.elm index a8a5ab624..80fed7368 100644 --- a/src/Morphir/IR/Type.elm +++ b/src/Morphir/IR/Type.elm @@ -171,10 +171,10 @@ mapSpecification f spec = f argType |> Result.map (Tuple.pair argName) ) - |> ListOfResults.toResult + |> ListOfResults.toResultOfList |> Result.map (Constructor ctorName) ) - |> ListOfResults.toResult + |> ListOfResults.toResultOfList |> Result.mapError List.concat in ctorsResult @@ -202,10 +202,10 @@ mapDefinition f def = f argType |> Result.map (Tuple.pair argName) ) - |> ListOfResults.toResult + |> ListOfResults.toResultOfList |> Result.map (Constructor ctorName) ) - |> ListOfResults.toResult + |> ListOfResults.toResultOfList |> Result.map (AccessControlled constructors.access) |> Result.mapError List.concat in diff --git a/src/Morphir/IR/Value.elm b/src/Morphir/IR/Value.elm index eb522fec6..def846e5e 100644 --- a/src/Morphir/IR/Value.elm +++ b/src/Morphir/IR/Value.elm @@ -172,7 +172,7 @@ mapSpecification mapType mapValue spec = mapType tpe |> Result.map (Tuple.pair name) ) - |> ListOfResults.toResult + |> ListOfResults.toResultOfList outputResult = mapType spec.output diff --git a/src/Morphir/ListOfResults.elm b/src/Morphir/ListOfResults.elm index ccaca5775..c36521836 100644 --- a/src/Morphir/ListOfResults.elm +++ b/src/Morphir/ListOfResults.elm @@ -1,4 +1,4 @@ -module Morphir.ListOfResults exposing (liftLastError, reduce, toResult) +module Morphir.ListOfResults exposing (liftLastError, reduce, toResultOfList) reduce : (List a -> b) -> List (Result e a) -> Result e b @@ -32,8 +32,8 @@ reduce f results = Err firstError -toResult : List (Result e a) -> Result (List e) (List a) -toResult results = +toResultOfList : List (Result e a) -> Result (List e) (List a) +toResultOfList results = let oks = results From 6f67614e0c5fcf6fe284711427bf889a3d870ede Mon Sep 17 00:00:00 2001 From: Attila Mihaly Date: Fri, 17 Apr 2020 18:07:10 -0400 Subject: [PATCH 30/42] Removed unused function --- src/Morphir/ListOfResults.elm | 9 +-------- 1 file changed, 1 insertion(+), 8 deletions(-) diff --git a/src/Morphir/ListOfResults.elm b/src/Morphir/ListOfResults.elm index c36521836..c87d40249 100644 --- a/src/Morphir/ListOfResults.elm +++ b/src/Morphir/ListOfResults.elm @@ -1,4 +1,4 @@ -module Morphir.ListOfResults exposing (liftLastError, reduce, toResultOfList) +module Morphir.ListOfResults exposing (reduce, toResultOfList) reduce : (List a -> b) -> List (Result e a) -> Result e b @@ -61,10 +61,3 @@ toResultOfList results = _ -> Err errs - - -{-| Turn a list of results into a single result of a list returning only the last error in the list. --} -liftLastError : List (Result e a) -> Result e (List a) -liftLastError results = - List.foldr (Result.map2 (::)) (Ok []) results From 5873328f3fbb66ee2a4512cafa31c140afbcbd27 Mon Sep 17 00:00:00 2001 From: Attila Mihaly Date: Fri, 17 Apr 2020 18:12:30 -0400 Subject: [PATCH 31/42] Better naming --- src/Morphir/Elm/Frontend.elm | 36 +++++++++++++++++------------------ src/Morphir/IR/Module.elm | 8 ++++---- src/Morphir/IR/Package.elm | 6 +++--- src/Morphir/IR/Type.elm | 8 ++++---- src/Morphir/IR/Value.elm | 2 +- src/Morphir/ListOfResults.elm | 6 +++--- 6 files changed, 33 insertions(+), 33 deletions(-) diff --git a/src/Morphir/Elm/Frontend.elm b/src/Morphir/Elm/Frontend.elm index 7c6568990..6e2cc80c2 100644 --- a/src/Morphir/Elm/Frontend.elm +++ b/src/Morphir/Elm/Frontend.elm @@ -201,7 +201,7 @@ packageDefinitionFromSource packageInfo sourceFiles = ) |> Result.mapError (ParseError sourceFile.path) ) - |> ListOfResults.toResultOfList + |> ListOfResults.liftAllErrors exposedModuleNames : Set ModuleName exposedModuleNames = @@ -501,7 +501,7 @@ mapDeclarationsToType sourceFile expose decls = ) ) ) - |> ListOfResults.toResultOfList + |> ListOfResults.liftAllErrors |> Result.mapError List.concat in ctorArgsResult @@ -510,7 +510,7 @@ mapDeclarationsToType sourceFile expose decls = Type.Constructor ctorName ctorArgs ) ) - |> ListOfResults.toResultOfList + |> ListOfResults.liftAllErrors |> Result.mapError List.concat in ctorsResult @@ -523,7 +523,7 @@ mapDeclarationsToType sourceFile expose decls = _ -> Nothing ) - |> ListOfResults.toResultOfList + |> ListOfResults.liftAllErrors |> Result.mapError List.concat @@ -556,7 +556,7 @@ mapDeclarationsToValue sourceFile expose decls = _ -> Nothing ) - |> ListOfResults.toResultOfList + |> ListOfResults.liftAllErrors |> Result.mapError List.concat @@ -575,7 +575,7 @@ mapTypeAnnotation sourceFile (Node range typeAnnotation) = (Type.Reference sourceLocation (fQName [] (moduleName |> List.map Name.fromString) (Name.fromString localName))) (argNodes |> List.map (mapTypeAnnotation sourceFile) - |> ListOfResults.toResultOfList + |> ListOfResults.liftAllErrors |> Result.mapError List.concat ) @@ -585,7 +585,7 @@ mapTypeAnnotation sourceFile (Node range typeAnnotation) = Tupled elemNodes -> elemNodes |> List.map (mapTypeAnnotation sourceFile) - |> ListOfResults.toResultOfList + |> ListOfResults.liftAllErrors |> Result.map (Type.Tuple sourceLocation) |> Result.mapError List.concat @@ -597,7 +597,7 @@ mapTypeAnnotation sourceFile (Node range typeAnnotation) = mapTypeAnnotation sourceFile fieldTypeNode |> Result.map (Type.Field (fieldName |> Name.fromString)) ) - |> ListOfResults.toResultOfList + |> ListOfResults.liftAllErrors |> Result.map (Type.Record sourceLocation) |> Result.mapError List.concat @@ -609,7 +609,7 @@ mapTypeAnnotation sourceFile (Node range typeAnnotation) = mapTypeAnnotation sourceFile fieldTypeNode |> Result.map (Type.Field (fieldName |> Name.fromString)) ) - |> ListOfResults.toResultOfList + |> ListOfResults.liftAllErrors |> Result.map (Type.ExtensibleRecord sourceLocation (argName |> Name.fromString)) |> Result.mapError List.concat @@ -702,7 +702,7 @@ mapExpression sourceFile (Node range exp) = in expNodes |> List.map (mapExpression sourceFile) - |> ListOfResults.toResultOfList + |> ListOfResults.liftAllErrors |> Result.mapError List.concat |> Result.andThen (List.reverse >> toApply) @@ -754,7 +754,7 @@ mapExpression sourceFile (Node range exp) = Expression.TupledExpression expNodes -> expNodes |> List.map (mapExpression sourceFile) - |> ListOfResults.toResultOfList + |> ListOfResults.liftAllErrors |> Result.mapError List.concat |> Result.map (Value.Tuple sourceLocation) @@ -774,7 +774,7 @@ mapExpression sourceFile (Node range exp) = (mapPattern sourceFile patternNode) (mapExpression sourceFile bodyNode) ) - |> ListOfResults.toResultOfList + |> ListOfResults.liftAllErrors |> Result.mapError List.concat ) @@ -801,14 +801,14 @@ mapExpression sourceFile (Node range exp) = mapExpression sourceFile fieldValue |> Result.map (Tuple.pair (fieldName |> Name.fromString)) ) - |> ListOfResults.toResultOfList + |> ListOfResults.liftAllErrors |> Result.mapError List.concat |> Result.map (Value.Record sourceLocation) Expression.ListExpr itemNodes -> itemNodes |> List.map (mapExpression sourceFile) - |> ListOfResults.toResultOfList + |> ListOfResults.liftAllErrors |> Result.mapError List.concat |> Result.map (Value.List sourceLocation) @@ -830,7 +830,7 @@ mapExpression sourceFile (Node range exp) = mapExpression sourceFile fieldValue |> Result.map (Tuple.pair (fieldName |> Name.fromString)) ) - |> ListOfResults.toResultOfList + |> ListOfResults.liftAllErrors |> Result.mapError List.concat |> Result.map (Value.UpdateRecord sourceLocation (targetVarNameNode |> Node.value |> Name.fromString |> Value.Variable sourceLocation)) @@ -870,7 +870,7 @@ mapPattern sourceFile (Node range pattern) = Pattern.TuplePattern elemNodes -> elemNodes |> List.map (mapPattern sourceFile) - |> ListOfResults.toResultOfList + |> ListOfResults.liftAllErrors |> Result.mapError List.concat |> Result.map (Value.TuplePattern sourceLocation) @@ -915,7 +915,7 @@ mapPattern sourceFile (Node range pattern) = in argNodes |> List.map (mapPattern sourceFile) - |> ListOfResults.toResultOfList + |> ListOfResults.liftAllErrors |> Result.mapError List.concat |> Result.map (Value.ConstructorPattern sourceLocation qualifiedName) @@ -1180,7 +1180,7 @@ mapLetExpression sourceFile sourceLocation letBlock = Expression.LetDestructuring _ _ -> Err [ NotSupported sourceLocation "Recursive destructuring" ] ) - |> ListOfResults.toResultOfList + |> ListOfResults.liftAllErrors |> Result.mapError List.concat |> Result.map Dict.fromList ) diff --git a/src/Morphir/IR/Module.elm b/src/Morphir/IR/Module.elm index 7eda1f7c6..19d2d6944 100644 --- a/src/Morphir/IR/Module.elm +++ b/src/Morphir/IR/Module.elm @@ -133,7 +133,7 @@ mapSpecification mapType mapValue spec = |> Type.mapSpecification mapType |> Result.map (Tuple.pair typeName) ) - |> ListOfResults.toResultOfList + |> ListOfResults.liftAllErrors |> Result.map Dict.fromList |> Result.mapError List.concat @@ -147,7 +147,7 @@ mapSpecification mapType mapValue spec = |> Value.mapSpecification mapType mapValue |> Result.map (Tuple.pair valueName) ) - |> ListOfResults.toResultOfList + |> ListOfResults.liftAllErrors |> Result.map Dict.fromList |> Result.mapError List.concat in @@ -170,7 +170,7 @@ mapDefinition mapType mapValue def = |> Result.map (AccessControlled typeDef.access) |> Result.map (Tuple.pair typeName) ) - |> ListOfResults.toResultOfList + |> ListOfResults.liftAllErrors |> Result.map Dict.fromList |> Result.mapError List.concat @@ -185,7 +185,7 @@ mapDefinition mapType mapValue def = |> Result.map (AccessControlled valueDef.access) |> Result.map (Tuple.pair valueName) ) - |> ListOfResults.toResultOfList + |> ListOfResults.liftAllErrors |> Result.map Dict.fromList |> Result.mapError List.concat in diff --git a/src/Morphir/IR/Package.elm b/src/Morphir/IR/Package.elm index 18fd5dec6..b19dc3986 100644 --- a/src/Morphir/IR/Package.elm +++ b/src/Morphir/IR/Package.elm @@ -87,7 +87,7 @@ mapSpecification mapType mapValue spec = |> Module.mapSpecification mapType mapValue |> Result.map (Tuple.pair modulePath) ) - |> ListOfResults.toResultOfList + |> ListOfResults.liftAllErrors |> Result.map Dict.fromList |> Result.mapError List.concat in @@ -116,7 +116,7 @@ mapDefinition mapType mapValue def = |> mapSpecification mapType mapValue |> Result.map (Tuple.pair packagePath) ) - |> ListOfResults.toResultOfList + |> ListOfResults.liftAllErrors |> Result.map Dict.fromList |> Result.mapError List.concat @@ -131,7 +131,7 @@ mapDefinition mapType mapValue def = |> Result.map (AccessControlled moduleDef.access) |> Result.map (Tuple.pair modulePath) ) - |> ListOfResults.toResultOfList + |> ListOfResults.liftAllErrors |> Result.map Dict.fromList |> Result.mapError List.concat in diff --git a/src/Morphir/IR/Type.elm b/src/Morphir/IR/Type.elm index 80fed7368..4521d61bd 100644 --- a/src/Morphir/IR/Type.elm +++ b/src/Morphir/IR/Type.elm @@ -171,10 +171,10 @@ mapSpecification f spec = f argType |> Result.map (Tuple.pair argName) ) - |> ListOfResults.toResultOfList + |> ListOfResults.liftAllErrors |> Result.map (Constructor ctorName) ) - |> ListOfResults.toResultOfList + |> ListOfResults.liftAllErrors |> Result.mapError List.concat in ctorsResult @@ -202,10 +202,10 @@ mapDefinition f def = f argType |> Result.map (Tuple.pair argName) ) - |> ListOfResults.toResultOfList + |> ListOfResults.liftAllErrors |> Result.map (Constructor ctorName) ) - |> ListOfResults.toResultOfList + |> ListOfResults.liftAllErrors |> Result.map (AccessControlled constructors.access) |> Result.mapError List.concat in diff --git a/src/Morphir/IR/Value.elm b/src/Morphir/IR/Value.elm index def846e5e..6afa62246 100644 --- a/src/Morphir/IR/Value.elm +++ b/src/Morphir/IR/Value.elm @@ -172,7 +172,7 @@ mapSpecification mapType mapValue spec = mapType tpe |> Result.map (Tuple.pair name) ) - |> ListOfResults.toResultOfList + |> ListOfResults.liftAllErrors outputResult = mapType spec.output diff --git a/src/Morphir/ListOfResults.elm b/src/Morphir/ListOfResults.elm index c87d40249..6ac9d36b5 100644 --- a/src/Morphir/ListOfResults.elm +++ b/src/Morphir/ListOfResults.elm @@ -1,4 +1,4 @@ -module Morphir.ListOfResults exposing (reduce, toResultOfList) +module Morphir.ListOfResults exposing (liftAllErrors, reduce) reduce : (List a -> b) -> List (Result e a) -> Result e b @@ -32,8 +32,8 @@ reduce f results = Err firstError -toResultOfList : List (Result e a) -> Result (List e) (List a) -toResultOfList results = +liftAllErrors : List (Result e a) -> Result (List e) (List a) +liftAllErrors results = let oks = results From 7f312ba9c6bb4135d62df6b6a4465a0e2f359053 Mon Sep 17 00:00:00 2001 From: Attila Mihaly Date: Fri, 17 Apr 2020 18:16:57 -0400 Subject: [PATCH 32/42] Added utility function and removed unused one. --- src/Morphir/ListOfResults.elm | 46 +++++++++++------------------------ 1 file changed, 14 insertions(+), 32 deletions(-) diff --git a/src/Morphir/ListOfResults.elm b/src/Morphir/ListOfResults.elm index 6ac9d36b5..6bd57f2fc 100644 --- a/src/Morphir/ListOfResults.elm +++ b/src/Morphir/ListOfResults.elm @@ -1,35 +1,4 @@ -module Morphir.ListOfResults exposing (liftAllErrors, reduce) - - -reduce : (List a -> b) -> List (Result e a) -> Result e b -reduce f results = - let - oks = - results - |> List.filterMap - (\result -> - result - |> Result.toMaybe - ) - - errs = - results - |> List.filterMap - (\result -> - case result of - Ok _ -> - Nothing - - Err e -> - Just e - ) - in - case errs of - [] -> - Ok (f oks) - - firstError :: _ -> - Err firstError +module Morphir.ListOfResults exposing (liftAllErrors, liftFirstError) liftAllErrors : List (Result e a) -> Result (List e) (List a) @@ -61,3 +30,16 @@ liftAllErrors results = _ -> Err errs + + +liftFirstError : List (Result e a) -> Result e (List a) +liftFirstError results = + case liftAllErrors results of + Ok a -> + Ok a + + Err errors -> + errors + |> List.head + |> Maybe.map Err + |> Maybe.withDefault (Ok []) From 1fdc4a4def40ddf0b38e3f5231f6a623818e3487 Mon Sep 17 00:00:00 2001 From: Attila Mihaly Date: Sat, 18 Apr 2020 23:44:36 -0400 Subject: [PATCH 33/42] Added variable resolution. --- cli/elm.json | 3 + src/Morphir/Elm/Frontend.elm | 269 +++++++++++++++++++++++++++- src/Morphir/IR/Value.elm | 100 ++++------- tests/Morphir/Elm/FrontendTests.elm | 28 +-- 4 files changed, 323 insertions(+), 77 deletions(-) diff --git a/cli/elm.json b/cli/elm.json index 50d1f6967..a160011d8 100644 --- a/cli/elm.json +++ b/cli/elm.json @@ -13,15 +13,18 @@ "elm/json": "1.1.3", "elm/parser": "1.1.0", "elm/regex": "1.0.0", + "elm-community/graph": "6.0.0", "elm-community/maybe-extra": "5.2.0", "elm-explorations/test": "1.2.2", "stil4m/elm-syntax": "7.1.1" }, "indirect": { + "avh4/elm-fifo": "1.0.4", "elm/random": "1.0.0", "elm/time": "1.0.0", "elm/url": "1.0.0", "elm/virtual-dom": "1.0.2", + "elm-community/intdict": "3.0.0", "elm-community/json-extra": "4.2.0", "elm-community/list-extra": "8.2.3", "rtfeldman/elm-hex": "1.0.0", diff --git a/src/Morphir/Elm/Frontend.elm b/src/Morphir/Elm/Frontend.elm index 6e2cc80c2..e2848e364 100644 --- a/src/Morphir/Elm/Frontend.elm +++ b/src/Morphir/Elm/Frontend.elm @@ -20,9 +20,9 @@ import Json.Encode as Encode import Morphir.Elm.Frontend.Resolve as Resolve exposing (ModuleResolver, PackageResolver) import Morphir.Graph import Morphir.IR.AccessControlled exposing (AccessControlled, private, public) -import Morphir.IR.FQName as FQName exposing (FQName, fQName) +import Morphir.IR.FQName as FQName exposing (FQName(..), fQName) import Morphir.IR.Module as Module -import Morphir.IR.Name as Name exposing (Name) +import Morphir.IR.Name as Name exposing (Name, encodeName) import Morphir.IR.Package as Package import Morphir.IR.Path as Path exposing (Path) import Morphir.IR.QName as QName @@ -142,6 +142,8 @@ type Error | ResolveError SourceLocation Resolve.Error | EmptyApply SourceLocation | NotSupported SourceLocation String + | DuplicateNameInPattern Name SourceLocation SourceLocation + | VariableShadowing Name SourceLocation SourceLocation encodeError : Error -> Encode.Value @@ -170,6 +172,20 @@ encodeError error = , Encode.string message ] + DuplicateNameInPattern name sourceLocation1 sourceLocation2 -> + JsonExtra.encodeConstructor "DuplicateNameInPattern" + [ encodeName name + , encodeSourceLocation sourceLocation1 + , encodeSourceLocation sourceLocation2 + ] + + VariableShadowing name sourceLocation1 sourceLocation2 -> + JsonExtra.encodeConstructor "VariableShadowing" + [ encodeName name + , encodeSourceLocation sourceLocation1 + , encodeSourceLocation sourceLocation2 + ] + type alias Imports = { lookupByExposedCtor : String -> Maybe Import @@ -669,7 +685,7 @@ mapFunctionImplementation sourceFile argumentNodes expression = lambdaWithParams lambdaArgPatterns expression in bodyResult - |> Result.map (Value.UntypedDefinition paramNames) + |> Result.map (Value.Definition Nothing paramNames) mapExpression : SourceFile -> Node Expression -> Result Errors (Value.Value SourceLocation) @@ -1294,6 +1310,253 @@ resolveLocalNames packagePath modulePath moduleResolver moduleDef = Module.mapDefinition rewriteTypes rewriteValues moduleDef +resolveVariables : Dict Name SourceLocation -> Value SourceLocation -> Result Errors (Value SourceLocation) +resolveVariables variables value = + let + unionNames : (Name -> SourceLocation -> SourceLocation -> Error) -> Dict Name SourceLocation -> Dict Name SourceLocation -> Result Errors (Dict Name SourceLocation) + unionNames toError namesA namesB = + let + duplicateNames : List Name + duplicateNames = + Set.intersect (namesA |> Dict.keys |> Set.fromList) (namesB |> Dict.keys |> Set.fromList) + |> Set.toList + in + if List.isEmpty duplicateNames then + Ok (Dict.union namesA namesB) + + else + Err + (duplicateNames + |> List.filterMap + (\name -> + Maybe.map2 (toError name) + (namesA |> Dict.get name) + (namesB |> Dict.get name) + ) + ) + + unionPatternNames : Dict Name SourceLocation -> Dict Name SourceLocation -> Result Errors (Dict Name SourceLocation) + unionPatternNames = + unionNames DuplicateNameInPattern + + unionVariableNames : Dict Name SourceLocation -> Dict Name SourceLocation -> Result Errors (Dict Name SourceLocation) + unionVariableNames = + unionNames VariableShadowing + + namesBoundInPattern : Value.Pattern SourceLocation -> Result Errors (Dict Name SourceLocation) + namesBoundInPattern pattern = + case pattern of + Value.AsPattern sourceLocation subjectPattern alias -> + namesBoundInPattern subjectPattern + |> Result.andThen + (\subjectNames -> + unionPatternNames subjectNames + (Dict.singleton alias sourceLocation) + ) + + Value.TuplePattern _ elems -> + elems + |> List.map namesBoundInPattern + |> List.foldl + (\nextNames soFar -> + soFar + |> Result.andThen + (\namesSoFar -> + nextNames + |> Result.andThen (unionPatternNames namesSoFar) + ) + ) + (Ok Dict.empty) + + Value.RecordPattern sourceLocation fieldNames -> + Ok + (fieldNames + |> List.map (\fieldName -> ( fieldName, sourceLocation )) + |> Dict.fromList + ) + + Value.ConstructorPattern _ _ args -> + args + |> List.map namesBoundInPattern + |> List.foldl + (\nextNames soFar -> + soFar + |> Result.andThen + (\namesSoFar -> + nextNames + |> Result.andThen (unionPatternNames namesSoFar) + ) + ) + (Ok Dict.empty) + + Value.HeadTailPattern _ headPattern tailPattern -> + namesBoundInPattern headPattern + |> Result.andThen + (\headNames -> + namesBoundInPattern tailPattern + |> Result.andThen (unionPatternNames headNames) + ) + + _ -> + Ok Dict.empty + in + case value of + Value.Reference a (FQName [] [] localName) -> + if variables |> Dict.member localName then + Ok (Value.Variable a localName) + + else + Ok value + + Value.Lambda a argPattern bodyValue -> + namesBoundInPattern argPattern + |> Result.andThen + (\patternNames -> + unionVariableNames variables patternNames + ) + |> Result.andThen + (\newVariables -> + resolveVariables newVariables bodyValue + ) + |> Result.map (Value.Lambda a argPattern) + + Value.LetDefinition sourceLocation name def inValue -> + Result.map2 (Value.LetDefinition sourceLocation name) + (resolveVariables variables def.body + |> Result.map + (\resolvedBody -> + { def + | body = resolvedBody + } + ) + ) + (unionVariableNames variables (Dict.singleton name sourceLocation) + |> Result.andThen + (\newVariables -> + resolveVariables newVariables inValue + ) + ) + + Value.LetRecursion sourceLocation defs inValue -> + defs + |> Dict.map (\_ _ -> sourceLocation) + |> unionVariableNames variables + |> Result.andThen + (\newVariables -> + Result.map2 (Value.LetRecursion sourceLocation) + (defs + |> Dict.toList + |> List.map + (\( name, def ) -> + resolveVariables newVariables def.body + |> Result.map + (\resolvedBody -> + ( name + , { def + | body = resolvedBody + } + ) + ) + ) + |> ListOfResults.liftAllErrors + |> Result.mapError List.concat + |> Result.map Dict.fromList + ) + (resolveVariables newVariables inValue) + ) + + Value.Destructure a pattern subjectValue inValue -> + Result.map2 (Value.Destructure a pattern) + (resolveVariables variables subjectValue) + (namesBoundInPattern pattern + |> Result.andThen + (\patternNames -> + unionVariableNames variables patternNames + ) + |> Result.andThen + (\newVariables -> + resolveVariables newVariables inValue + ) + ) + + Value.PatternMatch a matchValue cases -> + Result.map2 (Value.PatternMatch a) + (resolveVariables variables matchValue) + (cases + |> List.map + (\( casePattern, caseValue ) -> + namesBoundInPattern casePattern + |> Result.andThen + (\patternNames -> + unionVariableNames variables patternNames + ) + |> Result.andThen + (\newVariables -> + resolveVariables newVariables caseValue + ) + |> Result.map (Tuple.pair casePattern) + ) + |> ListOfResults.liftAllErrors + |> Result.mapError List.concat + ) + + Value.Tuple a elems -> + elems + |> List.map (resolveVariables variables) + |> ListOfResults.liftAllErrors + |> Result.mapError List.concat + |> Result.map (Value.Tuple a) + + Value.List a items -> + items + |> List.map (resolveVariables variables) + |> ListOfResults.liftAllErrors + |> Result.mapError List.concat + |> Result.map (Value.List a) + + Value.Record a fields -> + fields + |> List.map + (\( fieldName, fieldValue ) -> + resolveVariables variables fieldValue + |> Result.map (Tuple.pair fieldName) + ) + |> ListOfResults.liftAllErrors + |> Result.mapError List.concat + |> Result.map (Value.Record a) + + Value.Field a subjectValue fieldName -> + resolveVariables variables subjectValue + |> Result.map (\s -> Value.Field a s fieldName) + + Value.Apply a funValue argValue -> + Result.map2 (Value.Apply a) + (resolveVariables variables funValue) + (resolveVariables variables argValue) + + Value.IfThenElse a condValue thenValue elseValue -> + Result.map3 (Value.IfThenElse a) + (resolveVariables variables condValue) + (resolveVariables variables thenValue) + (resolveVariables variables elseValue) + + Value.UpdateRecord a subjectValue newFieldValues -> + Result.map2 (Value.UpdateRecord a) + (resolveVariables variables subjectValue) + (newFieldValues + |> List.map + (\( fieldName, fieldValue ) -> + resolveVariables variables fieldValue + |> Result.map (Tuple.pair fieldName) + ) + |> ListOfResults.liftAllErrors + |> Result.mapError List.concat + ) + + _ -> + Ok value + + withAccessControl : Bool -> a -> AccessControlled a withAccessControl isExposed a = if isExposed then diff --git a/src/Morphir/IR/Value.elm b/src/Morphir/IR/Value.elm index 6afa62246..53c19c2f4 100644 --- a/src/Morphir/IR/Value.elm +++ b/src/Morphir/IR/Value.elm @@ -4,7 +4,7 @@ module Morphir.IR.Value exposing , Literal(..), boolLiteral, charLiteral, stringLiteral, intLiteral, floatLiteral , Pattern(..), wildcardPattern, asPattern, tuplePattern, recordPattern, constructorPattern, emptyListPattern, headTailPattern, literalPattern , Specification - , Definition(..), typedDefinition, untypedDefinition + , Definition, typedDefinition, untypedDefinition , encodeValue, encodeSpecification, encodeDefinition , getDefinitionBody, mapDefinition, mapSpecification, mapValueAttributes ) @@ -133,19 +133,16 @@ type alias Specification a = {-| Type that represents a value or function definition. A definition is the actual data or logic as opposed to a specification which is just the specification of those. Value definitions can be typed or untyped. Exposed values have to be typed. -} -type Definition a - = TypedDefinition (Type a) (List Name) (Value a) - | UntypedDefinition (List Name) (Value a) +type alias Definition a = + { valueType : Maybe (Type a) + , argumentNames : List Name + , body : Value a + } getDefinitionBody : Definition a -> Value a -getDefinitionBody def = - case def of - TypedDefinition _ _ body -> - body - - UntypedDefinition _ body -> - body +getDefinitionBody = + .body @@ -185,17 +182,17 @@ mapSpecification mapType mapValue spec = mapDefinition : (Type a -> Result e (Type b)) -> (Value a -> Result e (Value b)) -> Definition a -> Result (List e) (Definition b) mapDefinition mapType mapValue def = - case def of - TypedDefinition tpe args body -> - Result.map2 (\t v -> TypedDefinition t args v) - (mapType tpe) - (mapValue body) - |> Result.mapError List.singleton + Result.map2 (\t v -> Definition t def.argumentNames v) + (case def.valueType of + Just valueType -> + mapType valueType + |> Result.map Just - UntypedDefinition args body -> - mapValue body - |> Result.map (UntypedDefinition args) - |> Result.mapError List.singleton + Nothing -> + Ok Nothing + ) + (mapValue def.body) + |> Result.mapError List.singleton mapValueAttributes : (a -> b) -> Value a -> Value b @@ -316,12 +313,7 @@ mapPatternAttributes f p = mapDefinitionAttributes : (a -> b) -> Definition a -> Definition b mapDefinitionAttributes f d = - case d of - TypedDefinition tpe args body -> - TypedDefinition (Type.mapTypeAttributes f tpe) args (mapValueAttributes f body) - - UntypedDefinition args body -> - UntypedDefinition args (mapValueAttributes f body) + Definition (d.valueType |> Maybe.map (Type.mapTypeAttributes f)) d.argumentNames (mapValueAttributes f d.body) @@ -875,7 +867,7 @@ arguments. The examples below try to visualize the process. -} typedDefinition : Type a -> List Name -> Value a -> Definition a typedDefinition valueType argumentNames body = - TypedDefinition valueType argumentNames body + Definition (Just valueType) argumentNames body {-| Untyped value or function definition. @@ -898,7 +890,7 @@ arguments. The examples below try to visualize the process. -} untypedDefinition : List Name -> Value a -> Definition a untypedDefinition argumentNames body = - UntypedDefinition argumentNames body + Definition Nothing argumentNames body encodeValue : (a -> Encode.Value) -> Value a -> Encode.Value @@ -1432,41 +1424,23 @@ encodeSpecification encodeAttributes spec = encodeDefinition : (a -> Encode.Value) -> Definition a -> Encode.Value -encodeDefinition encodeAttributes definition = - case definition of - TypedDefinition valueType argumentNames body -> - Encode.object - [ ( "@type", Encode.string "typedDefinition" ) - , ( "valueType", encodeType encodeAttributes valueType ) - , ( "argumentNames", argumentNames |> Encode.list encodeName ) - , ( "body", encodeValue encodeAttributes body ) - ] - - UntypedDefinition argumentNames body -> - Encode.object - [ ( "@type", Encode.string "untypedDefinition" ) - , ( "argumentNames", argumentNames |> Encode.list encodeName ) - , ( "body", encodeValue encodeAttributes body ) - ] +encodeDefinition encodeAttributes def = + Encode.list identity + [ Encode.string "Definition" + , case def.valueType of + Just valueType -> + encodeType encodeAttributes valueType + + Nothing -> + Encode.null + , def.argumentNames |> Encode.list encodeName + , encodeValue encodeAttributes def.body + ] decodeDefinition : Decode.Decoder a -> Decode.Decoder (Definition a) decodeDefinition decodeAttributes = - Decode.field "@type" Decode.string - |> Decode.andThen - (\kind -> - case kind of - "typedDefinition" -> - Decode.map3 TypedDefinition - (Decode.field "valueType" <| decodeType decodeAttributes) - (Decode.field "argumentNames" <| Decode.list decodeName) - (Decode.field "body" <| Decode.lazy (\_ -> decodeValue decodeAttributes)) - - "untypedDefinition" -> - Decode.map2 UntypedDefinition - (Decode.field "argumentNames" <| Decode.list decodeName) - (Decode.field "body" <| Decode.lazy (\_ -> decodeValue decodeAttributes)) - - other -> - Decode.fail <| "Unknown definition type: " ++ other - ) + Decode.map3 Definition + (Decode.index 1 (Decode.maybe (decodeType decodeAttributes))) + (Decode.index 2 (Decode.list decodeName)) + (Decode.index 3 (Decode.lazy (\_ -> decodeValue decodeAttributes))) diff --git a/tests/Morphir/Elm/FrontendTests.elm b/tests/Morphir/Elm/FrontendTests.elm index 9e9f372c3..eaba27126 100644 --- a/tests/Morphir/Elm/FrontendTests.elm +++ b/tests/Morphir/Elm/FrontendTests.elm @@ -20,7 +20,7 @@ import Morphir.IR.SDK.Maybe as Maybe import Morphir.IR.SDK.Number as Number import Morphir.IR.SDK.String as String import Morphir.IR.Type as Type -import Morphir.IR.Value as Value exposing (Definition(..), Literal(..), Pattern(..), Value(..)) +import Morphir.IR.Value as Value exposing (Definition, Literal(..), Pattern(..), Value(..)) import Set import Test exposing (..) @@ -216,6 +216,12 @@ valueTests = Frontend.NotSupported _ expType -> "Not Supported: " ++ expType + + Frontend.DuplicateNameInPattern name _ _ -> + "Duplicate name in pattern: " ++ Name.toCamelCase name + + Frontend.VariableShadowing name _ _ -> + "Variable shadowing: " ++ Name.toCamelCase name ) |> String.join ", " ) @@ -325,7 +331,7 @@ valueTests = <| LetDefinition () (Name.fromString "foo") - (UntypedDefinition [ Name.fromString "a" ] (ref "c")) + (Definition Nothing [ Name.fromString "a" ] (ref "c")) (ref "d") , checkIR (String.join "\n" @@ -375,10 +381,10 @@ valueTests = <| LetDefinition () (Name.fromString "b") - (UntypedDefinition [] (ref "c")) + (Definition Nothing [] (ref "c")) (LetDefinition () (Name.fromString "a") - (UntypedDefinition [] (ref "b")) + (Definition Nothing [] (ref "b")) (ref "a") ) , checkIR @@ -393,10 +399,10 @@ valueTests = <| LetDefinition () (Name.fromString "b") - (UntypedDefinition [] (ref "c")) + (Definition Nothing [] (ref "c")) (LetDefinition () (Name.fromString "a") - (UntypedDefinition [] (ref "b")) + (Definition Nothing [] (ref "b")) (ref "a") ) , checkIR @@ -411,8 +417,8 @@ valueTests = <| LetRecursion () (Dict.fromList - [ ( Name.fromString "b", UntypedDefinition [] (ref "a") ) - , ( Name.fromString "a", UntypedDefinition [] (ref "b") ) + [ ( Name.fromString "b", Definition Nothing [] (ref "a") ) + , ( Name.fromString "a", Definition Nothing [] (ref "b") ) ] ) (ref "a") @@ -429,11 +435,11 @@ valueTests = <| LetDefinition () (Name.fromString "c") - (UntypedDefinition [] (ref "d")) + (Definition Nothing [] (ref "d")) (LetRecursion () (Dict.fromList - [ ( Name.fromString "b", UntypedDefinition [] (ref "a") ) - , ( Name.fromString "a", UntypedDefinition [] (ref "b") ) + [ ( Name.fromString "b", Definition Nothing [] (ref "a") ) + , ( Name.fromString "a", Definition Nothing [] (ref "b") ) ] ) (ref "a") From c02d13833ec6a5db107acaa552a193821e0ff703 Mon Sep 17 00:00:00 2001 From: Attila Mihaly Date: Sat, 18 Apr 2020 23:54:44 -0400 Subject: [PATCH 34/42] Hooked up variable resolution and updated tests. #53 --- src/Morphir/Elm/Frontend.elm | 9 ++++--- tests/Morphir/Elm/FrontendTests.elm | 42 ++++++++++++++++------------- 2 files changed, 28 insertions(+), 23 deletions(-) diff --git a/src/Morphir/Elm/Frontend.elm b/src/Morphir/Elm/Frontend.elm index e2848e364..be11f3fac 100644 --- a/src/Morphir/Elm/Frontend.elm +++ b/src/Morphir/Elm/Frontend.elm @@ -1261,7 +1261,7 @@ namesBoundByPattern p = resolveLocalNames : Path -> Path -> ModuleResolver -> Module.Definition SourceLocation -> Result Errors (Module.Definition SourceLocation) resolveLocalNames packagePath modulePath moduleResolver moduleDef = let - rewriteTypes : Type SourceLocation -> Result Error (Type SourceLocation) + rewriteTypes : Type SourceLocation -> Result Errors (Type SourceLocation) rewriteTypes = Rewrite.bottomUp Type.rewriteType (\tpe -> @@ -1296,18 +1296,19 @@ resolveLocalNames packagePath modulePath moduleResolver moduleDef = (\resolvedFullName -> Type.Reference sourceLocation resolvedFullName args ) - |> Result.mapError (ResolveError sourceLocation) + |> Result.mapError (ResolveError sourceLocation >> List.singleton) |> Just _ -> Nothing ) - rewriteValues : Value SourceLocation -> Result Error (Value SourceLocation) + rewriteValues : Value SourceLocation -> Result Errors (Value SourceLocation) rewriteValues value = - Ok value + resolveVariables Dict.empty value in Module.mapDefinition rewriteTypes rewriteValues moduleDef + |> Result.mapError List.concat resolveVariables : Dict Name SourceLocation -> Value SourceLocation -> Result Errors (Value SourceLocation) diff --git a/tests/Morphir/Elm/FrontendTests.elm b/tests/Morphir/Elm/FrontendTests.elm index eaba27126..fb64e9d63 100644 --- a/tests/Morphir/Elm/FrontendTests.elm +++ b/tests/Morphir/Elm/FrontendTests.elm @@ -244,8 +244,12 @@ valueTests = ref name = Reference () (fQName [] [] [ name ]) - var : String -> Pattern () + var : String -> Value () var name = + Variable () [ name ] + + pvar : String -> Pattern () + pvar name = AsPattern () (WildcardPattern ()) (Name.fromString name) in describe "Values are mapped correctly" @@ -279,7 +283,7 @@ valueTests = , checkIR "\\42 -> foo " <| Lambda () (LiteralPattern () (IntLiteral 42)) (ref "foo") , checkIR "\\0x20 -> foo " <| Lambda () (LiteralPattern () (IntLiteral 32)) (ref "foo") , checkIR "\\( 1, 2 ) -> foo " <| Lambda () (TuplePattern () [ LiteralPattern () (IntLiteral 1), LiteralPattern () (IntLiteral 2) ]) (ref "foo") - , checkIR "\\{ foo, bar } -> foo " <| Lambda () (RecordPattern () [ Name.fromString "foo", Name.fromString "bar" ]) (ref "foo") + , checkIR "\\{ foo, bar } -> foo " <| Lambda () (RecordPattern () [ Name.fromString "foo", Name.fromString "bar" ]) (var "foo") , checkIR "\\1 :: 2 -> foo " <| Lambda () (HeadTailPattern () (LiteralPattern () (IntLiteral 1)) (LiteralPattern () (IntLiteral 2))) (ref "foo") , checkIR "\\[] -> foo " <| Lambda () (EmptyListPattern ()) (ref "foo") , checkIR "\\[ 1 ] -> foo " <| Lambda () (HeadTailPattern () (LiteralPattern () (IntLiteral 1)) (EmptyListPattern ())) (ref "foo") @@ -317,7 +321,7 @@ valueTests = ) <| Destructure () - (TuplePattern () [ var "a", var "b" ]) + (TuplePattern () [ pvar "a", pvar "b" ]) (ref "c") (ref "d") , checkIR @@ -344,11 +348,11 @@ valueTests = ) <| Destructure () - (TuplePattern () [ var "a", var "b" ]) + (TuplePattern () [ pvar "a", pvar "b" ]) (ref "c") (Destructure () - (TuplePattern () [ var "d", var "e" ]) - (ref "a") + (TuplePattern () [ pvar "d", pvar "e" ]) + (var "a") (ref "f") ) , checkIR @@ -362,11 +366,11 @@ valueTests = ) <| Destructure () - (TuplePattern () [ var "a", var "b" ]) + (TuplePattern () [ pvar "a", pvar "b" ]) (ref "c") (Destructure () - (TuplePattern () [ var "d", var "e" ]) - (ref "a") + (TuplePattern () [ pvar "d", pvar "e" ]) + (var "a") (ref "f") ) , checkIR @@ -384,8 +388,8 @@ valueTests = (Definition Nothing [] (ref "c")) (LetDefinition () (Name.fromString "a") - (Definition Nothing [] (ref "b")) - (ref "a") + (Definition Nothing [] (var "b")) + (var "a") ) , checkIR (String.join "\n" @@ -402,8 +406,8 @@ valueTests = (Definition Nothing [] (ref "c")) (LetDefinition () (Name.fromString "a") - (Definition Nothing [] (ref "b")) - (ref "a") + (Definition Nothing [] (var "b")) + (var "a") ) , checkIR (String.join "\n" @@ -417,11 +421,11 @@ valueTests = <| LetRecursion () (Dict.fromList - [ ( Name.fromString "b", Definition Nothing [] (ref "a") ) - , ( Name.fromString "a", Definition Nothing [] (ref "b") ) + [ ( Name.fromString "b", Definition Nothing [] (var "a") ) + , ( Name.fromString "a", Definition Nothing [] (var "b") ) ] ) - (ref "a") + (var "a") , checkIR (String.join "\n" [ " let" @@ -438,11 +442,11 @@ valueTests = (Definition Nothing [] (ref "d")) (LetRecursion () (Dict.fromList - [ ( Name.fromString "b", Definition Nothing [] (ref "a") ) - , ( Name.fromString "a", Definition Nothing [] (ref "b") ) + [ ( Name.fromString "b", Definition Nothing [] (var "a") ) + , ( Name.fromString "a", Definition Nothing [] (var "b") ) ] ) - (ref "a") + (var "a") ) ] From 4dc9173d4f780693684ed483acb15a3e851c9777 Mon Sep 17 00:00:00 2001 From: Attila Mihaly Date: Mon, 20 Apr 2020 12:39:29 -0400 Subject: [PATCH 35/42] Completed reference resolution. #53 --- src/Morphir/Elm/Frontend.elm | 111 ++++++++++++--------------- src/Morphir/Elm/Frontend/Resolve.elm | 43 +++++++++-- tests/Morphir/Elm/FrontendTests.elm | 49 ++++++------ 3 files changed, 109 insertions(+), 94 deletions(-) diff --git a/src/Morphir/Elm/Frontend.elm b/src/Morphir/Elm/Frontend.elm index be11f3fac..ce9ca52f8 100644 --- a/src/Morphir/Elm/Frontend.elm +++ b/src/Morphir/Elm/Frontend.elm @@ -368,12 +368,6 @@ mapProcessedFile currentPackagePath processedFile modulesSoFar = [ ( SDK.packageName, SDK.packageSpec ) ] - moduleResolver : ModuleResolver - moduleResolver = - Resolve.createModuleResolver - (Resolve.createPackageResolver dependencies currentPackagePath moduleDeclsSoFar) - (processedFile.file.imports |> List.map Node.value) - typesResult : Result Errors (Dict Name (AccessControlled (Type.Definition SourceLocation))) typesResult = mapDeclarationsToType processedFile.parsedFile.sourceFile moduleExpose (processedFile.file.declarations |> List.map Node.value) @@ -391,7 +385,19 @@ mapProcessedFile currentPackagePath processedFile modulesSoFar = valuesResult in moduleResult - |> Result.andThen (resolveLocalNames currentPackagePath modulePath moduleResolver) + |> Result.andThen + (\moduleDef -> + let + moduleResolver : ModuleResolver + moduleResolver = + Resolve.createModuleResolver + (Resolve.createPackageResolver dependencies currentPackagePath moduleDeclsSoFar) + (processedFile.file.imports |> List.map Node.value) + modulePath + moduleDef + in + resolveLocalNames moduleResolver moduleDef + ) |> Result.map (\m -> modulesSoFar @@ -1258,8 +1264,8 @@ namesBoundByPattern p = |> Set.fromList -resolveLocalNames : Path -> Path -> ModuleResolver -> Module.Definition SourceLocation -> Result Errors (Module.Definition SourceLocation) -resolveLocalNames packagePath modulePath moduleResolver moduleDef = +resolveLocalNames : ModuleResolver -> Module.Definition SourceLocation -> Result Errors (Module.Definition SourceLocation) +resolveLocalNames moduleResolver moduleDef = let rewriteTypes : Type SourceLocation -> Result Errors (Type SourceLocation) rewriteTypes = @@ -1267,31 +1273,9 @@ resolveLocalNames packagePath modulePath moduleResolver moduleDef = (\tpe -> case tpe of Type.Reference sourceLocation refFullName args -> - let - refModulePath : Path - refModulePath = - refFullName - |> FQName.getModulePath - - refLocalName : Name - refLocalName = - refFullName - |> FQName.getLocalName - - resolvedFullNameResult : Result Resolve.Error FQName - resolvedFullNameResult = - case moduleDef.types |> Dict.get refLocalName of - Just _ -> - if Path.isPrefixOf modulePath packagePath then - Ok (fQName packagePath (modulePath |> List.drop (List.length packagePath)) refLocalName) - - else - Err (Resolve.PackageNotPrefixOfModule packagePath modulePath) - - Nothing -> - moduleResolver.resolveType (refModulePath |> List.map Name.toTitleCase) (refLocalName |> Name.toTitleCase) - in - resolvedFullNameResult + moduleResolver.resolveType + (refFullName |> FQName.getModulePath |> List.map Name.toTitleCase) + (refFullName |> FQName.getLocalName |> Name.toTitleCase) |> Result.map (\resolvedFullName -> Type.Reference sourceLocation resolvedFullName args @@ -1305,14 +1289,14 @@ resolveLocalNames packagePath modulePath moduleResolver moduleDef = rewriteValues : Value SourceLocation -> Result Errors (Value SourceLocation) rewriteValues value = - resolveVariables Dict.empty value + resolveVariablesAndReferences Dict.empty moduleResolver value in Module.mapDefinition rewriteTypes rewriteValues moduleDef |> Result.mapError List.concat -resolveVariables : Dict Name SourceLocation -> Value SourceLocation -> Result Errors (Value SourceLocation) -resolveVariables variables value = +resolveVariablesAndReferences : Dict Name SourceLocation -> ModuleResolver -> Value SourceLocation -> Result Errors (Value SourceLocation) +resolveVariablesAndReferences variables moduleResolver value = let unionNames : (Name -> SourceLocation -> SourceLocation -> Error) -> Dict Name SourceLocation -> Dict Name SourceLocation -> Result Errors (Dict Name SourceLocation) unionNames toError namesA namesB = @@ -1402,12 +1386,19 @@ resolveVariables variables value = Ok Dict.empty in case value of - Value.Reference a (FQName [] [] localName) -> + Value.Reference sourceLocation (FQName [] modulePath localName) -> if variables |> Dict.member localName then - Ok (Value.Variable a localName) + Ok (Value.Variable sourceLocation localName) else - Ok value + moduleResolver.resolveValue + (modulePath |> List.map Name.toTitleCase) + (localName |> Name.toTitleCase) + |> Result.map + (\resolvedFullName -> + Value.Reference sourceLocation resolvedFullName + ) + |> Result.mapError (ResolveError sourceLocation >> List.singleton) Value.Lambda a argPattern bodyValue -> namesBoundInPattern argPattern @@ -1417,13 +1408,13 @@ resolveVariables variables value = ) |> Result.andThen (\newVariables -> - resolveVariables newVariables bodyValue + resolveVariablesAndReferences newVariables moduleResolver bodyValue ) |> Result.map (Value.Lambda a argPattern) Value.LetDefinition sourceLocation name def inValue -> Result.map2 (Value.LetDefinition sourceLocation name) - (resolveVariables variables def.body + (resolveVariablesAndReferences variables moduleResolver def.body |> Result.map (\resolvedBody -> { def @@ -1434,7 +1425,7 @@ resolveVariables variables value = (unionVariableNames variables (Dict.singleton name sourceLocation) |> Result.andThen (\newVariables -> - resolveVariables newVariables inValue + resolveVariablesAndReferences newVariables moduleResolver inValue ) ) @@ -1449,7 +1440,7 @@ resolveVariables variables value = |> Dict.toList |> List.map (\( name, def ) -> - resolveVariables newVariables def.body + resolveVariablesAndReferences newVariables moduleResolver def.body |> Result.map (\resolvedBody -> ( name @@ -1463,12 +1454,12 @@ resolveVariables variables value = |> Result.mapError List.concat |> Result.map Dict.fromList ) - (resolveVariables newVariables inValue) + (resolveVariablesAndReferences newVariables moduleResolver inValue) ) Value.Destructure a pattern subjectValue inValue -> Result.map2 (Value.Destructure a pattern) - (resolveVariables variables subjectValue) + (resolveVariablesAndReferences variables moduleResolver subjectValue) (namesBoundInPattern pattern |> Result.andThen (\patternNames -> @@ -1476,13 +1467,13 @@ resolveVariables variables value = ) |> Result.andThen (\newVariables -> - resolveVariables newVariables inValue + resolveVariablesAndReferences newVariables moduleResolver inValue ) ) Value.PatternMatch a matchValue cases -> Result.map2 (Value.PatternMatch a) - (resolveVariables variables matchValue) + (resolveVariablesAndReferences variables moduleResolver matchValue) (cases |> List.map (\( casePattern, caseValue ) -> @@ -1493,7 +1484,7 @@ resolveVariables variables value = ) |> Result.andThen (\newVariables -> - resolveVariables newVariables caseValue + resolveVariablesAndReferences newVariables moduleResolver caseValue ) |> Result.map (Tuple.pair casePattern) ) @@ -1503,14 +1494,14 @@ resolveVariables variables value = Value.Tuple a elems -> elems - |> List.map (resolveVariables variables) + |> List.map (resolveVariablesAndReferences variables moduleResolver) |> ListOfResults.liftAllErrors |> Result.mapError List.concat |> Result.map (Value.Tuple a) Value.List a items -> items - |> List.map (resolveVariables variables) + |> List.map (resolveVariablesAndReferences variables moduleResolver) |> ListOfResults.liftAllErrors |> Result.mapError List.concat |> Result.map (Value.List a) @@ -1519,7 +1510,7 @@ resolveVariables variables value = fields |> List.map (\( fieldName, fieldValue ) -> - resolveVariables variables fieldValue + resolveVariablesAndReferences variables moduleResolver fieldValue |> Result.map (Tuple.pair fieldName) ) |> ListOfResults.liftAllErrors @@ -1527,27 +1518,27 @@ resolveVariables variables value = |> Result.map (Value.Record a) Value.Field a subjectValue fieldName -> - resolveVariables variables subjectValue + resolveVariablesAndReferences variables moduleResolver subjectValue |> Result.map (\s -> Value.Field a s fieldName) Value.Apply a funValue argValue -> Result.map2 (Value.Apply a) - (resolveVariables variables funValue) - (resolveVariables variables argValue) + (resolveVariablesAndReferences variables moduleResolver funValue) + (resolveVariablesAndReferences variables moduleResolver argValue) Value.IfThenElse a condValue thenValue elseValue -> Result.map3 (Value.IfThenElse a) - (resolveVariables variables condValue) - (resolveVariables variables thenValue) - (resolveVariables variables elseValue) + (resolveVariablesAndReferences variables moduleResolver condValue) + (resolveVariablesAndReferences variables moduleResolver thenValue) + (resolveVariablesAndReferences variables moduleResolver elseValue) Value.UpdateRecord a subjectValue newFieldValues -> Result.map2 (Value.UpdateRecord a) - (resolveVariables variables subjectValue) + (resolveVariablesAndReferences variables moduleResolver subjectValue) (newFieldValues |> List.map (\( fieldName, fieldValue ) -> - resolveVariables variables fieldValue + resolveVariablesAndReferences variables moduleResolver fieldValue |> Result.map (Tuple.pair fieldName) ) |> ListOfResults.liftAllErrors diff --git a/src/Morphir/Elm/Frontend/Resolve.elm b/src/Morphir/Elm/Frontend/Resolve.elm index c70850925..606f321c8 100644 --- a/src/Morphir/Elm/Frontend/Resolve.elm +++ b/src/Morphir/Elm/Frontend/Resolve.elm @@ -13,7 +13,6 @@ import Morphir.IR.Package as Package import Morphir.IR.Path as Path exposing (Path) import Morphir.IR.Type as Type import Morphir.JsonExtra as JsonExtra -import Morphir.Pattern exposing (matchAny) import Set exposing (Set) @@ -86,7 +85,8 @@ type alias ModuleResolver = type alias PackageResolver = - { ctorNames : ModuleName -> LocalName -> Result Error (List String) + { packagePath : Path + , ctorNames : ModuleName -> LocalName -> Result Error (List String) , exposesType : ModuleName -> LocalName -> Result Error Bool , exposesValue : ModuleName -> LocalName -> Result Error Bool , decomposeModuleName : ModuleName -> Result Error ( Path, Path ) @@ -242,11 +242,11 @@ createPackageResolver dependencies currentPackagePath currentPackageModules = ) |> Result.fromMaybe (CouldNotDecompose moduleName) in - PackageResolver ctorNames exposesType exposesValue decomposeModuleName + PackageResolver currentPackagePath ctorNames exposesType exposesValue decomposeModuleName -createModuleResolver : PackageResolver -> List Import -> ModuleResolver -createModuleResolver packageResolver explicitImports = +createModuleResolver : PackageResolver -> List Import -> Path -> Module.Definition a -> ModuleResolver +createModuleResolver packageResolver explicitImports currenctModulePath moduleDef = let imports : List Import imports = @@ -402,8 +402,8 @@ createModuleResolver packageResolver explicitImports = else Err (ModuleNotImported fullModuleName) - resolve : Bool -> ModuleName -> LocalName -> Result Error FQName - resolve isType moduleName localName = + resolveExternally : Bool -> ModuleName -> LocalName -> Result Error FQName + resolveExternally isType moduleName localName = resolveModuleName isType moduleName localName |> Result.andThen packageResolver.decomposeModuleName |> Result.map @@ -411,6 +411,35 @@ createModuleResolver packageResolver explicitImports = fQName packagePath modulePath (Name.fromString localName) ) + resolve : Bool -> ModuleName -> LocalName -> Result Error FQName + resolve isType elmModuleName elmLocalName = + if List.isEmpty elmModuleName then + -- If the name is not prefixed with a module we need to look it up within the module first + let + localNames = + if isType then + moduleDef.types |> Dict.keys + + else + moduleDef.values |> Dict.keys + + localName = + elmLocalName |> Name.fromString + in + if localNames |> List.member localName then + if Path.isPrefixOf currenctModulePath packageResolver.packagePath then + Ok (fQName packageResolver.packagePath (currenctModulePath |> List.drop (List.length packageResolver.packagePath)) localName) + + else + Err (PackageNotPrefixOfModule packageResolver.packagePath currenctModulePath) + + else + resolveExternally isType elmModuleName elmLocalName + + else + -- If the name is prefixed with a module we can skip the local resolution + resolveExternally isType elmModuleName elmLocalName + resolveType : ModuleName -> LocalName -> Result Error FQName resolveType = resolve True diff --git a/tests/Morphir/Elm/FrontendTests.elm b/tests/Morphir/Elm/FrontendTests.elm index fb64e9d63..af1538074 100644 --- a/tests/Morphir/Elm/FrontendTests.elm +++ b/tests/Morphir/Elm/FrontendTests.elm @@ -2,6 +2,7 @@ module Morphir.Elm.FrontendTests exposing (..) import Dict import Expect exposing (Expectation) +import Json.Encode as Encode import Morphir.Elm.Frontend as Frontend exposing (Errors, SourceFile, SourceLocation) import Morphir.IR.AccessControlled exposing (AccessControlled, private, public) import Morphir.IR.FQName exposing (fQName) @@ -186,6 +187,25 @@ valueTests = String.join "\n" [ "module Test exposing (..)" , "" + , "import Bar as Bar" + , "import MyPack.Bar" + , "" + , "foo = 0" + , "" + , "bar = 0" + , "" + , "baz = 0" + , "" + , "a = 1" + , "" + , "b = 2" + , "" + , "c = 3" + , "" + , "d = 4" + , "" + , "f = 5" + , "" , "testValue = " ++ sourceValue ] } @@ -198,32 +218,7 @@ valueTests = |> Result.map Package.eraseDefinitionAttributes |> Result.mapError (\errors -> - errors - |> List.map - (\error -> - case error of - Frontend.ParseError _ _ -> - "Parse Error" - - Frontend.CyclicModules _ -> - "Cyclic Modules" - - Frontend.ResolveError _ _ -> - "Resolve Error" - - Frontend.EmptyApply _ -> - "Empty Apply" - - Frontend.NotSupported _ expType -> - "Not Supported: " ++ expType - - Frontend.DuplicateNameInPattern name _ _ -> - "Duplicate name in pattern: " ++ Name.toCamelCase name - - Frontend.VariableShadowing name _ _ -> - "Variable shadowing: " ++ Name.toCamelCase name - ) - |> String.join ", " + Encode.encode 0 (Encode.list Frontend.encodeError errors) ) |> Result.andThen (\packageDef -> @@ -242,7 +237,7 @@ valueTests = ref : String -> Value () ref name = - Reference () (fQName [] [] [ name ]) + Reference () (fQName [] [ [ "test" ] ] [ name ]) var : String -> Value () var name = From d3df1c6d2429eedf0c540d873351faec032e29d2 Mon Sep 17 00:00:00 2001 From: Attila Mihaly Date: Mon, 20 Apr 2020 14:28:48 -0400 Subject: [PATCH 36/42] Added missing docs and refactored. #68 --- elm.json | 7 ++- src/Morphir/IR/AccessControlled.elm | 57 ++++------------------- src/Morphir/IR/AccessControlled/Codec.elm | 45 ++++++++++++++++++ src/Morphir/IR/Module.elm | 3 +- src/Morphir/IR/Package.elm | 3 +- src/Morphir/IR/QName.elm | 56 ++++------------------ src/Morphir/IR/QName/Codec.elm | 27 +++++++++++ src/Morphir/IR/QName/Fuzzer.elm | 15 ++++++ src/Morphir/IR/Type.elm | 3 +- 9 files changed, 117 insertions(+), 99 deletions(-) create mode 100644 src/Morphir/IR/AccessControlled/Codec.elm create mode 100644 src/Morphir/IR/QName/Codec.elm create mode 100644 src/Morphir/IR/QName/Fuzzer.elm diff --git a/elm.json b/elm.json index 3b01c978b..baa026c63 100644 --- a/elm.json +++ b/elm.json @@ -5,7 +5,12 @@ "license": "Apache-2.0", "version": "1.0.0", "exposed-modules": [ - "Morphir.SDK.StatefulApp" + "Morphir.SDK.StatefulApp", + "Morphir.IR.Name", + "Morphir.IR.Path", + "Morphir.IR.QName", + "Morphir.IR.FQName", + "Morphir.IR.AccessControlled" ], "elm-version": "0.19.0 <= v < 0.20.0", "dependencies": { diff --git a/src/Morphir/IR/AccessControlled.elm b/src/Morphir/IR/AccessControlled.elm index 69987a591..268256030 100644 --- a/src/Morphir/IR/AccessControlled.elm +++ b/src/Morphir/IR/AccessControlled.elm @@ -1,9 +1,8 @@ module Morphir.IR.AccessControlled exposing - ( AccessControlled + ( AccessControlled, Access(..) , public, private , withPublicAccess, withPrivateAccess - , decodeAccessControlled, encodeAccessControlled - , Access(..), map + , map ) {-| Module to manage access to a node in the IR. This is only used to declare access levels @@ -11,7 +10,7 @@ not to enforce them. Enforcement can be done through the helper functions [withPublicAccess](#withPublicAccess) and [withPrivateAccess](#withPrivateAccess) but it's up to the consumer of the API to call the righ function. -@docs AccessControlled +@docs AccessControlled, Access # Creation @@ -24,15 +23,12 @@ up to the consumer of the API to call the righ function. @docs withPublicAccess, withPrivateAccess -# Serialization +# Transform -@docs decodeAccessControlled, encodeAccessControlled +@docs map -} -import Json.Decode as Decode -import Json.Encode as Encode - {-| Type that represents different access levels. -} @@ -42,6 +38,8 @@ type alias AccessControlled a = } +{-| Public or private access. +-} type Access = Public | Private @@ -95,45 +93,8 @@ withPrivateAccess ac = ac.value +{-| Apply a function to the access controlled value but keep the access unchanged. +-} map : (a -> b) -> AccessControlled a -> AccessControlled b map f ac = AccessControlled ac.access (f ac.value) - - -{-| Encode AccessControlled to JSON. --} -encodeAccessControlled : (a -> Encode.Value) -> AccessControlled a -> Encode.Value -encodeAccessControlled encodeValue ac = - case ac.access of - Public -> - Encode.list identity - [ Encode.string "Public" - , encodeValue ac.value - ] - - Private -> - Encode.list identity - [ Encode.string "Private" - , encodeValue ac.value - ] - - -{-| Decode AccessControlled from JSON. --} -decodeAccessControlled : Decode.Decoder a -> Decode.Decoder (AccessControlled a) -decodeAccessControlled decodeValue = - Decode.index 0 Decode.string - |> Decode.andThen - (\tag -> - case tag of - "Public" -> - Decode.map (AccessControlled Public) - (Decode.index 1 decodeValue) - - "Private" -> - Decode.map (AccessControlled Private) - (Decode.index 1 decodeValue) - - other -> - Decode.fail <| "Unknown access controlled type: " ++ other - ) diff --git a/src/Morphir/IR/AccessControlled/Codec.elm b/src/Morphir/IR/AccessControlled/Codec.elm new file mode 100644 index 000000000..5c2561b58 --- /dev/null +++ b/src/Morphir/IR/AccessControlled/Codec.elm @@ -0,0 +1,45 @@ +module Morphir.IR.AccessControlled.Codec exposing (..) + +{-| Encode AccessControlled to JSON. +-} + +import Json.Decode as Decode +import Json.Encode as Encode +import Morphir.IR.AccessControlled exposing (Access(..), AccessControlled) + + +encodeAccessControlled : (a -> Encode.Value) -> AccessControlled a -> Encode.Value +encodeAccessControlled encodeValue ac = + case ac.access of + Public -> + Encode.list identity + [ Encode.string "Public" + , encodeValue ac.value + ] + + Private -> + Encode.list identity + [ Encode.string "Private" + , encodeValue ac.value + ] + + +{-| Decode AccessControlled from JSON. +-} +decodeAccessControlled : Decode.Decoder a -> Decode.Decoder (AccessControlled a) +decodeAccessControlled decodeValue = + Decode.index 0 Decode.string + |> Decode.andThen + (\tag -> + case tag of + "Public" -> + Decode.map (AccessControlled Public) + (Decode.index 1 decodeValue) + + "Private" -> + Decode.map (AccessControlled Private) + (Decode.index 1 decodeValue) + + other -> + Decode.fail <| "Unknown access controlled type: " ++ other + ) diff --git a/src/Morphir/IR/Module.elm b/src/Morphir/IR/Module.elm index 19d2d6944..766e64c3a 100644 --- a/src/Morphir/IR/Module.elm +++ b/src/Morphir/IR/Module.elm @@ -14,7 +14,8 @@ module Morphir.IR.Module exposing import Dict exposing (Dict) import Json.Encode as Encode -import Morphir.IR.AccessControlled exposing (AccessControlled, encodeAccessControlled, withPublicAccess) +import Morphir.IR.AccessControlled exposing (AccessControlled, withPublicAccess) +import Morphir.IR.AccessControlled.Codec exposing (encodeAccessControlled) import Morphir.IR.Name exposing (Name, encodeName) import Morphir.IR.Path exposing (Path) import Morphir.IR.Type as Type exposing (Type) diff --git a/src/Morphir/IR/Package.elm b/src/Morphir/IR/Package.elm index b19dc3986..648ca35ef 100644 --- a/src/Morphir/IR/Package.elm +++ b/src/Morphir/IR/Package.elm @@ -14,7 +14,8 @@ module Morphir.IR.Package exposing import Dict exposing (Dict) import Json.Encode as Encode -import Morphir.IR.AccessControlled exposing (AccessControlled, encodeAccessControlled, withPublicAccess) +import Morphir.IR.AccessControlled exposing (AccessControlled, withPublicAccess) +import Morphir.IR.AccessControlled.Codec exposing (encodeAccessControlled) import Morphir.IR.Module as Module exposing (ModulePath) import Morphir.IR.Path exposing (Path, encodePath) import Morphir.IR.Type as Type exposing (Type) diff --git a/src/Morphir/IR/QName.elm b/src/Morphir/IR/QName.elm index 3086160a4..7f64bf45b 100644 --- a/src/Morphir/IR/QName.elm +++ b/src/Morphir/IR/QName.elm @@ -1,37 +1,27 @@ module Morphir.IR.QName exposing - ( QName, fromTuple, toTuple, getModulePath, getLocalName + ( QName(..), toTuple, getModulePath, getLocalName + , fromName, fromTuple , toString - , fuzzQName - , encodeQName, decodeQName - , fromName ) {-| Module to work with qualified names. A qualified name is a combination of a module path and a local name. -@docs QName, fromTuple, toTuple, qName, getModulePath, getLocalName +@docs QName, toTuple, getModulePath, getLocalName -# String conversion - -@docs toString - +# Creation -# Property Testing +@docs fromName, fromTuple -@docs fuzzQName +# String conversion -# Serialization - -@docs encodeQName, decodeQName +@docs toString -} -import Fuzz exposing (Fuzzer) -import Json.Decode as Decode -import Json.Encode as Encode -import Morphir.IR.Name exposing (Name, decodeName, encodeName, fuzzName) -import Morphir.IR.Path as Path exposing (Path, decodePath, encodePath, fuzzPath) +import Morphir.IR.Name exposing (Name) +import Morphir.IR.Path as Path exposing (Path) {-| Type that represents a qualified name. @@ -101,31 +91,3 @@ toString pathPartToString nameToString sep (QName mPath lName) = |> List.map pathPartToString |> List.append [ nameToString lName ] |> String.join sep - - -{-| QName fuzzer. --} -fuzzQName : Fuzzer QName -fuzzQName = - Fuzz.map2 QName - fuzzPath - fuzzName - - -{-| Encode a qualified name to JSON. --} -encodeQName : QName -> Encode.Value -encodeQName (QName modulePath localName) = - Encode.list identity - [ modulePath |> encodePath - , localName |> encodeName - ] - - -{-| Decode a qualified name from JSON. --} -decodeQName : Decode.Decoder QName -decodeQName = - Decode.map2 QName - (Decode.index 0 decodePath) - (Decode.index 1 decodeName) diff --git a/src/Morphir/IR/QName/Codec.elm b/src/Morphir/IR/QName/Codec.elm new file mode 100644 index 000000000..c2a8caf85 --- /dev/null +++ b/src/Morphir/IR/QName/Codec.elm @@ -0,0 +1,27 @@ +module Morphir.IR.QName.Codec exposing (..) + +{-| Encode a qualified name to JSON. +-} + +import Json.Decode as Decode +import Json.Encode as Encode +import Morphir.IR.Name exposing (decodeName, encodeName) +import Morphir.IR.Path exposing (decodePath, encodePath) +import Morphir.IR.QName exposing (QName) + + +encodeQName : QName -> Encode.Value +encodeQName (QName modulePath localName) = + Encode.list identity + [ modulePath |> encodePath + , localName |> encodeName + ] + + +{-| Decode a qualified name from JSON. +-} +decodeQName : Decode.Decoder QName +decodeQName = + Decode.map2 QName + (Decode.index 0 decodePath) + (Decode.index 1 decodeName) diff --git a/src/Morphir/IR/QName/Fuzzer.elm b/src/Morphir/IR/QName/Fuzzer.elm new file mode 100644 index 000000000..747b89b4a --- /dev/null +++ b/src/Morphir/IR/QName/Fuzzer.elm @@ -0,0 +1,15 @@ +module Morphir.IR.QName.Fuzzer exposing (..) + +import Fuzz exposing (Fuzzer) +import Morphir.IR.Name exposing (fuzzName) +import Morphir.IR.Path exposing (fuzzPath) +import Morphir.IR.QName exposing (QName(..)) + + +{-| QName fuzzer. +-} +fuzzQName : Fuzzer QName +fuzzQName = + Fuzz.map2 QName + fuzzPath + fuzzName diff --git a/src/Morphir/IR/Type.elm b/src/Morphir/IR/Type.elm index 4521d61bd..c4c9d3111 100644 --- a/src/Morphir/IR/Type.elm +++ b/src/Morphir/IR/Type.elm @@ -62,7 +62,8 @@ module Morphir.IR.Type exposing import Fuzz exposing (Fuzzer) import Json.Decode as Decode import Json.Encode as Encode -import Morphir.IR.AccessControlled as AccessControlled exposing (AccessControlled, encodeAccessControlled, withPublicAccess) +import Morphir.IR.AccessControlled as AccessControlled exposing (AccessControlled, withPublicAccess) +import Morphir.IR.AccessControlled.Codec exposing (encodeAccessControlled) import Morphir.IR.FQName exposing (FQName, decodeFQName, encodeFQName, fuzzFQName) import Morphir.IR.Name exposing (Name, decodeName, encodeName, fuzzName) import Morphir.ListOfResults as ListOfResults From 55d61dc9c455bf7d4108eea2d2aa7f7c8def1bd1 Mon Sep 17 00:00:00 2001 From: Attila Mihaly Date: Fri, 24 Apr 2020 16:59:33 -0400 Subject: [PATCH 37/42] Document and refactor driven by the goal to process Morphir using Morphir. #68 --- elm.json | 4 +- morphir.json | 11 +- package.json | 3 +- src/Morphir/Elm/Frontend.elm | 219 +++++---- src/Morphir/Elm/Frontend/Resolve.elm | 56 ++- src/Morphir/IR/FQName.elm | 54 +-- src/Morphir/IR/FQName/Codec.elm | 29 ++ src/Morphir/IR/FQName/Fuzzer.elm | 17 + src/Morphir/IR/Module.elm | 183 ++------ src/Morphir/IR/Module/Codec.elm | 68 +++ src/Morphir/IR/Name.elm | 93 ---- src/Morphir/IR/Name/Codec.elm | 22 + src/Morphir/IR/Name/Fuzzer.elm | 66 +++ src/Morphir/IR/Package.elm | 146 ++---- src/Morphir/IR/Package/Codec.elm | 53 +++ src/Morphir/IR/Path.elm | 43 +- src/Morphir/IR/Path/Codec.elm | 24 + src/Morphir/IR/Path/Fuzzer.elm | 15 + src/Morphir/IR/SDK/Appending.elm | 9 +- src/Morphir/IR/SDK/Bool.elm | 14 +- src/Morphir/IR/SDK/Comparison.elm | 27 +- src/Morphir/IR/SDK/Composition.elm | 15 +- src/Morphir/IR/SDK/Equality.elm | 15 +- src/Morphir/IR/SDK/Float.elm | 10 +- src/Morphir/IR/SDK/Int.elm | 10 +- src/Morphir/IR/SDK/List.elm | 10 +- src/Morphir/IR/SDK/Number.elm | 26 +- src/Morphir/IR/Type.elm | 456 +++---------------- src/Morphir/IR/Type/Codec.elm | 207 +++++++++ src/Morphir/IR/Type/Fuzzer.elm | 79 ++++ src/Morphir/IR/Type/Rewrite.elm | 64 +++ src/Morphir/IR/Value.elm | 637 ++------------------------- src/Morphir/IR/Value/Codec.elm | 569 ++++++++++++++++++++++++ tests/Morphir/Elm/FrontendTests.elm | 46 +- tests/Morphir/IR/NameTests.elm | 12 +- tests/Morphir/IR/PathTests.elm | 13 +- 36 files changed, 1681 insertions(+), 1644 deletions(-) create mode 100644 src/Morphir/IR/FQName/Codec.elm create mode 100644 src/Morphir/IR/FQName/Fuzzer.elm create mode 100644 src/Morphir/IR/Module/Codec.elm create mode 100644 src/Morphir/IR/Name/Codec.elm create mode 100644 src/Morphir/IR/Name/Fuzzer.elm create mode 100644 src/Morphir/IR/Package/Codec.elm create mode 100644 src/Morphir/IR/Path/Codec.elm create mode 100644 src/Morphir/IR/Path/Fuzzer.elm create mode 100644 src/Morphir/IR/Type/Codec.elm create mode 100644 src/Morphir/IR/Type/Fuzzer.elm create mode 100644 src/Morphir/IR/Type/Rewrite.elm create mode 100644 src/Morphir/IR/Value/Codec.elm diff --git a/elm.json b/elm.json index baa026c63..31757ddd1 100644 --- a/elm.json +++ b/elm.json @@ -10,7 +10,9 @@ "Morphir.IR.Path", "Morphir.IR.QName", "Morphir.IR.FQName", - "Morphir.IR.AccessControlled" + "Morphir.IR.AccessControlled", + "Morphir.IR.Type", + "Morphir.IR.Value" ], "elm-version": "0.19.0 <= v < 0.20.0", "dependencies": { diff --git a/morphir.json b/morphir.json index a1524892c..edc857f79 100644 --- a/morphir.json +++ b/morphir.json @@ -2,7 +2,14 @@ "name": "Morphir", "sourceDirectory": "src", "exposedModules": [ - "IR.Advanced.Type", - "IR.Advanced.Value" + "IR.Name", + "IR.Path", + "IR.QName", + "IR.FQName", + "IR.AccessControlled", + "IR.Type", + "IR.Value", + "IR.Module", + "IR.Package" ] } \ No newline at end of file diff --git a/package.json b/package.json index 86c2695b8..f93f95bb3 100644 --- a/package.json +++ b/package.json @@ -4,7 +4,8 @@ "description": "Elm bindings for Morphir", "scripts": { "test": "elm-test", - "make-cli": "cd cli && elm make src/Morphir/Elm/CLI.elm --output Morphir.Elm.CLI.js --optimize && elm make src/Morphir/Elm/DaprCLI.elm --output Morphir.Elm.DaprCLI.js --optimize" + "make-cli": "cd cli && elm make src/Morphir/Elm/CLI.elm --output Morphir.Elm.CLI.js --optimize && elm make src/Morphir/Elm/DaprCLI.elm --output Morphir.Elm.DaprCLI.js --optimize", + "make-cli-dev": "cd cli && elm make src/Morphir/Elm/CLI.elm --output Morphir.Elm.CLI.js && elm make src/Morphir/Elm/DaprCLI.elm --output Morphir.Elm.DaprCLI.js" }, "repository": { "type": "git", diff --git a/src/Morphir/Elm/Frontend.elm b/src/Morphir/Elm/Frontend.elm index ce9ca52f8..4ffaae826 100644 --- a/src/Morphir/Elm/Frontend.elm +++ b/src/Morphir/Elm/Frontend.elm @@ -22,7 +22,8 @@ import Morphir.Graph import Morphir.IR.AccessControlled exposing (AccessControlled, private, public) import Morphir.IR.FQName as FQName exposing (FQName(..), fQName) import Morphir.IR.Module as Module -import Morphir.IR.Name as Name exposing (Name, encodeName) +import Morphir.IR.Name as Name exposing (Name) +import Morphir.IR.Name.Codec exposing (encodeName) import Morphir.IR.Package as Package import Morphir.IR.Path as Path exposing (Path) import Morphir.IR.QName as QName @@ -37,6 +38,7 @@ import Morphir.IR.SDK.Int as Int import Morphir.IR.SDK.List as List import Morphir.IR.SDK.Number as Number import Morphir.IR.Type as Type exposing (Type) +import Morphir.IR.Type.Rewrite exposing (rewriteType) import Morphir.IR.Value as Value exposing (Value) import Morphir.JsonExtra as JsonExtra import Morphir.ListOfResults as ListOfResults @@ -657,16 +659,16 @@ mapFunctionImplementation sourceFile argumentNodes expression = sourceLocation range = range |> SourceLocation sourceFile - extractNamedParams : List Name -> List (Node Pattern) -> ( List Name, List (Node Pattern) ) + extractNamedParams : List ( Name, SourceLocation ) -> List (Node Pattern) -> ( List ( Name, SourceLocation ), List (Node Pattern) ) extractNamedParams namedParams patternParams = case patternParams of [] -> ( namedParams, patternParams ) - (Node _ firstParam) :: restOfParams -> + (Node range firstParam) :: restOfParams -> case firstParam of VarPattern paramName -> - extractNamedParams (namedParams ++ [ Name.fromString paramName ]) restOfParams + extractNamedParams (namedParams ++ [ ( Name.fromString paramName, range |> SourceLocation sourceFile ) ]) restOfParams _ -> ( namedParams, patternParams ) @@ -729,18 +731,45 @@ mapExpression sourceFile (Node range exp) = |> Result.andThen (List.reverse >> toApply) Expression.OperatorApplication op _ leftNode rightNode -> - mapOperator sourceFile sourceLocation op leftNode rightNode + case op of + "<|" -> + -- the purpose of this operator is cleaner syntax so it's not mapped to the IR + Result.map2 (Value.Apply sourceLocation) + (mapExpression sourceFile leftNode) + (mapExpression sourceFile rightNode) + + "|>" -> + -- the purpose of this operator is cleaner syntax so it's not mapped to the IR + Result.map2 (Value.Apply sourceLocation) + (mapExpression sourceFile rightNode) + (mapExpression sourceFile leftNode) - Expression.FunctionOrValue moduleName valueName -> - case ( moduleName, valueName ) of - ( [], "True" ) -> - Ok (Value.Literal sourceLocation (Value.BoolLiteral True)) + _ -> + Result.map3 (\fun arg1 arg2 -> Value.Apply sourceLocation (Value.Apply sourceLocation fun arg1) arg2) + (mapOperator sourceLocation op) + (mapExpression sourceFile leftNode) + (mapExpression sourceFile rightNode) + + Expression.FunctionOrValue moduleName localName -> + localName + |> String.uncons + |> Result.fromMaybe [ NotSupported sourceLocation "Empty value name" ] + |> Result.andThen + (\( firstChar, _ ) -> + if Char.isUpper firstChar then + case ( moduleName, localName ) of + ( [], "True" ) -> + Ok (Value.Literal sourceLocation (Value.BoolLiteral True)) - ( [], "False" ) -> - Ok (Value.Literal sourceLocation (Value.BoolLiteral False)) + ( [], "False" ) -> + Ok (Value.Literal sourceLocation (Value.BoolLiteral False)) - _ -> - Ok (Value.Reference sourceLocation (fQName [] (moduleName |> List.map Name.fromString) (valueName |> Name.fromString))) + _ -> + Ok (Value.Constructor sourceLocation (fQName [] (moduleName |> List.map Name.fromString) (localName |> Name.fromString))) + + else + Ok (Value.Reference sourceLocation (fQName [] (moduleName |> List.map Name.fromString) (localName |> Name.fromString))) + ) Expression.IfBlock condNode thenNode elseNode -> Result.map3 (Value.IfThenElse sourceLocation) @@ -748,11 +777,11 @@ mapExpression sourceFile (Node range exp) = (mapExpression sourceFile thenNode) (mapExpression sourceFile elseNode) - Expression.PrefixOperator _ -> - Err [ NotSupported sourceLocation "TODO: PrefixOperator" ] + Expression.PrefixOperator op -> + mapOperator sourceLocation op - Expression.Operator _ -> - Err [ NotSupported sourceLocation "TODO: Operator" ] + Expression.Operator op -> + mapOperator sourceLocation op Expression.Integer value -> Ok (Value.Literal sourceLocation (Value.IntLiteral value)) @@ -949,81 +978,62 @@ mapPattern sourceFile (Node range pattern) = mapPattern sourceFile childNode -mapOperator : SourceFile -> SourceLocation -> String -> Node Expression -> Node Expression -> Result Errors (Value.Value SourceLocation) -mapOperator sourceFile sourceLocation op leftNode rightNode = - let - applyBinary : (SourceLocation -> Value SourceLocation -> Value SourceLocation -> Value SourceLocation) -> Result Errors (Value.Value SourceLocation) - applyBinary fun = - Result.map2 (fun sourceLocation) - (mapExpression sourceFile leftNode) - (mapExpression sourceFile rightNode) - in +mapOperator : SourceLocation -> String -> Result Errors (Value.Value SourceLocation) +mapOperator sourceLocation op = case op of - "<|" -> - -- the purpose of this operator is cleaner syntax so it's not mapped to the IR - Result.map2 (Value.Apply sourceLocation) - (mapExpression sourceFile leftNode) - (mapExpression sourceFile rightNode) - - "|>" -> - -- the purpose of this operator is cleaner syntax so it's not mapped to the IR - Result.map2 (Value.Apply sourceLocation) - (mapExpression sourceFile rightNode) - (mapExpression sourceFile leftNode) - "||" -> - applyBinary Bool.or + Ok <| Bool.or sourceLocation "&&" -> - applyBinary Bool.and + Ok <| Bool.and sourceLocation "==" -> - applyBinary Equality.equal + Ok <| Equality.equal sourceLocation "/=" -> - applyBinary Equality.notEqual + Ok <| Equality.notEqual sourceLocation "<" -> - applyBinary Comparison.lessThan + Ok <| Comparison.lessThan sourceLocation ">" -> - applyBinary Comparison.greaterThan + Ok <| Comparison.greaterThan sourceLocation "<=" -> - applyBinary Comparison.lessThanOrEqual + Ok <| Comparison.lessThanOrEqual sourceLocation ">=" -> - applyBinary Comparison.greaterThanOrEqual + Ok <| Comparison.greaterThanOrEqual sourceLocation "++" -> - applyBinary Appending.append + Ok <| Appending.append sourceLocation "+" -> - applyBinary Number.add + Ok <| Number.add sourceLocation "-" -> - applyBinary Number.subtract + Ok <| Number.subtract sourceLocation "*" -> - applyBinary Number.multiply + Ok <| Number.multiply sourceLocation "/" -> - applyBinary Float.divide + Ok <| Float.divide sourceLocation "//" -> - applyBinary Int.divide + Ok <| Int.divide sourceLocation "^" -> - applyBinary Number.power + Ok <| Number.power sourceLocation "<<" -> - applyBinary Composition.composeLeft + Ok <| Composition.composeLeft sourceLocation ">>" -> - applyBinary Composition.composeRight + Ok <| Composition.composeRight sourceLocation "::" -> - applyBinary List.construct + Ok <| List.construct sourceLocation _ -> Err [ NotSupported sourceLocation <| "OperatorApplication: " ++ op ] @@ -1269,7 +1279,7 @@ resolveLocalNames moduleResolver moduleDef = let rewriteTypes : Type SourceLocation -> Result Errors (Type SourceLocation) rewriteTypes = - Rewrite.bottomUp Type.rewriteType + Rewrite.bottomUp rewriteType (\tpe -> case tpe of Type.Reference sourceLocation refFullName args -> @@ -1287,12 +1297,50 @@ resolveLocalNames moduleResolver moduleDef = Nothing ) - rewriteValues : Value SourceLocation -> Result Errors (Value SourceLocation) - rewriteValues value = - resolveVariablesAndReferences Dict.empty moduleResolver value + rewriteValues : Dict Name SourceLocation -> Value SourceLocation -> Result Errors (Value SourceLocation) + rewriteValues variables value = + resolveVariablesAndReferences variables moduleResolver value + + typesResult : Result Errors (Dict Name (AccessControlled (Type.Definition SourceLocation))) + typesResult = + moduleDef.types + |> Dict.toList + |> List.map + (\( typeName, typeDef ) -> + typeDef.value + |> Type.mapDefinition rewriteTypes + |> Result.map (AccessControlled typeDef.access) + |> Result.map (Tuple.pair typeName) + |> Result.mapError List.concat + ) + |> ListOfResults.liftAllErrors + |> Result.map Dict.fromList + |> Result.mapError List.concat + + valuesResult : Result Errors (Dict Name (AccessControlled (Value.Definition SourceLocation))) + valuesResult = + moduleDef.values + |> Dict.toList + |> List.map + (\( valueName, valueDef ) -> + let + variables : Dict Name SourceLocation + variables = + valueDef.value.arguments |> Dict.fromList + in + valueDef.value + |> Value.mapDefinition rewriteTypes (rewriteValues variables) + |> Result.map (AccessControlled valueDef.access) + |> Result.map (Tuple.pair valueName) + |> Result.mapError List.concat + ) + |> ListOfResults.liftAllErrors + |> Result.map Dict.fromList + |> Result.mapError List.concat in - Module.mapDefinition rewriteTypes rewriteValues moduleDef - |> Result.mapError List.concat + Result.map2 Module.Definition + typesResult + valuesResult resolveVariablesAndReferences : Dict Name SourceLocation -> ModuleResolver -> Value SourceLocation -> Result Errors (Value SourceLocation) @@ -1393,7 +1441,7 @@ resolveVariablesAndReferences variables moduleResolver value = else moduleResolver.resolveValue (modulePath |> List.map Name.toTitleCase) - (localName |> Name.toTitleCase) + (localName |> Name.toCamelCase) |> Result.map (\resolvedFullName -> Value.Reference sourceLocation resolvedFullName @@ -1414,12 +1462,19 @@ resolveVariablesAndReferences variables moduleResolver value = Value.LetDefinition sourceLocation name def inValue -> Result.map2 (Value.LetDefinition sourceLocation name) - (resolveVariablesAndReferences variables moduleResolver def.body - |> Result.map - (\resolvedBody -> - { def - | body = resolvedBody - } + (def.arguments + |> Dict.fromList + |> Dict.insert name sourceLocation + |> unionVariableNames variables + |> Result.andThen + (\variablesDefNameAndArgs -> + resolveVariablesAndReferences variablesDefNameAndArgs moduleResolver def.body + |> Result.map + (\resolvedBody -> + { def + | body = resolvedBody + } + ) ) ) (unionVariableNames variables (Dict.singleton name sourceLocation) @@ -1434,27 +1489,33 @@ resolveVariablesAndReferences variables moduleResolver value = |> Dict.map (\_ _ -> sourceLocation) |> unionVariableNames variables |> Result.andThen - (\newVariables -> + (\variablesAndDefNames -> Result.map2 (Value.LetRecursion sourceLocation) (defs |> Dict.toList |> List.map (\( name, def ) -> - resolveVariablesAndReferences newVariables moduleResolver def.body - |> Result.map - (\resolvedBody -> - ( name - , { def - | body = resolvedBody - } - ) + def.arguments + |> Dict.fromList + |> unionVariableNames variablesAndDefNames + |> Result.andThen + (\variablesDefNamesAndArgs -> + resolveVariablesAndReferences variablesDefNamesAndArgs moduleResolver def.body + |> Result.map + (\resolvedBody -> + ( name + , { def + | body = resolvedBody + } + ) + ) ) ) |> ListOfResults.liftAllErrors |> Result.mapError List.concat |> Result.map Dict.fromList ) - (resolveVariablesAndReferences newVariables moduleResolver inValue) + (resolveVariablesAndReferences variablesAndDefNames moduleResolver inValue) ) Value.Destructure a pattern subjectValue inValue -> diff --git a/src/Morphir/Elm/Frontend/Resolve.elm b/src/Morphir/Elm/Frontend/Resolve.elm index 606f321c8..b84666ef8 100644 --- a/src/Morphir/Elm/Frontend/Resolve.elm +++ b/src/Morphir/Elm/Frontend/Resolve.elm @@ -96,12 +96,12 @@ type alias PackageResolver = defaultImports : List Import defaultImports = let - importExplicit : ModuleName -> Maybe ModuleName -> List TopLevelExpose -> Import + importExplicit : ModuleName -> Maybe String -> List TopLevelExpose -> Import importExplicit moduleName maybeAlias exposingList = Import (Node emptyRange moduleName) (maybeAlias - |> Maybe.map (Node emptyRange) + |> Maybe.map (List.singleton >> Node emptyRange) ) (exposingList |> List.map (Node emptyRange) @@ -111,16 +111,25 @@ defaultImports = ) in [ importExplicit [ "Morphir", "SDK", "Bool" ] Nothing [ TypeOrAliasExpose "Bool" ] - , importExplicit [ "Morphir", "SDK", "Char" ] Nothing [ TypeOrAliasExpose "Char" ] + , importExplicit [ "Morphir", "SDK", "Char" ] (Just "Char") [ TypeOrAliasExpose "Char" ] , importExplicit [ "Morphir", "SDK", "Int" ] Nothing [ TypeOrAliasExpose "Int" ] , importExplicit [ "Morphir", "SDK", "Float" ] Nothing [ TypeOrAliasExpose "Float" ] - , importExplicit [ "Morphir", "SDK", "String" ] Nothing [ TypeOrAliasExpose "String" ] - , importExplicit [ "Morphir", "SDK", "Maybe" ] Nothing [ TypeOrAliasExpose "Maybe" ] - , importExplicit [ "Morphir", "SDK", "Result" ] Nothing [ TypeOrAliasExpose "Result" ] - , importExplicit [ "Morphir", "SDK", "List" ] Nothing [ TypeOrAliasExpose "List" ] + , importExplicit [ "Morphir", "SDK", "String" ] (Just "String") [ TypeOrAliasExpose "String" ] + , importExplicit [ "Morphir", "SDK", "Maybe" ] (Just "Maybe") [ TypeOrAliasExpose "Maybe" ] + , importExplicit [ "Morphir", "SDK", "Result" ] (Just "Result") [ TypeOrAliasExpose "Result" ] + , importExplicit [ "Morphir", "SDK", "List" ] (Just "List") [ TypeOrAliasExpose "List" ] + , importExplicit [ "Morphir", "SDK", "Regex" ] (Just "Regex") [ TypeOrAliasExpose "Regex" ] + , importExplicit [ "Morphir", "SDK", "Tuple" ] (Just "Tuple") [] ] +moduleMapping : Dict ModuleName ModuleName +moduleMapping = + Dict.fromList + [ ( [ "Dict" ], [ "Morphir", "SDK", "Dict" ] ) + ] + + createPackageResolver : Dict Path (Package.Specification a) -> Path -> Dict Path (Module.Specification a) -> PackageResolver createPackageResolver dependencies currentPackagePath currentPackageModules = let @@ -220,9 +229,13 @@ createPackageResolver dependencies currentPackagePath currentPackageModules = decomposeModuleName : ModuleName -> Result Error ( Path, Path ) decomposeModuleName moduleName = let + morphirModuleName : ModuleName + morphirModuleName = + moduleMapping |> Dict.get moduleName |> Maybe.withDefault moduleName + suppliedModulePath : Path suppliedModulePath = - moduleName + morphirModuleName |> List.map Name.fromString matchModuleToPackagePath modulePath packagePath = @@ -240,14 +253,31 @@ createPackageResolver dependencies currentPackagePath currentPackageModules = |> List.filterMap (matchModuleToPackagePath suppliedModulePath) |> List.head ) - |> Result.fromMaybe (CouldNotDecompose moduleName) + |> Result.fromMaybe (CouldNotDecompose morphirModuleName) in PackageResolver currentPackagePath ctorNames exposesType exposesValue decomposeModuleName createModuleResolver : PackageResolver -> List Import -> Path -> Module.Definition a -> ModuleResolver -createModuleResolver packageResolver explicitImports currenctModulePath moduleDef = +createModuleResolver packageResolver elmImports currenctModulePath moduleDef = let + explicitImports : List Import + explicitImports = + elmImports + |> List.map + (\imp -> + { imp + | moduleName = + imp.moduleName + |> Node.map + (\moduleName -> + moduleMapping + |> Dict.get moduleName + |> Maybe.withDefault moduleName + ) + } + ) + imports : List Import imports = defaultImports ++ explicitImports @@ -441,11 +471,13 @@ createModuleResolver packageResolver explicitImports currenctModulePath moduleDe resolveExternally isType elmModuleName elmLocalName resolveType : ModuleName -> LocalName -> Result Error FQName - resolveType = + resolveType moduleName = resolve True + (moduleMapping |> Dict.get moduleName |> Maybe.withDefault moduleName) resolveValue : ModuleName -> LocalName -> Result Error FQName - resolveValue = + resolveValue moduleName = resolve False + (moduleMapping |> Dict.get moduleName |> Maybe.withDefault moduleName) in ModuleResolver resolveType resolveValue diff --git a/src/Morphir/IR/FQName.elm b/src/Morphir/IR/FQName.elm index 4ac21108d..29aebc617 100644 --- a/src/Morphir/IR/FQName.elm +++ b/src/Morphir/IR/FQName.elm @@ -1,30 +1,13 @@ -module Morphir.IR.FQName exposing - ( FQName(..), fQName, fromQName, getPackagePath, getModulePath, getLocalName - , fuzzFQName - , encodeFQName, decodeFQName - ) +module Morphir.IR.FQName exposing (FQName(..), fQName, fromQName, getPackagePath, getModulePath, getLocalName) {-| Module to work with fully-qualified names. A qualified name is a combination of a package path, a module path and a local name. @docs FQName, fQName, fromQName, getPackagePath, getModulePath, getLocalName - -# Property Testing - -@docs fuzzFQName - - -# Serialization - -@docs encodeFQName, decodeFQName - -} -import Fuzz exposing (Fuzzer) -import Json.Decode as Decode -import Json.Encode as Encode -import Morphir.IR.Name exposing (Name, decodeName, encodeName, fuzzName) -import Morphir.IR.Path exposing (Path, decodePath, encodePath, fuzzPath) +import Morphir.IR.Name exposing (Name) +import Morphir.IR.Path exposing (Path) import Morphir.IR.QName as QName exposing (QName) @@ -67,34 +50,3 @@ getModulePath (FQName _ m _) = getLocalName : FQName -> Name getLocalName (FQName _ _ l) = l - - -{-| FQName fuzzer. --} -fuzzFQName : Fuzzer FQName -fuzzFQName = - Fuzz.map3 FQName - fuzzPath - fuzzPath - fuzzName - - -{-| Encode a fully-qualified name to JSON. --} -encodeFQName : FQName -> Encode.Value -encodeFQName (FQName packagePath modulePath localName) = - Encode.list identity - [ packagePath |> encodePath - , modulePath |> encodePath - , localName |> encodeName - ] - - -{-| Decode a fully-qualified name from JSON. --} -decodeFQName : Decode.Decoder FQName -decodeFQName = - Decode.map3 FQName - (Decode.index 0 decodePath) - (Decode.index 1 decodePath) - (Decode.index 2 decodeName) diff --git a/src/Morphir/IR/FQName/Codec.elm b/src/Morphir/IR/FQName/Codec.elm new file mode 100644 index 000000000..63d90e717 --- /dev/null +++ b/src/Morphir/IR/FQName/Codec.elm @@ -0,0 +1,29 @@ +module Morphir.IR.FQName.Codec exposing (..) + +{-| Encode a fully-qualified name to JSON. +-} + +import Json.Decode as Decode +import Json.Encode as Encode +import Morphir.IR.FQName exposing (FQName(..)) +import Morphir.IR.Name.Codec exposing (decodeName, encodeName) +import Morphir.IR.Path.Codec exposing (decodePath, encodePath) + + +encodeFQName : FQName -> Encode.Value +encodeFQName (FQName packagePath modulePath localName) = + Encode.list identity + [ packagePath |> encodePath + , modulePath |> encodePath + , localName |> encodeName + ] + + +{-| Decode a fully-qualified name from JSON. +-} +decodeFQName : Decode.Decoder FQName +decodeFQName = + Decode.map3 FQName + (Decode.index 0 decodePath) + (Decode.index 1 decodePath) + (Decode.index 2 decodeName) diff --git a/src/Morphir/IR/FQName/Fuzzer.elm b/src/Morphir/IR/FQName/Fuzzer.elm new file mode 100644 index 000000000..058c21155 --- /dev/null +++ b/src/Morphir/IR/FQName/Fuzzer.elm @@ -0,0 +1,17 @@ +module Morphir.IR.FQName.Fuzzer exposing (..) + +{-| FQName fuzzer. +-} + +import Fuzz exposing (Fuzzer) +import Morphir.IR.FQName exposing (FQName(..)) +import Morphir.IR.Name.Fuzzer exposing (fuzzName) +import Morphir.IR.Path.Fuzzer exposing (fuzzPath) + + +fuzzFQName : Fuzzer FQName +fuzzFQName = + Fuzz.map3 FQName + fuzzPath + fuzzPath + fuzzName diff --git a/src/Morphir/IR/Module.elm b/src/Morphir/IR/Module.elm index 766e64c3a..ea5c531ec 100644 --- a/src/Morphir/IR/Module.elm +++ b/src/Morphir/IR/Module.elm @@ -1,26 +1,20 @@ module Morphir.IR.Module exposing ( Specification, Definition - , encodeSpecification, encodeDefinition - , ModulePath, definitionToSpecification, eraseSpecificationAttributes, mapDefinition, mapSpecification + , ModulePath, definitionToSpecification, eraseSpecificationAttributes, mapDefinitionAttributes, mapSpecificationAttributes ) {-| Modules are groups of types and values that belong together. @docs Specification, Definition -@docs encodeSpecification, encodeDefinition - -} import Dict exposing (Dict) -import Json.Encode as Encode import Morphir.IR.AccessControlled exposing (AccessControlled, withPublicAccess) -import Morphir.IR.AccessControlled.Codec exposing (encodeAccessControlled) -import Morphir.IR.Name exposing (Name, encodeName) +import Morphir.IR.Name exposing (Name) import Morphir.IR.Path exposing (Path) import Morphir.IR.Type as Type exposing (Type) import Morphir.IR.Value as Value exposing (Value) -import Morphir.ListOfResults as ListOfResults type alias ModulePath = @@ -86,139 +80,40 @@ definitionToSpecification def = eraseSpecificationAttributes : Specification a -> Specification () eraseSpecificationAttributes spec = spec - |> mapSpecification - (Type.mapTypeAttributes (\_ -> ()) >> Ok) - (Value.mapValueAttributes (\_ -> ()) >> Ok) - |> Result.withDefault emptySpecification - - -{-| -} -encodeSpecification : (a -> Encode.Value) -> Specification a -> Encode.Value -encodeSpecification encodeAttributes spec = - Encode.object - [ ( "types" - , spec.types - |> Dict.toList - |> Encode.list - (\( name, typeSpec ) -> - Encode.object - [ ( "name", encodeName name ) - , ( "spec", Type.encodeSpecification encodeAttributes typeSpec ) - ] - ) - ) - , ( "values" - , spec.values - |> Dict.toList - |> Encode.list - (\( name, valueSpec ) -> - Encode.object - [ ( "name", encodeName name ) - , ( "spec", Value.encodeSpecification encodeAttributes valueSpec ) - ] - ) - ) - ] - - -mapSpecification : (Type a -> Result e (Type b)) -> (Value a -> Result e (Value b)) -> Specification a -> Result (List e) (Specification b) -mapSpecification mapType mapValue spec = - let - typesResult : Result (List e) (Dict Name (Type.Specification b)) - typesResult = - spec.types - |> Dict.toList - |> List.map - (\( typeName, typeSpec ) -> - typeSpec - |> Type.mapSpecification mapType - |> Result.map (Tuple.pair typeName) - ) - |> ListOfResults.liftAllErrors - |> Result.map Dict.fromList - |> Result.mapError List.concat - - valuesResult : Result (List e) (Dict Name (Value.Specification b)) - valuesResult = - spec.values - |> Dict.toList - |> List.map - (\( valueName, valueSpec ) -> - valueSpec - |> Value.mapSpecification mapType mapValue - |> Result.map (Tuple.pair valueName) - ) - |> ListOfResults.liftAllErrors - |> Result.map Dict.fromList - |> Result.mapError List.concat - in - Result.map2 Specification - typesResult - valuesResult - - -mapDefinition : (Type a -> Result e (Type b)) -> (Value a -> Result e (Value b)) -> Definition a -> Result (List e) (Definition b) -mapDefinition mapType mapValue def = - let - typesResult : Result (List e) (Dict Name (AccessControlled (Type.Definition b))) - typesResult = - def.types - |> Dict.toList - |> List.map - (\( typeName, typeDef ) -> - typeDef.value - |> Type.mapDefinition mapType - |> Result.map (AccessControlled typeDef.access) - |> Result.map (Tuple.pair typeName) - ) - |> ListOfResults.liftAllErrors - |> Result.map Dict.fromList - |> Result.mapError List.concat - - valuesResult : Result (List e) (Dict Name (AccessControlled (Value.Definition b))) - valuesResult = - def.values - |> Dict.toList - |> List.map - (\( valueName, valueDef ) -> - valueDef.value - |> Value.mapDefinition mapType mapValue - |> Result.map (AccessControlled valueDef.access) - |> Result.map (Tuple.pair valueName) - ) - |> ListOfResults.liftAllErrors - |> Result.map Dict.fromList - |> Result.mapError List.concat - in - Result.map2 Definition - typesResult - valuesResult - - -{-| -} -encodeDefinition : (a -> Encode.Value) -> Definition a -> Encode.Value -encodeDefinition encodeAttributes def = - Encode.object - [ ( "types" - , def.types - |> Dict.toList - |> Encode.list - (\( name, typeDef ) -> - Encode.object - [ ( "name", encodeName name ) - , ( "def", encodeAccessControlled (Type.encodeDefinition encodeAttributes) typeDef ) - ] - ) - ) - , ( "values" - , def.values - |> Dict.toList - |> Encode.list - (\( name, valueDef ) -> - Encode.object - [ ( "name", encodeName name ) - , ( "def", encodeAccessControlled (Value.encodeDefinition encodeAttributes) valueDef ) - ] - ) - ) - ] + |> mapSpecificationAttributes (\_ -> ()) + + +mapSpecificationAttributes : (a -> b) -> Specification a -> Specification b +mapSpecificationAttributes f spec = + Specification + (spec.types + |> Dict.map + (\_ typeSpec -> + Type.mapSpecificationAttributes f typeSpec + ) + ) + (spec.values + |> Dict.map + (\_ valueSpec -> + Value.mapSpecificationAttributes f valueSpec + ) + ) + + +mapDefinitionAttributes : (a -> b) -> Definition a -> Definition b +mapDefinitionAttributes f def = + Definition + (def.types + |> Dict.map + (\_ typeDef -> + AccessControlled typeDef.access + (Type.mapDefinitionAttributes f typeDef.value) + ) + ) + (def.values + |> Dict.map + (\_ valueDef -> + AccessControlled valueDef.access + (Value.mapDefinitionAttributes f valueDef.value) + ) + ) diff --git a/src/Morphir/IR/Module/Codec.elm b/src/Morphir/IR/Module/Codec.elm new file mode 100644 index 000000000..665dda948 --- /dev/null +++ b/src/Morphir/IR/Module/Codec.elm @@ -0,0 +1,68 @@ +module Morphir.IR.Module.Codec exposing (..) + +{-| -} + +import Dict +import Json.Encode as Encode +import Morphir.IR.AccessControlled.Codec exposing (encodeAccessControlled) +import Morphir.IR.Module exposing (Definition, Specification) +import Morphir.IR.Name.Codec exposing (encodeName) +import Morphir.IR.Type.Codec as TypeCodec +import Morphir.IR.Value.Codec as ValueCodec + + +{-| -} +encodeSpecification : (a -> Encode.Value) -> Specification a -> Encode.Value +encodeSpecification encodeAttributes spec = + Encode.object + [ ( "types" + , spec.types + |> Dict.toList + |> Encode.list + (\( name, typeSpec ) -> + Encode.object + [ ( "name", encodeName name ) + , ( "spec", TypeCodec.encodeSpecification encodeAttributes typeSpec ) + ] + ) + ) + , ( "values" + , spec.values + |> Dict.toList + |> Encode.list + (\( name, valueSpec ) -> + Encode.object + [ ( "name", encodeName name ) + , ( "spec", ValueCodec.encodeSpecification encodeAttributes valueSpec ) + ] + ) + ) + ] + + +encodeDefinition : (a -> Encode.Value) -> Definition a -> Encode.Value +encodeDefinition encodeAttributes def = + Encode.object + [ ( "types" + , def.types + |> Dict.toList + |> Encode.list + (\( name, typeDef ) -> + Encode.object + [ ( "name", encodeName name ) + , ( "def", encodeAccessControlled (TypeCodec.encodeDefinition encodeAttributes) typeDef ) + ] + ) + ) + , ( "values" + , def.values + |> Dict.toList + |> Encode.list + (\( name, valueDef ) -> + Encode.object + [ ( "name", encodeName name ) + , ( "def", encodeAccessControlled (ValueCodec.encodeDefinition encodeAttributes) valueDef ) + ] + ) + ) + ] diff --git a/src/Morphir/IR/Name.elm b/src/Morphir/IR/Name.elm index 4421511c0..bd8774899 100644 --- a/src/Morphir/IR/Name.elm +++ b/src/Morphir/IR/Name.elm @@ -1,8 +1,6 @@ module Morphir.IR.Name exposing ( Name, fromList, toList , fromString, toTitleCase, toCamelCase, toSnakeCase, toHumanWords - , fuzzName - , encodeName, decodeName ) {-| `Name` is an abstraction of human-readable identifiers made up of words. This abstraction @@ -39,21 +37,8 @@ abbreviation: @docs fromString, toTitleCase, toCamelCase, toSnakeCase, toHumanWords - -# Property Testing - -@docs fuzzName - - -# Serialization - -@docs encodeName, decodeName - -} -import Fuzz exposing (Fuzzer) -import Json.Decode as Decode -import Json.Encode as Encode import Regex exposing (Regex) @@ -219,81 +204,3 @@ fromList words = toList : Name -> List String toList words = words - - -{-| Name fuzzer. --} -fuzzName : Fuzzer Name -fuzzName = - let - nouns = - [ "area" - , "benchmark" - , "book" - , "business" - , "company" - , "country" - , "currency" - , "day" - , "description" - , "entity" - , "fact" - , "family" - , "from" - , "government" - , "group" - , "home" - , "id" - , "job" - , "left" - , "lot" - , "market" - , "minute" - , "money" - , "month" - , "name" - , "number" - , "owner" - , "parent" - , "part" - , "problem" - , "rate" - , "right" - , "state" - , "source" - , "system" - , "time" - , "title" - , "to" - , "valid" - , "week" - , "work" - , "world" - , "year" - ] - - fuzzWord = - nouns - |> List.map Fuzz.constant - |> Fuzz.oneOf - in - Fuzz.list fuzzWord - |> Fuzz.map (List.take 3) - |> Fuzz.map fromList - - -{-| Encode a name to JSON. --} -encodeName : Name -> Encode.Value -encodeName name = - name - |> toList - |> Encode.list Encode.string - - -{-| Decode a name from JSON. --} -decodeName : Decode.Decoder Name -decodeName = - Decode.list Decode.string - |> Decode.map fromList diff --git a/src/Morphir/IR/Name/Codec.elm b/src/Morphir/IR/Name/Codec.elm new file mode 100644 index 000000000..bb7d2a2fa --- /dev/null +++ b/src/Morphir/IR/Name/Codec.elm @@ -0,0 +1,22 @@ +module Morphir.IR.Name.Codec exposing (..) + +import Json.Decode as Decode +import Json.Encode as Encode +import Morphir.IR.Name as Name exposing (Name) + + +{-| Encode a name to JSON. +-} +encodeName : Name -> Encode.Value +encodeName name = + name + |> Name.toList + |> Encode.list Encode.string + + +{-| Decode a name from JSON. +-} +decodeName : Decode.Decoder Name +decodeName = + Decode.list Decode.string + |> Decode.map Name.fromList diff --git a/src/Morphir/IR/Name/Fuzzer.elm b/src/Morphir/IR/Name/Fuzzer.elm new file mode 100644 index 000000000..e4ccd62e0 --- /dev/null +++ b/src/Morphir/IR/Name/Fuzzer.elm @@ -0,0 +1,66 @@ +module Morphir.IR.Name.Fuzzer exposing (..) + +{-| Name fuzzer. +-} + +import Fuzz exposing (Fuzzer) +import Morphir.IR.Name as Name exposing (Name) + + +fuzzName : Fuzzer Name +fuzzName = + let + nouns = + [ "area" + , "benchmark" + , "book" + , "business" + , "company" + , "country" + , "currency" + , "day" + , "description" + , "entity" + , "fact" + , "family" + , "from" + , "government" + , "group" + , "home" + , "id" + , "job" + , "left" + , "lot" + , "market" + , "minute" + , "money" + , "month" + , "name" + , "number" + , "owner" + , "parent" + , "part" + , "problem" + , "rate" + , "right" + , "state" + , "source" + , "system" + , "time" + , "title" + , "to" + , "valid" + , "week" + , "work" + , "world" + , "year" + ] + + fuzzWord = + nouns + |> List.map Fuzz.constant + |> Fuzz.oneOf + in + Fuzz.list fuzzWord + |> Fuzz.map (List.take 3) + |> Fuzz.map Name.fromList diff --git a/src/Morphir/IR/Package.elm b/src/Morphir/IR/Package.elm index 648ca35ef..19cc8b911 100644 --- a/src/Morphir/IR/Package.elm +++ b/src/Morphir/IR/Package.elm @@ -1,7 +1,7 @@ module Morphir.IR.Package exposing ( Specification , Definition, emptyDefinition - , PackagePath, definitionToSpecification, encodeDefinition, eraseDefinitionAttributes, eraseSpecificationAttributes + , PackagePath, definitionToSpecification, eraseDefinitionAttributes, eraseSpecificationAttributes ) {-| Tools to work with packages. @@ -13,14 +13,9 @@ module Morphir.IR.Package exposing -} import Dict exposing (Dict) -import Json.Encode as Encode import Morphir.IR.AccessControlled exposing (AccessControlled, withPublicAccess) -import Morphir.IR.AccessControlled.Codec exposing (encodeAccessControlled) import Morphir.IR.Module as Module exposing (ModulePath) -import Morphir.IR.Path exposing (Path, encodePath) -import Morphir.IR.Type as Type exposing (Type) -import Morphir.IR.Value as Value exposing (Value) -import Morphir.ListOfResults as ListOfResults +import Morphir.IR.Path exposing (Path) type alias PackagePath = @@ -75,121 +70,42 @@ definitionToSpecification def = } -mapSpecification : (Type a -> Result e (Type b)) -> (Value a -> Result e (Value b)) -> Specification a -> Result (List e) (Specification b) -mapSpecification mapType mapValue spec = - let - modulesResult : Result (List e) (Dict Path (Module.Specification b)) - modulesResult = - spec.modules - |> Dict.toList - |> List.map - (\( modulePath, moduleSpec ) -> - moduleSpec - |> Module.mapSpecification mapType mapValue - |> Result.map (Tuple.pair modulePath) - ) - |> ListOfResults.liftAllErrors - |> Result.map Dict.fromList - |> Result.mapError List.concat - in - Result.map Specification modulesResult +mapSpecificationAttributes : (a -> b) -> Specification a -> Specification b +mapSpecificationAttributes f spec = + Specification + (spec.modules + |> Dict.map + (\_ moduleSpec -> + Module.mapSpecificationAttributes f moduleSpec + ) + ) + + +mapDefinitionAttributes : (a -> b) -> Definition a -> Definition b +mapDefinitionAttributes f def = + Definition + (def.dependencies + |> Dict.map + (\_ packageSpec -> + mapSpecificationAttributes f packageSpec + ) + ) + (def.modules + |> Dict.map + (\_ moduleDef -> + AccessControlled moduleDef.access + (Module.mapDefinitionAttributes f moduleDef.value) + ) + ) eraseSpecificationAttributes : Specification a -> Specification () eraseSpecificationAttributes spec = spec - |> mapSpecification - (Type.mapTypeAttributes (\_ -> ()) >> Ok) - (Value.mapValueAttributes (\_ -> ()) >> Ok) - |> Result.withDefault emptySpecification - - -mapDefinition : (Type a -> Result e (Type b)) -> (Value a -> Result e (Value b)) -> Definition a -> Result (List e) (Definition b) -mapDefinition mapType mapValue def = - let - dependenciesResult : Result (List e) (Dict Path (Specification b)) - dependenciesResult = - def.dependencies - |> Dict.toList - |> List.map - (\( packagePath, packageSpec ) -> - packageSpec - |> mapSpecification mapType mapValue - |> Result.map (Tuple.pair packagePath) - ) - |> ListOfResults.liftAllErrors - |> Result.map Dict.fromList - |> Result.mapError List.concat - - modulesResult : Result (List e) (Dict Path (AccessControlled (Module.Definition b))) - modulesResult = - def.modules - |> Dict.toList - |> List.map - (\( modulePath, moduleDef ) -> - moduleDef.value - |> Module.mapDefinition mapType mapValue - |> Result.map (AccessControlled moduleDef.access) - |> Result.map (Tuple.pair modulePath) - ) - |> ListOfResults.liftAllErrors - |> Result.map Dict.fromList - |> Result.mapError List.concat - in - Result.map2 Definition - dependenciesResult - modulesResult + |> mapSpecificationAttributes (\_ -> ()) eraseDefinitionAttributes : Definition a -> Definition () eraseDefinitionAttributes def = def - |> mapDefinition - (Type.mapTypeAttributes (\_ -> ()) >> Ok) - (Value.mapValueAttributes (\_ -> ()) >> Ok) - |> Result.withDefault emptyDefinition - - -encodeSpecification : (a -> Encode.Value) -> Specification a -> Encode.Value -encodeSpecification encodeAttributes spec = - Encode.object - [ ( "modules" - , spec.modules - |> Dict.toList - |> Encode.list - (\( moduleName, moduleSpec ) -> - Encode.object - [ ( "name", encodePath moduleName ) - , ( "spec", Module.encodeSpecification encodeAttributes moduleSpec ) - ] - ) - ) - ] - - -encodeDefinition : (a -> Encode.Value) -> Definition a -> Encode.Value -encodeDefinition encodeAttributes def = - Encode.object - [ ( "dependencies" - , def.dependencies - |> Dict.toList - |> Encode.list - (\( packageName, packageSpec ) -> - Encode.object - [ ( "name", encodePath packageName ) - , ( "spec", encodeSpecification encodeAttributes packageSpec ) - ] - ) - ) - , ( "modules" - , def.modules - |> Dict.toList - |> Encode.list - (\( moduleName, moduleDef ) -> - Encode.object - [ ( "name", encodePath moduleName ) - , ( "def", encodeAccessControlled (Module.encodeDefinition encodeAttributes) moduleDef ) - ] - ) - ) - ] + |> mapDefinitionAttributes (\_ -> ()) diff --git a/src/Morphir/IR/Package/Codec.elm b/src/Morphir/IR/Package/Codec.elm new file mode 100644 index 000000000..83cbf0848 --- /dev/null +++ b/src/Morphir/IR/Package/Codec.elm @@ -0,0 +1,53 @@ +module Morphir.IR.Package.Codec exposing (..) + +import Dict +import Json.Encode as Encode +import Morphir.IR.AccessControlled.Codec exposing (encodeAccessControlled) +import Morphir.IR.Module.Codec as ModuleCodec +import Morphir.IR.Package exposing (Definition, Specification) +import Morphir.IR.Path.Codec exposing (encodePath) + + +encodeSpecification : (a -> Encode.Value) -> Specification a -> Encode.Value +encodeSpecification encodeAttributes spec = + Encode.object + [ ( "modules" + , spec.modules + |> Dict.toList + |> Encode.list + (\( moduleName, moduleSpec ) -> + Encode.object + [ ( "name", encodePath moduleName ) + , ( "spec", ModuleCodec.encodeSpecification encodeAttributes moduleSpec ) + ] + ) + ) + ] + + +encodeDefinition : (a -> Encode.Value) -> Definition a -> Encode.Value +encodeDefinition encodeAttributes def = + Encode.object + [ ( "dependencies" + , def.dependencies + |> Dict.toList + |> Encode.list + (\( packageName, packageSpec ) -> + Encode.object + [ ( "name", encodePath packageName ) + , ( "spec", encodeSpecification encodeAttributes packageSpec ) + ] + ) + ) + , ( "modules" + , def.modules + |> Dict.toList + |> Encode.list + (\( moduleName, moduleDef ) -> + Encode.object + [ ( "name", encodePath moduleName ) + , ( "def", encodeAccessControlled (ModuleCodec.encodeDefinition encodeAttributes) moduleDef ) + ] + ) + ) + ] diff --git a/src/Morphir/IR/Path.elm b/src/Morphir/IR/Path.elm index fcc2b903c..5b08cd73a 100644 --- a/src/Morphir/IR/Path.elm +++ b/src/Morphir/IR/Path.elm @@ -2,8 +2,6 @@ module Morphir.IR.Path exposing ( Path, fromList, toList , fromString, toString , isPrefixOf - , fuzzPath - , encodePath, decodePath ) {-| `Path` is a list of names that represents a path in the tree. It's used at various @@ -21,22 +19,9 @@ places in the IR to identify types and values. @docs isPrefixOf - -# Property Testing - -@docs fuzzPath - - -# Serialization - -@docs encodePath, decodePath - -} -import Fuzz exposing (Fuzzer) -import Json.Decode as Decode -import Json.Encode as Encode -import Morphir.IR.Name as Name exposing (Name, decodeName, encodeName, fuzzName) +import Morphir.IR.Name as Name exposing (Name) import Regex exposing (Regex) @@ -139,29 +124,3 @@ isPrefixOf prefix path = else False - - -{-| Path fuzzer. --} -fuzzPath : Fuzzer Path -fuzzPath = - Fuzz.list fuzzName - |> Fuzz.map (List.take 3) - |> Fuzz.map fromList - - -{-| Encode a path to JSON. --} -encodePath : Path -> Encode.Value -encodePath path = - path - |> toList - |> Encode.list encodeName - - -{-| Decode a path from JSON. --} -decodePath : Decode.Decoder Path -decodePath = - Decode.list decodeName - |> Decode.map fromList diff --git a/src/Morphir/IR/Path/Codec.elm b/src/Morphir/IR/Path/Codec.elm new file mode 100644 index 000000000..9a5487f69 --- /dev/null +++ b/src/Morphir/IR/Path/Codec.elm @@ -0,0 +1,24 @@ +module Morphir.IR.Path.Codec exposing (..) + +{-| Encode a path to JSON. +-} + +import Json.Decode as Decode +import Json.Encode as Encode +import Morphir.IR.Name.Codec exposing (decodeName, encodeName) +import Morphir.IR.Path as Path exposing (Path) + + +encodePath : Path -> Encode.Value +encodePath path = + path + |> Path.toList + |> Encode.list encodeName + + +{-| Decode a path from JSON. +-} +decodePath : Decode.Decoder Path +decodePath = + Decode.list decodeName + |> Decode.map Path.fromList diff --git a/src/Morphir/IR/Path/Fuzzer.elm b/src/Morphir/IR/Path/Fuzzer.elm new file mode 100644 index 000000000..7ebd82d9e --- /dev/null +++ b/src/Morphir/IR/Path/Fuzzer.elm @@ -0,0 +1,15 @@ +module Morphir.IR.Path.Fuzzer exposing (..) + +{-| Path fuzzer. +-} + +import Fuzz exposing (Fuzzer) +import Morphir.IR.Name.Fuzzer exposing (fuzzName) +import Morphir.IR.Path as Path exposing (Path) + + +fuzzPath : Fuzzer Path +fuzzPath = + Fuzz.list fuzzName + |> Fuzz.map (List.take 3) + |> Fuzz.map Path.fromList diff --git a/src/Morphir/IR/SDK/Appending.elm b/src/Morphir/IR/SDK/Appending.elm index 3e2d91f8c..d07e9370b 100644 --- a/src/Morphir/IR/SDK/Appending.elm +++ b/src/Morphir/IR/SDK/Appending.elm @@ -3,8 +3,7 @@ module Morphir.IR.SDK.Appending exposing (..) import Dict import Morphir.IR.Module as Module exposing (ModulePath) import Morphir.IR.Path as Path exposing (Path) -import Morphir.IR.SDK.Common exposing (binaryApply, toFQName) -import Morphir.IR.Type exposing (Specification(..), Type(..)) +import Morphir.IR.SDK.Common exposing (toFQName) import Morphir.IR.Value as Value exposing (Value) @@ -22,6 +21,6 @@ moduleSpec = } -append : a -> Value a -> Value a -> Value a -append = - binaryApply moduleName "append" +append : a -> Value a +append a = + Value.Reference a (toFQName moduleName "append") diff --git a/src/Morphir/IR/SDK/Bool.elm b/src/Morphir/IR/SDK/Bool.elm index 827cfd8b5..ab711e43e 100644 --- a/src/Morphir/IR/SDK/Bool.elm +++ b/src/Morphir/IR/SDK/Bool.elm @@ -4,7 +4,7 @@ import Dict import Morphir.IR.Module as Module exposing (ModulePath) import Morphir.IR.Name as Name import Morphir.IR.Path as Path -import Morphir.IR.SDK.Common exposing (binaryApply, toFQName) +import Morphir.IR.SDK.Common exposing (toFQName) import Morphir.IR.Type exposing (Specification(..), Type(..)) import Morphir.IR.Value as Value exposing (Value) @@ -30,11 +30,11 @@ boolType attributes = Reference attributes (toFQName moduleName "Bool") [] -and : a -> Value a -> Value a -> Value a -and = - binaryApply moduleName "and" +and : a -> Value a +and a = + Value.Reference a (toFQName moduleName "and") -or : a -> Value a -> Value a -> Value a -or = - binaryApply moduleName "or" +or : a -> Value a +or a = + Value.Reference a (toFQName moduleName "or") diff --git a/src/Morphir/IR/SDK/Comparison.elm b/src/Morphir/IR/SDK/Comparison.elm index b329d0019..244b7ea57 100644 --- a/src/Morphir/IR/SDK/Comparison.elm +++ b/src/Morphir/IR/SDK/Comparison.elm @@ -3,8 +3,7 @@ module Morphir.IR.SDK.Comparison exposing (..) import Dict import Morphir.IR.Module as Module exposing (ModulePath) import Morphir.IR.Path as Path exposing (Path) -import Morphir.IR.SDK.Common exposing (binaryApply, toFQName) -import Morphir.IR.Type exposing (Specification(..), Type(..)) +import Morphir.IR.SDK.Common exposing (toFQName) import Morphir.IR.Value as Value exposing (Value) @@ -22,21 +21,21 @@ moduleSpec = } -lessThan : a -> Value a -> Value a -> Value a -lessThan = - binaryApply moduleName "lessThan" +lessThan : a -> Value a +lessThan a = + Value.Reference a (toFQName moduleName "lessThan") -lessThanOrEqual : a -> Value a -> Value a -> Value a -lessThanOrEqual = - binaryApply moduleName "lessThanOrEqual" +lessThanOrEqual : a -> Value a +lessThanOrEqual a = + Value.Reference a (toFQName moduleName "lessThanOrEqual") -greaterThan : a -> Value a -> Value a -> Value a -greaterThan = - binaryApply moduleName "greaterThan" +greaterThan : a -> Value a +greaterThan a = + Value.Reference a (toFQName moduleName "greaterThan") -greaterThanOrEqual : a -> Value a -> Value a -> Value a -greaterThanOrEqual = - binaryApply moduleName "greaterThanOrEqual" +greaterThanOrEqual : a -> Value a +greaterThanOrEqual a = + Value.Reference a (toFQName moduleName "greaterThanOrEqual") diff --git a/src/Morphir/IR/SDK/Composition.elm b/src/Morphir/IR/SDK/Composition.elm index 585f7a9b0..f153bdbb6 100644 --- a/src/Morphir/IR/SDK/Composition.elm +++ b/src/Morphir/IR/SDK/Composition.elm @@ -3,8 +3,7 @@ module Morphir.IR.SDK.Composition exposing (..) import Dict import Morphir.IR.Module as Module exposing (ModulePath) import Morphir.IR.Path as Path exposing (Path) -import Morphir.IR.SDK.Common exposing (binaryApply, toFQName) -import Morphir.IR.Type exposing (Specification(..), Type(..)) +import Morphir.IR.SDK.Common exposing (toFQName) import Morphir.IR.Value as Value exposing (Value) @@ -22,11 +21,11 @@ moduleSpec = } -composeLeft : a -> Value a -> Value a -> Value a -composeLeft = - binaryApply moduleName "composeLeft" +composeLeft : a -> Value a +composeLeft a = + Value.Reference a (toFQName moduleName "composeLeft") -composeRight : a -> Value a -> Value a -> Value a -composeRight = - binaryApply moduleName "composeRight" +composeRight : a -> Value a +composeRight a = + Value.Reference a (toFQName moduleName "composeRight") diff --git a/src/Morphir/IR/SDK/Equality.elm b/src/Morphir/IR/SDK/Equality.elm index e170ece01..0d6a52938 100644 --- a/src/Morphir/IR/SDK/Equality.elm +++ b/src/Morphir/IR/SDK/Equality.elm @@ -3,8 +3,7 @@ module Morphir.IR.SDK.Equality exposing (..) import Dict import Morphir.IR.Module as Module exposing (ModulePath) import Morphir.IR.Path as Path exposing (Path) -import Morphir.IR.SDK.Common exposing (binaryApply, toFQName) -import Morphir.IR.Type exposing (Specification(..), Type(..)) +import Morphir.IR.SDK.Common exposing (toFQName) import Morphir.IR.Value as Value exposing (Value) @@ -22,11 +21,11 @@ moduleSpec = } -equal : a -> Value a -> Value a -> Value a -equal = - binaryApply moduleName "equal" +equal : a -> Value a +equal a = + Value.Reference a (toFQName moduleName "equal") -notEqual : a -> Value a -> Value a -> Value a -notEqual = - binaryApply moduleName "notEqual" +notEqual : a -> Value a +notEqual a = + Value.Reference a (toFQName moduleName "notEqual") diff --git a/src/Morphir/IR/SDK/Float.elm b/src/Morphir/IR/SDK/Float.elm index 7087dacef..46b6a2de0 100644 --- a/src/Morphir/IR/SDK/Float.elm +++ b/src/Morphir/IR/SDK/Float.elm @@ -4,9 +4,9 @@ import Dict import Morphir.IR.Module as Module exposing (ModulePath) import Morphir.IR.Name as Name import Morphir.IR.Path as Path -import Morphir.IR.SDK.Common exposing (binaryApply, toFQName) +import Morphir.IR.SDK.Common exposing (toFQName) import Morphir.IR.Type exposing (Specification(..), Type(..)) -import Morphir.IR.Value exposing (Value) +import Morphir.IR.Value as Value exposing (Value) moduleName : ModulePath @@ -30,6 +30,6 @@ floatType attributes = Reference attributes (toFQName moduleName "Float") [] -divide : a -> Value a -> Value a -> Value a -divide = - binaryApply moduleName "divide" +divide : a -> Value a +divide a = + Value.Reference a (toFQName moduleName "divide") diff --git a/src/Morphir/IR/SDK/Int.elm b/src/Morphir/IR/SDK/Int.elm index ecbb03ac9..88976ce2c 100644 --- a/src/Morphir/IR/SDK/Int.elm +++ b/src/Morphir/IR/SDK/Int.elm @@ -4,9 +4,9 @@ import Dict import Morphir.IR.Module as Module exposing (ModulePath) import Morphir.IR.Name as Name import Morphir.IR.Path as Path -import Morphir.IR.SDK.Common exposing (binaryApply, toFQName) +import Morphir.IR.SDK.Common exposing (toFQName) import Morphir.IR.Type exposing (Specification(..), Type(..)) -import Morphir.IR.Value exposing (Value) +import Morphir.IR.Value as Value exposing (Value) moduleName : ModulePath @@ -30,6 +30,6 @@ intType attributes = Reference attributes (toFQName moduleName "Int") [] -divide : a -> Value a -> Value a -> Value a -divide = - binaryApply moduleName "divide" +divide : a -> Value a +divide a = + Value.Reference a (toFQName moduleName "divide") diff --git a/src/Morphir/IR/SDK/List.elm b/src/Morphir/IR/SDK/List.elm index 0a0e357d7..07ab964d6 100644 --- a/src/Morphir/IR/SDK/List.elm +++ b/src/Morphir/IR/SDK/List.elm @@ -4,9 +4,9 @@ import Dict import Morphir.IR.Module as Module exposing (ModulePath) import Morphir.IR.Name as Name import Morphir.IR.Path as Path -import Morphir.IR.SDK.Common exposing (binaryApply, toFQName) +import Morphir.IR.SDK.Common exposing (toFQName) import Morphir.IR.Type as Type exposing (Specification(..), Type(..)) -import Morphir.IR.Value exposing (Value) +import Morphir.IR.Value as Value exposing (Value) moduleName : ModulePath @@ -30,6 +30,6 @@ listType attributes itemType = Type.Reference attributes (toFQName moduleName "List") [ itemType ] -construct : a -> Value a -> Value a -> Value a -construct = - binaryApply moduleName "construct" +construct : a -> Value a +construct a = + Value.Reference a (toFQName moduleName "construct") diff --git a/src/Morphir/IR/SDK/Number.elm b/src/Morphir/IR/SDK/Number.elm index ae908addb..1fb693cb8 100644 --- a/src/Morphir/IR/SDK/Number.elm +++ b/src/Morphir/IR/SDK/Number.elm @@ -3,7 +3,7 @@ module Morphir.IR.SDK.Number exposing (..) import Dict import Morphir.IR.Module as Module exposing (ModulePath) import Morphir.IR.Path as Path exposing (Path) -import Morphir.IR.SDK.Common exposing (binaryApply, toFQName) +import Morphir.IR.SDK.Common exposing (toFQName) import Morphir.IR.Type exposing (Specification(..), Type(..)) import Morphir.IR.Value as Value exposing (Value) @@ -32,21 +32,21 @@ negate refAttributes valueAttributes arg = Value.Apply valueAttributes (Value.Reference refAttributes (toFQName moduleName "negate")) arg -add : a -> Value a -> Value a -> Value a -add = - binaryApply moduleName "add" +add : a -> Value a +add a = + Value.Reference a (toFQName moduleName "add") -subtract : a -> Value a -> Value a -> Value a -subtract = - binaryApply moduleName "subtract" +subtract : a -> Value a +subtract a = + Value.Reference a (toFQName moduleName "subtract") -multiply : a -> Value a -> Value a -> Value a -multiply = - binaryApply moduleName "multiply" +multiply : a -> Value a +multiply a = + Value.Reference a (toFQName moduleName "multiply") -power : a -> Value a -> Value a -> Value a -power = - binaryApply moduleName "power" +power : a -> Value a +power a = + Value.Reference a (toFQName moduleName "power") diff --git a/src/Morphir/IR/Type.elm b/src/Morphir/IR/Type.elm index c4c9d3111..e8627cd58 100644 --- a/src/Morphir/IR/Type.elm +++ b/src/Morphir/IR/Type.elm @@ -1,13 +1,11 @@ module Morphir.IR.Type exposing ( Type(..) , variable, reference, tuple, record, extensibleRecord, function, unit - , Field, matchField, mapFieldName, mapFieldType + , Field, mapFieldName, mapFieldType , Specification(..), typeAliasSpecification, opaqueTypeSpecification, customTypeSpecification - , Definition(..), typeAliasDefinition, customTypeDefinition + , Definition(..), typeAliasDefinition, customTypeDefinition, definitionToSpecification , Constructors, Constructor(..) - , fuzzType - , encodeType, decodeType, encodeSpecification, encodeDefinition - , definitionToSpecification, eraseAttributes, mapDefinition, mapSpecification, mapTypeAttributes, rewriteType + , mapTypeAttributes, mapSpecificationAttributes, mapDefinitionAttributes, mapDefinition, eraseAttributes ) {-| This module contains the building blocks of types in the Morphir IR. @@ -23,24 +21,19 @@ module Morphir.IR.Type exposing @docs variable, reference, tuple, record, extensibleRecord, function, unit -## Matching - -@docs matchVariable, matchReference, matchTuple, matchRecord, matchExtensibleRecord, matchFunction, matchUnit - - # Record Field -@docs Field, matchField, mapFieldName, mapFieldType +@docs Field, mapFieldName, mapFieldType # Specification -@docs Specification, typeAliasSpecification, opaqueTypeSpecification, customTypeSpecification, matchCustomTypeSpecification +@docs Specification, typeAliasSpecification, opaqueTypeSpecification, customTypeSpecification # Definition -@docs Definition, typeAliasDefinition, customTypeDefinition +@docs Definition, typeAliasDefinition, customTypeDefinition, definitionToSpecification # Constructors @@ -48,27 +41,16 @@ module Morphir.IR.Type exposing @docs Constructors, Constructor -# Property Testing - -@docs fuzzType +# Mapping - -# Serialization - -@docs encodeType, decodeType, encodeSpecification, encodeDefinition +@docs mapTypeAttributes, mapSpecificationAttributes, mapDefinitionAttributes, mapDefinition, eraseAttributes -} -import Fuzz exposing (Fuzzer) -import Json.Decode as Decode -import Json.Encode as Encode import Morphir.IR.AccessControlled as AccessControlled exposing (AccessControlled, withPublicAccess) -import Morphir.IR.AccessControlled.Codec exposing (encodeAccessControlled) -import Morphir.IR.FQName exposing (FQName, decodeFQName, encodeFQName, fuzzFQName) -import Morphir.IR.Name exposing (Name, decodeName, encodeName, fuzzName) +import Morphir.IR.FQName exposing (FQName) +import Morphir.IR.Name exposing (Name) import Morphir.ListOfResults as ListOfResults -import Morphir.Pattern exposing (Pattern) -import Morphir.Rewrite exposing (Rewrite) {-| An opaque representation of a type. Check out the docs for each building blocks @@ -132,6 +114,7 @@ type Constructor a = Constructor Name (List ( Name, Type a )) +{-| -} definitionToSpecification : Definition a -> Specification a definitionToSpecification def = case def of @@ -147,41 +130,33 @@ definitionToSpecification def = OpaqueTypeSpecification params -mapSpecification : (Type a -> Result e (Type b)) -> Specification a -> Result (List e) (Specification b) -mapSpecification f spec = +{-| -} +mapSpecificationAttributes : (a -> b) -> Specification a -> Specification b +mapSpecificationAttributes f spec = case spec of TypeAliasSpecification params tpe -> - f tpe - |> Result.map (TypeAliasSpecification params) - |> Result.mapError List.singleton + TypeAliasSpecification params (mapTypeAttributes f tpe) OpaqueTypeSpecification params -> OpaqueTypeSpecification params - |> Ok CustomTypeSpecification params constructors -> - let - ctorsResult : Result (List e) (Constructors b) - ctorsResult = - constructors - |> List.map - (\(Constructor ctorName ctorArgs) -> - ctorArgs + CustomTypeSpecification params + (constructors + |> List.map + (\(Constructor ctorName ctorArgs) -> + Constructor ctorName + (ctorArgs |> List.map (\( argName, argType ) -> - f argType - |> Result.map (Tuple.pair argName) + ( argName, mapTypeAttributes f argType ) ) - |> ListOfResults.liftAllErrors - |> Result.map (Constructor ctorName) - ) - |> ListOfResults.liftAllErrors - |> Result.mapError List.concat - in - ctorsResult - |> Result.map (CustomTypeSpecification params) + ) + ) + ) +{-| -} mapDefinition : (Type a -> Result e (Type b)) -> Definition a -> Result (List e) (Definition b) mapDefinition f def = case def of @@ -214,6 +189,32 @@ mapDefinition f def = |> Result.map (CustomTypeDefinition params) +{-| -} +mapDefinitionAttributes : (a -> b) -> Definition a -> Definition b +mapDefinitionAttributes f def = + case def of + TypeAliasDefinition params tpe -> + TypeAliasDefinition params (mapTypeAttributes f tpe) + + CustomTypeDefinition params constructors -> + CustomTypeDefinition params + (AccessControlled constructors.access + (constructors.value + |> List.map + (\(Constructor ctorName ctorArgs) -> + Constructor ctorName + (ctorArgs + |> List.map + (\( argName, argType ) -> + ( argName, mapTypeAttributes f argType ) + ) + ) + ) + ) + ) + + +{-| -} mapTypeAttributes : (a -> b) -> Type a -> Type b mapTypeAttributes f tpe = case tpe of @@ -239,6 +240,7 @@ mapTypeAttributes f tpe = Unit (f a) +{-| -} typeAttributes : Type a -> a typeAttributes tpe = case tpe of @@ -264,6 +266,7 @@ typeAttributes tpe = a +{-| -} eraseAttributes : Definition a -> Definition () eraseAttributes typeDef = case typeDef of @@ -431,86 +434,6 @@ customTypeSpecification typeParams ctors = CustomTypeSpecification typeParams ctors -rewriteType : Rewrite e (Type a) -rewriteType rewriteBranch rewriteLeaf typeToRewrite = - case typeToRewrite of - Reference a fQName argTypes -> - argTypes - |> List.foldr - (\nextArg resultSoFar -> - Result.map2 (::) - (rewriteBranch nextArg) - resultSoFar - ) - (Ok []) - |> Result.map (Reference a fQName) - - Tuple a elemTypes -> - elemTypes - |> List.foldr - (\nextArg resultSoFar -> - Result.map2 (::) - (rewriteBranch nextArg) - resultSoFar - ) - (Ok []) - |> Result.map (Tuple a) - - Record a fieldTypes -> - fieldTypes - |> List.foldr - (\field resultSoFar -> - Result.map2 (::) - (rewriteBranch field.tpe - |> Result.map (Field field.name) - ) - resultSoFar - ) - (Ok []) - |> Result.map (Record a) - - ExtensibleRecord a varName fieldTypes -> - fieldTypes - |> List.foldr - (\field resultSoFar -> - Result.map2 (::) - (rewriteBranch field.tpe - |> Result.map (Field field.name) - ) - resultSoFar - ) - (Ok []) - |> Result.map (ExtensibleRecord a varName) - - Function a argType returnType -> - Result.map2 (Function a) - (rewriteBranch argType) - (rewriteBranch returnType) - - _ -> - rewriteLeaf typeToRewrite - - -{-| Matches a field. - - let - field = - field [ "foo" ] SDK.Basics.intType - - pattern = - matchField matchAny matchAny - in - pattern field - == Just ( [ "foo" ], SDK.Basics.intType ) - --} -matchField : Pattern Name a -> Pattern (Type a) b -> Pattern (Field a) ( a, b ) -matchField matchFieldName matchFieldType field = - Maybe.map2 Tuple.pair - (matchFieldName field.name) - (matchFieldType field.tpe) - - {-| Map the name of the field to get a new field. -} mapFieldName : (Name -> Name) -> Field a -> Field a @@ -523,274 +446,3 @@ mapFieldName f field = mapFieldType : (Type a -> Type b) -> Field a -> Field b mapFieldType f field = Field field.name (f field.tpe) - - -{-| Generate random types. --} -fuzzType : Int -> Fuzzer a -> Fuzzer (Type a) -fuzzType maxDepth fuzzAttributes = - let - fuzzField depth = - Fuzz.map2 Field - fuzzName - (fuzzType depth fuzzAttributes) - - fuzzVariable = - Fuzz.map2 Variable - fuzzAttributes - fuzzName - - fuzzReference depth = - Fuzz.map3 Reference - fuzzAttributes - fuzzFQName - (Fuzz.list (fuzzType depth fuzzAttributes) |> Fuzz.map (List.take depth)) - - fuzzTuple depth = - Fuzz.map2 Tuple - fuzzAttributes - (Fuzz.list (fuzzType depth fuzzAttributes) |> Fuzz.map (List.take depth)) - - fuzzRecord depth = - Fuzz.map2 Record - fuzzAttributes - (Fuzz.list (fuzzField (depth - 1)) |> Fuzz.map (List.take depth)) - - fuzzExtensibleRecord depth = - Fuzz.map3 ExtensibleRecord - fuzzAttributes - fuzzName - (Fuzz.list (fuzzField (depth - 1)) |> Fuzz.map (List.take depth)) - - fuzzFunction depth = - Fuzz.map3 Function - fuzzAttributes - (fuzzType depth fuzzAttributes) - (fuzzType depth fuzzAttributes) - - fuzzUnit = - Fuzz.map Unit - fuzzAttributes - - fuzzLeaf = - Fuzz.oneOf - [ fuzzVariable - , fuzzUnit - ] - - fuzzBranch depth = - Fuzz.oneOf - [ fuzzFunction depth - , fuzzReference depth - , fuzzTuple depth - , fuzzRecord depth - , fuzzExtensibleRecord depth - ] - in - if maxDepth <= 0 then - fuzzLeaf - - else - Fuzz.oneOf - [ fuzzLeaf - , fuzzBranch (maxDepth - 1) - ] - - -{-| Encode a type into JSON. --} -encodeType : (a -> Encode.Value) -> Type a -> Encode.Value -encodeType encodeAttributes tpe = - case tpe of - Variable a name -> - Encode.list identity - [ Encode.string "Variable" - , encodeAttributes a - , encodeName name - ] - - Reference a typeName typeParameters -> - Encode.list identity - [ Encode.string "Reference" - , encodeAttributes a - , encodeFQName typeName - , Encode.list (encodeType encodeAttributes) typeParameters - ] - - Tuple a elementTypes -> - Encode.list identity - [ Encode.string "Tuple" - , encodeAttributes a - , Encode.list (encodeType encodeAttributes) elementTypes - ] - - Record a fieldTypes -> - Encode.list identity - [ Encode.string "Record" - , encodeAttributes a - , Encode.list (encodeField encodeAttributes) fieldTypes - ] - - ExtensibleRecord a variableName fieldTypes -> - Encode.list identity - [ Encode.string "ExtensibleRecord" - , encodeAttributes a - , encodeName variableName - , Encode.list (encodeField encodeAttributes) fieldTypes - ] - - Function a argumentType returnType -> - Encode.list identity - [ Encode.string "Function" - , encodeAttributes a - , encodeType encodeAttributes argumentType - , encodeType encodeAttributes returnType - ] - - Unit a -> - Encode.list identity - [ Encode.string "Unit" - , encodeAttributes a - ] - - -{-| Decode a type from JSON. --} -decodeType : Decode.Decoder a -> Decode.Decoder (Type a) -decodeType decodeAttributes = - let - lazyDecodeType = - Decode.lazy - (\_ -> - decodeType decodeAttributes - ) - - lazyDecodeField = - Decode.lazy - (\_ -> - decodeField decodeAttributes - ) - in - Decode.index 0 Decode.string - |> Decode.andThen - (\kind -> - case kind of - "Variable" -> - Decode.map2 Variable - (Decode.index 1 decodeAttributes) - (Decode.index 2 decodeName) - - "Reference" -> - Decode.map3 Reference - (Decode.index 1 decodeAttributes) - (Decode.index 2 decodeFQName) - (Decode.index 3 (Decode.list (Decode.lazy (\_ -> decodeType decodeAttributes)))) - - "Tuple" -> - Decode.map2 Tuple - (Decode.index 1 decodeAttributes) - (Decode.index 2 (Decode.list lazyDecodeType)) - - "Record" -> - Decode.map2 Record - (Decode.index 1 decodeAttributes) - (Decode.index 2 (Decode.list lazyDecodeField)) - - "ExtensibleRecord" -> - Decode.map3 ExtensibleRecord - (Decode.index 1 decodeAttributes) - (Decode.index 2 decodeName) - (Decode.index 3 (Decode.list lazyDecodeField)) - - "Function" -> - Decode.map3 Function - (Decode.index 1 decodeAttributes) - (Decode.index 2 lazyDecodeType) - (Decode.index 3 lazyDecodeType) - - "Unit" -> - Decode.map Unit - (Decode.index 1 decodeAttributes) - - _ -> - Decode.fail ("Unknown kind: " ++ kind) - ) - - -encodeField : (a -> Encode.Value) -> Field a -> Encode.Value -encodeField encodeAttributes field = - Encode.list identity - [ encodeName field.name - , encodeType encodeAttributes field.tpe - ] - - -decodeField : Decode.Decoder a -> Decode.Decoder (Field a) -decodeField decodeAttributes = - Decode.map2 Field - (Decode.index 0 decodeName) - (Decode.index 1 (decodeType decodeAttributes)) - - -{-| -} -encodeSpecification : (a -> Encode.Value) -> Specification a -> Encode.Value -encodeSpecification encodeAttributes spec = - case spec of - TypeAliasSpecification params exp -> - Encode.list identity - [ Encode.string "TypeAliasSpecification" - , Encode.list encodeName params - , encodeType encodeAttributes exp - ] - - OpaqueTypeSpecification params -> - Encode.list identity - [ Encode.string "OpaqueTypeSpecification" - , Encode.list encodeName params - ] - - CustomTypeSpecification params ctors -> - Encode.list identity - [ Encode.string "CustomTypeSpecification" - , Encode.list encodeName params - , encodeConstructors encodeAttributes ctors - ] - - -{-| -} -encodeDefinition : (a -> Encode.Value) -> Definition a -> Encode.Value -encodeDefinition encodeAttributes def = - case def of - TypeAliasDefinition params exp -> - Encode.list identity - [ Encode.string "TypeAliasDefinition" - , Encode.list encodeName params - , encodeType encodeAttributes exp - ] - - CustomTypeDefinition params ctors -> - Encode.list identity - [ Encode.string "CustomTypeDefinition" - , Encode.list encodeName params - , encodeAccessControlled (encodeConstructors encodeAttributes) ctors - ] - - -encodeConstructors : (a -> Encode.Value) -> Constructors a -> Encode.Value -encodeConstructors encodeAttributes ctors = - ctors - |> Encode.list - (\(Constructor ctorName ctorArgs) -> - Encode.list identity - [ Encode.string "Constructor" - , encodeName ctorName - , ctorArgs - |> Encode.list - (\( argName, argType ) -> - Encode.list identity - [ encodeName argName - , encodeType encodeAttributes argType - ] - ) - ] - ) diff --git a/src/Morphir/IR/Type/Codec.elm b/src/Morphir/IR/Type/Codec.elm new file mode 100644 index 000000000..2ab0929b1 --- /dev/null +++ b/src/Morphir/IR/Type/Codec.elm @@ -0,0 +1,207 @@ +module Morphir.IR.Type.Codec exposing (..) + +import Json.Decode as Decode +import Json.Encode as Encode +import Morphir.IR.AccessControlled.Codec exposing (encodeAccessControlled) +import Morphir.IR.FQName.Codec exposing (decodeFQName, encodeFQName) +import Morphir.IR.Name.Codec exposing (decodeName, encodeName) +import Morphir.IR.Type exposing (Constructor(..), Constructors, Definition(..), Field, Specification(..), Type(..)) + + +{-| Encode a type into JSON. +-} +encodeType : (a -> Encode.Value) -> Type a -> Encode.Value +encodeType encodeAttributes tpe = + case tpe of + Variable a name -> + Encode.list identity + [ Encode.string "Variable" + , encodeAttributes a + , encodeName name + ] + + Reference a typeName typeParameters -> + Encode.list identity + [ Encode.string "Reference" + , encodeAttributes a + , encodeFQName typeName + , Encode.list (encodeType encodeAttributes) typeParameters + ] + + Tuple a elementTypes -> + Encode.list identity + [ Encode.string "Tuple" + , encodeAttributes a + , Encode.list (encodeType encodeAttributes) elementTypes + ] + + Record a fieldTypes -> + Encode.list identity + [ Encode.string "Record" + , encodeAttributes a + , Encode.list (encodeField encodeAttributes) fieldTypes + ] + + ExtensibleRecord a variableName fieldTypes -> + Encode.list identity + [ Encode.string "ExtensibleRecord" + , encodeAttributes a + , encodeName variableName + , Encode.list (encodeField encodeAttributes) fieldTypes + ] + + Function a argumentType returnType -> + Encode.list identity + [ Encode.string "Function" + , encodeAttributes a + , encodeType encodeAttributes argumentType + , encodeType encodeAttributes returnType + ] + + Unit a -> + Encode.list identity + [ Encode.string "Unit" + , encodeAttributes a + ] + + +{-| Decode a type from JSON. +-} +decodeType : Decode.Decoder a -> Decode.Decoder (Type a) +decodeType decodeAttributes = + let + lazyDecodeType = + Decode.lazy + (\_ -> + decodeType decodeAttributes + ) + + lazyDecodeField = + Decode.lazy + (\_ -> + decodeField decodeAttributes + ) + in + Decode.index 0 Decode.string + |> Decode.andThen + (\kind -> + case kind of + "Variable" -> + Decode.map2 Variable + (Decode.index 1 decodeAttributes) + (Decode.index 2 decodeName) + + "Reference" -> + Decode.map3 Reference + (Decode.index 1 decodeAttributes) + (Decode.index 2 decodeFQName) + (Decode.index 3 (Decode.list (Decode.lazy (\_ -> decodeType decodeAttributes)))) + + "Tuple" -> + Decode.map2 Tuple + (Decode.index 1 decodeAttributes) + (Decode.index 2 (Decode.list lazyDecodeType)) + + "Record" -> + Decode.map2 Record + (Decode.index 1 decodeAttributes) + (Decode.index 2 (Decode.list lazyDecodeField)) + + "ExtensibleRecord" -> + Decode.map3 ExtensibleRecord + (Decode.index 1 decodeAttributes) + (Decode.index 2 decodeName) + (Decode.index 3 (Decode.list lazyDecodeField)) + + "Function" -> + Decode.map3 Function + (Decode.index 1 decodeAttributes) + (Decode.index 2 lazyDecodeType) + (Decode.index 3 lazyDecodeType) + + "Unit" -> + Decode.map Unit + (Decode.index 1 decodeAttributes) + + _ -> + Decode.fail ("Unknown kind: " ++ kind) + ) + + +encodeField : (a -> Encode.Value) -> Field a -> Encode.Value +encodeField encodeAttributes field = + Encode.list identity + [ encodeName field.name + , encodeType encodeAttributes field.tpe + ] + + +decodeField : Decode.Decoder a -> Decode.Decoder (Field a) +decodeField decodeAttributes = + Decode.map2 Field + (Decode.index 0 decodeName) + (Decode.index 1 (decodeType decodeAttributes)) + + +{-| -} +encodeSpecification : (a -> Encode.Value) -> Specification a -> Encode.Value +encodeSpecification encodeAttributes spec = + case spec of + TypeAliasSpecification params exp -> + Encode.list identity + [ Encode.string "TypeAliasSpecification" + , Encode.list encodeName params + , encodeType encodeAttributes exp + ] + + OpaqueTypeSpecification params -> + Encode.list identity + [ Encode.string "OpaqueTypeSpecification" + , Encode.list encodeName params + ] + + CustomTypeSpecification params ctors -> + Encode.list identity + [ Encode.string "CustomTypeSpecification" + , Encode.list encodeName params + , encodeConstructors encodeAttributes ctors + ] + + +{-| -} +encodeDefinition : (a -> Encode.Value) -> Definition a -> Encode.Value +encodeDefinition encodeAttributes def = + case def of + TypeAliasDefinition params exp -> + Encode.list identity + [ Encode.string "TypeAliasDefinition" + , Encode.list encodeName params + , encodeType encodeAttributes exp + ] + + CustomTypeDefinition params ctors -> + Encode.list identity + [ Encode.string "CustomTypeDefinition" + , Encode.list encodeName params + , encodeAccessControlled (encodeConstructors encodeAttributes) ctors + ] + + +encodeConstructors : (a -> Encode.Value) -> Constructors a -> Encode.Value +encodeConstructors encodeAttributes ctors = + ctors + |> Encode.list + (\(Constructor ctorName ctorArgs) -> + Encode.list identity + [ Encode.string "Constructor" + , encodeName ctorName + , ctorArgs + |> Encode.list + (\( argName, argType ) -> + Encode.list identity + [ encodeName argName + , encodeType encodeAttributes argType + ] + ) + ] + ) diff --git a/src/Morphir/IR/Type/Fuzzer.elm b/src/Morphir/IR/Type/Fuzzer.elm new file mode 100644 index 000000000..4942e33ff --- /dev/null +++ b/src/Morphir/IR/Type/Fuzzer.elm @@ -0,0 +1,79 @@ +module Morphir.IR.Type.Fuzzer exposing (..) + +{-| Generate random types. +-} + +import Fuzz exposing (Fuzzer) +import Morphir.IR.FQName.Fuzzer exposing (fuzzFQName) +import Morphir.IR.Name.Fuzzer exposing (fuzzName) +import Morphir.IR.Type exposing (Field, Type(..)) + + +fuzzType : Int -> Fuzzer a -> Fuzzer (Type a) +fuzzType maxDepth fuzzAttributes = + let + fuzzField depth = + Fuzz.map2 Field + fuzzName + (fuzzType depth fuzzAttributes) + + fuzzVariable = + Fuzz.map2 Variable + fuzzAttributes + fuzzName + + fuzzReference depth = + Fuzz.map3 Reference + fuzzAttributes + fuzzFQName + (Fuzz.list (fuzzType depth fuzzAttributes) |> Fuzz.map (List.take depth)) + + fuzzTuple depth = + Fuzz.map2 Tuple + fuzzAttributes + (Fuzz.list (fuzzType depth fuzzAttributes) |> Fuzz.map (List.take depth)) + + fuzzRecord depth = + Fuzz.map2 Record + fuzzAttributes + (Fuzz.list (fuzzField (depth - 1)) |> Fuzz.map (List.take depth)) + + fuzzExtensibleRecord depth = + Fuzz.map3 ExtensibleRecord + fuzzAttributes + fuzzName + (Fuzz.list (fuzzField (depth - 1)) |> Fuzz.map (List.take depth)) + + fuzzFunction depth = + Fuzz.map3 Function + fuzzAttributes + (fuzzType depth fuzzAttributes) + (fuzzType depth fuzzAttributes) + + fuzzUnit = + Fuzz.map Unit + fuzzAttributes + + fuzzLeaf = + Fuzz.oneOf + [ fuzzVariable + , fuzzUnit + ] + + fuzzBranch depth = + Fuzz.oneOf + [ fuzzFunction depth + , fuzzReference depth + , fuzzTuple depth + , fuzzRecord depth + , fuzzExtensibleRecord depth + ] + in + if maxDepth <= 0 then + fuzzLeaf + + else + Fuzz.oneOf + [ fuzzLeaf + , fuzzBranch (maxDepth - 1) + ] diff --git a/src/Morphir/IR/Type/Rewrite.elm b/src/Morphir/IR/Type/Rewrite.elm new file mode 100644 index 000000000..512b42052 --- /dev/null +++ b/src/Morphir/IR/Type/Rewrite.elm @@ -0,0 +1,64 @@ +module Morphir.IR.Type.Rewrite exposing (..) + +import Morphir.IR.Type exposing (Field, Type(..)) +import Morphir.Rewrite exposing (Rewrite) + + +rewriteType : Rewrite e (Type a) +rewriteType rewriteBranch rewriteLeaf typeToRewrite = + case typeToRewrite of + Reference a fQName argTypes -> + argTypes + |> List.foldr + (\nextArg resultSoFar -> + Result.map2 (::) + (rewriteBranch nextArg) + resultSoFar + ) + (Ok []) + |> Result.map (Reference a fQName) + + Tuple a elemTypes -> + elemTypes + |> List.foldr + (\nextArg resultSoFar -> + Result.map2 (::) + (rewriteBranch nextArg) + resultSoFar + ) + (Ok []) + |> Result.map (Tuple a) + + Record a fieldTypes -> + fieldTypes + |> List.foldr + (\field resultSoFar -> + Result.map2 (::) + (rewriteBranch field.tpe + |> Result.map (Field field.name) + ) + resultSoFar + ) + (Ok []) + |> Result.map (Record a) + + ExtensibleRecord a varName fieldTypes -> + fieldTypes + |> List.foldr + (\field resultSoFar -> + Result.map2 (::) + (rewriteBranch field.tpe + |> Result.map (Field field.name) + ) + resultSoFar + ) + (Ok []) + |> Result.map (ExtensibleRecord a varName) + + Function a argType returnType -> + Result.map2 (Function a) + (rewriteBranch argType) + (rewriteBranch returnType) + + _ -> + rewriteLeaf typeToRewrite diff --git a/src/Morphir/IR/Value.elm b/src/Morphir/IR/Value.elm index 53c19c2f4..73db44186 100644 --- a/src/Morphir/IR/Value.elm +++ b/src/Morphir/IR/Value.elm @@ -1,12 +1,11 @@ module Morphir.IR.Value exposing ( Value(..), literal, constructor, apply, field, fieldFunction, lambda, letDef, letDestruct, letRec, list, record, reference , tuple, variable, ifThenElse, patternMatch, update, unit + , mapValueAttributes , Literal(..), boolLiteral, charLiteral, stringLiteral, intLiteral, floatLiteral , Pattern(..), wildcardPattern, asPattern, tuplePattern, recordPattern, constructorPattern, emptyListPattern, headTailPattern, literalPattern - , Specification - , Definition, typedDefinition, untypedDefinition - , encodeValue, encodeSpecification, encodeDefinition - , getDefinitionBody, mapDefinition, mapSpecification, mapValueAttributes + , Specification, mapSpecificationAttributes + , Definition, typedDefinition, untypedDefinition, mapDefinition, mapDefinitionAttributes ) {-| This module contains the building blocks of values in the Morphir IR. @@ -18,6 +17,7 @@ Value is the top level building block for data and logic. See the constructor fu @docs Value, literal, constructor, apply, field, fieldFunction, lambda, letDef, letDestruct, letRec, list, record, reference @docs tuple, variable, ifThenElse, patternMatch, update, unit +@docs mapValueAttributes # Literal @@ -47,7 +47,7 @@ destructuring and pattern-matching. Pattern-matching is a combination of destruc The specification of what the value or function is without the actual data or logic behind it. -@docs Specification +@docs Specification, mapSpecificationAttributes # Definition @@ -55,22 +55,14 @@ is without the actual data or logic behind it. A definition is the actual data or logic as opposed to a specification which is just the specification of those. Value definitions can be typed or untyped. Exposed values have to be typed. -@docs Definition, typedDefinition, untypedDefinition - - -# Serialization - -@docs encodeValue, encodeSpecification, encodeDefinition +@docs Definition, typedDefinition, untypedDefinition, mapDefinition, mapDefinitionAttributes -} import Dict exposing (Dict) -import Json.Decode as Decode -import Json.Encode as Encode -import Morphir.IR.FQName exposing (FQName, decodeFQName, encodeFQName) -import Morphir.IR.Name exposing (Name, decodeName, encodeName) -import Morphir.IR.Type as Type exposing (Type, decodeType, encodeType) -import Morphir.ListOfResults as ListOfResults +import Morphir.IR.FQName exposing (FQName) +import Morphir.IR.Name exposing (Name) +import Morphir.IR.Type as Type exposing (Type) import String @@ -135,16 +127,11 @@ which is just the specification of those. Value definitions can be typed or unty -} type alias Definition a = { valueType : Maybe (Type a) - , argumentNames : List Name + , arguments : List ( Name, a ) , body : Value a } -getDefinitionBody : Definition a -> Value a -getDefinitionBody = - .body - - -- definitionToSpecification : Definition extra -> Maybe (Specification extra) -- definitionToSpecification def = @@ -159,30 +146,10 @@ getDefinitionBody = -- in -mapSpecification : (Type a -> Result e (Type b)) -> (Value a -> Result e (Value b)) -> Specification a -> Result (List e) (Specification b) -mapSpecification mapType mapValue spec = - let - inputsResult = - spec.inputs - |> List.map - (\( name, tpe ) -> - mapType tpe - |> Result.map (Tuple.pair name) - ) - |> ListOfResults.liftAllErrors - - outputResult = - mapType spec.output - |> Result.mapError List.singleton - in - Result.map2 Specification - inputsResult - outputResult - - -mapDefinition : (Type a -> Result e (Type b)) -> (Value a -> Result e (Value b)) -> Definition a -> Result (List e) (Definition b) +{-| -} +mapDefinition : (Type a -> Result e (Type a)) -> (Value a -> Result e (Value a)) -> Definition a -> Result (List e) (Definition a) mapDefinition mapType mapValue def = - Result.map2 (\t v -> Definition t def.argumentNames v) + Result.map2 (\t v -> Definition t def.arguments v) (case def.valueType of Just valueType -> mapType valueType @@ -195,6 +162,20 @@ mapDefinition mapType mapValue def = |> Result.mapError List.singleton +{-| -} +mapSpecificationAttributes : (a -> b) -> Specification a -> Specification b +mapSpecificationAttributes f spec = + Specification + (spec.inputs + |> List.map + (\( name, tpe ) -> + ( name, Type.mapTypeAttributes f tpe ) + ) + ) + (Type.mapTypeAttributes f spec.output) + + +{-| -} mapValueAttributes : (a -> b) -> Value a -> Value b mapValueAttributes f v = case v of @@ -280,6 +261,7 @@ mapValueAttributes f v = Unit (f a) +{-| -} mapPatternAttributes : (a -> b) -> Pattern a -> Pattern b mapPatternAttributes f p = case p of @@ -311,9 +293,13 @@ mapPatternAttributes f p = UnitPattern (f a) +{-| -} mapDefinitionAttributes : (a -> b) -> Definition a -> Definition b mapDefinitionAttributes f d = - Definition (d.valueType |> Maybe.map (Type.mapTypeAttributes f)) d.argumentNames (mapValueAttributes f d.body) + Definition + (d.valueType |> Maybe.map (Type.mapTypeAttributes f)) + (d.arguments |> List.map (\( name, a ) -> ( name, f a ))) + (mapValueAttributes f d.body) @@ -865,7 +851,7 @@ arguments. The examples below try to visualize the process. body -} -typedDefinition : Type a -> List Name -> Value a -> Definition a +typedDefinition : Type a -> List ( Name, a ) -> Value a -> Definition a typedDefinition valueType argumentNames body = Definition (Just valueType) argumentNames body @@ -888,559 +874,6 @@ arguments. The examples below try to visualize the process. body -} -untypedDefinition : List Name -> Value a -> Definition a +untypedDefinition : List ( Name, a ) -> Value a -> Definition a untypedDefinition argumentNames body = Definition Nothing argumentNames body - - -encodeValue : (a -> Encode.Value) -> Value a -> Encode.Value -encodeValue encodeAttributes v = - case v of - Literal a value -> - Encode.list identity - [ Encode.string "Literal" - , encodeAttributes a - , encodeLiteral value - ] - - Constructor a fullyQualifiedName -> - Encode.list identity - [ Encode.string "Constructor" - , encodeAttributes a - , encodeFQName fullyQualifiedName - ] - - Tuple a elements -> - Encode.list identity - [ Encode.string "Tuple" - , encodeAttributes a - , elements |> Encode.list (encodeValue encodeAttributes) - ] - - List a items -> - Encode.list identity - [ Encode.string "List" - , encodeAttributes a - , items |> Encode.list (encodeValue encodeAttributes) - ] - - Record a fields -> - Encode.list identity - [ Encode.string "Record" - , encodeAttributes a - , fields - |> Encode.list - (\( fieldName, fieldValue ) -> - Encode.list identity - [ encodeName fieldName - , encodeValue encodeAttributes fieldValue - ] - ) - ] - - Variable a name -> - Encode.list identity - [ Encode.string "Variable" - , encodeAttributes a - , encodeName name - ] - - Reference a fullyQualifiedName -> - Encode.list identity - [ Encode.string "Reference" - , encodeAttributes a - , encodeFQName fullyQualifiedName - ] - - Field a subjectValue fieldName -> - Encode.list identity - [ Encode.string "Field" - , encodeAttributes a - , encodeValue encodeAttributes subjectValue - , encodeName fieldName - ] - - FieldFunction a fieldName -> - Encode.list identity - [ Encode.string "FieldFunction" - , encodeAttributes a - , encodeName fieldName - ] - - Apply a function argument -> - Encode.list identity - [ Encode.string "Apply" - , encodeAttributes a - , encodeValue encodeAttributes function - , encodeValue encodeAttributes argument - ] - - Lambda a argumentPattern body -> - Encode.list identity - [ Encode.string "Lambda" - , encodeAttributes a - , encodePattern encodeAttributes argumentPattern - , encodeValue encodeAttributes body - ] - - LetDefinition a valueName valueDefinition inValue -> - Encode.list identity - [ Encode.string "LetDefinition" - , encodeAttributes a - , encodeName valueName - , encodeDefinition encodeAttributes valueDefinition - , encodeValue encodeAttributes inValue - ] - - LetRecursion a valueDefinitions inValue -> - Encode.list identity - [ Encode.string "LetRecursion" - , encodeAttributes a - , valueDefinitions - |> Dict.toList - |> Encode.list - (\( name, def ) -> - Encode.list identity - [ encodeName name - , encodeDefinition encodeAttributes def - ] - ) - , encodeValue encodeAttributes inValue - ] - - Destructure a pattern valueToDestruct inValue -> - Encode.list identity - [ Encode.string "Destructure" - , encodeAttributes a - , encodePattern encodeAttributes pattern - , encodeValue encodeAttributes valueToDestruct - , encodeValue encodeAttributes inValue - ] - - IfThenElse a condition thenBranch elseBranch -> - Encode.list identity - [ Encode.string "IfThenElse" - , encodeAttributes a - , encodeValue encodeAttributes condition - , encodeValue encodeAttributes thenBranch - , encodeValue encodeAttributes elseBranch - ] - - PatternMatch a branchOutOn cases -> - Encode.list identity - [ Encode.string "PatternMatch" - , encodeAttributes a - , encodeValue encodeAttributes branchOutOn - , cases - |> Encode.list - (\( pattern, body ) -> - Encode.list identity - [ encodePattern encodeAttributes pattern - , encodeValue encodeAttributes body - ] - ) - ] - - UpdateRecord a valueToUpdate fieldsToUpdate -> - Encode.list identity - [ Encode.string "Update" - , encodeAttributes a - , encodeValue encodeAttributes valueToUpdate - , fieldsToUpdate - |> Encode.list - (\( fieldName, fieldValue ) -> - Encode.list identity - [ encodeName fieldName - , encodeValue encodeAttributes fieldValue - ] - ) - ] - - Unit a -> - Encode.list identity - [ Encode.string "Unit" - , encodeAttributes a - ] - - -decodeValue : Decode.Decoder a -> Decode.Decoder (Value a) -decodeValue decodeAttributes = - let - lazyDecodeValue = - Decode.lazy <| - \_ -> - decodeValue decodeAttributes - in - Decode.index 0 Decode.string - |> Decode.andThen - (\kind -> - case kind of - "Literal" -> - Decode.map2 Literal - (Decode.index 1 decodeAttributes) - (Decode.index 2 decodeLiteral) - - "Constructor" -> - Decode.map2 Constructor - (Decode.index 1 decodeAttributes) - (Decode.index 2 decodeFQName) - - "Tuple" -> - Decode.map2 Tuple - (Decode.index 1 decodeAttributes) - (Decode.index 2 <| Decode.list lazyDecodeValue) - - "List" -> - Decode.map2 List - (Decode.index 1 decodeAttributes) - (Decode.index 2 <| Decode.list lazyDecodeValue) - - "Record" -> - Decode.map2 Record - (Decode.index 1 decodeAttributes) - (Decode.index 2 - (Decode.list - (Decode.map2 Tuple.pair - (Decode.index 0 decodeName) - (Decode.index 1 <| decodeValue decodeAttributes) - ) - ) - ) - - "Variable" -> - Decode.map2 Variable - (Decode.index 1 decodeAttributes) - (Decode.index 2 decodeName) - - "Reference" -> - Decode.map2 Reference - (Decode.index 1 decodeAttributes) - (Decode.index 2 decodeFQName) - - "Field" -> - Decode.map3 Field - (Decode.index 1 decodeAttributes) - (Decode.index 2 <| decodeValue decodeAttributes) - (Decode.index 3 decodeName) - - "FieldFunction" -> - Decode.map2 FieldFunction - (Decode.index 1 decodeAttributes) - (Decode.index 2 decodeName) - - "Apply" -> - Decode.map3 Apply - (Decode.index 1 decodeAttributes) - (Decode.index 2 <| decodeValue decodeAttributes) - (Decode.index 3 <| decodeValue decodeAttributes) - - "Lambda" -> - Decode.map3 Lambda - (Decode.index 1 decodeAttributes) - (Decode.index 2 <| decodePattern decodeAttributes) - (Decode.index 3 <| decodeValue decodeAttributes) - - "LetDefinition" -> - Decode.map4 LetDefinition - (Decode.index 1 decodeAttributes) - (Decode.index 2 decodeName) - (Decode.index 3 <| decodeDefinition decodeAttributes) - (Decode.index 4 <| decodeValue decodeAttributes) - - "LetRecursion" -> - Decode.map3 LetRecursion - (Decode.index 1 decodeAttributes) - (Decode.index 2 - (Decode.list - (Decode.map2 Tuple.pair - (Decode.index 0 decodeName) - (Decode.index 1 <| decodeDefinition decodeAttributes) - ) - |> Decode.map Dict.fromList - ) - ) - (Decode.index 3 <| decodeValue decodeAttributes) - - "Destructure" -> - Decode.map4 Destructure - (Decode.index 1 decodeAttributes) - (Decode.index 2 <| decodePattern decodeAttributes) - (Decode.index 3 <| decodeValue decodeAttributes) - (Decode.index 4 <| decodeValue decodeAttributes) - - "IfThenElse" -> - Decode.map4 IfThenElse - (Decode.index 1 decodeAttributes) - (Decode.index 2 <| decodeValue decodeAttributes) - (Decode.index 3 <| decodeValue decodeAttributes) - (Decode.index 4 <| decodeValue decodeAttributes) - - "PatternMatch" -> - Decode.map3 PatternMatch - (Decode.index 1 decodeAttributes) - (Decode.index 2 <| decodeValue decodeAttributes) - (Decode.index 3 <| - Decode.list - (Decode.map2 Tuple.pair - (decodePattern decodeAttributes) - (decodeValue decodeAttributes) - ) - ) - - "UpdateRecord" -> - Decode.map3 UpdateRecord - (Decode.index 1 decodeAttributes) - (Decode.index 2 <| decodeValue decodeAttributes) - (Decode.index 3 <| - Decode.list <| - Decode.map2 Tuple.pair - decodeName - (decodeValue decodeAttributes) - ) - - "Unit" -> - Decode.map Unit - (Decode.index 1 decodeAttributes) - - other -> - Decode.fail <| "Unknown value type: " ++ other - ) - - -encodePattern : (a -> Encode.Value) -> Pattern a -> Encode.Value -encodePattern encodeAttributes pattern = - case pattern of - WildcardPattern a -> - Encode.list identity - [ Encode.string "WildcardPattern" - , encodeAttributes a - ] - - AsPattern a p name -> - Encode.list identity - [ Encode.string "AsPattern" - , encodeAttributes a - , encodePattern encodeAttributes p - , encodeName name - ] - - TuplePattern a elementPatterns -> - Encode.list identity - [ Encode.string "TuplePattern" - , encodeAttributes a - , elementPatterns |> Encode.list (encodePattern encodeAttributes) - ] - - RecordPattern a fieldNames -> - Encode.list identity - [ Encode.string "RecordPattern" - , encodeAttributes a - , fieldNames |> Encode.list encodeName - ] - - ConstructorPattern a constructorName argumentPatterns -> - Encode.list identity - [ Encode.string "ConstructorPattern" - , encodeAttributes a - , encodeFQName constructorName - , argumentPatterns |> Encode.list (encodePattern encodeAttributes) - ] - - EmptyListPattern a -> - Encode.list identity - [ Encode.string "EmptyListPattern" - , encodeAttributes a - ] - - HeadTailPattern a headPattern tailPattern -> - Encode.list identity - [ Encode.string "HeadTailPattern" - , encodeAttributes a - , encodePattern encodeAttributes headPattern - , encodePattern encodeAttributes tailPattern - ] - - LiteralPattern a value -> - Encode.list identity - [ Encode.string "LiteralPattern" - , encodeAttributes a - , encodeLiteral value - ] - - UnitPattern a -> - Encode.list identity - [ Encode.string "UnitPattern" - , encodeAttributes a - ] - - -decodePattern : Decode.Decoder a -> Decode.Decoder (Pattern a) -decodePattern decodeAttributes = - let - lazyDecodePattern = - Decode.lazy <| - \_ -> - decodePattern decodeAttributes - in - Decode.index 0 Decode.string - |> Decode.andThen - (\kind -> - case kind of - "WildcardPattern" -> - Decode.map WildcardPattern - (Decode.index 1 decodeAttributes) - - "AsPattern" -> - Decode.map3 AsPattern - (Decode.index 1 decodeAttributes) - (Decode.index 2 lazyDecodePattern) - (Decode.index 3 decodeName) - - "TuplePattern" -> - Decode.map2 TuplePattern - (Decode.index 1 decodeAttributes) - (Decode.index 2 <| Decode.list lazyDecodePattern) - - "RecordPattern" -> - Decode.map2 RecordPattern - (Decode.index 1 decodeAttributes) - (Decode.index 2 <| Decode.list decodeName) - - "ConstructorPattern" -> - Decode.map3 ConstructorPattern - (Decode.index 1 decodeAttributes) - (Decode.index 2 decodeFQName) - (Decode.index 3 <| Decode.list lazyDecodePattern) - - "EmptyListPattern" -> - Decode.map EmptyListPattern - (Decode.index 1 decodeAttributes) - - "HeadTailPattern" -> - Decode.map3 HeadTailPattern - (Decode.index 1 decodeAttributes) - (Decode.index 2 lazyDecodePattern) - (Decode.index 3 lazyDecodePattern) - - other -> - Decode.fail <| "Unknown pattern type: " ++ other - ) - - -encodeLiteral : Literal -> Encode.Value -encodeLiteral l = - let - typeTag tag = - ( "@type", Encode.string tag ) - in - case l of - BoolLiteral v -> - Encode.object - [ typeTag "boolLiteral" - , ( "value", Encode.bool v ) - ] - - CharLiteral v -> - Encode.object - [ typeTag "charLiteral" - , ( "value", Encode.string (String.fromChar v) ) - ] - - StringLiteral v -> - Encode.object - [ typeTag "stringLiteral" - , ( "value", Encode.string v ) - ] - - IntLiteral v -> - Encode.object - [ typeTag "intLiteral" - , ( "value", Encode.int v ) - ] - - FloatLiteral v -> - Encode.object - [ typeTag "floatLiteral" - , ( "value", Encode.float v ) - ] - - -decodeLiteral : Decode.Decoder Literal -decodeLiteral = - Decode.field "@type" Decode.string - |> Decode.andThen - (\kind -> - case kind of - "boolLiteral" -> - Decode.map BoolLiteral - (Decode.field "value" Decode.bool) - - "charLiteral" -> - Decode.map CharLiteral - (Decode.field "value" Decode.string - |> Decode.andThen - (\str -> - case String.uncons str of - Just ( ch, _ ) -> - Decode.succeed ch - - Nothing -> - Decode.fail "Single char expected" - ) - ) - - "stringLiteral" -> - Decode.map StringLiteral - (Decode.field "value" Decode.string) - - "intLiteral" -> - Decode.map IntLiteral - (Decode.field "value" Decode.int) - - "floatLiteral" -> - Decode.map FloatLiteral - (Decode.field "value" Decode.float) - - other -> - Decode.fail <| "Unknown literal type: " ++ other - ) - - -encodeSpecification : (a -> Encode.Value) -> Specification a -> Encode.Value -encodeSpecification encodeAttributes spec = - Encode.object - [ ( "inputs" - , spec.inputs - |> Encode.list - (\( argName, argType ) -> - Encode.object - [ ( "argName", encodeName argName ) - , ( "argType", encodeType encodeAttributes argType ) - ] - ) - ) - , ( "output", encodeType encodeAttributes spec.output ) - ] - - -encodeDefinition : (a -> Encode.Value) -> Definition a -> Encode.Value -encodeDefinition encodeAttributes def = - Encode.list identity - [ Encode.string "Definition" - , case def.valueType of - Just valueType -> - encodeType encodeAttributes valueType - - Nothing -> - Encode.null - , def.argumentNames |> Encode.list encodeName - , encodeValue encodeAttributes def.body - ] - - -decodeDefinition : Decode.Decoder a -> Decode.Decoder (Definition a) -decodeDefinition decodeAttributes = - Decode.map3 Definition - (Decode.index 1 (Decode.maybe (decodeType decodeAttributes))) - (Decode.index 2 (Decode.list decodeName)) - (Decode.index 3 (Decode.lazy (\_ -> decodeValue decodeAttributes))) diff --git a/src/Morphir/IR/Value/Codec.elm b/src/Morphir/IR/Value/Codec.elm new file mode 100644 index 000000000..1507281ec --- /dev/null +++ b/src/Morphir/IR/Value/Codec.elm @@ -0,0 +1,569 @@ +module Morphir.IR.Value.Codec exposing (..) + +import Dict +import Json.Decode as Decode +import Json.Encode as Encode +import Morphir.IR.FQName.Codec exposing (decodeFQName, encodeFQName) +import Morphir.IR.Name.Codec exposing (decodeName, encodeName) +import Morphir.IR.Type.Codec exposing (decodeType, encodeType) +import Morphir.IR.Value exposing (Definition, Literal(..), Pattern(..), Specification, Value(..)) + + +encodeValue : (a -> Encode.Value) -> Value a -> Encode.Value +encodeValue encodeAttributes v = + case v of + Literal a value -> + Encode.list identity + [ Encode.string "Literal" + , encodeAttributes a + , encodeLiteral value + ] + + Constructor a fullyQualifiedName -> + Encode.list identity + [ Encode.string "Constructor" + , encodeAttributes a + , encodeFQName fullyQualifiedName + ] + + Tuple a elements -> + Encode.list identity + [ Encode.string "Tuple" + , encodeAttributes a + , elements |> Encode.list (encodeValue encodeAttributes) + ] + + List a items -> + Encode.list identity + [ Encode.string "List" + , encodeAttributes a + , items |> Encode.list (encodeValue encodeAttributes) + ] + + Record a fields -> + Encode.list identity + [ Encode.string "Record" + , encodeAttributes a + , fields + |> Encode.list + (\( fieldName, fieldValue ) -> + Encode.list identity + [ encodeName fieldName + , encodeValue encodeAttributes fieldValue + ] + ) + ] + + Variable a name -> + Encode.list identity + [ Encode.string "Variable" + , encodeAttributes a + , encodeName name + ] + + Reference a fullyQualifiedName -> + Encode.list identity + [ Encode.string "Reference" + , encodeAttributes a + , encodeFQName fullyQualifiedName + ] + + Field a subjectValue fieldName -> + Encode.list identity + [ Encode.string "Field" + , encodeAttributes a + , encodeValue encodeAttributes subjectValue + , encodeName fieldName + ] + + FieldFunction a fieldName -> + Encode.list identity + [ Encode.string "FieldFunction" + , encodeAttributes a + , encodeName fieldName + ] + + Apply a function argument -> + Encode.list identity + [ Encode.string "Apply" + , encodeAttributes a + , encodeValue encodeAttributes function + , encodeValue encodeAttributes argument + ] + + Lambda a argumentPattern body -> + Encode.list identity + [ Encode.string "Lambda" + , encodeAttributes a + , encodePattern encodeAttributes argumentPattern + , encodeValue encodeAttributes body + ] + + LetDefinition a valueName valueDefinition inValue -> + Encode.list identity + [ Encode.string "LetDefinition" + , encodeAttributes a + , encodeName valueName + , encodeDefinition encodeAttributes valueDefinition + , encodeValue encodeAttributes inValue + ] + + LetRecursion a valueDefinitions inValue -> + Encode.list identity + [ Encode.string "LetRecursion" + , encodeAttributes a + , valueDefinitions + |> Dict.toList + |> Encode.list + (\( name, def ) -> + Encode.list identity + [ encodeName name + , encodeDefinition encodeAttributes def + ] + ) + , encodeValue encodeAttributes inValue + ] + + Destructure a pattern valueToDestruct inValue -> + Encode.list identity + [ Encode.string "Destructure" + , encodeAttributes a + , encodePattern encodeAttributes pattern + , encodeValue encodeAttributes valueToDestruct + , encodeValue encodeAttributes inValue + ] + + IfThenElse a condition thenBranch elseBranch -> + Encode.list identity + [ Encode.string "IfThenElse" + , encodeAttributes a + , encodeValue encodeAttributes condition + , encodeValue encodeAttributes thenBranch + , encodeValue encodeAttributes elseBranch + ] + + PatternMatch a branchOutOn cases -> + Encode.list identity + [ Encode.string "PatternMatch" + , encodeAttributes a + , encodeValue encodeAttributes branchOutOn + , cases + |> Encode.list + (\( pattern, body ) -> + Encode.list identity + [ encodePattern encodeAttributes pattern + , encodeValue encodeAttributes body + ] + ) + ] + + UpdateRecord a valueToUpdate fieldsToUpdate -> + Encode.list identity + [ Encode.string "Update" + , encodeAttributes a + , encodeValue encodeAttributes valueToUpdate + , fieldsToUpdate + |> Encode.list + (\( fieldName, fieldValue ) -> + Encode.list identity + [ encodeName fieldName + , encodeValue encodeAttributes fieldValue + ] + ) + ] + + Unit a -> + Encode.list identity + [ Encode.string "Unit" + , encodeAttributes a + ] + + +decodeValue : Decode.Decoder a -> Decode.Decoder (Value a) +decodeValue decodeAttributes = + let + lazyDecodeValue = + Decode.lazy <| + \_ -> + decodeValue decodeAttributes + in + Decode.index 0 Decode.string + |> Decode.andThen + (\kind -> + case kind of + "Literal" -> + Decode.map2 Literal + (Decode.index 1 decodeAttributes) + (Decode.index 2 decodeLiteral) + + "Constructor" -> + Decode.map2 Constructor + (Decode.index 1 decodeAttributes) + (Decode.index 2 decodeFQName) + + "Tuple" -> + Decode.map2 Tuple + (Decode.index 1 decodeAttributes) + (Decode.index 2 <| Decode.list lazyDecodeValue) + + "List" -> + Decode.map2 List + (Decode.index 1 decodeAttributes) + (Decode.index 2 <| Decode.list lazyDecodeValue) + + "Record" -> + Decode.map2 Record + (Decode.index 1 decodeAttributes) + (Decode.index 2 + (Decode.list + (Decode.map2 Tuple.pair + (Decode.index 0 decodeName) + (Decode.index 1 <| decodeValue decodeAttributes) + ) + ) + ) + + "Variable" -> + Decode.map2 Variable + (Decode.index 1 decodeAttributes) + (Decode.index 2 decodeName) + + "Reference" -> + Decode.map2 Reference + (Decode.index 1 decodeAttributes) + (Decode.index 2 decodeFQName) + + "Field" -> + Decode.map3 Field + (Decode.index 1 decodeAttributes) + (Decode.index 2 <| decodeValue decodeAttributes) + (Decode.index 3 decodeName) + + "FieldFunction" -> + Decode.map2 FieldFunction + (Decode.index 1 decodeAttributes) + (Decode.index 2 decodeName) + + "Apply" -> + Decode.map3 Apply + (Decode.index 1 decodeAttributes) + (Decode.index 2 <| decodeValue decodeAttributes) + (Decode.index 3 <| decodeValue decodeAttributes) + + "Lambda" -> + Decode.map3 Lambda + (Decode.index 1 decodeAttributes) + (Decode.index 2 <| decodePattern decodeAttributes) + (Decode.index 3 <| decodeValue decodeAttributes) + + "LetDefinition" -> + Decode.map4 LetDefinition + (Decode.index 1 decodeAttributes) + (Decode.index 2 decodeName) + (Decode.index 3 <| decodeDefinition decodeAttributes) + (Decode.index 4 <| decodeValue decodeAttributes) + + "LetRecursion" -> + Decode.map3 LetRecursion + (Decode.index 1 decodeAttributes) + (Decode.index 2 + (Decode.list + (Decode.map2 Tuple.pair + (Decode.index 0 decodeName) + (Decode.index 1 <| decodeDefinition decodeAttributes) + ) + |> Decode.map Dict.fromList + ) + ) + (Decode.index 3 <| decodeValue decodeAttributes) + + "Destructure" -> + Decode.map4 Destructure + (Decode.index 1 decodeAttributes) + (Decode.index 2 <| decodePattern decodeAttributes) + (Decode.index 3 <| decodeValue decodeAttributes) + (Decode.index 4 <| decodeValue decodeAttributes) + + "IfThenElse" -> + Decode.map4 IfThenElse + (Decode.index 1 decodeAttributes) + (Decode.index 2 <| decodeValue decodeAttributes) + (Decode.index 3 <| decodeValue decodeAttributes) + (Decode.index 4 <| decodeValue decodeAttributes) + + "PatternMatch" -> + Decode.map3 PatternMatch + (Decode.index 1 decodeAttributes) + (Decode.index 2 <| decodeValue decodeAttributes) + (Decode.index 3 <| + Decode.list + (Decode.map2 Tuple.pair + (decodePattern decodeAttributes) + (decodeValue decodeAttributes) + ) + ) + + "UpdateRecord" -> + Decode.map3 UpdateRecord + (Decode.index 1 decodeAttributes) + (Decode.index 2 <| decodeValue decodeAttributes) + (Decode.index 3 <| + Decode.list <| + Decode.map2 Tuple.pair + decodeName + (decodeValue decodeAttributes) + ) + + "Unit" -> + Decode.map Unit + (Decode.index 1 decodeAttributes) + + other -> + Decode.fail <| "Unknown value type: " ++ other + ) + + +encodePattern : (a -> Encode.Value) -> Pattern a -> Encode.Value +encodePattern encodeAttributes pattern = + case pattern of + WildcardPattern a -> + Encode.list identity + [ Encode.string "WildcardPattern" + , encodeAttributes a + ] + + AsPattern a p name -> + Encode.list identity + [ Encode.string "AsPattern" + , encodeAttributes a + , encodePattern encodeAttributes p + , encodeName name + ] + + TuplePattern a elementPatterns -> + Encode.list identity + [ Encode.string "TuplePattern" + , encodeAttributes a + , elementPatterns |> Encode.list (encodePattern encodeAttributes) + ] + + RecordPattern a fieldNames -> + Encode.list identity + [ Encode.string "RecordPattern" + , encodeAttributes a + , fieldNames |> Encode.list encodeName + ] + + ConstructorPattern a constructorName argumentPatterns -> + Encode.list identity + [ Encode.string "ConstructorPattern" + , encodeAttributes a + , encodeFQName constructorName + , argumentPatterns |> Encode.list (encodePattern encodeAttributes) + ] + + EmptyListPattern a -> + Encode.list identity + [ Encode.string "EmptyListPattern" + , encodeAttributes a + ] + + HeadTailPattern a headPattern tailPattern -> + Encode.list identity + [ Encode.string "HeadTailPattern" + , encodeAttributes a + , encodePattern encodeAttributes headPattern + , encodePattern encodeAttributes tailPattern + ] + + LiteralPattern a value -> + Encode.list identity + [ Encode.string "LiteralPattern" + , encodeAttributes a + , encodeLiteral value + ] + + UnitPattern a -> + Encode.list identity + [ Encode.string "UnitPattern" + , encodeAttributes a + ] + + +decodePattern : Decode.Decoder a -> Decode.Decoder (Pattern a) +decodePattern decodeAttributes = + let + lazyDecodePattern = + Decode.lazy <| + \_ -> + decodePattern decodeAttributes + in + Decode.index 0 Decode.string + |> Decode.andThen + (\kind -> + case kind of + "WildcardPattern" -> + Decode.map WildcardPattern + (Decode.index 1 decodeAttributes) + + "AsPattern" -> + Decode.map3 AsPattern + (Decode.index 1 decodeAttributes) + (Decode.index 2 lazyDecodePattern) + (Decode.index 3 decodeName) + + "TuplePattern" -> + Decode.map2 TuplePattern + (Decode.index 1 decodeAttributes) + (Decode.index 2 <| Decode.list lazyDecodePattern) + + "RecordPattern" -> + Decode.map2 RecordPattern + (Decode.index 1 decodeAttributes) + (Decode.index 2 <| Decode.list decodeName) + + "ConstructorPattern" -> + Decode.map3 ConstructorPattern + (Decode.index 1 decodeAttributes) + (Decode.index 2 decodeFQName) + (Decode.index 3 <| Decode.list lazyDecodePattern) + + "EmptyListPattern" -> + Decode.map EmptyListPattern + (Decode.index 1 decodeAttributes) + + "HeadTailPattern" -> + Decode.map3 HeadTailPattern + (Decode.index 1 decodeAttributes) + (Decode.index 2 lazyDecodePattern) + (Decode.index 3 lazyDecodePattern) + + other -> + Decode.fail <| "Unknown pattern type: " ++ other + ) + + +encodeLiteral : Literal -> Encode.Value +encodeLiteral l = + let + typeTag tag = + ( "@type", Encode.string tag ) + in + case l of + BoolLiteral v -> + Encode.object + [ typeTag "boolLiteral" + , ( "value", Encode.bool v ) + ] + + CharLiteral v -> + Encode.object + [ typeTag "charLiteral" + , ( "value", Encode.string (String.fromChar v) ) + ] + + StringLiteral v -> + Encode.object + [ typeTag "stringLiteral" + , ( "value", Encode.string v ) + ] + + IntLiteral v -> + Encode.object + [ typeTag "intLiteral" + , ( "value", Encode.int v ) + ] + + FloatLiteral v -> + Encode.object + [ typeTag "floatLiteral" + , ( "value", Encode.float v ) + ] + + +decodeLiteral : Decode.Decoder Literal +decodeLiteral = + Decode.field "@type" Decode.string + |> Decode.andThen + (\kind -> + case kind of + "boolLiteral" -> + Decode.map BoolLiteral + (Decode.field "value" Decode.bool) + + "charLiteral" -> + Decode.map CharLiteral + (Decode.field "value" Decode.string + |> Decode.andThen + (\str -> + case String.uncons str of + Just ( ch, _ ) -> + Decode.succeed ch + + Nothing -> + Decode.fail "Single char expected" + ) + ) + + "stringLiteral" -> + Decode.map StringLiteral + (Decode.field "value" Decode.string) + + "intLiteral" -> + Decode.map IntLiteral + (Decode.field "value" Decode.int) + + "floatLiteral" -> + Decode.map FloatLiteral + (Decode.field "value" Decode.float) + + other -> + Decode.fail <| "Unknown literal type: " ++ other + ) + + +encodeSpecification : (a -> Encode.Value) -> Specification a -> Encode.Value +encodeSpecification encodeAttributes spec = + Encode.object + [ ( "inputs" + , spec.inputs + |> Encode.list + (\( argName, argType ) -> + Encode.object + [ ( "argName", encodeName argName ) + , ( "argType", encodeType encodeAttributes argType ) + ] + ) + ) + , ( "output", encodeType encodeAttributes spec.output ) + ] + + +encodeDefinition : (a -> Encode.Value) -> Definition a -> Encode.Value +encodeDefinition encodeAttributes def = + Encode.list identity + [ Encode.string "Definition" + , case def.valueType of + Just valueType -> + encodeType encodeAttributes valueType + + Nothing -> + Encode.null + , def.arguments + |> Encode.list + (\( name, a ) -> + Encode.list identity + [ encodeName name + , encodeAttributes a + ] + ) + , encodeValue encodeAttributes def.body + ] + + +decodeDefinition : Decode.Decoder a -> Decode.Decoder (Definition a) +decodeDefinition decodeAttributes = + Decode.map3 Definition + (Decode.index 1 (Decode.maybe (decodeType decodeAttributes))) + (Decode.index 2 (Decode.list (Decode.map2 Tuple.pair decodeName decodeAttributes))) + (Decode.index 3 (Decode.lazy (\_ -> decodeValue decodeAttributes))) diff --git a/tests/Morphir/Elm/FrontendTests.elm b/tests/Morphir/Elm/FrontendTests.elm index af1538074..b1aeec754 100644 --- a/tests/Morphir/Elm/FrontendTests.elm +++ b/tests/Morphir/Elm/FrontendTests.elm @@ -230,7 +230,7 @@ valueTests = moduleDef.value.values |> Dict.get [ "test", "value" ] |> Result.fromMaybe "Could not find test value" - |> Result.map (.value >> Value.getDefinitionBody) + |> Result.map (.value >> .body) ) ) |> resultToExpectation expectedValueIR @@ -246,6 +246,10 @@ valueTests = pvar : String -> Pattern () pvar name = AsPattern () (WildcardPattern ()) (Name.fromString name) + + binary : (() -> Value ()) -> Value () -> Value () -> Value () + binary fun arg1 arg2 = + Apply () (Apply () (fun ()) arg1) arg2 in describe "Values are mapped correctly" [ checkIR "()" <| Unit () @@ -288,24 +292,26 @@ valueTests = , checkIR "case a of\n 1 -> foo\n _ -> bar" <| PatternMatch () (ref "a") [ ( LiteralPattern () (IntLiteral 1), ref "foo" ), ( WildcardPattern (), ref "bar" ) ] , checkIR "a <| b" <| Apply () (ref "a") (ref "b") , checkIR "a |> b" <| Apply () (ref "b") (ref "a") - , checkIR "a || b" <| Bool.or () (ref "a") (ref "b") - , checkIR "a && b" <| Bool.and () (ref "a") (ref "b") - , checkIR "a == b" <| Equality.equal () (ref "a") (ref "b") - , checkIR "a /= b" <| Equality.notEqual () (ref "a") (ref "b") - , checkIR "a < b" <| Comparison.lessThan () (ref "a") (ref "b") - , checkIR "a > b" <| Comparison.greaterThan () (ref "a") (ref "b") - , checkIR "a <= b" <| Comparison.lessThanOrEqual () (ref "a") (ref "b") - , checkIR "a >= b" <| Comparison.greaterThanOrEqual () (ref "a") (ref "b") - , checkIR "a ++ b" <| Appending.append () (ref "a") (ref "b") - , checkIR "a + b" <| Number.add () (ref "a") (ref "b") - , checkIR "a - b" <| Number.subtract () (ref "a") (ref "b") - , checkIR "a * b" <| Number.multiply () (ref "a") (ref "b") - , checkIR "a / b" <| Float.divide () (ref "a") (ref "b") - , checkIR "a // b" <| Int.divide () (ref "a") (ref "b") - , checkIR "a ^ b" <| Number.power () (ref "a") (ref "b") - , checkIR "a << b" <| Composition.composeLeft () (ref "a") (ref "b") - , checkIR "a >> b" <| Composition.composeRight () (ref "a") (ref "b") - , checkIR "a :: b" <| List.construct () (ref "a") (ref "b") + , checkIR "a || b" <| binary Bool.or (ref "a") (ref "b") + , checkIR "a && b" <| binary Bool.and (ref "a") (ref "b") + , checkIR "a == b" <| binary Equality.equal (ref "a") (ref "b") + , checkIR "a /= b" <| binary Equality.notEqual (ref "a") (ref "b") + , checkIR "a < b" <| binary Comparison.lessThan (ref "a") (ref "b") + , checkIR "a > b" <| binary Comparison.greaterThan (ref "a") (ref "b") + , checkIR "a <= b" <| binary Comparison.lessThanOrEqual (ref "a") (ref "b") + , checkIR "a >= b" <| binary Comparison.greaterThanOrEqual (ref "a") (ref "b") + , checkIR "a ++ b" <| binary Appending.append (ref "a") (ref "b") + , checkIR "a + b" <| binary Number.add (ref "a") (ref "b") + , checkIR "a - b" <| binary Number.subtract (ref "a") (ref "b") + , checkIR "a * b" <| binary Number.multiply (ref "a") (ref "b") + , checkIR "a / b" <| binary Float.divide (ref "a") (ref "b") + , checkIR "a // b" <| binary Int.divide (ref "a") (ref "b") + , checkIR "a ^ b" <| binary Number.power (ref "a") (ref "b") + , checkIR "a << b" <| binary Composition.composeLeft (ref "a") (ref "b") + , checkIR "a >> b" <| binary Composition.composeRight (ref "a") (ref "b") + , checkIR "a :: b" <| binary List.construct (ref "a") (ref "b") + , checkIR "::" <| List.construct () + , checkIR "foo (::)" <| Apply () (ref "foo") (List.construct ()) , checkIR (String.join "\n" [ " let" @@ -330,7 +336,7 @@ valueTests = <| LetDefinition () (Name.fromString "foo") - (Definition Nothing [ Name.fromString "a" ] (ref "c")) + (Definition Nothing [ ( Name.fromString "a", () ) ] (ref "c")) (ref "d") , checkIR (String.join "\n" diff --git a/tests/Morphir/IR/NameTests.elm b/tests/Morphir/IR/NameTests.elm index 03a84019f..f62611a78 100644 --- a/tests/Morphir/IR/NameTests.elm +++ b/tests/Morphir/IR/NameTests.elm @@ -1,9 +1,10 @@ module Morphir.IR.NameTests exposing (..) import Expect +import Json.Encode exposing (encode) import Morphir.IR.Name as Name +import Morphir.IR.Name.Codec exposing (encodeName) import Test exposing (..) -import Json.Encode exposing(encode) fromStringTests : Test @@ -87,6 +88,7 @@ toHumanWordsTests = , assert [ "value", "in", "u", "s", "d" ] [ "value", "in", "USD" ] ] + encodeNameTests : Test encodeNameTests = let @@ -94,11 +96,11 @@ encodeNameTests = test ("encodeName " ++ (expectedText ++ " ")) <| \_ -> Name.fromList inList - |> Name.encodeName + |> encodeName |> encode 0 |> Expect.equal expectedText in describe "encodeName" - [ assert ["delta", "sigma", "theta"] """["delta","sigma","theta"]""" - , assert ["sigma","gamma","ro"] """["sigma","gamma","ro"]""" - ] \ No newline at end of file + [ assert [ "delta", "sigma", "theta" ] """["delta","sigma","theta"]""" + , assert [ "sigma", "gamma", "ro" ] """["sigma","gamma","ro"]""" + ] diff --git a/tests/Morphir/IR/PathTests.elm b/tests/Morphir/IR/PathTests.elm index 5b6fe8f15..2ef5340c8 100644 --- a/tests/Morphir/IR/PathTests.elm +++ b/tests/Morphir/IR/PathTests.elm @@ -1,10 +1,12 @@ module Morphir.IR.PathTests exposing (..) import Expect +import Json.Encode exposing (encode) import Morphir.IR.Name as Name import Morphir.IR.Path as Path +import Morphir.IR.Path.Codec exposing (encodePath) import Test exposing (..) -import Json.Encode exposing (encode) + isPrefixOfTests : Test isPrefixOfTests = @@ -31,6 +33,7 @@ isPrefixOfTests = , isPrefixOf [ [ "foo" ], [ "bar" ] ] [ [ "foo" ], [ "bar" ] ] True ] + encodePathTests : Test encodePathTests = let @@ -38,11 +41,11 @@ encodePathTests = test ("encodePath " ++ (expectedJsonText ++ " ")) <| \_ -> Path.fromList input - |> Path.encodePath + |> encodePath |> encode 0 |> Expect.equal expectedJsonText in describe "encodePath" - [ assert (Path.fromList [Name.fromList ["alpha"], Name.fromList ["beta"], Name.fromList ["gamma"]]) """[["alpha"],["beta"],["gamma"]]""" - , assert (Path.fromList [Name.fromList ["alpha","omega"], Name.fromList ["beta","delta"], Name.fromList ["gamma"]]) """[["alpha","omega"],["beta","delta"],["gamma"]]""" - ] \ No newline at end of file + [ assert (Path.fromList [ Name.fromList [ "alpha" ], Name.fromList [ "beta" ], Name.fromList [ "gamma" ] ]) """[["alpha"],["beta"],["gamma"]]""" + , assert (Path.fromList [ Name.fromList [ "alpha", "omega" ], Name.fromList [ "beta", "delta" ], Name.fromList [ "gamma" ] ]) """[["alpha","omega"],["beta","delta"],["gamma"]]""" + ] From 3bf59a9c0c99893b8ffec3eaf9004953e17fcc81 Mon Sep 17 00:00:00 2001 From: Attila Mihaly Date: Tue, 28 Apr 2020 15:27:19 -0400 Subject: [PATCH 38/42] Various fixes. #68 --- cli/src/Morphir/Elm/CLI.elm | 3 ++- cli/src/Morphir/Elm/DaprCLI.elm | 13 +++++++------ elm.json | 4 +++- src/Morphir/IR/Module.elm | 7 +++++++ src/Morphir/IR/Package.elm | 9 +++++++++ 5 files changed, 28 insertions(+), 8 deletions(-) diff --git a/cli/src/Morphir/Elm/CLI.elm b/cli/src/Morphir/Elm/CLI.elm index 5b1f5755d..554152c31 100644 --- a/cli/src/Morphir/Elm/CLI.elm +++ b/cli/src/Morphir/Elm/CLI.elm @@ -4,6 +4,7 @@ import Json.Decode as Decode import Json.Encode as Encode import Morphir.Elm.Frontend as Frontend exposing (PackageInfo, SourceFile, decodePackageInfo, encodeError) import Morphir.IR.Package as Package +import Morphir.IR.Package.Codec as PackageCodec port packageDefinitionFromSource : (( Decode.Value, List SourceFile ) -> msg) -> Sub msg @@ -39,7 +40,7 @@ update msg model = Frontend.packageDefinitionFromSource packageInfo sourceFiles |> Result.map Package.eraseDefinitionAttributes in - ( model, result |> encodeResult (Encode.list encodeError) (Package.encodeDefinition (\_ -> Encode.null)) |> packageDefinitionFromSourceResult ) + ( model, result |> encodeResult (Encode.list encodeError) (PackageCodec.encodeDefinition (\_ -> Encode.null)) |> packageDefinitionFromSourceResult ) Err errorMessage -> ( model, errorMessage |> Decode.errorToString |> decodeError ) diff --git a/cli/src/Morphir/Elm/DaprCLI.elm b/cli/src/Morphir/Elm/DaprCLI.elm index 9c2214286..f15ba69fa 100644 --- a/cli/src/Morphir/Elm/DaprCLI.elm +++ b/cli/src/Morphir/Elm/DaprCLI.elm @@ -6,20 +6,21 @@ import Elm.Syntax.Exposing exposing (Exposing(..)) import Elm.Syntax.File exposing (File) import Elm.Syntax.Module exposing (Module(..)) import Elm.Syntax.Node exposing (Node) -import Elm.Syntax.Range as Range exposing (emptyRange) +import Elm.Syntax.Range as Range import Elm.Writer as Writer exposing (..) import Json.Decode as Decode import Json.Encode as Encode import Maybe.Extra as MaybeExtra exposing (..) -import Morphir.Elm.Backend.Codec.DecoderGen as DecoderGen exposing (typeDefToDecoder) -import Morphir.Elm.Backend.Codec.EncoderGen as EncoderGen exposing (typeDefToEncoder) -import Morphir.Elm.Backend.Dapr.StatefulApp as StatefulApp exposing (gen) +import Morphir.Elm.Backend.Codec.DecoderGen as DecoderGen +import Morphir.Elm.Backend.Codec.EncoderGen as EncoderGen +import Morphir.Elm.Backend.Dapr.StatefulApp as StatefulApp import Morphir.Elm.Backend.Utils as Utils exposing (..) import Morphir.Elm.Frontend as Frontend exposing (PackageInfo, SourceFile, decodePackageInfo, encodeError) import Morphir.IR.AccessControlled as AccessControlled exposing (..) import Morphir.IR.Module as Module exposing (..) -import Morphir.IR.Name as Name exposing (Name, toCamelCase) +import Morphir.IR.Name as Name exposing (Name) import Morphir.IR.Package as Package +import Morphir.IR.Package.Codec as PackageCodec import Morphir.IR.Path exposing (Path) import Morphir.IR.Type as Type exposing (Definition(..), Type) @@ -68,7 +69,7 @@ update msg model = packageDefResult |> Result.map (\pkgDef -> IrAndElmBackendResult pkgDef (daprSource pkgInfo.name pkgDef)) in - ( model, result |> encodeResult (Encode.list encodeError) (Package.encodeDefinition (\_ -> Encode.null)) |> packageDefAndDaprCodeFromSrcResult ) + ( model, result |> encodeResult (Encode.list encodeError) (PackageCodec.encodeDefinition (\_ -> Encode.null)) |> packageDefAndDaprCodeFromSrcResult ) Err errorMessage -> ( model, errorMessage |> Decode.errorToString |> decodeError ) diff --git a/elm.json b/elm.json index 31757ddd1..c7a96d9a3 100644 --- a/elm.json +++ b/elm.json @@ -12,7 +12,9 @@ "Morphir.IR.FQName", "Morphir.IR.AccessControlled", "Morphir.IR.Type", - "Morphir.IR.Value" + "Morphir.IR.Value", + "Morphir.IR.Module", + "Morphir.IR.Package" ], "elm-version": "0.19.0 <= v < 0.20.0", "dependencies": { diff --git a/src/Morphir/IR/Module.elm b/src/Morphir/IR/Module.elm index ea5c531ec..95d337af1 100644 --- a/src/Morphir/IR/Module.elm +++ b/src/Morphir/IR/Module.elm @@ -6,6 +6,7 @@ module Morphir.IR.Module exposing {-| Modules are groups of types and values that belong together. @docs Specification, Definition +@docs ModulePath, definitionToSpecification, eraseSpecificationAttributes, mapDefinitionAttributes, mapSpecificationAttributes -} @@ -17,6 +18,7 @@ import Morphir.IR.Type as Type exposing (Type) import Morphir.IR.Value as Value exposing (Value) +{-| -} type alias ModulePath = Path @@ -29,6 +31,7 @@ type alias Specification a = } +{-| -} emptySpecification : Specification a emptySpecification = { types = Dict.empty @@ -44,6 +47,7 @@ type alias Definition a = } +{-| -} definitionToSpecification : Definition a -> Specification a definitionToSpecification def = { types = @@ -77,12 +81,14 @@ definitionToSpecification def = } +{-| -} eraseSpecificationAttributes : Specification a -> Specification () eraseSpecificationAttributes spec = spec |> mapSpecificationAttributes (\_ -> ()) +{-| -} mapSpecificationAttributes : (a -> b) -> Specification a -> Specification b mapSpecificationAttributes f spec = Specification @@ -100,6 +106,7 @@ mapSpecificationAttributes f spec = ) +{-| -} mapDefinitionAttributes : (a -> b) -> Definition a -> Definition b mapDefinitionAttributes f def = Definition diff --git a/src/Morphir/IR/Package.elm b/src/Morphir/IR/Package.elm index 19cc8b911..f43a632d1 100644 --- a/src/Morphir/IR/Package.elm +++ b/src/Morphir/IR/Package.elm @@ -10,6 +10,8 @@ module Morphir.IR.Package exposing @docs Definition, emptyDefinition +@docs PackagePath, definitionToSpecification, eraseDefinitionAttributes, eraseSpecificationAttributes + -} import Dict exposing (Dict) @@ -18,6 +20,7 @@ import Morphir.IR.Module as Module exposing (ModulePath) import Morphir.IR.Path exposing (Path) +{-| -} type alias PackagePath = Path @@ -29,6 +32,7 @@ type alias Specification a = } +{-| -} emptySpecification : Specification a emptySpecification = { modules = Dict.empty @@ -52,6 +56,7 @@ emptyDefinition = } +{-| -} definitionToSpecification : Definition a -> Specification a definitionToSpecification def = { modules = @@ -70,6 +75,7 @@ definitionToSpecification def = } +{-| -} mapSpecificationAttributes : (a -> b) -> Specification a -> Specification b mapSpecificationAttributes f spec = Specification @@ -81,6 +87,7 @@ mapSpecificationAttributes f spec = ) +{-| -} mapDefinitionAttributes : (a -> b) -> Definition a -> Definition b mapDefinitionAttributes f def = Definition @@ -99,12 +106,14 @@ mapDefinitionAttributes f def = ) +{-| -} eraseSpecificationAttributes : Specification a -> Specification () eraseSpecificationAttributes spec = spec |> mapSpecificationAttributes (\_ -> ()) +{-| -} eraseDefinitionAttributes : Definition a -> Definition () eraseDefinitionAttributes def = def From 9c5d4484cd3d2d76dfe49ad279d368742b162536 Mon Sep 17 00:00:00 2001 From: Attila Mihaly Date: Tue, 28 Apr 2020 15:53:21 -0400 Subject: [PATCH 39/42] Report parse errors. --- src/Morphir/Elm/Frontend.elm | 17 ++++++++++++++--- 1 file changed, 14 insertions(+), 3 deletions(-) diff --git a/src/Morphir/Elm/Frontend.elm b/src/Morphir/Elm/Frontend.elm index 4ffaae826..a09beca04 100644 --- a/src/Morphir/Elm/Frontend.elm +++ b/src/Morphir/Elm/Frontend.elm @@ -43,7 +43,7 @@ import Morphir.IR.Value as Value exposing (Value) import Morphir.JsonExtra as JsonExtra import Morphir.ListOfResults as ListOfResults import Morphir.Rewrite as Rewrite -import Parser +import Parser exposing (DeadEnd) import Set exposing (Set) @@ -148,11 +148,22 @@ type Error | VariableShadowing Name SourceLocation SourceLocation +encodeDeadEnd : DeadEnd -> Encode.Value +encodeDeadEnd deadEnd = + Encode.list identity + [ Encode.int deadEnd.row + , Encode.int deadEnd.col + ] + + encodeError : Error -> Encode.Value encodeError error = case error of - ParseError _ _ -> - JsonExtra.encodeConstructor "ParseError" [] + ParseError sourcePath deadEnds -> + JsonExtra.encodeConstructor "ParseError" + [ Encode.string sourcePath + , Encode.list encodeDeadEnd deadEnds + ] CyclicModules _ -> JsonExtra.encodeConstructor "CyclicModules" [] From 07de3d2afd6adfc3e9e79603335867eed760b5f4 Mon Sep 17 00:00:00 2001 From: Attila Mihaly Date: Thu, 7 May 2020 10:24:46 -0400 Subject: [PATCH 40/42] Updated docs. --- README.md | 30 ++++++++++++++---------------- 1 file changed, 14 insertions(+), 16 deletions(-) diff --git a/README.md b/README.md index cd0e69f3a..02df13152 100644 --- a/README.md +++ b/README.md @@ -1,11 +1,15 @@ # morphir-elm -[![npm version](https://badge.fury.io/js/morphir-elm.svg)](https://badge.fury.io/js/morphir-elm) -morphir-elm is a set of tools to work with Morphir in Elm. It currently provides these features: +morphir-elm is a set of tools to work with Morphir in Elm. It's dual published as an NPM and an Elm package: -* Translate Elm sources to Morphir IR -* Generate code from the Morphir IR +- NPM package: [![npm version](https://badge.fury.io/js/morphir-elm.svg)](https://badge.fury.io/js/morphir-elm) +- Elm package: ![Latest version of the Elm package](https://reiner-dolp.github.io/elm-badges/Morgan-Stanley/morphir-elm/version.svg) + +The NPM package provides a CLI to run the tooling while the Elm package can be used for direct integration. +The CLI currently supports the following features: + +- [Translate Elm sources to Morphir IR](#translate-elm-sources-to-morphir-ir) # Installation @@ -47,15 +51,9 @@ root directory with the following structure: ### Options -|Option|Shorthand|Description| -|---|---|---| -|`--project-dir `|`-p`|Root directory of the project where morphir.json is located. (default: ".")| -|`--output `|`-o`|Target location where the Morphir IR will be sent. Defaults to STDOUT.| - -## Generate code from the Morphir IR - -Generate code from the Morphir IR - -``` -morphir-elm gen -``` \ No newline at end of file +- `--project-dir `, `-p` + - Root directory of the project where morphir.json is located. + - Defaults to current directory. +- `--output `, `-o` + - Target location where the Morphir IR will be sent + - Defaults to STDOUT. From 9ad3a73852950aa416b52f3a04f4f38ef435b8cc Mon Sep 17 00:00:00 2001 From: Attila Mihaly Date: Thu, 7 May 2020 10:27:45 -0400 Subject: [PATCH 41/42] Link to Elm package. --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index 02df13152..03a4243e2 100644 --- a/README.md +++ b/README.md @@ -4,7 +4,7 @@ morphir-elm is a set of tools to work with Morphir in Elm. It's dual published as an NPM and an Elm package: - NPM package: [![npm version](https://badge.fury.io/js/morphir-elm.svg)](https://badge.fury.io/js/morphir-elm) -- Elm package: ![Latest version of the Elm package](https://reiner-dolp.github.io/elm-badges/Morgan-Stanley/morphir-elm/version.svg) +- Elm package: [![Latest version of the Elm package](https://reiner-dolp.github.io/elm-badges/Morgan-Stanley/morphir-elm/version.svg)](https://package.elm-lang.org/packages/Morgan-Stanley/morphir-elm/latest) The NPM package provides a CLI to run the tooling while the Elm package can be used for direct integration. The CLI currently supports the following features: From b500b73fb117ec363b761973e63c3e7e3f0302dd Mon Sep 17 00:00:00 2001 From: Attila Mihaly Date: Thu, 7 May 2020 16:20:37 -0400 Subject: [PATCH 42/42] More documentation. --- README.md | 83 ++++++++++++++++++++++++++++++++++++++++++++++++------- 1 file changed, 73 insertions(+), 10 deletions(-) diff --git a/README.md b/README.md index 03a4243e2..c9d68b2c7 100644 --- a/README.md +++ b/README.md @@ -3,21 +3,22 @@ morphir-elm is a set of tools to work with Morphir in Elm. It's dual published as an NPM and an Elm package: -- NPM package: [![npm version](https://badge.fury.io/js/morphir-elm.svg)](https://badge.fury.io/js/morphir-elm) -- Elm package: [![Latest version of the Elm package](https://reiner-dolp.github.io/elm-badges/Morgan-Stanley/morphir-elm/version.svg)](https://package.elm-lang.org/packages/Morgan-Stanley/morphir-elm/latest) - -The NPM package provides a CLI to run the tooling while the Elm package can be used for direct integration. -The CLI currently supports the following features: +- [NPM package](#npm-package) +- [Elm package](#elm-package) + +# NPM package -- [Translate Elm sources to Morphir IR](#translate-elm-sources-to-morphir-ir) +[![npm version](https://badge.fury.io/js/morphir-elm.svg)](https://badge.fury.io/js/morphir-elm) + +The **morphir-elm** NPM package provides a CLI to run the tooling. -# Installation +## Installation ``` npm install -g morphir-elm ``` -# Usage +## Usage All the features can be accessed through sub-commands within the `morphir-elm` command: @@ -27,7 +28,7 @@ morphir-elm [command] Each command has different options which are detailed below: -## Translate Elm sources to Morphir IR +### Translate Elm sources to Morphir IR This command reads Elm sources, translates to Morphir IR and outputs the IR into JSON. @@ -49,7 +50,7 @@ root directory with the following structure: } ``` -### Options +#### Options - `--project-dir `, `-p` - Root directory of the project where morphir.json is located. @@ -57,3 +58,65 @@ root directory with the following structure: - `--output `, `-o` - Target location where the Morphir IR will be sent - Defaults to STDOUT. + +# Elm package + +[![Latest version of the Elm package](https://reiner-dolp.github.io/elm-badges/Morgan-Stanley/morphir-elm/version.svg)](https://package.elm-lang.org/packages/Morgan-Stanley/morphir-elm/latest) + +The [Morgan-Stanley/morphir-elm](https://package.elm-lang.org/packages/Morgan-Stanley/morphir-elm/latest) package +provides various tools to work with Morphir. It contains the following main components: + +- The [Morphir SDK](#morphir-sdk) which provides the base set of types and functions that Morphir tools support + out-of-the-box. (the SDK is a superset [elm/core](https://package.elm-lang.org/packages/elm/core/latest) with a few + exceptions documented below) +- A type-safe API for the [Morphir IR](#morphir-ir) that allows you to create or inspect it. + +## Installation + +``` +elm install Morgan-Stanley/morphir-elm +``` + +## Morphir SDK + +The goal of the `Morphir.SDK` module is to provide you the basic building blocks to build your domain model and +business logic. It also serves as a specification for backend developers that describes the minimum set of functionality +each backend implementation should support. + +It is generally based on [elm/core/1.0.5](https://package.elm-lang.org/packages/elm/core/1.0.5/) and provides most of +the functionality provided there except for some modules that fall outside the scope of business knowledge modeling: +`Debug`, `Platform`, `Process` and `Task`. + +Apart from the modules mentioned above you can use everything that's available in `elm/core/1.0.5` without importing +the `Morphir SDK`. The Elm frontend will simply map those to the corresponding type/function names in the Morphir SDK. + +The `Morphir SDK` also provides some features beyond `elm/core/1.0.5`. To use those features you have to import the +specific `Morphir SDK` module. Modules that extends `elm/core` will implement the same functions so in general you can +use an alias if you want to switch from the `elm/core` module to the `Morphir SDK` version. For example if you want to +use extended `List` functions you can do the below an all existing code should continue to work without changes: + +```elm +import Morphir.SDK.List as List +``` + +## Morphir IR + +The `Morphir.IR` module defines a type-safe API to work with Morphir's intermediate representation. The module +structure follows the structure of the IR. Here's a list of concepts in a top-down approach: + +- [Package](https://package.elm-lang.org/packages/Morgan-Stanley/morphir-elm/latest/Morphir-IR-Package) represents an + entire library or application that is versioned as a whole. A package is made up of several modules. +- [Module](https://package.elm-lang.org/packages/Morgan-Stanley/morphir-elm/latest/Morphir-IR-Module) is a container + to group types and values. +- [Types](https://package.elm-lang.org/packages/Morgan-Stanley/morphir-elm/latest/Morphir-IR-Type) allow you to describe + your domain model. +- [Values](https://package.elm-lang.org/packages/Morgan-Stanley/morphir-elm/latest/Morphir-IR-Value) allows you to + describe your business logic. +- [Names](https://package.elm-lang.org/packages/Morgan-Stanley/morphir-elm/latest/Morphir-IR-Name) provide a naming + convention agnostic representation for all nodes that can be named: types, values, modules and packages. Names can be + composed into hierarchies: + - [path](https://package.elm-lang.org/packages/Morgan-Stanley/morphir-elm/latest/Morphir-IR-Path) is a list of names + - [qualifield name](https://package.elm-lang.org/packages/Morgan-Stanley/morphir-elm/latest/Morphir-IR-QName) is a module path with a local name + - [fully-qualifield name](https://package.elm-lang.org/packages/Morgan-Stanley/morphir-elm/latest/Morphir-IR-FQName) is a package path with a qualified name +- [AccessControlled](https://package.elm-lang.org/packages/Morgan-Stanley/morphir-elm/latest/Morphir-IR-AccessControlled) + is a utility to define visibility constraints for modules, types and values \ No newline at end of file