From f92b5f1f583f291430d647c6f74b8ef391cfcb9f Mon Sep 17 00:00:00 2001 From: Attila Mihaly <60483498+AttilaMihaly@users.noreply.github.com> Date: Mon, 20 Apr 2020 12:54:04 -0400 Subject: [PATCH] Full value resolution support (#67) * Added missing module declarations. #37 * Process only those modules that are reachable from exposed ones. Remove package path from module names. #21 * Renaming concepts based on review feedback. #41 * Moved Advanced module up a level. #43 * Removed unused unindent function. * Moved name to SDK. * Added missing module to SDK. * Partial implementation of value mapping. * Ignore all generated JS. * Change extra arg position and naming. #46, #25 * Change extra arg position and naming. #46, #25 * Removed remaining references to extra. #5 * Change extra arg position. #46, #25, #5 * Added more coverage. #46, #25, #5 * Changes suggested in the PR. #46, #25, #5 * Use more explicit names. * All patterns supported. * Pattern-match supported. * Added support for SDK operators. #52 * Fix compile errors. * Prepare Elm module publishing. #2 * Fix repo name. #2 * Support for let expressions. #54 * Simple join implementations. #64 * Refactoring to make the code more organized. * Refactoring to make the code more organized. * Prepare value mapping utils. #53 * More descriptive naming. * More descriptive naming. * Removed unused function * Better naming * Added utility function and removed unused one. * Added variable resolution. * Hooked up variable resolution and updated tests. #53 * Completed reference resolution. #53 --- cli/elm.json | 3 + src/Morphir/Elm/Frontend.elm | 1041 ++++++++++++++++---------- src/Morphir/Elm/Frontend/Resolve.elm | 43 +- src/Morphir/IR/Module.elm | 19 +- src/Morphir/IR/Package.elm | 20 +- src/Morphir/IR/Type.elm | 10 +- src/Morphir/IR/Value.elm | 110 +-- src/Morphir/ListOfResults.elm | 45 ++ src/Morphir/ResultList.elm | 70 -- tests/Morphir/Elm/FrontendTests.elm | 95 +-- 10 files changed, 836 insertions(+), 620 deletions(-) create mode 100644 src/Morphir/ListOfResults.elm delete mode 100644 src/Morphir/ResultList.elm 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 2647b0473..ce9ca52f8 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 @@ -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) @@ -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 @@ -201,7 +217,7 @@ packageDefinitionFromSource packageInfo sourceFiles = ) |> Result.mapError (ParseError sourceFile.path) ) - |> ResultList.toResult + |> ListOfResults.liftAllErrors exposedModuleNames : Set ModuleName exposedModuleNames = @@ -342,7 +358,7 @@ mapProcessedFile currentPackagePath processedFile modulesSoFar = moduleDeclsSoFar = modulesSoFar |> Dict.map - (\path def -> + (\_ def -> Module.definitionToSpecification def |> Module.eraseSpecificationAttributes ) @@ -352,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) @@ -375,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 @@ -501,7 +523,7 @@ mapDeclarationsToType sourceFile expose decls = ) ) ) - |> ResultList.toResult + |> ListOfResults.liftAllErrors |> Result.mapError List.concat in ctorArgsResult @@ -510,20 +532,20 @@ mapDeclarationsToType sourceFile expose decls = Type.Constructor ctorName ctorArgs ) ) - |> ResultList.toResult + |> ListOfResults.liftAllErrors |> Result.mapError List.concat 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 _ -> Nothing ) - |> ResultList.toResult + |> ListOfResults.liftAllErrors |> Result.mapError List.concat @@ -556,7 +578,7 @@ mapDeclarationsToValue sourceFile expose decls = _ -> Nothing ) - |> ResultList.toResult + |> ListOfResults.liftAllErrors |> Result.mapError List.concat @@ -575,7 +597,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.liftAllErrors |> Result.mapError List.concat ) @@ -585,7 +607,7 @@ mapTypeAnnotation sourceFile (Node range typeAnnotation) = Tupled elemNodes -> elemNodes |> List.map (mapTypeAnnotation sourceFile) - |> ResultList.toResult + |> ListOfResults.liftAllErrors |> Result.map (Type.Tuple sourceLocation) |> Result.mapError List.concat @@ -597,7 +619,7 @@ mapTypeAnnotation sourceFile (Node range typeAnnotation) = mapTypeAnnotation sourceFile fieldTypeNode |> Result.map (Type.Field (fieldName |> Name.fromString)) ) - |> ResultList.toResult + |> ListOfResults.liftAllErrors |> Result.map (Type.Record sourceLocation) |> Result.mapError List.concat @@ -609,7 +631,7 @@ mapTypeAnnotation sourceFile (Node range typeAnnotation) = mapTypeAnnotation sourceFile fieldTypeNode |> Result.map (Type.Field (fieldName |> Name.fromString)) ) - |> ResultList.toResult + |> ListOfResults.liftAllErrors |> Result.map (Type.ExtensibleRecord sourceLocation (argName |> Name.fromString)) |> Result.mapError List.concat @@ -669,7 +691,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) @@ -702,87 +724,12 @@ mapExpression sourceFile (Node range exp) = in expNodes |> List.map (mapExpression sourceFile) - |> ResultList.toResult + |> ListOfResults.liftAllErrors |> Result.mapError List.concat |> 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 ] + Expression.OperatorApplication op _ leftNode rightNode -> + mapOperator sourceFile sourceLocation op leftNode rightNode Expression.FunctionOrValue moduleName valueName -> case ( moduleName, valueName ) of @@ -801,10 +748,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 -> @@ -829,7 +776,7 @@ mapExpression sourceFile (Node range exp) = Expression.TupledExpression expNodes -> expNodes |> List.map (mapExpression sourceFile) - |> ResultList.toResult + |> ListOfResults.liftAllErrors |> Result.mapError List.concat |> Result.map (Value.Tuple sourceLocation) @@ -837,268 +784,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) @@ -1110,7 +796,7 @@ mapExpression sourceFile (Node range exp) = (mapPattern sourceFile patternNode) (mapExpression sourceFile bodyNode) ) - |> ResultList.toResult + |> ListOfResults.liftAllErrors |> Result.mapError List.concat ) @@ -1137,14 +823,14 @@ mapExpression sourceFile (Node range exp) = mapExpression sourceFile fieldValue |> Result.map (Tuple.pair (fieldName |> Name.fromString)) ) - |> ResultList.toResult + |> ListOfResults.liftAllErrors |> Result.mapError List.concat |> Result.map (Value.Record sourceLocation) Expression.ListExpr itemNodes -> itemNodes |> List.map (mapExpression sourceFile) - |> ResultList.toResult + |> ListOfResults.liftAllErrors |> Result.mapError List.concat |> Result.map (Value.List sourceLocation) @@ -1166,7 +852,7 @@ mapExpression sourceFile (Node range exp) = mapExpression sourceFile fieldValue |> Result.map (Tuple.pair (fieldName |> Name.fromString)) ) - |> ResultList.toResult + |> ListOfResults.liftAllErrors |> Result.mapError List.concat |> Result.map (Value.UpdateRecord sourceLocation (targetVarNameNode |> Node.value |> Name.fromString |> Value.Variable sourceLocation)) @@ -1206,7 +892,7 @@ mapPattern sourceFile (Node range pattern) = Pattern.TuplePattern elemNodes -> elemNodes |> List.map (mapPattern sourceFile) - |> ResultList.toResult + |> ListOfResults.liftAllErrors |> Result.mapError List.concat |> Result.map (Value.TuplePattern sourceLocation) @@ -1251,7 +937,7 @@ mapPattern sourceFile (Node range pattern) = in argNodes |> List.map (mapPattern sourceFile) - |> ResultList.toResult + |> ListOfResults.liftAllErrors |> Result.mapError List.concat |> Result.map (Value.ConstructorPattern sourceLocation qualifiedName) @@ -1263,55 +949,604 @@ mapPattern sourceFile (Node range pattern) = mapPattern sourceFile childNode -resolveLocalNames : Path -> Path -> ModuleResolver -> Module.Definition SourceLocation -> Result Errors (Module.Definition SourceLocation) -resolveLocalNames packagePath modulePath moduleResolver moduleDef = +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" ] + ) + |> ListOfResults.liftAllErrors + |> 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 : ModuleResolver -> Module.Definition SourceLocation -> Result Errors (Module.Definition SourceLocation) +resolveLocalNames moduleResolver moduleDef = let - rewriteTypes : Type SourceLocation -> Result Error (Type SourceLocation) + rewriteTypes : Type SourceLocation -> Result Errors (Type SourceLocation) rewriteTypes = Rewrite.bottomUp Type.rewriteType (\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 ) - |> Result.mapError (ResolveError sourceLocation) + |> Result.mapError (ResolveError sourceLocation >> List.singleton) |> Just _ -> Nothing ) - rewriteValues = - identity + rewriteValues : Value SourceLocation -> Result Errors (Value SourceLocation) + rewriteValues value = + resolveVariablesAndReferences Dict.empty moduleResolver value in Module.mapDefinition rewriteTypes rewriteValues moduleDef + |> Result.mapError List.concat + + +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 = + 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 sourceLocation (FQName [] modulePath localName) -> + if variables |> Dict.member localName then + Ok (Value.Variable sourceLocation localName) + + else + 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 + |> Result.andThen + (\patternNames -> + unionVariableNames variables patternNames + ) + |> Result.andThen + (\newVariables -> + resolveVariablesAndReferences newVariables moduleResolver bodyValue + ) + |> Result.map (Value.Lambda a argPattern) + + Value.LetDefinition sourceLocation name def inValue -> + Result.map2 (Value.LetDefinition sourceLocation name) + (resolveVariablesAndReferences variables moduleResolver def.body + |> Result.map + (\resolvedBody -> + { def + | body = resolvedBody + } + ) + ) + (unionVariableNames variables (Dict.singleton name sourceLocation) + |> Result.andThen + (\newVariables -> + resolveVariablesAndReferences newVariables moduleResolver 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 ) -> + resolveVariablesAndReferences newVariables moduleResolver def.body + |> Result.map + (\resolvedBody -> + ( name + , { def + | body = resolvedBody + } + ) + ) + ) + |> ListOfResults.liftAllErrors + |> Result.mapError List.concat + |> Result.map Dict.fromList + ) + (resolveVariablesAndReferences newVariables moduleResolver inValue) + ) + + Value.Destructure a pattern subjectValue inValue -> + Result.map2 (Value.Destructure a pattern) + (resolveVariablesAndReferences variables moduleResolver subjectValue) + (namesBoundInPattern pattern + |> Result.andThen + (\patternNames -> + unionVariableNames variables patternNames + ) + |> Result.andThen + (\newVariables -> + resolveVariablesAndReferences newVariables moduleResolver inValue + ) + ) + + Value.PatternMatch a matchValue cases -> + Result.map2 (Value.PatternMatch a) + (resolveVariablesAndReferences variables moduleResolver matchValue) + (cases + |> List.map + (\( casePattern, caseValue ) -> + namesBoundInPattern casePattern + |> Result.andThen + (\patternNames -> + unionVariableNames variables patternNames + ) + |> Result.andThen + (\newVariables -> + resolveVariablesAndReferences newVariables moduleResolver caseValue + ) + |> Result.map (Tuple.pair casePattern) + ) + |> ListOfResults.liftAllErrors + |> Result.mapError List.concat + ) + + Value.Tuple a elems -> + elems + |> List.map (resolveVariablesAndReferences variables moduleResolver) + |> ListOfResults.liftAllErrors + |> Result.mapError List.concat + |> Result.map (Value.Tuple a) + + Value.List a items -> + items + |> List.map (resolveVariablesAndReferences variables moduleResolver) + |> ListOfResults.liftAllErrors + |> Result.mapError List.concat + |> Result.map (Value.List a) + + Value.Record a fields -> + fields + |> List.map + (\( fieldName, fieldValue ) -> + resolveVariablesAndReferences variables moduleResolver fieldValue + |> Result.map (Tuple.pair fieldName) + ) + |> ListOfResults.liftAllErrors + |> Result.mapError List.concat + |> Result.map (Value.Record a) + + Value.Field a subjectValue fieldName -> + resolveVariablesAndReferences variables moduleResolver subjectValue + |> Result.map (\s -> Value.Field a s fieldName) + + Value.Apply a funValue argValue -> + Result.map2 (Value.Apply a) + (resolveVariablesAndReferences variables moduleResolver funValue) + (resolveVariablesAndReferences variables moduleResolver argValue) + + Value.IfThenElse a condValue thenValue elseValue -> + Result.map3 (Value.IfThenElse a) + (resolveVariablesAndReferences variables moduleResolver condValue) + (resolveVariablesAndReferences variables moduleResolver thenValue) + (resolveVariablesAndReferences variables moduleResolver elseValue) + + Value.UpdateRecord a subjectValue newFieldValues -> + Result.map2 (Value.UpdateRecord a) + (resolveVariablesAndReferences variables moduleResolver subjectValue) + (newFieldValues + |> List.map + (\( fieldName, fieldValue ) -> + resolveVariablesAndReferences variables moduleResolver fieldValue + |> Result.map (Tuple.pair fieldName) + ) + |> ListOfResults.liftAllErrors + |> Result.mapError List.concat + ) + + _ -> + Ok value withAccessControl : Bool -> a -> AccessControlled a 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/src/Morphir/IR/Module.elm b/src/Morphir/IR/Module.elm index c3da58e71..19d2d6944 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 = @@ -88,7 +87,7 @@ eraseSpecificationAttributes spec = spec |> mapSpecification (Type.mapTypeAttributes (\_ -> ()) >> Ok) - (Value.mapValueAttributes (\_ -> ())) + (Value.mapValueAttributes (\_ -> ()) >> Ok) |> Result.withDefault emptySpecification @@ -121,7 +120,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)) @@ -134,7 +133,7 @@ mapSpecification mapType mapValue spec = |> Type.mapSpecification mapType |> Result.map (Tuple.pair typeName) ) - |> ResultList.toResult + |> ListOfResults.liftAllErrors |> 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.liftAllErrors |> Result.map Dict.fromList |> Result.mapError List.concat in @@ -157,7 +156,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))) @@ -171,7 +170,7 @@ mapDefinition mapType mapValue def = |> Result.map (AccessControlled typeDef.access) |> Result.map (Tuple.pair typeName) ) - |> ResultList.toResult + |> ListOfResults.liftAllErrors |> 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.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 bd9702dcd..b19dc3986 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 = @@ -76,7 +74,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)) @@ -89,7 +87,7 @@ mapSpecification mapType mapValue spec = |> Module.mapSpecification mapType mapValue |> Result.map (Tuple.pair modulePath) ) - |> ResultList.toResult + |> ListOfResults.liftAllErrors |> Result.map Dict.fromList |> Result.mapError List.concat in @@ -101,11 +99,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)) @@ -118,7 +116,7 @@ mapDefinition mapType mapValue def = |> mapSpecification mapType mapValue |> Result.map (Tuple.pair packagePath) ) - |> ResultList.toResult + |> ListOfResults.liftAllErrors |> 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.liftAllErrors |> Result.map Dict.fromList |> Result.mapError List.concat in @@ -147,7 +145,7 @@ eraseDefinitionAttributes def = def |> mapDefinition (Type.mapTypeAttributes (\_ -> ()) >> Ok) - (Value.mapValueAttributes (\_ -> ())) + (Value.mapValueAttributes (\_ -> ()) >> Ok) |> Result.withDefault emptyDefinition diff --git a/src/Morphir/IR/Type.elm b/src/Morphir/IR/Type.elm index 2a76398fb..4521d61bd 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.liftAllErrors |> Result.map (Constructor ctorName) ) - |> ResultList.toResult + |> ListOfResults.liftAllErrors |> Result.mapError List.concat in ctorsResult @@ -202,10 +202,10 @@ mapDefinition f def = f argType |> Result.map (Tuple.pair argName) ) - |> ResultList.toResult + |> ListOfResults.liftAllErrors |> Result.map (Constructor ctorName) ) - |> ResultList.toResult + |> 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 aac114a0c..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 ) @@ -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 @@ -134,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 @@ -163,7 +159,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 = @@ -173,7 +169,7 @@ mapSpecification mapType mapValue spec = mapType tpe |> Result.map (Tuple.pair name) ) - |> ResultList.toResult + |> ListOfResults.liftAllErrors outputResult = mapType spec.output @@ -184,20 +180,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.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 -> - UntypedDefinition args (mapValue body) - |> Ok + Nothing -> + Ok Nothing + ) + (mapValue def.body) + |> Result.mapError List.singleton mapValueAttributes : (a -> b) -> Value a -> Value b @@ -318,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) @@ -877,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. @@ -900,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 @@ -1434,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/src/Morphir/ListOfResults.elm b/src/Morphir/ListOfResults.elm new file mode 100644 index 000000000..6bd57f2fc --- /dev/null +++ b/src/Morphir/ListOfResults.elm @@ -0,0 +1,45 @@ +module Morphir.ListOfResults exposing (liftAllErrors, liftFirstError) + + +liftAllErrors : List (Result e a) -> Result (List e) (List a) +liftAllErrors 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 oks + + _ -> + 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 []) diff --git a/src/Morphir/ResultList.elm b/src/Morphir/ResultList.elm deleted file mode 100644 index 12e44eaa0..000000000 --- a/src/Morphir/ResultList.elm +++ /dev/null @@ -1,70 +0,0 @@ -module Morphir.ResultList exposing (liftLastError, reduce, toResult) - - -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 - - -toResult : List (Result e a) -> Result (List e) (List a) -toResult 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 oks - - _ -> - 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 9e9f372c3..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) @@ -20,7 +21,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 (..) @@ -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,26 +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 - ) - |> String.join ", " + Encode.encode 0 (Encode.list Frontend.encodeError errors) ) |> Result.andThen (\packageDef -> @@ -236,10 +237,14 @@ valueTests = ref : String -> Value () ref name = - Reference () (fQName [] [] [ name ]) + Reference () (fQName [] [ [ "test" ] ] [ 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" @@ -273,7 +278,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") @@ -311,7 +316,7 @@ valueTests = ) <| Destructure () - (TuplePattern () [ var "a", var "b" ]) + (TuplePattern () [ pvar "a", pvar "b" ]) (ref "c") (ref "d") , checkIR @@ -325,7 +330,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" @@ -338,11 +343,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 @@ -356,11 +361,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 @@ -375,11 +380,11 @@ valueTests = <| LetDefinition () (Name.fromString "b") - (UntypedDefinition [] (ref "c")) + (Definition Nothing [] (ref "c")) (LetDefinition () (Name.fromString "a") - (UntypedDefinition [] (ref "b")) - (ref "a") + (Definition Nothing [] (var "b")) + (var "a") ) , checkIR (String.join "\n" @@ -393,11 +398,11 @@ valueTests = <| LetDefinition () (Name.fromString "b") - (UntypedDefinition [] (ref "c")) + (Definition Nothing [] (ref "c")) (LetDefinition () (Name.fromString "a") - (UntypedDefinition [] (ref "b")) - (ref "a") + (Definition Nothing [] (var "b")) + (var "a") ) , checkIR (String.join "\n" @@ -411,11 +416,11 @@ valueTests = <| LetRecursion () (Dict.fromList - [ ( Name.fromString "b", UntypedDefinition [] (ref "a") ) - , ( Name.fromString "a", UntypedDefinition [] (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" @@ -429,14 +434,14 @@ 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 [] (var "a") ) + , ( Name.fromString "a", Definition Nothing [] (var "b") ) ] ) - (ref "a") + (var "a") ) ]