diff --git a/src/Morphir/Elm/Backend/Codec/Gen.elm b/src/Morphir/Elm/Backend/Codec/Gen.elm index c9b0a3dcc..c0910df03 100644 --- a/src/Morphir/Elm/Backend/Codec/Gen.elm +++ b/src/Morphir/Elm/Backend/Codec/Gen.elm @@ -6,8 +6,8 @@ import Elm.Syntax.ModuleName exposing (ModuleName) import Elm.Syntax.Node exposing (Node(..)) import Elm.Syntax.Pattern exposing (Pattern(..), QualifiedNameRef) import Elm.Syntax.Range exposing (emptyRange) -import Morphir.IR.AccessControlled exposing (AccessControlled(..)) -import Morphir.IR.Advanced.Type exposing (Constructor, Definition(..), Field(..), Type(..), field, record) +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) @@ -36,77 +36,91 @@ typeDefToEncoder e typeName typeDef = args : List (Node Pattern) args = - case typeDef of - Public (CustomTypeDefinition _ (Public constructors)) -> - case constructors of - [] -> - [] - - ( ctorName, fields ) :: [] -> - [ deconsPattern ctorName fields - |> emptyRangeNode - |> ParenthesizedPattern - |> emptyRangeNode - ] - - _ -> + case typeDef.access of + Public -> + case typeDef.value of + CustomTypeDefinition _ constructors -> + case constructors.access of + Public -> + case constructors.value of + [] -> + [] + + ( ctorName, fields ) :: [] -> + [ deconsPattern ctorName fields + |> emptyRangeNode + |> ParenthesizedPattern + |> emptyRangeNode + ] + + _ -> + [ typeName |> Name.toCamelCase |> VarPattern |> emptyRangeNode ] + + Private -> + [] + + TypeAliasDefinition _ _ -> [ typeName |> Name.toCamelCase |> VarPattern |> emptyRangeNode ] - Public (TypeAliasDefinition _ _) -> - [ typeName |> Name.toCamelCase |> VarPattern |> emptyRangeNode ] - - _ -> + Private -> [] funcExpr : Expression funcExpr = - case typeDef of - Public (CustomTypeDefinition _ (Public constructors)) -> - case constructors of - [] -> - Literal "Types without constructors are not supported" - - ctor :: [] -> - ctor - |> constructorToRecord e - |> typeToEncoder False [ Tuple.first ctor ] - - ctors -> - let - caseValExpr : Node Expression - caseValExpr = - typeName - |> Name.toCamelCase - |> FunctionOrValue [] - |> emptyRangeNode - - cases : List ( Node Pattern, Node Expression ) - cases = - let - ctorToPatternExpr : Constructor extra -> ( Node Pattern, Node Expression ) - ctorToPatternExpr ctor = + case typeDef.access of + Public -> + case typeDef.value of + CustomTypeDefinition _ constructors -> + case constructors.access of + Public -> + case constructors.value of + [] -> + Literal "Types without constructors are not supported" + + ctor :: [] -> + ctor + |> constructorToRecord e + |> typeToEncoder False [ Tuple.first ctor ] + + ctors -> let - pattern : Pattern - pattern = - deconsPattern (Tuple.first ctor) (Tuple.second ctor) - - expr : Expression - expr = - ctor - |> constructorToRecord e - |> typeToEncoder True [ Tuple.first ctor ] - |> customTypeTopExpr + caseValExpr : Node Expression + caseValExpr = + typeName + |> Name.toCamelCase + |> FunctionOrValue [] + |> emptyRangeNode + + cases : List ( Node Pattern, Node Expression ) + cases = + let + ctorToPatternExpr : Constructor extra -> ( Node Pattern, Node Expression ) + ctorToPatternExpr ctor = + let + pattern : Pattern + pattern = + deconsPattern (Tuple.first ctor) (Tuple.second ctor) + + expr : Expression + expr = + ctor + |> constructorToRecord e + |> typeToEncoder True [ Tuple.first ctor ] + |> customTypeTopExpr + in + ( emptyRangeNode pattern, emptyRangeNode expr ) + in + ctors |> List.map ctorToPatternExpr in - ( emptyRangeNode pattern, emptyRangeNode expr ) - in - ctors |> List.map ctorToPatternExpr - in - CaseExpression { expression = caseValExpr, cases = cases } + CaseExpression { expression = caseValExpr, cases = cases } + + Private -> + Literal "Private constructors are not supported" - Public (TypeAliasDefinition _ tpe) -> - typeToEncoder True [ typeName ] tpe + TypeAliasDefinition _ tpe -> + typeToEncoder True [ typeName ] tpe - _ -> + Private -> Literal "Private types are not supported" in FunctionDeclaration function @@ -193,10 +207,10 @@ typeToEncoder fwdNames varName tpe = [ name ] fieldEncoder : Field extra -> Expression - fieldEncoder (Field name fieldType) = + fieldEncoder field = TupledExpression - [ name |> Name.toCamelCase |> Literal |> emptyRangeNode - , typeToEncoder fwdNames (namesToFwd name) fieldType |> emptyRangeNode + [ field.name |> Name.toCamelCase |> Literal |> emptyRangeNode + , typeToEncoder fwdNames (namesToFwd field.name) field.tpe |> emptyRangeNode ] in elmJsonEncoderApplication @@ -268,7 +282,7 @@ constructorToRecord e ( _, types ) = fields : List (Morphir.IR.Advanced.Type.Field extra) fields = types - |> List.map (\t -> field (Tuple.first t) (Tuple.second t)) + |> List.map (\t -> Field (Tuple.first t) (Tuple.second t)) in record fields e diff --git a/src/Morphir/Elm/Frontend.elm b/src/Morphir/Elm/Frontend.elm index d7d049861..abf3df485 100644 --- a/src/Morphir/Elm/Frontend.elm +++ b/src/Morphir/Elm/Frontend.elm @@ -20,7 +20,7 @@ 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) +import Morphir.IR.FQName as FQName exposing (FQName, fQName) import Morphir.IR.Name as Name exposing (Name) import Morphir.IR.Path as Path exposing (Path) import Morphir.ResultList as ResultList @@ -255,7 +255,7 @@ mapProcessedFile currentPackagePath processedFile modulesSoFar = valuesResult in moduleResult - |> Result.andThen (resolveLocalTypes currentPackagePath modulePath) + |> Result.andThen (resolveLocalTypes currentPackagePath modulePath moduleResolver) |> Result.map (\m -> modulesSoFar @@ -444,7 +444,7 @@ mapTypeAnnotation sourceFile (Node range typeAnnotation) = |> List.map (\( Node _ fieldName, fieldTypeNode ) -> mapTypeAnnotation sourceFile fieldTypeNode - |> Result.map (Type.field (fieldName |> Name.fromString)) + |> Result.map (Type.Field (fieldName |> Name.fromString)) ) |> ResultList.toResult |> Result.map @@ -459,7 +459,7 @@ mapTypeAnnotation sourceFile (Node range typeAnnotation) = |> List.map (\( Node _ fieldName, fieldTypeNode ) -> mapTypeAnnotation sourceFile fieldTypeNode - |> Result.map (Type.field (fieldName |> Name.fromString)) + |> Result.map (Type.Field (fieldName |> Name.fromString)) ) |> ResultList.toResult |> Result.map @@ -477,25 +477,46 @@ mapTypeAnnotation sourceFile (Node range typeAnnotation) = (mapTypeAnnotation sourceFile returnTypeNode) -resolveLocalTypes : Path -> Path -> Module.Definition SourceLocation -> Result Errors (Module.Definition SourceLocation) -resolveLocalTypes packagePath modulePath moduleDef = +resolveLocalTypes : Path -> Path -> ModuleResolver -> Module.Definition SourceLocation -> Result Errors (Module.Definition SourceLocation) +resolveLocalTypes packagePath modulePath moduleResolver moduleDef = let + rewriteTypes : Type SourceLocation -> Result Error (Type SourceLocation) rewriteTypes = Rewrite.bottomUp Type.rewriteType (\tpe -> case tpe of - Type.Reference fullName args sourceLocation -> + Type.Reference refFullName args sourceLocation -> let - localName = - fullName + 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 - moduleDef.types - |> Dict.get localName - |> Maybe.map - (\_ -> - Type.Reference (fQName packagePath modulePath localName) args sourceLocation + resolvedFullNameResult + |> Result.map + (\resolvedFullName -> + Type.Reference resolvedFullName args sourceLocation ) + |> Result.mapError ResolveError + |> Just _ -> Nothing @@ -504,9 +525,7 @@ resolveLocalTypes packagePath modulePath moduleDef = rewriteValues = identity in - moduleDef - |> Module.mapDefinition rewriteTypes rewriteValues - |> Ok + Module.mapDefinition rewriteTypes rewriteValues moduleDef withAccessControl : Bool -> a -> AccessControlled a diff --git a/src/Morphir/Elm/Frontend/Resolve.elm b/src/Morphir/Elm/Frontend/Resolve.elm index 0dc570558..cb4fe38a6 100644 --- a/src/Morphir/Elm/Frontend/Resolve.elm +++ b/src/Morphir/Elm/Frontend/Resolve.elm @@ -1,4 +1,4 @@ -module Morphir.Elm.Frontend.Resolve exposing (Error, ModuleResolver, PackageResolver, createModuleResolver, createPackageResolver) +module Morphir.Elm.Frontend.Resolve exposing (Error(..), ModuleResolver, PackageResolver, createModuleResolver, createPackageResolver) import Dict exposing (Dict) import Elm.Syntax.Exposing exposing (Exposing(..), TopLevelExpose(..)) @@ -31,6 +31,7 @@ type Error | CouldNotFindPackage Path | ModuleNotImported ModuleName | AliasNotFound String + | PackageNotPrefixOfModule Path Path type alias ModuleResolver = diff --git a/src/Morphir/IR/AccessControlled.elm b/src/Morphir/IR/AccessControlled.elm index bbbcb6003..d46b1efc8 100644 --- a/src/Morphir/IR/AccessControlled.elm +++ b/src/Morphir/IR/AccessControlled.elm @@ -1,9 +1,9 @@ module Morphir.IR.AccessControlled exposing - ( AccessControlled(..) + ( AccessControlled , public, private , withPublicAccess, withPrivateAccess , decodeAccessControlled, encodeAccessControlled - , map + , Access(..), map ) {-| Module to manage access to a node in the IR. This is only used to declare access levels @@ -36,23 +36,29 @@ import Json.Encode as Encode {-| Type that represents different access levels. -} -type AccessControlled a - = Public a - | Private a +type alias AccessControlled a = + { access : Access + , value : a + } + + +type Access + = Public + | Private {-| Mark a node as public access. Actors with both public and private access are allowed to see. -} public : a -> AccessControlled a public value = - Public value + AccessControlled Public value {-| Mark a node as private access. Only actors with private access level can see. -} private : a -> AccessControlled a private value = - Private value + AccessControlled Private value {-| Get the value with public access level. Will return `Nothing` if the value is private. @@ -64,11 +70,11 @@ private value = -} withPublicAccess : AccessControlled a -> Maybe a withPublicAccess ac = - case ac of - Public a -> - Just a + case ac.access of + Public -> + Just ac.value - Private a -> + Private -> Nothing @@ -81,39 +87,34 @@ withPublicAccess ac = -} withPrivateAccess : AccessControlled a -> a withPrivateAccess ac = - case ac of - Public a -> - a + case ac.access of + Public -> + ac.value - Private a -> - a + Private -> + ac.value map : (a -> b) -> AccessControlled a -> AccessControlled b map f ac = - case ac of - Public a -> - Public (f a) - - Private a -> - Private (f a) + AccessControlled ac.access (f ac.value) {-| Encode AccessControlled to JSON. -} encodeAccessControlled : (a -> Encode.Value) -> AccessControlled a -> Encode.Value encodeAccessControlled encodeValue ac = - case ac of - Public value -> + case ac.access of + Public -> Encode.object [ ( "$type", Encode.string "public" ) - , ( "value", encodeValue value ) + , ( "value", encodeValue ac.value ) ] - Private value -> + Private -> Encode.object [ ( "$type", Encode.string "private" ) - , ( "value", encodeValue value ) + , ( "value", encodeValue ac.value ) ] @@ -126,11 +127,11 @@ decodeAccessControlled decodeValue = (\tag -> case tag of "public" -> - Decode.map Public + Decode.map (AccessControlled Public) (Decode.field "value" decodeValue) "private" -> - Decode.map Private + Decode.map (AccessControlled Private) (Decode.field "value" decodeValue) other -> diff --git a/src/Morphir/IR/Advanced/Module.elm b/src/Morphir/IR/Advanced/Module.elm index 0d060b1ce..b37ddcf69 100644 --- a/src/Morphir/IR/Advanced/Module.elm +++ b/src/Morphir/IR/Advanced/Module.elm @@ -19,6 +19,7 @@ import Morphir.IR.AccessControlled as AccessControlled exposing (AccessControlle 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 declaration. @@ -99,31 +100,78 @@ encodeDeclaration encodeExtra decl = ] -mapDeclaration : (Type a -> Type b) -> (Value a -> Value b) -> Declaration a -> Declaration b +mapDeclaration : (Type a -> Result e (Type b)) -> (Value a -> Value b) -> Declaration a -> Result (List e) (Declaration b) mapDeclaration mapType mapValue decl = - { types = - decl.types - |> Dict.map (\_ typeDecl -> Type.mapDeclaration mapType typeDecl) - , values = - decl.values - |> Dict.map (\_ valueDecl -> Value.mapDeclaration mapType mapValue valueDecl) - } + let + typesResult : Result (List e) (Dict Name (Type.Declaration b)) + typesResult = + decl.types + |> Dict.toList + |> List.map + (\( typeName, typeDecl ) -> + typeDecl + |> Type.mapDeclaration 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 = + decl.values + |> Dict.toList + |> List.map + (\( valueName, valueDecl ) -> + valueDecl + |> Value.mapDeclaration mapType mapValue + |> Result.map (Tuple.pair valueName) + ) + |> ResultList.toResult + |> Result.map Dict.fromList + |> Result.mapError List.concat + in + Result.map2 Declaration + typesResult + valuesResult -mapDefinition : (Type a -> Type b) -> (Value a -> Value b) -> Definition a -> Definition b + +mapDefinition : (Type a -> Result e (Type b)) -> (Value a -> Value b) -> Definition a -> Result (List e) (Definition b) mapDefinition mapType mapValue def = - { types = - def.types - |> Dict.map - (\_ ac -> - ac - |> AccessControlled.map - (Type.mapDefinition mapType) - ) - , values = - def.values - |> Dict.map (\_ ac -> ac |> AccessControlled.map (Value.mapDefinition mapType mapValue)) - } + 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 {-| -} diff --git a/src/Morphir/IR/Advanced/Package.elm b/src/Morphir/IR/Advanced/Package.elm index 2b155592e..958cfd473 100644 --- a/src/Morphir/IR/Advanced/Package.elm +++ b/src/Morphir/IR/Advanced/Package.elm @@ -21,6 +21,7 @@ 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 declaration. @@ -30,6 +31,12 @@ type alias Declaration extra = } +emptyDeclaration : Declaration extra +emptyDeclaration = + { modules = Dict.empty + } + + {-| Type that represents a package definition. -} type alias Definition extra = @@ -65,37 +72,79 @@ definitionToDeclaration def = } -mapDeclaration : (Type a -> Type b) -> (Value a -> Value b) -> Declaration a -> Declaration b +mapDeclaration : (Type a -> Result e (Type b)) -> (Value a -> Value b) -> Declaration a -> Result (List e) (Declaration b) mapDeclaration mapType mapValue decl = - { modules = - decl.modules - |> Dict.map (\_ moduleDecl -> Module.mapDeclaration mapType mapValue moduleDecl) - } + let + modulesResult : Result (List e) (Dict Path (Module.Declaration b)) + modulesResult = + decl.modules + |> Dict.toList + |> List.map + (\( modulePath, moduleDecl ) -> + moduleDecl + |> Module.mapDeclaration mapType mapValue + |> Result.map (Tuple.pair modulePath) + ) + |> ResultList.toResult + |> Result.map Dict.fromList + |> Result.mapError List.concat + in + Result.map Declaration modulesResult eraseDeclarationExtra : Declaration a -> Declaration () -eraseDeclarationExtra = - mapDeclaration - (Type.mapTypeExtra (\_ -> ())) - (Value.mapValueExtra (\_ -> ())) +eraseDeclarationExtra decl = + decl + |> mapDeclaration + (Type.mapTypeExtra (\_ -> ()) >> Ok) + (Value.mapValueExtra (\_ -> ())) + |> Result.withDefault emptyDeclaration -mapDefinition : (Type a -> Type b) -> (Value a -> Value b) -> Definition a -> Definition b +mapDefinition : (Type a -> Result e (Type b)) -> (Value a -> Value b) -> Definition a -> Result (List e) (Definition b) mapDefinition mapType mapValue def = - { dependencies = - def.dependencies - |> Dict.map (\_ packageDecl -> mapDeclaration mapType mapValue packageDecl) - , modules = - def.modules - |> Dict.map (\_ ac -> ac |> AccessControlled.map (Module.mapDefinition mapType mapValue)) - } + let + dependenciesResult : Result (List e) (Dict Path (Declaration b)) + dependenciesResult = + def.dependencies + |> Dict.toList + |> List.map + (\( packagePath, packageDecl ) -> + packageDecl + |> mapDeclaration 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 = - mapDefinition - (Type.mapTypeExtra (\_ -> ())) - (Value.mapValueExtra (\_ -> ())) +eraseDefinitionExtra def = + def + |> mapDefinition + (Type.mapTypeExtra (\_ -> ()) >> Ok) + (Value.mapValueExtra (\_ -> ())) + |> Result.withDefault emptyDefinition encodeDeclaration : (extra -> Encode.Value) -> Declaration extra -> Encode.Value diff --git a/src/Morphir/IR/Advanced/Type.elm b/src/Morphir/IR/Advanced/Type.elm index adcf627eb..83211aca6 100644 --- a/src/Morphir/IR/Advanced/Type.elm +++ b/src/Morphir/IR/Advanced/Type.elm @@ -2,7 +2,7 @@ module Morphir.IR.Advanced.Type exposing ( Type(..) , variable, reference, tuple, record, extensibleRecord, function, unit , matchVariable, matchReference, matchTuple, matchRecord, matchExtensibleRecord, matchFunction, matchUnit - , Field(..), field, matchField, mapFieldName, mapFieldType + , Field, matchField, mapFieldName, mapFieldType , Declaration, typeAliasDeclaration, opaqueTypeDeclaration, customTypeDeclaration, matchCustomTypeDeclaration , Definition(..), typeAliasDefinition, customTypeDefinition , Constructors @@ -31,7 +31,7 @@ module Morphir.IR.Advanced.Type exposing # Record Field -@docs Field, field, matchField, mapFieldName, mapFieldType +@docs Field, matchField, mapFieldName, mapFieldType # Declaration @@ -67,6 +67,7 @@ import Morphir.IR.AccessControlled as AccessControlled exposing (AccessControlle 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) @@ -94,8 +95,10 @@ type Type extra {-| An opaque representation of a field. It's made up of a name and a type. -} -type Field extra - = Field Name (Type extra) +type alias Field extra = + { name : Name + , tpe : Type extra + } {-| -} @@ -144,55 +147,71 @@ definitionToDeclaration def = OpaqueTypeDeclaration params -mapDeclaration : (Type a -> Type b) -> Declaration a -> Declaration b +mapDeclaration : (Type a -> Result e (Type b)) -> Declaration a -> Result (List e) (Declaration b) mapDeclaration f decl = case decl of TypeAliasDeclaration params tpe -> - TypeAliasDeclaration params (f tpe) + f tpe + |> Result.map (TypeAliasDeclaration params) + |> Result.mapError List.singleton OpaqueTypeDeclaration params -> OpaqueTypeDeclaration params - - CustomTypeDeclaration params ctors -> - CustomTypeDeclaration params - (ctors - |> List.map - (\( name, args ) -> - ( name - , args - |> List.map - (\( argName, argType ) -> - ( argName, f argType ) - ) + |> Ok + + CustomTypeDeclaration 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 (CustomTypeDeclaration params) -mapDefinition : (Type a -> Type b) -> Definition a -> Definition b +mapDefinition : (Type a -> Result e (Type b)) -> Definition a -> Result (List e) (Definition b) mapDefinition f def = case def of TypeAliasDefinition params tpe -> - TypeAliasDefinition params (f tpe) - - CustomTypeDefinition params ac -> - CustomTypeDefinition params - (ac - |> AccessControlled.map - (\ctors -> - ctors - |> List.map - (\( name, args ) -> - ( name - , args - |> List.map - (\( argName, argType ) -> - ( argName, f argType ) - ) + 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 @@ -533,39 +552,78 @@ matchCustomTypeDeclaration matchTypeParams matchCtors declToMatch = Nothing -rewriteType : Rewrite (Type extra) +rewriteType : Rewrite e (Type extra) rewriteType rewriteBranch rewriteLeaf typeToRewrite = case typeToRewrite of Reference fQName argTypes extra -> - Reference fQName (argTypes |> List.map rewriteBranch) extra + argTypes + |> List.foldr + (\nextArg resultSoFar -> + Result.map2 (::) + (rewriteBranch nextArg) + resultSoFar + ) + (Ok []) + |> Result.map + (\args -> + Reference fQName args extra + ) Tuple elemTypes extra -> - Tuple (elemTypes |> List.map rewriteBranch) extra - - Record fields extra -> - Record (fields |> List.map (mapFieldType rewriteBranch)) extra + elemTypes + |> List.foldr + (\nextArg resultSoFar -> + Result.map2 (::) + (rewriteBranch nextArg) + resultSoFar + ) + (Ok []) + |> Result.map + (\elems -> + Tuple elems extra + ) - ExtensibleRecord varName fields extra -> - ExtensibleRecord varName (fields |> List.map (mapFieldType rewriteBranch)) 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 -> - Function (argType |> rewriteBranch) (returnType |> rewriteBranch) extra + Result.map2 (\arg return -> Function arg return extra) + (rewriteBranch argType) + (rewriteBranch returnType) _ -> rewriteLeaf typeToRewrite -{-| Creates a field. - - toIR { foo = Int } - == record [ field [ "foo" ] SDK.Basics.intType ] - --} -field : Name -> Type extra -> Field extra -field fieldName fieldType = - Field fieldName fieldType - - {-| Matches a field. let @@ -580,24 +638,24 @@ field fieldName fieldType = -} matchField : Pattern Name a -> Pattern (Type extra) b -> Pattern (Field extra) ( a, b ) -matchField matchFieldName matchFieldType (Field fieldName fieldType) = +matchField matchFieldName matchFieldType field = Maybe.map2 Tuple.pair - (matchFieldName fieldName) - (matchFieldType fieldType) + (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 name tpe) = - Field (f name) tpe +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 name tpe) = - Field name (f tpe) +mapFieldType f field = + Field field.name (f field.tpe) {-| Generate random types. @@ -797,10 +855,10 @@ decodeType decodeExtra = encodeField : (extra -> Encode.Value) -> Field extra -> Encode.Value -encodeField encodeExtra (Field fieldName fieldType) = +encodeField encodeExtra field = Encode.list identity - [ encodeName fieldName - , encodeType encodeExtra fieldType + [ encodeName field.name + , encodeType encodeExtra field.tpe ] diff --git a/src/Morphir/IR/Advanced/Value.elm b/src/Morphir/IR/Advanced/Value.elm index f4b48cea8..80b9207c6 100644 --- a/src/Morphir/IR/Advanced/Value.elm +++ b/src/Morphir/IR/Advanced/Value.elm @@ -70,6 +70,7 @@ 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 @@ -150,27 +151,41 @@ type Definition extra -- in -mapDeclaration : (Type a -> Type b) -> (Value a -> Value b) -> Declaration a -> Declaration b +mapDeclaration : (Type a -> Result e (Type b)) -> (Value a -> Value b) -> Declaration a -> Result (List e) (Declaration b) mapDeclaration mapType mapValue decl = - { inputs = - decl.inputs - |> List.map - (\( name, tpe ) -> - ( name, mapType tpe ) - ) - , output = - mapType decl.output - } + let + inputsResult = + decl.inputs + |> List.map + (\( name, tpe ) -> + mapType tpe + |> Result.map (Tuple.pair name) + ) + |> ResultList.toResult + + outputResult = + mapType decl.output + |> Result.mapError List.singleton + in + Result.map2 Declaration + inputsResult + outputResult -mapDefinition : (Type a -> Type b) -> (Value a -> Value b) -> Definition a -> Definition b +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 -> - TypedDefinition (mapType tpe) args (mapValue 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 diff --git a/src/Morphir/Rewrite.elm b/src/Morphir/Rewrite.elm index a4b85d98c..6c79cbb0c 100644 --- a/src/Morphir/Rewrite.elm +++ b/src/Morphir/Rewrite.elm @@ -14,8 +14,8 @@ import Morphir.Rule as Rule exposing (Rule) tree node. It takes two functions as input: a mapping that's applied to the children of branch nodes and one that is applied to leaf nodes. -} -type alias Rewrite a = - (a -> a) -> (a -> a) -> a -> a +type alias Rewrite e a = + (a -> Result e a) -> (a -> Result e a) -> a -> Result e a {-| Executes a rewrite using a top-down approach where the rules are @@ -23,15 +23,17 @@ applied to nodes from the root towards the leaf nodes. When a rule does not match the rewrite continues downward. When a rule matches it's applied and the rewrite process stops traversing downward in the subtree. -} -topDown : Rewrite a -> Rule a -> a -> a -topDown rewrite rewriteRule typeToRewrite = - rewriteRule typeToRewrite - |> Maybe.withDefault - (rewrite +topDown : Rewrite e a -> Rule e a -> a -> Result e a +topDown rewrite rewriteRule nodeToRewrite = + case rewriteRule nodeToRewrite of + Nothing -> + rewrite (topDown rewrite rewriteRule) - identity - typeToRewrite - ) + (\a -> Ok a) + nodeToRewrite + + Just result -> + result {-| Executes a rewrite using a bottom-up approach where the rules are @@ -39,14 +41,22 @@ applied to nodes from the leaf nodes towards the root. Always traverses the entire tree regardless of rule matches but only changes the tree if a rule matches. -} -bottomUp : Rewrite a -> Rule a -> a -> a -bottomUp rewrite rewriteRule typeToRewrite = +bottomUp : Rewrite e a -> Rule e a -> a -> Result e a +bottomUp rewrite rewriteRule nodeToRewrite = let + top : Result e a top = rewrite (\a -> bottomUp rewrite rewriteRule a) (Rule.defaultToOriginal rewriteRule) - typeToRewrite + nodeToRewrite in - rewriteRule top - |> Maybe.withDefault top + case top |> Result.map rewriteRule of + Ok Nothing -> + top + + Ok (Just result) -> + result + + Err error -> + Err error diff --git a/src/Morphir/Rule.elm b/src/Morphir/Rule.elm index 08c0f1fc0..01cec0f53 100644 --- a/src/Morphir/Rule.elm +++ b/src/Morphir/Rule.elm @@ -24,8 +24,8 @@ import Morphir.Pattern exposing (Pattern) {-| Type that represents a rewrite rule which is a pattern that maps back to the same type. -} -type alias Rule a = - Pattern a a +type alias Rule e a = + Pattern a (Result e a) {-| Chains two rules together. @@ -46,10 +46,14 @@ type alias Rule a = rule 2 == Nothing -- rule1 does not match -} -andThen : (a -> Rule a) -> Rule a -> Rule a +andThen : (a -> Rule e a) -> Rule e a -> Rule e a andThen f rule a = - rule a - |> Maybe.andThen (f a) + case rule a of + Just (Ok firstRuleOut) -> + f firstRuleOut a + + other -> + other {-| Turns a rule into a function that will return the original value when the rule doesn't match. @@ -67,7 +71,11 @@ andThen f rule a = fun 13 == 13 -- rule doesn't match, original value returned -} -defaultToOriginal : Rule a -> a -> a +defaultToOriginal : Rule e a -> a -> Result e a defaultToOriginal rule a = - rule a - |> Maybe.withDefault a + case rule a of + Nothing -> + Ok a + + Just result -> + result diff --git a/tests/Morphir/Elm/FrontendTests.elm b/tests/Morphir/Elm/FrontendTests.elm index 734ca7bf0..7e51793f6 100644 --- a/tests/Morphir/Elm/FrontendTests.elm +++ b/tests/Morphir/Elm/FrontendTests.elm @@ -16,12 +16,14 @@ frontendTest : Test frontendTest = let sourceA = - { path = "A.elm" + { path = "My/Package/A.elm" , content = unindent """ -module A exposing (..) +module My.Package.A exposing (..) -type Foo = Foo Int +import My.Package.B exposing (Bee) + +type Foo = Foo Bee type alias Bar = Foo @@ -33,10 +35,12 @@ type alias Rec = } sourceB = - { path = "B.elm" + { path = "My/Package/B.elm" , content = unindent """ -module B exposing (..) +module My.Package.B exposing (..) + +type Bee = Bee """ } @@ -44,7 +48,10 @@ module B exposing (..) Path.fromString "my/package" moduleA = - Path.fromString "A" + Path.fromString "My.Package.A" + + moduleB = + Path.fromString "My.Package.B" packageInfo = { name = @@ -60,14 +67,14 @@ module B exposing (..) { dependencies = Dict.empty , modules = Dict.fromList - [ ( [ [ "a" ] ] + [ ( moduleA , public { types = Dict.fromList [ ( [ "bar" ] , public (Type.typeAliasDefinition [] - (Type.reference (fQName packageName moduleA [ "foo" ]) [] ()) + (Type.reference (fQName packageName [ [ "a" ] ] [ "foo" ]) [] ()) ) ) , ( [ "foo" ] @@ -75,7 +82,7 @@ module B exposing (..) (Type.customTypeDefinition [] (public [ ( [ "foo" ] - , [ ( [ "arg", "1" ], Type.reference (fQName [] [] [ "int" ]) [] () ) + , [ ( [ "arg", "1" ], Type.reference (fQName packageName [ [ "b" ] ] [ "bee" ]) [] () ) ] ) ] @@ -86,10 +93,10 @@ module B exposing (..) , public (Type.typeAliasDefinition [] (Type.record - [ Type.field [ "field", "1" ] - (Type.reference (fQName packageName moduleA [ "foo" ]) [] ()) - , Type.field [ "field", "2" ] - (Type.reference (fQName packageName moduleA [ "bar" ]) [] ()) + [ Type.Field [ "field", "1" ] + (Type.reference (fQName packageName [ [ "a" ] ] [ "foo" ]) [] ()) + , Type.Field [ "field", "2" ] + (Type.reference (fQName packageName [ [ "a" ] ] [ "bar" ]) [] ()) ] () ) @@ -100,10 +107,17 @@ module B exposing (..) Dict.empty } ) - , ( [ [ "b" ] ] + , ( moduleB , private { types = - Dict.empty + Dict.fromList + [ ( [ "bee" ] + , public + (Type.customTypeDefinition [] + (public [ ( [ "bee" ], [] ) ]) + ) + ) + ] , values = Dict.empty }