diff --git a/elm.json b/elm.json index 3b01c978b..31757ddd1 100644 --- a/elm.json +++ b/elm.json @@ -5,7 +5,14 @@ "license": "Apache-2.0", "version": "1.0.0", "exposed-modules": [ - "Morphir.SDK.StatefulApp" + "Morphir.SDK.StatefulApp", + "Morphir.IR.Name", + "Morphir.IR.Path", + "Morphir.IR.QName", + "Morphir.IR.FQName", + "Morphir.IR.AccessControlled", + "Morphir.IR.Type", + "Morphir.IR.Value" ], "elm-version": "0.19.0 <= v < 0.20.0", "dependencies": { diff --git a/morphir.json b/morphir.json index a1524892c..edc857f79 100644 --- a/morphir.json +++ b/morphir.json @@ -2,7 +2,14 @@ "name": "Morphir", "sourceDirectory": "src", "exposedModules": [ - "IR.Advanced.Type", - "IR.Advanced.Value" + "IR.Name", + "IR.Path", + "IR.QName", + "IR.FQName", + "IR.AccessControlled", + "IR.Type", + "IR.Value", + "IR.Module", + "IR.Package" ] } \ No newline at end of file diff --git a/package.json b/package.json index 86c2695b8..f93f95bb3 100644 --- a/package.json +++ b/package.json @@ -4,7 +4,8 @@ "description": "Elm bindings for Morphir", "scripts": { "test": "elm-test", - "make-cli": "cd cli && elm make src/Morphir/Elm/CLI.elm --output Morphir.Elm.CLI.js --optimize && elm make src/Morphir/Elm/DaprCLI.elm --output Morphir.Elm.DaprCLI.js --optimize" + "make-cli": "cd cli && elm make src/Morphir/Elm/CLI.elm --output Morphir.Elm.CLI.js --optimize && elm make src/Morphir/Elm/DaprCLI.elm --output Morphir.Elm.DaprCLI.js --optimize", + "make-cli-dev": "cd cli && elm make src/Morphir/Elm/CLI.elm --output Morphir.Elm.CLI.js && elm make src/Morphir/Elm/DaprCLI.elm --output Morphir.Elm.DaprCLI.js" }, "repository": { "type": "git", diff --git a/src/Morphir/Elm/Frontend.elm b/src/Morphir/Elm/Frontend.elm index ce9ca52f8..4ffaae826 100644 --- a/src/Morphir/Elm/Frontend.elm +++ b/src/Morphir/Elm/Frontend.elm @@ -22,7 +22,8 @@ import Morphir.Graph import Morphir.IR.AccessControlled exposing (AccessControlled, private, public) import Morphir.IR.FQName as FQName exposing (FQName(..), fQName) import Morphir.IR.Module as Module -import Morphir.IR.Name as Name exposing (Name, encodeName) +import Morphir.IR.Name as Name exposing (Name) +import Morphir.IR.Name.Codec exposing (encodeName) import Morphir.IR.Package as Package import Morphir.IR.Path as Path exposing (Path) import Morphir.IR.QName as QName @@ -37,6 +38,7 @@ import Morphir.IR.SDK.Int as Int import Morphir.IR.SDK.List as List import Morphir.IR.SDK.Number as Number import Morphir.IR.Type as Type exposing (Type) +import Morphir.IR.Type.Rewrite exposing (rewriteType) import Morphir.IR.Value as Value exposing (Value) import Morphir.JsonExtra as JsonExtra import Morphir.ListOfResults as ListOfResults @@ -657,16 +659,16 @@ mapFunctionImplementation sourceFile argumentNodes expression = sourceLocation range = range |> SourceLocation sourceFile - extractNamedParams : List Name -> List (Node Pattern) -> ( List Name, List (Node Pattern) ) + extractNamedParams : List ( Name, SourceLocation ) -> List (Node Pattern) -> ( List ( Name, SourceLocation ), List (Node Pattern) ) extractNamedParams namedParams patternParams = case patternParams of [] -> ( namedParams, patternParams ) - (Node _ firstParam) :: restOfParams -> + (Node range firstParam) :: restOfParams -> case firstParam of VarPattern paramName -> - extractNamedParams (namedParams ++ [ Name.fromString paramName ]) restOfParams + extractNamedParams (namedParams ++ [ ( Name.fromString paramName, range |> SourceLocation sourceFile ) ]) restOfParams _ -> ( namedParams, patternParams ) @@ -729,18 +731,45 @@ mapExpression sourceFile (Node range exp) = |> Result.andThen (List.reverse >> toApply) Expression.OperatorApplication op _ leftNode rightNode -> - mapOperator sourceFile sourceLocation op leftNode rightNode + case op of + "<|" -> + -- the purpose of this operator is cleaner syntax so it's not mapped to the IR + Result.map2 (Value.Apply sourceLocation) + (mapExpression sourceFile leftNode) + (mapExpression sourceFile rightNode) + + "|>" -> + -- the purpose of this operator is cleaner syntax so it's not mapped to the IR + Result.map2 (Value.Apply sourceLocation) + (mapExpression sourceFile rightNode) + (mapExpression sourceFile leftNode) - Expression.FunctionOrValue moduleName valueName -> - case ( moduleName, valueName ) of - ( [], "True" ) -> - Ok (Value.Literal sourceLocation (Value.BoolLiteral True)) + _ -> + Result.map3 (\fun arg1 arg2 -> Value.Apply sourceLocation (Value.Apply sourceLocation fun arg1) arg2) + (mapOperator sourceLocation op) + (mapExpression sourceFile leftNode) + (mapExpression sourceFile rightNode) + + Expression.FunctionOrValue moduleName localName -> + localName + |> String.uncons + |> Result.fromMaybe [ NotSupported sourceLocation "Empty value name" ] + |> Result.andThen + (\( firstChar, _ ) -> + if Char.isUpper firstChar then + case ( moduleName, localName ) of + ( [], "True" ) -> + Ok (Value.Literal sourceLocation (Value.BoolLiteral True)) - ( [], "False" ) -> - Ok (Value.Literal sourceLocation (Value.BoolLiteral False)) + ( [], "False" ) -> + Ok (Value.Literal sourceLocation (Value.BoolLiteral False)) - _ -> - Ok (Value.Reference sourceLocation (fQName [] (moduleName |> List.map Name.fromString) (valueName |> Name.fromString))) + _ -> + Ok (Value.Constructor sourceLocation (fQName [] (moduleName |> List.map Name.fromString) (localName |> Name.fromString))) + + else + Ok (Value.Reference sourceLocation (fQName [] (moduleName |> List.map Name.fromString) (localName |> Name.fromString))) + ) Expression.IfBlock condNode thenNode elseNode -> Result.map3 (Value.IfThenElse sourceLocation) @@ -748,11 +777,11 @@ mapExpression sourceFile (Node range exp) = (mapExpression sourceFile thenNode) (mapExpression sourceFile elseNode) - Expression.PrefixOperator _ -> - Err [ NotSupported sourceLocation "TODO: PrefixOperator" ] + Expression.PrefixOperator op -> + mapOperator sourceLocation op - Expression.Operator _ -> - Err [ NotSupported sourceLocation "TODO: Operator" ] + Expression.Operator op -> + mapOperator sourceLocation op Expression.Integer value -> Ok (Value.Literal sourceLocation (Value.IntLiteral value)) @@ -949,81 +978,62 @@ mapPattern sourceFile (Node range pattern) = mapPattern sourceFile childNode -mapOperator : SourceFile -> SourceLocation -> String -> Node Expression -> Node Expression -> Result Errors (Value.Value SourceLocation) -mapOperator sourceFile sourceLocation op leftNode rightNode = - let - applyBinary : (SourceLocation -> Value SourceLocation -> Value SourceLocation -> Value SourceLocation) -> Result Errors (Value.Value SourceLocation) - applyBinary fun = - Result.map2 (fun sourceLocation) - (mapExpression sourceFile leftNode) - (mapExpression sourceFile rightNode) - in +mapOperator : SourceLocation -> String -> Result Errors (Value.Value SourceLocation) +mapOperator sourceLocation op = case op of - "<|" -> - -- the purpose of this operator is cleaner syntax so it's not mapped to the IR - Result.map2 (Value.Apply sourceLocation) - (mapExpression sourceFile leftNode) - (mapExpression sourceFile rightNode) - - "|>" -> - -- the purpose of this operator is cleaner syntax so it's not mapped to the IR - Result.map2 (Value.Apply sourceLocation) - (mapExpression sourceFile rightNode) - (mapExpression sourceFile leftNode) - "||" -> - applyBinary Bool.or + Ok <| Bool.or sourceLocation "&&" -> - applyBinary Bool.and + Ok <| Bool.and sourceLocation "==" -> - applyBinary Equality.equal + Ok <| Equality.equal sourceLocation "/=" -> - applyBinary Equality.notEqual + Ok <| Equality.notEqual sourceLocation "<" -> - applyBinary Comparison.lessThan + Ok <| Comparison.lessThan sourceLocation ">" -> - applyBinary Comparison.greaterThan + Ok <| Comparison.greaterThan sourceLocation "<=" -> - applyBinary Comparison.lessThanOrEqual + Ok <| Comparison.lessThanOrEqual sourceLocation ">=" -> - applyBinary Comparison.greaterThanOrEqual + Ok <| Comparison.greaterThanOrEqual sourceLocation "++" -> - applyBinary Appending.append + Ok <| Appending.append sourceLocation "+" -> - applyBinary Number.add + Ok <| Number.add sourceLocation "-" -> - applyBinary Number.subtract + Ok <| Number.subtract sourceLocation "*" -> - applyBinary Number.multiply + Ok <| Number.multiply sourceLocation "/" -> - applyBinary Float.divide + Ok <| Float.divide sourceLocation "//" -> - applyBinary Int.divide + Ok <| Int.divide sourceLocation "^" -> - applyBinary Number.power + Ok <| Number.power sourceLocation "<<" -> - applyBinary Composition.composeLeft + Ok <| Composition.composeLeft sourceLocation ">>" -> - applyBinary Composition.composeRight + Ok <| Composition.composeRight sourceLocation "::" -> - applyBinary List.construct + Ok <| List.construct sourceLocation _ -> Err [ NotSupported sourceLocation <| "OperatorApplication: " ++ op ] @@ -1269,7 +1279,7 @@ resolveLocalNames moduleResolver moduleDef = let rewriteTypes : Type SourceLocation -> Result Errors (Type SourceLocation) rewriteTypes = - Rewrite.bottomUp Type.rewriteType + Rewrite.bottomUp rewriteType (\tpe -> case tpe of Type.Reference sourceLocation refFullName args -> @@ -1287,12 +1297,50 @@ resolveLocalNames moduleResolver moduleDef = Nothing ) - rewriteValues : Value SourceLocation -> Result Errors (Value SourceLocation) - rewriteValues value = - resolveVariablesAndReferences Dict.empty moduleResolver value + rewriteValues : Dict Name SourceLocation -> Value SourceLocation -> Result Errors (Value SourceLocation) + rewriteValues variables value = + resolveVariablesAndReferences variables moduleResolver value + + typesResult : Result Errors (Dict Name (AccessControlled (Type.Definition SourceLocation))) + typesResult = + moduleDef.types + |> Dict.toList + |> List.map + (\( typeName, typeDef ) -> + typeDef.value + |> Type.mapDefinition rewriteTypes + |> Result.map (AccessControlled typeDef.access) + |> Result.map (Tuple.pair typeName) + |> Result.mapError List.concat + ) + |> ListOfResults.liftAllErrors + |> Result.map Dict.fromList + |> Result.mapError List.concat + + valuesResult : Result Errors (Dict Name (AccessControlled (Value.Definition SourceLocation))) + valuesResult = + moduleDef.values + |> Dict.toList + |> List.map + (\( valueName, valueDef ) -> + let + variables : Dict Name SourceLocation + variables = + valueDef.value.arguments |> Dict.fromList + in + valueDef.value + |> Value.mapDefinition rewriteTypes (rewriteValues variables) + |> Result.map (AccessControlled valueDef.access) + |> Result.map (Tuple.pair valueName) + |> Result.mapError List.concat + ) + |> ListOfResults.liftAllErrors + |> Result.map Dict.fromList + |> Result.mapError List.concat in - Module.mapDefinition rewriteTypes rewriteValues moduleDef - |> Result.mapError List.concat + Result.map2 Module.Definition + typesResult + valuesResult resolveVariablesAndReferences : Dict Name SourceLocation -> ModuleResolver -> Value SourceLocation -> Result Errors (Value SourceLocation) @@ -1393,7 +1441,7 @@ resolveVariablesAndReferences variables moduleResolver value = else moduleResolver.resolveValue (modulePath |> List.map Name.toTitleCase) - (localName |> Name.toTitleCase) + (localName |> Name.toCamelCase) |> Result.map (\resolvedFullName -> Value.Reference sourceLocation resolvedFullName @@ -1414,12 +1462,19 @@ resolveVariablesAndReferences variables moduleResolver value = Value.LetDefinition sourceLocation name def inValue -> Result.map2 (Value.LetDefinition sourceLocation name) - (resolveVariablesAndReferences variables moduleResolver def.body - |> Result.map - (\resolvedBody -> - { def - | body = resolvedBody - } + (def.arguments + |> Dict.fromList + |> Dict.insert name sourceLocation + |> unionVariableNames variables + |> Result.andThen + (\variablesDefNameAndArgs -> + resolveVariablesAndReferences variablesDefNameAndArgs moduleResolver def.body + |> Result.map + (\resolvedBody -> + { def + | body = resolvedBody + } + ) ) ) (unionVariableNames variables (Dict.singleton name sourceLocation) @@ -1434,27 +1489,33 @@ resolveVariablesAndReferences variables moduleResolver value = |> Dict.map (\_ _ -> sourceLocation) |> unionVariableNames variables |> Result.andThen - (\newVariables -> + (\variablesAndDefNames -> Result.map2 (Value.LetRecursion sourceLocation) (defs |> Dict.toList |> List.map (\( name, def ) -> - resolveVariablesAndReferences newVariables moduleResolver def.body - |> Result.map - (\resolvedBody -> - ( name - , { def - | body = resolvedBody - } - ) + def.arguments + |> Dict.fromList + |> unionVariableNames variablesAndDefNames + |> Result.andThen + (\variablesDefNamesAndArgs -> + resolveVariablesAndReferences variablesDefNamesAndArgs moduleResolver def.body + |> Result.map + (\resolvedBody -> + ( name + , { def + | body = resolvedBody + } + ) + ) ) ) |> ListOfResults.liftAllErrors |> Result.mapError List.concat |> Result.map Dict.fromList ) - (resolveVariablesAndReferences newVariables moduleResolver inValue) + (resolveVariablesAndReferences variablesAndDefNames moduleResolver inValue) ) Value.Destructure a pattern subjectValue inValue -> diff --git a/src/Morphir/Elm/Frontend/Resolve.elm b/src/Morphir/Elm/Frontend/Resolve.elm index 606f321c8..b84666ef8 100644 --- a/src/Morphir/Elm/Frontend/Resolve.elm +++ b/src/Morphir/Elm/Frontend/Resolve.elm @@ -96,12 +96,12 @@ type alias PackageResolver = defaultImports : List Import defaultImports = let - importExplicit : ModuleName -> Maybe ModuleName -> List TopLevelExpose -> Import + importExplicit : ModuleName -> Maybe String -> List TopLevelExpose -> Import importExplicit moduleName maybeAlias exposingList = Import (Node emptyRange moduleName) (maybeAlias - |> Maybe.map (Node emptyRange) + |> Maybe.map (List.singleton >> Node emptyRange) ) (exposingList |> List.map (Node emptyRange) @@ -111,16 +111,25 @@ defaultImports = ) in [ importExplicit [ "Morphir", "SDK", "Bool" ] Nothing [ TypeOrAliasExpose "Bool" ] - , importExplicit [ "Morphir", "SDK", "Char" ] Nothing [ TypeOrAliasExpose "Char" ] + , importExplicit [ "Morphir", "SDK", "Char" ] (Just "Char") [ TypeOrAliasExpose "Char" ] , importExplicit [ "Morphir", "SDK", "Int" ] Nothing [ TypeOrAliasExpose "Int" ] , importExplicit [ "Morphir", "SDK", "Float" ] Nothing [ TypeOrAliasExpose "Float" ] - , importExplicit [ "Morphir", "SDK", "String" ] Nothing [ TypeOrAliasExpose "String" ] - , importExplicit [ "Morphir", "SDK", "Maybe" ] Nothing [ TypeOrAliasExpose "Maybe" ] - , importExplicit [ "Morphir", "SDK", "Result" ] Nothing [ TypeOrAliasExpose "Result" ] - , importExplicit [ "Morphir", "SDK", "List" ] Nothing [ TypeOrAliasExpose "List" ] + , importExplicit [ "Morphir", "SDK", "String" ] (Just "String") [ TypeOrAliasExpose "String" ] + , importExplicit [ "Morphir", "SDK", "Maybe" ] (Just "Maybe") [ TypeOrAliasExpose "Maybe" ] + , importExplicit [ "Morphir", "SDK", "Result" ] (Just "Result") [ TypeOrAliasExpose "Result" ] + , importExplicit [ "Morphir", "SDK", "List" ] (Just "List") [ TypeOrAliasExpose "List" ] + , importExplicit [ "Morphir", "SDK", "Regex" ] (Just "Regex") [ TypeOrAliasExpose "Regex" ] + , importExplicit [ "Morphir", "SDK", "Tuple" ] (Just "Tuple") [] ] +moduleMapping : Dict ModuleName ModuleName +moduleMapping = + Dict.fromList + [ ( [ "Dict" ], [ "Morphir", "SDK", "Dict" ] ) + ] + + createPackageResolver : Dict Path (Package.Specification a) -> Path -> Dict Path (Module.Specification a) -> PackageResolver createPackageResolver dependencies currentPackagePath currentPackageModules = let @@ -220,9 +229,13 @@ createPackageResolver dependencies currentPackagePath currentPackageModules = decomposeModuleName : ModuleName -> Result Error ( Path, Path ) decomposeModuleName moduleName = let + morphirModuleName : ModuleName + morphirModuleName = + moduleMapping |> Dict.get moduleName |> Maybe.withDefault moduleName + suppliedModulePath : Path suppliedModulePath = - moduleName + morphirModuleName |> List.map Name.fromString matchModuleToPackagePath modulePath packagePath = @@ -240,14 +253,31 @@ createPackageResolver dependencies currentPackagePath currentPackageModules = |> List.filterMap (matchModuleToPackagePath suppliedModulePath) |> List.head ) - |> Result.fromMaybe (CouldNotDecompose moduleName) + |> Result.fromMaybe (CouldNotDecompose morphirModuleName) in PackageResolver currentPackagePath ctorNames exposesType exposesValue decomposeModuleName createModuleResolver : PackageResolver -> List Import -> Path -> Module.Definition a -> ModuleResolver -createModuleResolver packageResolver explicitImports currenctModulePath moduleDef = +createModuleResolver packageResolver elmImports currenctModulePath moduleDef = let + explicitImports : List Import + explicitImports = + elmImports + |> List.map + (\imp -> + { imp + | moduleName = + imp.moduleName + |> Node.map + (\moduleName -> + moduleMapping + |> Dict.get moduleName + |> Maybe.withDefault moduleName + ) + } + ) + imports : List Import imports = defaultImports ++ explicitImports @@ -441,11 +471,13 @@ createModuleResolver packageResolver explicitImports currenctModulePath moduleDe resolveExternally isType elmModuleName elmLocalName resolveType : ModuleName -> LocalName -> Result Error FQName - resolveType = + resolveType moduleName = resolve True + (moduleMapping |> Dict.get moduleName |> Maybe.withDefault moduleName) resolveValue : ModuleName -> LocalName -> Result Error FQName - resolveValue = + resolveValue moduleName = resolve False + (moduleMapping |> Dict.get moduleName |> Maybe.withDefault moduleName) in ModuleResolver resolveType resolveValue diff --git a/src/Morphir/IR/AccessControlled.elm b/src/Morphir/IR/AccessControlled.elm index 69987a591..268256030 100644 --- a/src/Morphir/IR/AccessControlled.elm +++ b/src/Morphir/IR/AccessControlled.elm @@ -1,9 +1,8 @@ module Morphir.IR.AccessControlled exposing - ( AccessControlled + ( AccessControlled, Access(..) , public, private , withPublicAccess, withPrivateAccess - , decodeAccessControlled, encodeAccessControlled - , Access(..), map + , map ) {-| Module to manage access to a node in the IR. This is only used to declare access levels @@ -11,7 +10,7 @@ not to enforce them. Enforcement can be done through the helper functions [withPublicAccess](#withPublicAccess) and [withPrivateAccess](#withPrivateAccess) but it's up to the consumer of the API to call the righ function. -@docs AccessControlled +@docs AccessControlled, Access # Creation @@ -24,15 +23,12 @@ up to the consumer of the API to call the righ function. @docs withPublicAccess, withPrivateAccess -# Serialization +# Transform -@docs decodeAccessControlled, encodeAccessControlled +@docs map -} -import Json.Decode as Decode -import Json.Encode as Encode - {-| Type that represents different access levels. -} @@ -42,6 +38,8 @@ type alias AccessControlled a = } +{-| Public or private access. +-} type Access = Public | Private @@ -95,45 +93,8 @@ withPrivateAccess ac = ac.value +{-| Apply a function to the access controlled value but keep the access unchanged. +-} map : (a -> b) -> AccessControlled a -> AccessControlled b map f ac = AccessControlled ac.access (f ac.value) - - -{-| Encode AccessControlled to JSON. --} -encodeAccessControlled : (a -> Encode.Value) -> AccessControlled a -> Encode.Value -encodeAccessControlled encodeValue ac = - case ac.access of - Public -> - Encode.list identity - [ Encode.string "Public" - , encodeValue ac.value - ] - - Private -> - Encode.list identity - [ Encode.string "Private" - , encodeValue ac.value - ] - - -{-| Decode AccessControlled from JSON. --} -decodeAccessControlled : Decode.Decoder a -> Decode.Decoder (AccessControlled a) -decodeAccessControlled decodeValue = - Decode.index 0 Decode.string - |> Decode.andThen - (\tag -> - case tag of - "Public" -> - Decode.map (AccessControlled Public) - (Decode.index 1 decodeValue) - - "Private" -> - Decode.map (AccessControlled Private) - (Decode.index 1 decodeValue) - - other -> - Decode.fail <| "Unknown access controlled type: " ++ other - ) diff --git a/src/Morphir/IR/AccessControlled/Codec.elm b/src/Morphir/IR/AccessControlled/Codec.elm new file mode 100644 index 000000000..5c2561b58 --- /dev/null +++ b/src/Morphir/IR/AccessControlled/Codec.elm @@ -0,0 +1,45 @@ +module Morphir.IR.AccessControlled.Codec exposing (..) + +{-| Encode AccessControlled to JSON. +-} + +import Json.Decode as Decode +import Json.Encode as Encode +import Morphir.IR.AccessControlled exposing (Access(..), AccessControlled) + + +encodeAccessControlled : (a -> Encode.Value) -> AccessControlled a -> Encode.Value +encodeAccessControlled encodeValue ac = + case ac.access of + Public -> + Encode.list identity + [ Encode.string "Public" + , encodeValue ac.value + ] + + Private -> + Encode.list identity + [ Encode.string "Private" + , encodeValue ac.value + ] + + +{-| Decode AccessControlled from JSON. +-} +decodeAccessControlled : Decode.Decoder a -> Decode.Decoder (AccessControlled a) +decodeAccessControlled decodeValue = + Decode.index 0 Decode.string + |> Decode.andThen + (\tag -> + case tag of + "Public" -> + Decode.map (AccessControlled Public) + (Decode.index 1 decodeValue) + + "Private" -> + Decode.map (AccessControlled Private) + (Decode.index 1 decodeValue) + + other -> + Decode.fail <| "Unknown access controlled type: " ++ other + ) diff --git a/src/Morphir/IR/FQName.elm b/src/Morphir/IR/FQName.elm index 4ac21108d..29aebc617 100644 --- a/src/Morphir/IR/FQName.elm +++ b/src/Morphir/IR/FQName.elm @@ -1,30 +1,13 @@ -module Morphir.IR.FQName exposing - ( FQName(..), fQName, fromQName, getPackagePath, getModulePath, getLocalName - , fuzzFQName - , encodeFQName, decodeFQName - ) +module Morphir.IR.FQName exposing (FQName(..), fQName, fromQName, getPackagePath, getModulePath, getLocalName) {-| Module to work with fully-qualified names. A qualified name is a combination of a package path, a module path and a local name. @docs FQName, fQName, fromQName, getPackagePath, getModulePath, getLocalName - -# Property Testing - -@docs fuzzFQName - - -# Serialization - -@docs encodeFQName, decodeFQName - -} -import Fuzz exposing (Fuzzer) -import Json.Decode as Decode -import Json.Encode as Encode -import Morphir.IR.Name exposing (Name, decodeName, encodeName, fuzzName) -import Morphir.IR.Path exposing (Path, decodePath, encodePath, fuzzPath) +import Morphir.IR.Name exposing (Name) +import Morphir.IR.Path exposing (Path) import Morphir.IR.QName as QName exposing (QName) @@ -67,34 +50,3 @@ getModulePath (FQName _ m _) = getLocalName : FQName -> Name getLocalName (FQName _ _ l) = l - - -{-| FQName fuzzer. --} -fuzzFQName : Fuzzer FQName -fuzzFQName = - Fuzz.map3 FQName - fuzzPath - fuzzPath - fuzzName - - -{-| Encode a fully-qualified name to JSON. --} -encodeFQName : FQName -> Encode.Value -encodeFQName (FQName packagePath modulePath localName) = - Encode.list identity - [ packagePath |> encodePath - , modulePath |> encodePath - , localName |> encodeName - ] - - -{-| Decode a fully-qualified name from JSON. --} -decodeFQName : Decode.Decoder FQName -decodeFQName = - Decode.map3 FQName - (Decode.index 0 decodePath) - (Decode.index 1 decodePath) - (Decode.index 2 decodeName) diff --git a/src/Morphir/IR/FQName/Codec.elm b/src/Morphir/IR/FQName/Codec.elm new file mode 100644 index 000000000..63d90e717 --- /dev/null +++ b/src/Morphir/IR/FQName/Codec.elm @@ -0,0 +1,29 @@ +module Morphir.IR.FQName.Codec exposing (..) + +{-| Encode a fully-qualified name to JSON. +-} + +import Json.Decode as Decode +import Json.Encode as Encode +import Morphir.IR.FQName exposing (FQName(..)) +import Morphir.IR.Name.Codec exposing (decodeName, encodeName) +import Morphir.IR.Path.Codec exposing (decodePath, encodePath) + + +encodeFQName : FQName -> Encode.Value +encodeFQName (FQName packagePath modulePath localName) = + Encode.list identity + [ packagePath |> encodePath + , modulePath |> encodePath + , localName |> encodeName + ] + + +{-| Decode a fully-qualified name from JSON. +-} +decodeFQName : Decode.Decoder FQName +decodeFQName = + Decode.map3 FQName + (Decode.index 0 decodePath) + (Decode.index 1 decodePath) + (Decode.index 2 decodeName) diff --git a/src/Morphir/IR/FQName/Fuzzer.elm b/src/Morphir/IR/FQName/Fuzzer.elm new file mode 100644 index 000000000..058c21155 --- /dev/null +++ b/src/Morphir/IR/FQName/Fuzzer.elm @@ -0,0 +1,17 @@ +module Morphir.IR.FQName.Fuzzer exposing (..) + +{-| FQName fuzzer. +-} + +import Fuzz exposing (Fuzzer) +import Morphir.IR.FQName exposing (FQName(..)) +import Morphir.IR.Name.Fuzzer exposing (fuzzName) +import Morphir.IR.Path.Fuzzer exposing (fuzzPath) + + +fuzzFQName : Fuzzer FQName +fuzzFQName = + Fuzz.map3 FQName + fuzzPath + fuzzPath + fuzzName diff --git a/src/Morphir/IR/Module.elm b/src/Morphir/IR/Module.elm index 19d2d6944..ea5c531ec 100644 --- a/src/Morphir/IR/Module.elm +++ b/src/Morphir/IR/Module.elm @@ -1,25 +1,20 @@ module Morphir.IR.Module exposing ( Specification, Definition - , encodeSpecification, encodeDefinition - , ModulePath, definitionToSpecification, eraseSpecificationAttributes, mapDefinition, mapSpecification + , ModulePath, definitionToSpecification, eraseSpecificationAttributes, mapDefinitionAttributes, mapSpecificationAttributes ) {-| Modules are groups of types and values that belong together. @docs Specification, Definition -@docs encodeSpecification, encodeDefinition - -} import Dict exposing (Dict) -import Json.Encode as Encode -import Morphir.IR.AccessControlled exposing (AccessControlled, encodeAccessControlled, withPublicAccess) -import Morphir.IR.Name exposing (Name, encodeName) +import Morphir.IR.AccessControlled exposing (AccessControlled, withPublicAccess) +import Morphir.IR.Name exposing (Name) import Morphir.IR.Path exposing (Path) import Morphir.IR.Type as Type exposing (Type) import Morphir.IR.Value as Value exposing (Value) -import Morphir.ListOfResults as ListOfResults type alias ModulePath = @@ -85,139 +80,40 @@ definitionToSpecification def = eraseSpecificationAttributes : Specification a -> Specification () eraseSpecificationAttributes spec = spec - |> mapSpecification - (Type.mapTypeAttributes (\_ -> ()) >> Ok) - (Value.mapValueAttributes (\_ -> ()) >> Ok) - |> Result.withDefault emptySpecification - - -{-| -} -encodeSpecification : (a -> Encode.Value) -> Specification a -> Encode.Value -encodeSpecification encodeAttributes spec = - Encode.object - [ ( "types" - , spec.types - |> Dict.toList - |> Encode.list - (\( name, typeSpec ) -> - Encode.object - [ ( "name", encodeName name ) - , ( "spec", Type.encodeSpecification encodeAttributes typeSpec ) - ] - ) - ) - , ( "values" - , spec.values - |> Dict.toList - |> Encode.list - (\( name, valueSpec ) -> - Encode.object - [ ( "name", encodeName name ) - , ( "spec", Value.encodeSpecification encodeAttributes valueSpec ) - ] - ) - ) - ] - - -mapSpecification : (Type a -> Result e (Type b)) -> (Value a -> Result e (Value b)) -> Specification a -> Result (List e) (Specification b) -mapSpecification mapType mapValue spec = - let - typesResult : Result (List e) (Dict Name (Type.Specification b)) - typesResult = - spec.types - |> Dict.toList - |> List.map - (\( typeName, typeSpec ) -> - typeSpec - |> Type.mapSpecification mapType - |> Result.map (Tuple.pair typeName) - ) - |> ListOfResults.liftAllErrors - |> Result.map Dict.fromList - |> Result.mapError List.concat - - valuesResult : Result (List e) (Dict Name (Value.Specification b)) - valuesResult = - spec.values - |> Dict.toList - |> List.map - (\( valueName, valueSpec ) -> - valueSpec - |> Value.mapSpecification mapType mapValue - |> Result.map (Tuple.pair valueName) - ) - |> ListOfResults.liftAllErrors - |> Result.map Dict.fromList - |> Result.mapError List.concat - in - Result.map2 Specification - typesResult - valuesResult - - -mapDefinition : (Type a -> Result e (Type b)) -> (Value a -> Result e (Value b)) -> Definition a -> Result (List e) (Definition b) -mapDefinition mapType mapValue def = - let - typesResult : Result (List e) (Dict Name (AccessControlled (Type.Definition b))) - typesResult = - def.types - |> Dict.toList - |> List.map - (\( typeName, typeDef ) -> - typeDef.value - |> Type.mapDefinition mapType - |> Result.map (AccessControlled typeDef.access) - |> Result.map (Tuple.pair typeName) - ) - |> ListOfResults.liftAllErrors - |> Result.map Dict.fromList - |> Result.mapError List.concat - - valuesResult : Result (List e) (Dict Name (AccessControlled (Value.Definition b))) - valuesResult = - def.values - |> Dict.toList - |> List.map - (\( valueName, valueDef ) -> - valueDef.value - |> Value.mapDefinition mapType mapValue - |> Result.map (AccessControlled valueDef.access) - |> Result.map (Tuple.pair valueName) - ) - |> ListOfResults.liftAllErrors - |> Result.map Dict.fromList - |> Result.mapError List.concat - in - Result.map2 Definition - typesResult - valuesResult - - -{-| -} -encodeDefinition : (a -> Encode.Value) -> Definition a -> Encode.Value -encodeDefinition encodeAttributes def = - Encode.object - [ ( "types" - , def.types - |> Dict.toList - |> Encode.list - (\( name, typeDef ) -> - Encode.object - [ ( "name", encodeName name ) - , ( "def", encodeAccessControlled (Type.encodeDefinition encodeAttributes) typeDef ) - ] - ) - ) - , ( "values" - , def.values - |> Dict.toList - |> Encode.list - (\( name, valueDef ) -> - Encode.object - [ ( "name", encodeName name ) - , ( "def", encodeAccessControlled (Value.encodeDefinition encodeAttributes) valueDef ) - ] - ) - ) - ] + |> mapSpecificationAttributes (\_ -> ()) + + +mapSpecificationAttributes : (a -> b) -> Specification a -> Specification b +mapSpecificationAttributes f spec = + Specification + (spec.types + |> Dict.map + (\_ typeSpec -> + Type.mapSpecificationAttributes f typeSpec + ) + ) + (spec.values + |> Dict.map + (\_ valueSpec -> + Value.mapSpecificationAttributes f valueSpec + ) + ) + + +mapDefinitionAttributes : (a -> b) -> Definition a -> Definition b +mapDefinitionAttributes f def = + Definition + (def.types + |> Dict.map + (\_ typeDef -> + AccessControlled typeDef.access + (Type.mapDefinitionAttributes f typeDef.value) + ) + ) + (def.values + |> Dict.map + (\_ valueDef -> + AccessControlled valueDef.access + (Value.mapDefinitionAttributes f valueDef.value) + ) + ) diff --git a/src/Morphir/IR/Module/Codec.elm b/src/Morphir/IR/Module/Codec.elm new file mode 100644 index 000000000..665dda948 --- /dev/null +++ b/src/Morphir/IR/Module/Codec.elm @@ -0,0 +1,68 @@ +module Morphir.IR.Module.Codec exposing (..) + +{-| -} + +import Dict +import Json.Encode as Encode +import Morphir.IR.AccessControlled.Codec exposing (encodeAccessControlled) +import Morphir.IR.Module exposing (Definition, Specification) +import Morphir.IR.Name.Codec exposing (encodeName) +import Morphir.IR.Type.Codec as TypeCodec +import Morphir.IR.Value.Codec as ValueCodec + + +{-| -} +encodeSpecification : (a -> Encode.Value) -> Specification a -> Encode.Value +encodeSpecification encodeAttributes spec = + Encode.object + [ ( "types" + , spec.types + |> Dict.toList + |> Encode.list + (\( name, typeSpec ) -> + Encode.object + [ ( "name", encodeName name ) + , ( "spec", TypeCodec.encodeSpecification encodeAttributes typeSpec ) + ] + ) + ) + , ( "values" + , spec.values + |> Dict.toList + |> Encode.list + (\( name, valueSpec ) -> + Encode.object + [ ( "name", encodeName name ) + , ( "spec", ValueCodec.encodeSpecification encodeAttributes valueSpec ) + ] + ) + ) + ] + + +encodeDefinition : (a -> Encode.Value) -> Definition a -> Encode.Value +encodeDefinition encodeAttributes def = + Encode.object + [ ( "types" + , def.types + |> Dict.toList + |> Encode.list + (\( name, typeDef ) -> + Encode.object + [ ( "name", encodeName name ) + , ( "def", encodeAccessControlled (TypeCodec.encodeDefinition encodeAttributes) typeDef ) + ] + ) + ) + , ( "values" + , def.values + |> Dict.toList + |> Encode.list + (\( name, valueDef ) -> + Encode.object + [ ( "name", encodeName name ) + , ( "def", encodeAccessControlled (ValueCodec.encodeDefinition encodeAttributes) valueDef ) + ] + ) + ) + ] diff --git a/src/Morphir/IR/Name.elm b/src/Morphir/IR/Name.elm index 4421511c0..bd8774899 100644 --- a/src/Morphir/IR/Name.elm +++ b/src/Morphir/IR/Name.elm @@ -1,8 +1,6 @@ module Morphir.IR.Name exposing ( Name, fromList, toList , fromString, toTitleCase, toCamelCase, toSnakeCase, toHumanWords - , fuzzName - , encodeName, decodeName ) {-| `Name` is an abstraction of human-readable identifiers made up of words. This abstraction @@ -39,21 +37,8 @@ abbreviation: @docs fromString, toTitleCase, toCamelCase, toSnakeCase, toHumanWords - -# Property Testing - -@docs fuzzName - - -# Serialization - -@docs encodeName, decodeName - -} -import Fuzz exposing (Fuzzer) -import Json.Decode as Decode -import Json.Encode as Encode import Regex exposing (Regex) @@ -219,81 +204,3 @@ fromList words = toList : Name -> List String toList words = words - - -{-| Name fuzzer. --} -fuzzName : Fuzzer Name -fuzzName = - let - nouns = - [ "area" - , "benchmark" - , "book" - , "business" - , "company" - , "country" - , "currency" - , "day" - , "description" - , "entity" - , "fact" - , "family" - , "from" - , "government" - , "group" - , "home" - , "id" - , "job" - , "left" - , "lot" - , "market" - , "minute" - , "money" - , "month" - , "name" - , "number" - , "owner" - , "parent" - , "part" - , "problem" - , "rate" - , "right" - , "state" - , "source" - , "system" - , "time" - , "title" - , "to" - , "valid" - , "week" - , "work" - , "world" - , "year" - ] - - fuzzWord = - nouns - |> List.map Fuzz.constant - |> Fuzz.oneOf - in - Fuzz.list fuzzWord - |> Fuzz.map (List.take 3) - |> Fuzz.map fromList - - -{-| Encode a name to JSON. --} -encodeName : Name -> Encode.Value -encodeName name = - name - |> toList - |> Encode.list Encode.string - - -{-| Decode a name from JSON. --} -decodeName : Decode.Decoder Name -decodeName = - Decode.list Decode.string - |> Decode.map fromList diff --git a/src/Morphir/IR/Name/Codec.elm b/src/Morphir/IR/Name/Codec.elm new file mode 100644 index 000000000..bb7d2a2fa --- /dev/null +++ b/src/Morphir/IR/Name/Codec.elm @@ -0,0 +1,22 @@ +module Morphir.IR.Name.Codec exposing (..) + +import Json.Decode as Decode +import Json.Encode as Encode +import Morphir.IR.Name as Name exposing (Name) + + +{-| Encode a name to JSON. +-} +encodeName : Name -> Encode.Value +encodeName name = + name + |> Name.toList + |> Encode.list Encode.string + + +{-| Decode a name from JSON. +-} +decodeName : Decode.Decoder Name +decodeName = + Decode.list Decode.string + |> Decode.map Name.fromList diff --git a/src/Morphir/IR/Name/Fuzzer.elm b/src/Morphir/IR/Name/Fuzzer.elm new file mode 100644 index 000000000..e4ccd62e0 --- /dev/null +++ b/src/Morphir/IR/Name/Fuzzer.elm @@ -0,0 +1,66 @@ +module Morphir.IR.Name.Fuzzer exposing (..) + +{-| Name fuzzer. +-} + +import Fuzz exposing (Fuzzer) +import Morphir.IR.Name as Name exposing (Name) + + +fuzzName : Fuzzer Name +fuzzName = + let + nouns = + [ "area" + , "benchmark" + , "book" + , "business" + , "company" + , "country" + , "currency" + , "day" + , "description" + , "entity" + , "fact" + , "family" + , "from" + , "government" + , "group" + , "home" + , "id" + , "job" + , "left" + , "lot" + , "market" + , "minute" + , "money" + , "month" + , "name" + , "number" + , "owner" + , "parent" + , "part" + , "problem" + , "rate" + , "right" + , "state" + , "source" + , "system" + , "time" + , "title" + , "to" + , "valid" + , "week" + , "work" + , "world" + , "year" + ] + + fuzzWord = + nouns + |> List.map Fuzz.constant + |> Fuzz.oneOf + in + Fuzz.list fuzzWord + |> Fuzz.map (List.take 3) + |> Fuzz.map Name.fromList diff --git a/src/Morphir/IR/Package.elm b/src/Morphir/IR/Package.elm index b19dc3986..19cc8b911 100644 --- a/src/Morphir/IR/Package.elm +++ b/src/Morphir/IR/Package.elm @@ -1,7 +1,7 @@ module Morphir.IR.Package exposing ( Specification , Definition, emptyDefinition - , PackagePath, definitionToSpecification, encodeDefinition, eraseDefinitionAttributes, eraseSpecificationAttributes + , PackagePath, definitionToSpecification, eraseDefinitionAttributes, eraseSpecificationAttributes ) {-| Tools to work with packages. @@ -13,13 +13,9 @@ module Morphir.IR.Package exposing -} import Dict exposing (Dict) -import Json.Encode as Encode -import Morphir.IR.AccessControlled exposing (AccessControlled, encodeAccessControlled, withPublicAccess) +import Morphir.IR.AccessControlled exposing (AccessControlled, withPublicAccess) import Morphir.IR.Module as Module exposing (ModulePath) -import Morphir.IR.Path exposing (Path, encodePath) -import Morphir.IR.Type as Type exposing (Type) -import Morphir.IR.Value as Value exposing (Value) -import Morphir.ListOfResults as ListOfResults +import Morphir.IR.Path exposing (Path) type alias PackagePath = @@ -74,121 +70,42 @@ definitionToSpecification def = } -mapSpecification : (Type a -> Result e (Type b)) -> (Value a -> Result e (Value b)) -> Specification a -> Result (List e) (Specification b) -mapSpecification mapType mapValue spec = - let - modulesResult : Result (List e) (Dict Path (Module.Specification b)) - modulesResult = - spec.modules - |> Dict.toList - |> List.map - (\( modulePath, moduleSpec ) -> - moduleSpec - |> Module.mapSpecification mapType mapValue - |> Result.map (Tuple.pair modulePath) - ) - |> ListOfResults.liftAllErrors - |> Result.map Dict.fromList - |> Result.mapError List.concat - in - Result.map Specification modulesResult +mapSpecificationAttributes : (a -> b) -> Specification a -> Specification b +mapSpecificationAttributes f spec = + Specification + (spec.modules + |> Dict.map + (\_ moduleSpec -> + Module.mapSpecificationAttributes f moduleSpec + ) + ) + + +mapDefinitionAttributes : (a -> b) -> Definition a -> Definition b +mapDefinitionAttributes f def = + Definition + (def.dependencies + |> Dict.map + (\_ packageSpec -> + mapSpecificationAttributes f packageSpec + ) + ) + (def.modules + |> Dict.map + (\_ moduleDef -> + AccessControlled moduleDef.access + (Module.mapDefinitionAttributes f moduleDef.value) + ) + ) eraseSpecificationAttributes : Specification a -> Specification () eraseSpecificationAttributes spec = spec - |> mapSpecification - (Type.mapTypeAttributes (\_ -> ()) >> Ok) - (Value.mapValueAttributes (\_ -> ()) >> Ok) - |> Result.withDefault emptySpecification - - -mapDefinition : (Type a -> Result e (Type b)) -> (Value a -> Result e (Value b)) -> Definition a -> Result (List e) (Definition b) -mapDefinition mapType mapValue def = - let - dependenciesResult : Result (List e) (Dict Path (Specification b)) - dependenciesResult = - def.dependencies - |> Dict.toList - |> List.map - (\( packagePath, packageSpec ) -> - packageSpec - |> mapSpecification mapType mapValue - |> Result.map (Tuple.pair packagePath) - ) - |> ListOfResults.liftAllErrors - |> Result.map Dict.fromList - |> Result.mapError List.concat - - modulesResult : Result (List e) (Dict Path (AccessControlled (Module.Definition b))) - modulesResult = - def.modules - |> Dict.toList - |> List.map - (\( modulePath, moduleDef ) -> - moduleDef.value - |> Module.mapDefinition mapType mapValue - |> Result.map (AccessControlled moduleDef.access) - |> Result.map (Tuple.pair modulePath) - ) - |> ListOfResults.liftAllErrors - |> Result.map Dict.fromList - |> Result.mapError List.concat - in - Result.map2 Definition - dependenciesResult - modulesResult + |> mapSpecificationAttributes (\_ -> ()) eraseDefinitionAttributes : Definition a -> Definition () eraseDefinitionAttributes def = def - |> mapDefinition - (Type.mapTypeAttributes (\_ -> ()) >> Ok) - (Value.mapValueAttributes (\_ -> ()) >> Ok) - |> Result.withDefault emptyDefinition - - -encodeSpecification : (a -> Encode.Value) -> Specification a -> Encode.Value -encodeSpecification encodeAttributes spec = - Encode.object - [ ( "modules" - , spec.modules - |> Dict.toList - |> Encode.list - (\( moduleName, moduleSpec ) -> - Encode.object - [ ( "name", encodePath moduleName ) - , ( "spec", Module.encodeSpecification encodeAttributes moduleSpec ) - ] - ) - ) - ] - - -encodeDefinition : (a -> Encode.Value) -> Definition a -> Encode.Value -encodeDefinition encodeAttributes def = - Encode.object - [ ( "dependencies" - , def.dependencies - |> Dict.toList - |> Encode.list - (\( packageName, packageSpec ) -> - Encode.object - [ ( "name", encodePath packageName ) - , ( "spec", encodeSpecification encodeAttributes packageSpec ) - ] - ) - ) - , ( "modules" - , def.modules - |> Dict.toList - |> Encode.list - (\( moduleName, moduleDef ) -> - Encode.object - [ ( "name", encodePath moduleName ) - , ( "def", encodeAccessControlled (Module.encodeDefinition encodeAttributes) moduleDef ) - ] - ) - ) - ] + |> mapDefinitionAttributes (\_ -> ()) diff --git a/src/Morphir/IR/Package/Codec.elm b/src/Morphir/IR/Package/Codec.elm new file mode 100644 index 000000000..83cbf0848 --- /dev/null +++ b/src/Morphir/IR/Package/Codec.elm @@ -0,0 +1,53 @@ +module Morphir.IR.Package.Codec exposing (..) + +import Dict +import Json.Encode as Encode +import Morphir.IR.AccessControlled.Codec exposing (encodeAccessControlled) +import Morphir.IR.Module.Codec as ModuleCodec +import Morphir.IR.Package exposing (Definition, Specification) +import Morphir.IR.Path.Codec exposing (encodePath) + + +encodeSpecification : (a -> Encode.Value) -> Specification a -> Encode.Value +encodeSpecification encodeAttributes spec = + Encode.object + [ ( "modules" + , spec.modules + |> Dict.toList + |> Encode.list + (\( moduleName, moduleSpec ) -> + Encode.object + [ ( "name", encodePath moduleName ) + , ( "spec", ModuleCodec.encodeSpecification encodeAttributes moduleSpec ) + ] + ) + ) + ] + + +encodeDefinition : (a -> Encode.Value) -> Definition a -> Encode.Value +encodeDefinition encodeAttributes def = + Encode.object + [ ( "dependencies" + , def.dependencies + |> Dict.toList + |> Encode.list + (\( packageName, packageSpec ) -> + Encode.object + [ ( "name", encodePath packageName ) + , ( "spec", encodeSpecification encodeAttributes packageSpec ) + ] + ) + ) + , ( "modules" + , def.modules + |> Dict.toList + |> Encode.list + (\( moduleName, moduleDef ) -> + Encode.object + [ ( "name", encodePath moduleName ) + , ( "def", encodeAccessControlled (ModuleCodec.encodeDefinition encodeAttributes) moduleDef ) + ] + ) + ) + ] diff --git a/src/Morphir/IR/Path.elm b/src/Morphir/IR/Path.elm index fcc2b903c..5b08cd73a 100644 --- a/src/Morphir/IR/Path.elm +++ b/src/Morphir/IR/Path.elm @@ -2,8 +2,6 @@ module Morphir.IR.Path exposing ( Path, fromList, toList , fromString, toString , isPrefixOf - , fuzzPath - , encodePath, decodePath ) {-| `Path` is a list of names that represents a path in the tree. It's used at various @@ -21,22 +19,9 @@ places in the IR to identify types and values. @docs isPrefixOf - -# Property Testing - -@docs fuzzPath - - -# Serialization - -@docs encodePath, decodePath - -} -import Fuzz exposing (Fuzzer) -import Json.Decode as Decode -import Json.Encode as Encode -import Morphir.IR.Name as Name exposing (Name, decodeName, encodeName, fuzzName) +import Morphir.IR.Name as Name exposing (Name) import Regex exposing (Regex) @@ -139,29 +124,3 @@ isPrefixOf prefix path = else False - - -{-| Path fuzzer. --} -fuzzPath : Fuzzer Path -fuzzPath = - Fuzz.list fuzzName - |> Fuzz.map (List.take 3) - |> Fuzz.map fromList - - -{-| Encode a path to JSON. --} -encodePath : Path -> Encode.Value -encodePath path = - path - |> toList - |> Encode.list encodeName - - -{-| Decode a path from JSON. --} -decodePath : Decode.Decoder Path -decodePath = - Decode.list decodeName - |> Decode.map fromList diff --git a/src/Morphir/IR/Path/Codec.elm b/src/Morphir/IR/Path/Codec.elm new file mode 100644 index 000000000..9a5487f69 --- /dev/null +++ b/src/Morphir/IR/Path/Codec.elm @@ -0,0 +1,24 @@ +module Morphir.IR.Path.Codec exposing (..) + +{-| Encode a path to JSON. +-} + +import Json.Decode as Decode +import Json.Encode as Encode +import Morphir.IR.Name.Codec exposing (decodeName, encodeName) +import Morphir.IR.Path as Path exposing (Path) + + +encodePath : Path -> Encode.Value +encodePath path = + path + |> Path.toList + |> Encode.list encodeName + + +{-| Decode a path from JSON. +-} +decodePath : Decode.Decoder Path +decodePath = + Decode.list decodeName + |> Decode.map Path.fromList diff --git a/src/Morphir/IR/Path/Fuzzer.elm b/src/Morphir/IR/Path/Fuzzer.elm new file mode 100644 index 000000000..7ebd82d9e --- /dev/null +++ b/src/Morphir/IR/Path/Fuzzer.elm @@ -0,0 +1,15 @@ +module Morphir.IR.Path.Fuzzer exposing (..) + +{-| Path fuzzer. +-} + +import Fuzz exposing (Fuzzer) +import Morphir.IR.Name.Fuzzer exposing (fuzzName) +import Morphir.IR.Path as Path exposing (Path) + + +fuzzPath : Fuzzer Path +fuzzPath = + Fuzz.list fuzzName + |> Fuzz.map (List.take 3) + |> Fuzz.map Path.fromList diff --git a/src/Morphir/IR/QName.elm b/src/Morphir/IR/QName.elm index 3086160a4..7f64bf45b 100644 --- a/src/Morphir/IR/QName.elm +++ b/src/Morphir/IR/QName.elm @@ -1,37 +1,27 @@ module Morphir.IR.QName exposing - ( QName, fromTuple, toTuple, getModulePath, getLocalName + ( QName(..), toTuple, getModulePath, getLocalName + , fromName, fromTuple , toString - , fuzzQName - , encodeQName, decodeQName - , fromName ) {-| Module to work with qualified names. A qualified name is a combination of a module path and a local name. -@docs QName, fromTuple, toTuple, qName, getModulePath, getLocalName +@docs QName, toTuple, getModulePath, getLocalName -# String conversion - -@docs toString - +# Creation -# Property Testing +@docs fromName, fromTuple -@docs fuzzQName +# String conversion -# Serialization - -@docs encodeQName, decodeQName +@docs toString -} -import Fuzz exposing (Fuzzer) -import Json.Decode as Decode -import Json.Encode as Encode -import Morphir.IR.Name exposing (Name, decodeName, encodeName, fuzzName) -import Morphir.IR.Path as Path exposing (Path, decodePath, encodePath, fuzzPath) +import Morphir.IR.Name exposing (Name) +import Morphir.IR.Path as Path exposing (Path) {-| Type that represents a qualified name. @@ -101,31 +91,3 @@ toString pathPartToString nameToString sep (QName mPath lName) = |> List.map pathPartToString |> List.append [ nameToString lName ] |> String.join sep - - -{-| QName fuzzer. --} -fuzzQName : Fuzzer QName -fuzzQName = - Fuzz.map2 QName - fuzzPath - fuzzName - - -{-| Encode a qualified name to JSON. --} -encodeQName : QName -> Encode.Value -encodeQName (QName modulePath localName) = - Encode.list identity - [ modulePath |> encodePath - , localName |> encodeName - ] - - -{-| Decode a qualified name from JSON. --} -decodeQName : Decode.Decoder QName -decodeQName = - Decode.map2 QName - (Decode.index 0 decodePath) - (Decode.index 1 decodeName) diff --git a/src/Morphir/IR/QName/Codec.elm b/src/Morphir/IR/QName/Codec.elm new file mode 100644 index 000000000..c2a8caf85 --- /dev/null +++ b/src/Morphir/IR/QName/Codec.elm @@ -0,0 +1,27 @@ +module Morphir.IR.QName.Codec exposing (..) + +{-| Encode a qualified name to JSON. +-} + +import Json.Decode as Decode +import Json.Encode as Encode +import Morphir.IR.Name exposing (decodeName, encodeName) +import Morphir.IR.Path exposing (decodePath, encodePath) +import Morphir.IR.QName exposing (QName) + + +encodeQName : QName -> Encode.Value +encodeQName (QName modulePath localName) = + Encode.list identity + [ modulePath |> encodePath + , localName |> encodeName + ] + + +{-| Decode a qualified name from JSON. +-} +decodeQName : Decode.Decoder QName +decodeQName = + Decode.map2 QName + (Decode.index 0 decodePath) + (Decode.index 1 decodeName) diff --git a/src/Morphir/IR/QName/Fuzzer.elm b/src/Morphir/IR/QName/Fuzzer.elm new file mode 100644 index 000000000..747b89b4a --- /dev/null +++ b/src/Morphir/IR/QName/Fuzzer.elm @@ -0,0 +1,15 @@ +module Morphir.IR.QName.Fuzzer exposing (..) + +import Fuzz exposing (Fuzzer) +import Morphir.IR.Name exposing (fuzzName) +import Morphir.IR.Path exposing (fuzzPath) +import Morphir.IR.QName exposing (QName(..)) + + +{-| QName fuzzer. +-} +fuzzQName : Fuzzer QName +fuzzQName = + Fuzz.map2 QName + fuzzPath + fuzzName diff --git a/src/Morphir/IR/SDK/Appending.elm b/src/Morphir/IR/SDK/Appending.elm index 3e2d91f8c..d07e9370b 100644 --- a/src/Morphir/IR/SDK/Appending.elm +++ b/src/Morphir/IR/SDK/Appending.elm @@ -3,8 +3,7 @@ module Morphir.IR.SDK.Appending exposing (..) import Dict import Morphir.IR.Module as Module exposing (ModulePath) import Morphir.IR.Path as Path exposing (Path) -import Morphir.IR.SDK.Common exposing (binaryApply, toFQName) -import Morphir.IR.Type exposing (Specification(..), Type(..)) +import Morphir.IR.SDK.Common exposing (toFQName) import Morphir.IR.Value as Value exposing (Value) @@ -22,6 +21,6 @@ moduleSpec = } -append : a -> Value a -> Value a -> Value a -append = - binaryApply moduleName "append" +append : a -> Value a +append a = + Value.Reference a (toFQName moduleName "append") diff --git a/src/Morphir/IR/SDK/Bool.elm b/src/Morphir/IR/SDK/Bool.elm index 827cfd8b5..ab711e43e 100644 --- a/src/Morphir/IR/SDK/Bool.elm +++ b/src/Morphir/IR/SDK/Bool.elm @@ -4,7 +4,7 @@ import Dict import Morphir.IR.Module as Module exposing (ModulePath) import Morphir.IR.Name as Name import Morphir.IR.Path as Path -import Morphir.IR.SDK.Common exposing (binaryApply, toFQName) +import Morphir.IR.SDK.Common exposing (toFQName) import Morphir.IR.Type exposing (Specification(..), Type(..)) import Morphir.IR.Value as Value exposing (Value) @@ -30,11 +30,11 @@ boolType attributes = Reference attributes (toFQName moduleName "Bool") [] -and : a -> Value a -> Value a -> Value a -and = - binaryApply moduleName "and" +and : a -> Value a +and a = + Value.Reference a (toFQName moduleName "and") -or : a -> Value a -> Value a -> Value a -or = - binaryApply moduleName "or" +or : a -> Value a +or a = + Value.Reference a (toFQName moduleName "or") diff --git a/src/Morphir/IR/SDK/Comparison.elm b/src/Morphir/IR/SDK/Comparison.elm index b329d0019..244b7ea57 100644 --- a/src/Morphir/IR/SDK/Comparison.elm +++ b/src/Morphir/IR/SDK/Comparison.elm @@ -3,8 +3,7 @@ module Morphir.IR.SDK.Comparison exposing (..) import Dict import Morphir.IR.Module as Module exposing (ModulePath) import Morphir.IR.Path as Path exposing (Path) -import Morphir.IR.SDK.Common exposing (binaryApply, toFQName) -import Morphir.IR.Type exposing (Specification(..), Type(..)) +import Morphir.IR.SDK.Common exposing (toFQName) import Morphir.IR.Value as Value exposing (Value) @@ -22,21 +21,21 @@ moduleSpec = } -lessThan : a -> Value a -> Value a -> Value a -lessThan = - binaryApply moduleName "lessThan" +lessThan : a -> Value a +lessThan a = + Value.Reference a (toFQName moduleName "lessThan") -lessThanOrEqual : a -> Value a -> Value a -> Value a -lessThanOrEqual = - binaryApply moduleName "lessThanOrEqual" +lessThanOrEqual : a -> Value a +lessThanOrEqual a = + Value.Reference a (toFQName moduleName "lessThanOrEqual") -greaterThan : a -> Value a -> Value a -> Value a -greaterThan = - binaryApply moduleName "greaterThan" +greaterThan : a -> Value a +greaterThan a = + Value.Reference a (toFQName moduleName "greaterThan") -greaterThanOrEqual : a -> Value a -> Value a -> Value a -greaterThanOrEqual = - binaryApply moduleName "greaterThanOrEqual" +greaterThanOrEqual : a -> Value a +greaterThanOrEqual a = + Value.Reference a (toFQName moduleName "greaterThanOrEqual") diff --git a/src/Morphir/IR/SDK/Composition.elm b/src/Morphir/IR/SDK/Composition.elm index 585f7a9b0..f153bdbb6 100644 --- a/src/Morphir/IR/SDK/Composition.elm +++ b/src/Morphir/IR/SDK/Composition.elm @@ -3,8 +3,7 @@ module Morphir.IR.SDK.Composition exposing (..) import Dict import Morphir.IR.Module as Module exposing (ModulePath) import Morphir.IR.Path as Path exposing (Path) -import Morphir.IR.SDK.Common exposing (binaryApply, toFQName) -import Morphir.IR.Type exposing (Specification(..), Type(..)) +import Morphir.IR.SDK.Common exposing (toFQName) import Morphir.IR.Value as Value exposing (Value) @@ -22,11 +21,11 @@ moduleSpec = } -composeLeft : a -> Value a -> Value a -> Value a -composeLeft = - binaryApply moduleName "composeLeft" +composeLeft : a -> Value a +composeLeft a = + Value.Reference a (toFQName moduleName "composeLeft") -composeRight : a -> Value a -> Value a -> Value a -composeRight = - binaryApply moduleName "composeRight" +composeRight : a -> Value a +composeRight a = + Value.Reference a (toFQName moduleName "composeRight") diff --git a/src/Morphir/IR/SDK/Equality.elm b/src/Morphir/IR/SDK/Equality.elm index e170ece01..0d6a52938 100644 --- a/src/Morphir/IR/SDK/Equality.elm +++ b/src/Morphir/IR/SDK/Equality.elm @@ -3,8 +3,7 @@ module Morphir.IR.SDK.Equality exposing (..) import Dict import Morphir.IR.Module as Module exposing (ModulePath) import Morphir.IR.Path as Path exposing (Path) -import Morphir.IR.SDK.Common exposing (binaryApply, toFQName) -import Morphir.IR.Type exposing (Specification(..), Type(..)) +import Morphir.IR.SDK.Common exposing (toFQName) import Morphir.IR.Value as Value exposing (Value) @@ -22,11 +21,11 @@ moduleSpec = } -equal : a -> Value a -> Value a -> Value a -equal = - binaryApply moduleName "equal" +equal : a -> Value a +equal a = + Value.Reference a (toFQName moduleName "equal") -notEqual : a -> Value a -> Value a -> Value a -notEqual = - binaryApply moduleName "notEqual" +notEqual : a -> Value a +notEqual a = + Value.Reference a (toFQName moduleName "notEqual") diff --git a/src/Morphir/IR/SDK/Float.elm b/src/Morphir/IR/SDK/Float.elm index 7087dacef..46b6a2de0 100644 --- a/src/Morphir/IR/SDK/Float.elm +++ b/src/Morphir/IR/SDK/Float.elm @@ -4,9 +4,9 @@ import Dict import Morphir.IR.Module as Module exposing (ModulePath) import Morphir.IR.Name as Name import Morphir.IR.Path as Path -import Morphir.IR.SDK.Common exposing (binaryApply, toFQName) +import Morphir.IR.SDK.Common exposing (toFQName) import Morphir.IR.Type exposing (Specification(..), Type(..)) -import Morphir.IR.Value exposing (Value) +import Morphir.IR.Value as Value exposing (Value) moduleName : ModulePath @@ -30,6 +30,6 @@ floatType attributes = Reference attributes (toFQName moduleName "Float") [] -divide : a -> Value a -> Value a -> Value a -divide = - binaryApply moduleName "divide" +divide : a -> Value a +divide a = + Value.Reference a (toFQName moduleName "divide") diff --git a/src/Morphir/IR/SDK/Int.elm b/src/Morphir/IR/SDK/Int.elm index ecbb03ac9..88976ce2c 100644 --- a/src/Morphir/IR/SDK/Int.elm +++ b/src/Morphir/IR/SDK/Int.elm @@ -4,9 +4,9 @@ import Dict import Morphir.IR.Module as Module exposing (ModulePath) import Morphir.IR.Name as Name import Morphir.IR.Path as Path -import Morphir.IR.SDK.Common exposing (binaryApply, toFQName) +import Morphir.IR.SDK.Common exposing (toFQName) import Morphir.IR.Type exposing (Specification(..), Type(..)) -import Morphir.IR.Value exposing (Value) +import Morphir.IR.Value as Value exposing (Value) moduleName : ModulePath @@ -30,6 +30,6 @@ intType attributes = Reference attributes (toFQName moduleName "Int") [] -divide : a -> Value a -> Value a -> Value a -divide = - binaryApply moduleName "divide" +divide : a -> Value a +divide a = + Value.Reference a (toFQName moduleName "divide") diff --git a/src/Morphir/IR/SDK/List.elm b/src/Morphir/IR/SDK/List.elm index 0a0e357d7..07ab964d6 100644 --- a/src/Morphir/IR/SDK/List.elm +++ b/src/Morphir/IR/SDK/List.elm @@ -4,9 +4,9 @@ import Dict import Morphir.IR.Module as Module exposing (ModulePath) import Morphir.IR.Name as Name import Morphir.IR.Path as Path -import Morphir.IR.SDK.Common exposing (binaryApply, toFQName) +import Morphir.IR.SDK.Common exposing (toFQName) import Morphir.IR.Type as Type exposing (Specification(..), Type(..)) -import Morphir.IR.Value exposing (Value) +import Morphir.IR.Value as Value exposing (Value) moduleName : ModulePath @@ -30,6 +30,6 @@ listType attributes itemType = Type.Reference attributes (toFQName moduleName "List") [ itemType ] -construct : a -> Value a -> Value a -> Value a -construct = - binaryApply moduleName "construct" +construct : a -> Value a +construct a = + Value.Reference a (toFQName moduleName "construct") diff --git a/src/Morphir/IR/SDK/Number.elm b/src/Morphir/IR/SDK/Number.elm index ae908addb..1fb693cb8 100644 --- a/src/Morphir/IR/SDK/Number.elm +++ b/src/Morphir/IR/SDK/Number.elm @@ -3,7 +3,7 @@ module Morphir.IR.SDK.Number exposing (..) import Dict import Morphir.IR.Module as Module exposing (ModulePath) import Morphir.IR.Path as Path exposing (Path) -import Morphir.IR.SDK.Common exposing (binaryApply, toFQName) +import Morphir.IR.SDK.Common exposing (toFQName) import Morphir.IR.Type exposing (Specification(..), Type(..)) import Morphir.IR.Value as Value exposing (Value) @@ -32,21 +32,21 @@ negate refAttributes valueAttributes arg = Value.Apply valueAttributes (Value.Reference refAttributes (toFQName moduleName "negate")) arg -add : a -> Value a -> Value a -> Value a -add = - binaryApply moduleName "add" +add : a -> Value a +add a = + Value.Reference a (toFQName moduleName "add") -subtract : a -> Value a -> Value a -> Value a -subtract = - binaryApply moduleName "subtract" +subtract : a -> Value a +subtract a = + Value.Reference a (toFQName moduleName "subtract") -multiply : a -> Value a -> Value a -> Value a -multiply = - binaryApply moduleName "multiply" +multiply : a -> Value a +multiply a = + Value.Reference a (toFQName moduleName "multiply") -power : a -> Value a -> Value a -> Value a -power = - binaryApply moduleName "power" +power : a -> Value a +power a = + Value.Reference a (toFQName moduleName "power") diff --git a/src/Morphir/IR/Type.elm b/src/Morphir/IR/Type.elm index 4521d61bd..e8627cd58 100644 --- a/src/Morphir/IR/Type.elm +++ b/src/Morphir/IR/Type.elm @@ -1,13 +1,11 @@ module Morphir.IR.Type exposing ( Type(..) , variable, reference, tuple, record, extensibleRecord, function, unit - , Field, matchField, mapFieldName, mapFieldType + , Field, mapFieldName, mapFieldType , Specification(..), typeAliasSpecification, opaqueTypeSpecification, customTypeSpecification - , Definition(..), typeAliasDefinition, customTypeDefinition + , Definition(..), typeAliasDefinition, customTypeDefinition, definitionToSpecification , Constructors, Constructor(..) - , fuzzType - , encodeType, decodeType, encodeSpecification, encodeDefinition - , definitionToSpecification, eraseAttributes, mapDefinition, mapSpecification, mapTypeAttributes, rewriteType + , mapTypeAttributes, mapSpecificationAttributes, mapDefinitionAttributes, mapDefinition, eraseAttributes ) {-| This module contains the building blocks of types in the Morphir IR. @@ -23,24 +21,19 @@ module Morphir.IR.Type exposing @docs variable, reference, tuple, record, extensibleRecord, function, unit -## Matching - -@docs matchVariable, matchReference, matchTuple, matchRecord, matchExtensibleRecord, matchFunction, matchUnit - - # Record Field -@docs Field, matchField, mapFieldName, mapFieldType +@docs Field, mapFieldName, mapFieldType # Specification -@docs Specification, typeAliasSpecification, opaqueTypeSpecification, customTypeSpecification, matchCustomTypeSpecification +@docs Specification, typeAliasSpecification, opaqueTypeSpecification, customTypeSpecification # Definition -@docs Definition, typeAliasDefinition, customTypeDefinition +@docs Definition, typeAliasDefinition, customTypeDefinition, definitionToSpecification # Constructors @@ -48,26 +41,16 @@ module Morphir.IR.Type exposing @docs Constructors, Constructor -# Property Testing - -@docs fuzzType +# Mapping - -# Serialization - -@docs encodeType, decodeType, encodeSpecification, encodeDefinition +@docs mapTypeAttributes, mapSpecificationAttributes, mapDefinitionAttributes, mapDefinition, eraseAttributes -} -import Fuzz exposing (Fuzzer) -import Json.Decode as Decode -import Json.Encode as Encode -import Morphir.IR.AccessControlled as AccessControlled exposing (AccessControlled, encodeAccessControlled, withPublicAccess) -import Morphir.IR.FQName exposing (FQName, decodeFQName, encodeFQName, fuzzFQName) -import Morphir.IR.Name exposing (Name, decodeName, encodeName, fuzzName) +import Morphir.IR.AccessControlled as AccessControlled exposing (AccessControlled, withPublicAccess) +import Morphir.IR.FQName exposing (FQName) +import Morphir.IR.Name exposing (Name) import Morphir.ListOfResults as ListOfResults -import Morphir.Pattern exposing (Pattern) -import Morphir.Rewrite exposing (Rewrite) {-| An opaque representation of a type. Check out the docs for each building blocks @@ -131,6 +114,7 @@ type Constructor a = Constructor Name (List ( Name, Type a )) +{-| -} definitionToSpecification : Definition a -> Specification a definitionToSpecification def = case def of @@ -146,41 +130,33 @@ definitionToSpecification def = OpaqueTypeSpecification params -mapSpecification : (Type a -> Result e (Type b)) -> Specification a -> Result (List e) (Specification b) -mapSpecification f spec = +{-| -} +mapSpecificationAttributes : (a -> b) -> Specification a -> Specification b +mapSpecificationAttributes f spec = case spec of TypeAliasSpecification params tpe -> - f tpe - |> Result.map (TypeAliasSpecification params) - |> Result.mapError List.singleton + TypeAliasSpecification params (mapTypeAttributes f tpe) OpaqueTypeSpecification params -> OpaqueTypeSpecification params - |> Ok CustomTypeSpecification params constructors -> - let - ctorsResult : Result (List e) (Constructors b) - ctorsResult = - constructors - |> List.map - (\(Constructor ctorName ctorArgs) -> - ctorArgs + CustomTypeSpecification params + (constructors + |> List.map + (\(Constructor ctorName ctorArgs) -> + Constructor ctorName + (ctorArgs |> List.map (\( argName, argType ) -> - f argType - |> Result.map (Tuple.pair argName) + ( argName, mapTypeAttributes f argType ) ) - |> ListOfResults.liftAllErrors - |> Result.map (Constructor ctorName) - ) - |> ListOfResults.liftAllErrors - |> Result.mapError List.concat - in - ctorsResult - |> Result.map (CustomTypeSpecification params) + ) + ) + ) +{-| -} mapDefinition : (Type a -> Result e (Type b)) -> Definition a -> Result (List e) (Definition b) mapDefinition f def = case def of @@ -213,6 +189,32 @@ mapDefinition f def = |> Result.map (CustomTypeDefinition params) +{-| -} +mapDefinitionAttributes : (a -> b) -> Definition a -> Definition b +mapDefinitionAttributes f def = + case def of + TypeAliasDefinition params tpe -> + TypeAliasDefinition params (mapTypeAttributes f tpe) + + CustomTypeDefinition params constructors -> + CustomTypeDefinition params + (AccessControlled constructors.access + (constructors.value + |> List.map + (\(Constructor ctorName ctorArgs) -> + Constructor ctorName + (ctorArgs + |> List.map + (\( argName, argType ) -> + ( argName, mapTypeAttributes f argType ) + ) + ) + ) + ) + ) + + +{-| -} mapTypeAttributes : (a -> b) -> Type a -> Type b mapTypeAttributes f tpe = case tpe of @@ -238,6 +240,7 @@ mapTypeAttributes f tpe = Unit (f a) +{-| -} typeAttributes : Type a -> a typeAttributes tpe = case tpe of @@ -263,6 +266,7 @@ typeAttributes tpe = a +{-| -} eraseAttributes : Definition a -> Definition () eraseAttributes typeDef = case typeDef of @@ -430,86 +434,6 @@ customTypeSpecification typeParams ctors = CustomTypeSpecification typeParams ctors -rewriteType : Rewrite e (Type a) -rewriteType rewriteBranch rewriteLeaf typeToRewrite = - case typeToRewrite of - Reference a fQName argTypes -> - argTypes - |> List.foldr - (\nextArg resultSoFar -> - Result.map2 (::) - (rewriteBranch nextArg) - resultSoFar - ) - (Ok []) - |> Result.map (Reference a fQName) - - Tuple a elemTypes -> - elemTypes - |> List.foldr - (\nextArg resultSoFar -> - Result.map2 (::) - (rewriteBranch nextArg) - resultSoFar - ) - (Ok []) - |> Result.map (Tuple a) - - Record a fieldTypes -> - fieldTypes - |> List.foldr - (\field resultSoFar -> - Result.map2 (::) - (rewriteBranch field.tpe - |> Result.map (Field field.name) - ) - resultSoFar - ) - (Ok []) - |> Result.map (Record a) - - ExtensibleRecord a varName fieldTypes -> - fieldTypes - |> List.foldr - (\field resultSoFar -> - Result.map2 (::) - (rewriteBranch field.tpe - |> Result.map (Field field.name) - ) - resultSoFar - ) - (Ok []) - |> Result.map (ExtensibleRecord a varName) - - Function a argType returnType -> - Result.map2 (Function a) - (rewriteBranch argType) - (rewriteBranch returnType) - - _ -> - rewriteLeaf typeToRewrite - - -{-| Matches a field. - - let - field = - field [ "foo" ] SDK.Basics.intType - - pattern = - matchField matchAny matchAny - in - pattern field - == Just ( [ "foo" ], SDK.Basics.intType ) - --} -matchField : Pattern Name a -> Pattern (Type a) b -> Pattern (Field a) ( a, b ) -matchField matchFieldName matchFieldType field = - Maybe.map2 Tuple.pair - (matchFieldName field.name) - (matchFieldType field.tpe) - - {-| Map the name of the field to get a new field. -} mapFieldName : (Name -> Name) -> Field a -> Field a @@ -522,274 +446,3 @@ mapFieldName f field = mapFieldType : (Type a -> Type b) -> Field a -> Field b mapFieldType f field = Field field.name (f field.tpe) - - -{-| Generate random types. --} -fuzzType : Int -> Fuzzer a -> Fuzzer (Type a) -fuzzType maxDepth fuzzAttributes = - let - fuzzField depth = - Fuzz.map2 Field - fuzzName - (fuzzType depth fuzzAttributes) - - fuzzVariable = - Fuzz.map2 Variable - fuzzAttributes - fuzzName - - fuzzReference depth = - Fuzz.map3 Reference - fuzzAttributes - fuzzFQName - (Fuzz.list (fuzzType depth fuzzAttributes) |> Fuzz.map (List.take depth)) - - fuzzTuple depth = - Fuzz.map2 Tuple - fuzzAttributes - (Fuzz.list (fuzzType depth fuzzAttributes) |> Fuzz.map (List.take depth)) - - fuzzRecord depth = - Fuzz.map2 Record - fuzzAttributes - (Fuzz.list (fuzzField (depth - 1)) |> Fuzz.map (List.take depth)) - - fuzzExtensibleRecord depth = - Fuzz.map3 ExtensibleRecord - fuzzAttributes - fuzzName - (Fuzz.list (fuzzField (depth - 1)) |> Fuzz.map (List.take depth)) - - fuzzFunction depth = - Fuzz.map3 Function - fuzzAttributes - (fuzzType depth fuzzAttributes) - (fuzzType depth fuzzAttributes) - - fuzzUnit = - Fuzz.map Unit - fuzzAttributes - - fuzzLeaf = - Fuzz.oneOf - [ fuzzVariable - , fuzzUnit - ] - - fuzzBranch depth = - Fuzz.oneOf - [ fuzzFunction depth - , fuzzReference depth - , fuzzTuple depth - , fuzzRecord depth - , fuzzExtensibleRecord depth - ] - in - if maxDepth <= 0 then - fuzzLeaf - - else - Fuzz.oneOf - [ fuzzLeaf - , fuzzBranch (maxDepth - 1) - ] - - -{-| Encode a type into JSON. --} -encodeType : (a -> Encode.Value) -> Type a -> Encode.Value -encodeType encodeAttributes tpe = - case tpe of - Variable a name -> - Encode.list identity - [ Encode.string "Variable" - , encodeAttributes a - , encodeName name - ] - - Reference a typeName typeParameters -> - Encode.list identity - [ Encode.string "Reference" - , encodeAttributes a - , encodeFQName typeName - , Encode.list (encodeType encodeAttributes) typeParameters - ] - - Tuple a elementTypes -> - Encode.list identity - [ Encode.string "Tuple" - , encodeAttributes a - , Encode.list (encodeType encodeAttributes) elementTypes - ] - - Record a fieldTypes -> - Encode.list identity - [ Encode.string "Record" - , encodeAttributes a - , Encode.list (encodeField encodeAttributes) fieldTypes - ] - - ExtensibleRecord a variableName fieldTypes -> - Encode.list identity - [ Encode.string "ExtensibleRecord" - , encodeAttributes a - , encodeName variableName - , Encode.list (encodeField encodeAttributes) fieldTypes - ] - - Function a argumentType returnType -> - Encode.list identity - [ Encode.string "Function" - , encodeAttributes a - , encodeType encodeAttributes argumentType - , encodeType encodeAttributes returnType - ] - - Unit a -> - Encode.list identity - [ Encode.string "Unit" - , encodeAttributes a - ] - - -{-| Decode a type from JSON. --} -decodeType : Decode.Decoder a -> Decode.Decoder (Type a) -decodeType decodeAttributes = - let - lazyDecodeType = - Decode.lazy - (\_ -> - decodeType decodeAttributes - ) - - lazyDecodeField = - Decode.lazy - (\_ -> - decodeField decodeAttributes - ) - in - Decode.index 0 Decode.string - |> Decode.andThen - (\kind -> - case kind of - "Variable" -> - Decode.map2 Variable - (Decode.index 1 decodeAttributes) - (Decode.index 2 decodeName) - - "Reference" -> - Decode.map3 Reference - (Decode.index 1 decodeAttributes) - (Decode.index 2 decodeFQName) - (Decode.index 3 (Decode.list (Decode.lazy (\_ -> decodeType decodeAttributes)))) - - "Tuple" -> - Decode.map2 Tuple - (Decode.index 1 decodeAttributes) - (Decode.index 2 (Decode.list lazyDecodeType)) - - "Record" -> - Decode.map2 Record - (Decode.index 1 decodeAttributes) - (Decode.index 2 (Decode.list lazyDecodeField)) - - "ExtensibleRecord" -> - Decode.map3 ExtensibleRecord - (Decode.index 1 decodeAttributes) - (Decode.index 2 decodeName) - (Decode.index 3 (Decode.list lazyDecodeField)) - - "Function" -> - Decode.map3 Function - (Decode.index 1 decodeAttributes) - (Decode.index 2 lazyDecodeType) - (Decode.index 3 lazyDecodeType) - - "Unit" -> - Decode.map Unit - (Decode.index 1 decodeAttributes) - - _ -> - Decode.fail ("Unknown kind: " ++ kind) - ) - - -encodeField : (a -> Encode.Value) -> Field a -> Encode.Value -encodeField encodeAttributes field = - Encode.list identity - [ encodeName field.name - , encodeType encodeAttributes field.tpe - ] - - -decodeField : Decode.Decoder a -> Decode.Decoder (Field a) -decodeField decodeAttributes = - Decode.map2 Field - (Decode.index 0 decodeName) - (Decode.index 1 (decodeType decodeAttributes)) - - -{-| -} -encodeSpecification : (a -> Encode.Value) -> Specification a -> Encode.Value -encodeSpecification encodeAttributes spec = - case spec of - TypeAliasSpecification params exp -> - Encode.list identity - [ Encode.string "TypeAliasSpecification" - , Encode.list encodeName params - , encodeType encodeAttributes exp - ] - - OpaqueTypeSpecification params -> - Encode.list identity - [ Encode.string "OpaqueTypeSpecification" - , Encode.list encodeName params - ] - - CustomTypeSpecification params ctors -> - Encode.list identity - [ Encode.string "CustomTypeSpecification" - , Encode.list encodeName params - , encodeConstructors encodeAttributes ctors - ] - - -{-| -} -encodeDefinition : (a -> Encode.Value) -> Definition a -> Encode.Value -encodeDefinition encodeAttributes def = - case def of - TypeAliasDefinition params exp -> - Encode.list identity - [ Encode.string "TypeAliasDefinition" - , Encode.list encodeName params - , encodeType encodeAttributes exp - ] - - CustomTypeDefinition params ctors -> - Encode.list identity - [ Encode.string "CustomTypeDefinition" - , Encode.list encodeName params - , encodeAccessControlled (encodeConstructors encodeAttributes) ctors - ] - - -encodeConstructors : (a -> Encode.Value) -> Constructors a -> Encode.Value -encodeConstructors encodeAttributes ctors = - ctors - |> Encode.list - (\(Constructor ctorName ctorArgs) -> - Encode.list identity - [ Encode.string "Constructor" - , encodeName ctorName - , ctorArgs - |> Encode.list - (\( argName, argType ) -> - Encode.list identity - [ encodeName argName - , encodeType encodeAttributes argType - ] - ) - ] - ) diff --git a/src/Morphir/IR/Type/Codec.elm b/src/Morphir/IR/Type/Codec.elm new file mode 100644 index 000000000..2ab0929b1 --- /dev/null +++ b/src/Morphir/IR/Type/Codec.elm @@ -0,0 +1,207 @@ +module Morphir.IR.Type.Codec exposing (..) + +import Json.Decode as Decode +import Json.Encode as Encode +import Morphir.IR.AccessControlled.Codec exposing (encodeAccessControlled) +import Morphir.IR.FQName.Codec exposing (decodeFQName, encodeFQName) +import Morphir.IR.Name.Codec exposing (decodeName, encodeName) +import Morphir.IR.Type exposing (Constructor(..), Constructors, Definition(..), Field, Specification(..), Type(..)) + + +{-| Encode a type into JSON. +-} +encodeType : (a -> Encode.Value) -> Type a -> Encode.Value +encodeType encodeAttributes tpe = + case tpe of + Variable a name -> + Encode.list identity + [ Encode.string "Variable" + , encodeAttributes a + , encodeName name + ] + + Reference a typeName typeParameters -> + Encode.list identity + [ Encode.string "Reference" + , encodeAttributes a + , encodeFQName typeName + , Encode.list (encodeType encodeAttributes) typeParameters + ] + + Tuple a elementTypes -> + Encode.list identity + [ Encode.string "Tuple" + , encodeAttributes a + , Encode.list (encodeType encodeAttributes) elementTypes + ] + + Record a fieldTypes -> + Encode.list identity + [ Encode.string "Record" + , encodeAttributes a + , Encode.list (encodeField encodeAttributes) fieldTypes + ] + + ExtensibleRecord a variableName fieldTypes -> + Encode.list identity + [ Encode.string "ExtensibleRecord" + , encodeAttributes a + , encodeName variableName + , Encode.list (encodeField encodeAttributes) fieldTypes + ] + + Function a argumentType returnType -> + Encode.list identity + [ Encode.string "Function" + , encodeAttributes a + , encodeType encodeAttributes argumentType + , encodeType encodeAttributes returnType + ] + + Unit a -> + Encode.list identity + [ Encode.string "Unit" + , encodeAttributes a + ] + + +{-| Decode a type from JSON. +-} +decodeType : Decode.Decoder a -> Decode.Decoder (Type a) +decodeType decodeAttributes = + let + lazyDecodeType = + Decode.lazy + (\_ -> + decodeType decodeAttributes + ) + + lazyDecodeField = + Decode.lazy + (\_ -> + decodeField decodeAttributes + ) + in + Decode.index 0 Decode.string + |> Decode.andThen + (\kind -> + case kind of + "Variable" -> + Decode.map2 Variable + (Decode.index 1 decodeAttributes) + (Decode.index 2 decodeName) + + "Reference" -> + Decode.map3 Reference + (Decode.index 1 decodeAttributes) + (Decode.index 2 decodeFQName) + (Decode.index 3 (Decode.list (Decode.lazy (\_ -> decodeType decodeAttributes)))) + + "Tuple" -> + Decode.map2 Tuple + (Decode.index 1 decodeAttributes) + (Decode.index 2 (Decode.list lazyDecodeType)) + + "Record" -> + Decode.map2 Record + (Decode.index 1 decodeAttributes) + (Decode.index 2 (Decode.list lazyDecodeField)) + + "ExtensibleRecord" -> + Decode.map3 ExtensibleRecord + (Decode.index 1 decodeAttributes) + (Decode.index 2 decodeName) + (Decode.index 3 (Decode.list lazyDecodeField)) + + "Function" -> + Decode.map3 Function + (Decode.index 1 decodeAttributes) + (Decode.index 2 lazyDecodeType) + (Decode.index 3 lazyDecodeType) + + "Unit" -> + Decode.map Unit + (Decode.index 1 decodeAttributes) + + _ -> + Decode.fail ("Unknown kind: " ++ kind) + ) + + +encodeField : (a -> Encode.Value) -> Field a -> Encode.Value +encodeField encodeAttributes field = + Encode.list identity + [ encodeName field.name + , encodeType encodeAttributes field.tpe + ] + + +decodeField : Decode.Decoder a -> Decode.Decoder (Field a) +decodeField decodeAttributes = + Decode.map2 Field + (Decode.index 0 decodeName) + (Decode.index 1 (decodeType decodeAttributes)) + + +{-| -} +encodeSpecification : (a -> Encode.Value) -> Specification a -> Encode.Value +encodeSpecification encodeAttributes spec = + case spec of + TypeAliasSpecification params exp -> + Encode.list identity + [ Encode.string "TypeAliasSpecification" + , Encode.list encodeName params + , encodeType encodeAttributes exp + ] + + OpaqueTypeSpecification params -> + Encode.list identity + [ Encode.string "OpaqueTypeSpecification" + , Encode.list encodeName params + ] + + CustomTypeSpecification params ctors -> + Encode.list identity + [ Encode.string "CustomTypeSpecification" + , Encode.list encodeName params + , encodeConstructors encodeAttributes ctors + ] + + +{-| -} +encodeDefinition : (a -> Encode.Value) -> Definition a -> Encode.Value +encodeDefinition encodeAttributes def = + case def of + TypeAliasDefinition params exp -> + Encode.list identity + [ Encode.string "TypeAliasDefinition" + , Encode.list encodeName params + , encodeType encodeAttributes exp + ] + + CustomTypeDefinition params ctors -> + Encode.list identity + [ Encode.string "CustomTypeDefinition" + , Encode.list encodeName params + , encodeAccessControlled (encodeConstructors encodeAttributes) ctors + ] + + +encodeConstructors : (a -> Encode.Value) -> Constructors a -> Encode.Value +encodeConstructors encodeAttributes ctors = + ctors + |> Encode.list + (\(Constructor ctorName ctorArgs) -> + Encode.list identity + [ Encode.string "Constructor" + , encodeName ctorName + , ctorArgs + |> Encode.list + (\( argName, argType ) -> + Encode.list identity + [ encodeName argName + , encodeType encodeAttributes argType + ] + ) + ] + ) diff --git a/src/Morphir/IR/Type/Fuzzer.elm b/src/Morphir/IR/Type/Fuzzer.elm new file mode 100644 index 000000000..4942e33ff --- /dev/null +++ b/src/Morphir/IR/Type/Fuzzer.elm @@ -0,0 +1,79 @@ +module Morphir.IR.Type.Fuzzer exposing (..) + +{-| Generate random types. +-} + +import Fuzz exposing (Fuzzer) +import Morphir.IR.FQName.Fuzzer exposing (fuzzFQName) +import Morphir.IR.Name.Fuzzer exposing (fuzzName) +import Morphir.IR.Type exposing (Field, Type(..)) + + +fuzzType : Int -> Fuzzer a -> Fuzzer (Type a) +fuzzType maxDepth fuzzAttributes = + let + fuzzField depth = + Fuzz.map2 Field + fuzzName + (fuzzType depth fuzzAttributes) + + fuzzVariable = + Fuzz.map2 Variable + fuzzAttributes + fuzzName + + fuzzReference depth = + Fuzz.map3 Reference + fuzzAttributes + fuzzFQName + (Fuzz.list (fuzzType depth fuzzAttributes) |> Fuzz.map (List.take depth)) + + fuzzTuple depth = + Fuzz.map2 Tuple + fuzzAttributes + (Fuzz.list (fuzzType depth fuzzAttributes) |> Fuzz.map (List.take depth)) + + fuzzRecord depth = + Fuzz.map2 Record + fuzzAttributes + (Fuzz.list (fuzzField (depth - 1)) |> Fuzz.map (List.take depth)) + + fuzzExtensibleRecord depth = + Fuzz.map3 ExtensibleRecord + fuzzAttributes + fuzzName + (Fuzz.list (fuzzField (depth - 1)) |> Fuzz.map (List.take depth)) + + fuzzFunction depth = + Fuzz.map3 Function + fuzzAttributes + (fuzzType depth fuzzAttributes) + (fuzzType depth fuzzAttributes) + + fuzzUnit = + Fuzz.map Unit + fuzzAttributes + + fuzzLeaf = + Fuzz.oneOf + [ fuzzVariable + , fuzzUnit + ] + + fuzzBranch depth = + Fuzz.oneOf + [ fuzzFunction depth + , fuzzReference depth + , fuzzTuple depth + , fuzzRecord depth + , fuzzExtensibleRecord depth + ] + in + if maxDepth <= 0 then + fuzzLeaf + + else + Fuzz.oneOf + [ fuzzLeaf + , fuzzBranch (maxDepth - 1) + ] diff --git a/src/Morphir/IR/Type/Rewrite.elm b/src/Morphir/IR/Type/Rewrite.elm new file mode 100644 index 000000000..512b42052 --- /dev/null +++ b/src/Morphir/IR/Type/Rewrite.elm @@ -0,0 +1,64 @@ +module Morphir.IR.Type.Rewrite exposing (..) + +import Morphir.IR.Type exposing (Field, Type(..)) +import Morphir.Rewrite exposing (Rewrite) + + +rewriteType : Rewrite e (Type a) +rewriteType rewriteBranch rewriteLeaf typeToRewrite = + case typeToRewrite of + Reference a fQName argTypes -> + argTypes + |> List.foldr + (\nextArg resultSoFar -> + Result.map2 (::) + (rewriteBranch nextArg) + resultSoFar + ) + (Ok []) + |> Result.map (Reference a fQName) + + Tuple a elemTypes -> + elemTypes + |> List.foldr + (\nextArg resultSoFar -> + Result.map2 (::) + (rewriteBranch nextArg) + resultSoFar + ) + (Ok []) + |> Result.map (Tuple a) + + Record a fieldTypes -> + fieldTypes + |> List.foldr + (\field resultSoFar -> + Result.map2 (::) + (rewriteBranch field.tpe + |> Result.map (Field field.name) + ) + resultSoFar + ) + (Ok []) + |> Result.map (Record a) + + ExtensibleRecord a varName fieldTypes -> + fieldTypes + |> List.foldr + (\field resultSoFar -> + Result.map2 (::) + (rewriteBranch field.tpe + |> Result.map (Field field.name) + ) + resultSoFar + ) + (Ok []) + |> Result.map (ExtensibleRecord a varName) + + Function a argType returnType -> + Result.map2 (Function a) + (rewriteBranch argType) + (rewriteBranch returnType) + + _ -> + rewriteLeaf typeToRewrite diff --git a/src/Morphir/IR/Value.elm b/src/Morphir/IR/Value.elm index 53c19c2f4..73db44186 100644 --- a/src/Morphir/IR/Value.elm +++ b/src/Morphir/IR/Value.elm @@ -1,12 +1,11 @@ module Morphir.IR.Value exposing ( Value(..), literal, constructor, apply, field, fieldFunction, lambda, letDef, letDestruct, letRec, list, record, reference , tuple, variable, ifThenElse, patternMatch, update, unit + , mapValueAttributes , Literal(..), boolLiteral, charLiteral, stringLiteral, intLiteral, floatLiteral , Pattern(..), wildcardPattern, asPattern, tuplePattern, recordPattern, constructorPattern, emptyListPattern, headTailPattern, literalPattern - , Specification - , Definition, typedDefinition, untypedDefinition - , encodeValue, encodeSpecification, encodeDefinition - , getDefinitionBody, mapDefinition, mapSpecification, mapValueAttributes + , Specification, mapSpecificationAttributes + , Definition, typedDefinition, untypedDefinition, mapDefinition, mapDefinitionAttributes ) {-| This module contains the building blocks of values in the Morphir IR. @@ -18,6 +17,7 @@ Value is the top level building block for data and logic. See the constructor fu @docs Value, literal, constructor, apply, field, fieldFunction, lambda, letDef, letDestruct, letRec, list, record, reference @docs tuple, variable, ifThenElse, patternMatch, update, unit +@docs mapValueAttributes # Literal @@ -47,7 +47,7 @@ destructuring and pattern-matching. Pattern-matching is a combination of destruc The specification of what the value or function is without the actual data or logic behind it. -@docs Specification +@docs Specification, mapSpecificationAttributes # Definition @@ -55,22 +55,14 @@ is without the actual data or logic behind it. A definition is the actual data or logic as opposed to a specification which is just the specification of those. Value definitions can be typed or untyped. Exposed values have to be typed. -@docs Definition, typedDefinition, untypedDefinition - - -# Serialization - -@docs encodeValue, encodeSpecification, encodeDefinition +@docs Definition, typedDefinition, untypedDefinition, mapDefinition, mapDefinitionAttributes -} import Dict exposing (Dict) -import Json.Decode as Decode -import Json.Encode as Encode -import Morphir.IR.FQName exposing (FQName, decodeFQName, encodeFQName) -import Morphir.IR.Name exposing (Name, decodeName, encodeName) -import Morphir.IR.Type as Type exposing (Type, decodeType, encodeType) -import Morphir.ListOfResults as ListOfResults +import Morphir.IR.FQName exposing (FQName) +import Morphir.IR.Name exposing (Name) +import Morphir.IR.Type as Type exposing (Type) import String @@ -135,16 +127,11 @@ which is just the specification of those. Value definitions can be typed or unty -} type alias Definition a = { valueType : Maybe (Type a) - , argumentNames : List Name + , arguments : List ( Name, a ) , body : Value a } -getDefinitionBody : Definition a -> Value a -getDefinitionBody = - .body - - -- definitionToSpecification : Definition extra -> Maybe (Specification extra) -- definitionToSpecification def = @@ -159,30 +146,10 @@ getDefinitionBody = -- in -mapSpecification : (Type a -> Result e (Type b)) -> (Value a -> Result e (Value b)) -> Specification a -> Result (List e) (Specification b) -mapSpecification mapType mapValue spec = - let - inputsResult = - spec.inputs - |> List.map - (\( name, tpe ) -> - mapType tpe - |> Result.map (Tuple.pair name) - ) - |> ListOfResults.liftAllErrors - - outputResult = - mapType spec.output - |> Result.mapError List.singleton - in - Result.map2 Specification - inputsResult - outputResult - - -mapDefinition : (Type a -> Result e (Type b)) -> (Value a -> Result e (Value b)) -> Definition a -> Result (List e) (Definition b) +{-| -} +mapDefinition : (Type a -> Result e (Type a)) -> (Value a -> Result e (Value a)) -> Definition a -> Result (List e) (Definition a) mapDefinition mapType mapValue def = - Result.map2 (\t v -> Definition t def.argumentNames v) + Result.map2 (\t v -> Definition t def.arguments v) (case def.valueType of Just valueType -> mapType valueType @@ -195,6 +162,20 @@ mapDefinition mapType mapValue def = |> Result.mapError List.singleton +{-| -} +mapSpecificationAttributes : (a -> b) -> Specification a -> Specification b +mapSpecificationAttributes f spec = + Specification + (spec.inputs + |> List.map + (\( name, tpe ) -> + ( name, Type.mapTypeAttributes f tpe ) + ) + ) + (Type.mapTypeAttributes f spec.output) + + +{-| -} mapValueAttributes : (a -> b) -> Value a -> Value b mapValueAttributes f v = case v of @@ -280,6 +261,7 @@ mapValueAttributes f v = Unit (f a) +{-| -} mapPatternAttributes : (a -> b) -> Pattern a -> Pattern b mapPatternAttributes f p = case p of @@ -311,9 +293,13 @@ mapPatternAttributes f p = UnitPattern (f a) +{-| -} mapDefinitionAttributes : (a -> b) -> Definition a -> Definition b mapDefinitionAttributes f d = - Definition (d.valueType |> Maybe.map (Type.mapTypeAttributes f)) d.argumentNames (mapValueAttributes f d.body) + Definition + (d.valueType |> Maybe.map (Type.mapTypeAttributes f)) + (d.arguments |> List.map (\( name, a ) -> ( name, f a ))) + (mapValueAttributes f d.body) @@ -865,7 +851,7 @@ arguments. The examples below try to visualize the process. body -} -typedDefinition : Type a -> List Name -> Value a -> Definition a +typedDefinition : Type a -> List ( Name, a ) -> Value a -> Definition a typedDefinition valueType argumentNames body = Definition (Just valueType) argumentNames body @@ -888,559 +874,6 @@ arguments. The examples below try to visualize the process. body -} -untypedDefinition : List Name -> Value a -> Definition a +untypedDefinition : List ( Name, a ) -> Value a -> Definition a untypedDefinition argumentNames body = Definition Nothing argumentNames body - - -encodeValue : (a -> Encode.Value) -> Value a -> Encode.Value -encodeValue encodeAttributes v = - case v of - Literal a value -> - Encode.list identity - [ Encode.string "Literal" - , encodeAttributes a - , encodeLiteral value - ] - - Constructor a fullyQualifiedName -> - Encode.list identity - [ Encode.string "Constructor" - , encodeAttributes a - , encodeFQName fullyQualifiedName - ] - - Tuple a elements -> - Encode.list identity - [ Encode.string "Tuple" - , encodeAttributes a - , elements |> Encode.list (encodeValue encodeAttributes) - ] - - List a items -> - Encode.list identity - [ Encode.string "List" - , encodeAttributes a - , items |> Encode.list (encodeValue encodeAttributes) - ] - - Record a fields -> - Encode.list identity - [ Encode.string "Record" - , encodeAttributes a - , fields - |> Encode.list - (\( fieldName, fieldValue ) -> - Encode.list identity - [ encodeName fieldName - , encodeValue encodeAttributes fieldValue - ] - ) - ] - - Variable a name -> - Encode.list identity - [ Encode.string "Variable" - , encodeAttributes a - , encodeName name - ] - - Reference a fullyQualifiedName -> - Encode.list identity - [ Encode.string "Reference" - , encodeAttributes a - , encodeFQName fullyQualifiedName - ] - - Field a subjectValue fieldName -> - Encode.list identity - [ Encode.string "Field" - , encodeAttributes a - , encodeValue encodeAttributes subjectValue - , encodeName fieldName - ] - - FieldFunction a fieldName -> - Encode.list identity - [ Encode.string "FieldFunction" - , encodeAttributes a - , encodeName fieldName - ] - - Apply a function argument -> - Encode.list identity - [ Encode.string "Apply" - , encodeAttributes a - , encodeValue encodeAttributes function - , encodeValue encodeAttributes argument - ] - - Lambda a argumentPattern body -> - Encode.list identity - [ Encode.string "Lambda" - , encodeAttributes a - , encodePattern encodeAttributes argumentPattern - , encodeValue encodeAttributes body - ] - - LetDefinition a valueName valueDefinition inValue -> - Encode.list identity - [ Encode.string "LetDefinition" - , encodeAttributes a - , encodeName valueName - , encodeDefinition encodeAttributes valueDefinition - , encodeValue encodeAttributes inValue - ] - - LetRecursion a valueDefinitions inValue -> - Encode.list identity - [ Encode.string "LetRecursion" - , encodeAttributes a - , valueDefinitions - |> Dict.toList - |> Encode.list - (\( name, def ) -> - Encode.list identity - [ encodeName name - , encodeDefinition encodeAttributes def - ] - ) - , encodeValue encodeAttributes inValue - ] - - Destructure a pattern valueToDestruct inValue -> - Encode.list identity - [ Encode.string "Destructure" - , encodeAttributes a - , encodePattern encodeAttributes pattern - , encodeValue encodeAttributes valueToDestruct - , encodeValue encodeAttributes inValue - ] - - IfThenElse a condition thenBranch elseBranch -> - Encode.list identity - [ Encode.string "IfThenElse" - , encodeAttributes a - , encodeValue encodeAttributes condition - , encodeValue encodeAttributes thenBranch - , encodeValue encodeAttributes elseBranch - ] - - PatternMatch a branchOutOn cases -> - Encode.list identity - [ Encode.string "PatternMatch" - , encodeAttributes a - , encodeValue encodeAttributes branchOutOn - , cases - |> Encode.list - (\( pattern, body ) -> - Encode.list identity - [ encodePattern encodeAttributes pattern - , encodeValue encodeAttributes body - ] - ) - ] - - UpdateRecord a valueToUpdate fieldsToUpdate -> - Encode.list identity - [ Encode.string "Update" - , encodeAttributes a - , encodeValue encodeAttributes valueToUpdate - , fieldsToUpdate - |> Encode.list - (\( fieldName, fieldValue ) -> - Encode.list identity - [ encodeName fieldName - , encodeValue encodeAttributes fieldValue - ] - ) - ] - - Unit a -> - Encode.list identity - [ Encode.string "Unit" - , encodeAttributes a - ] - - -decodeValue : Decode.Decoder a -> Decode.Decoder (Value a) -decodeValue decodeAttributes = - let - lazyDecodeValue = - Decode.lazy <| - \_ -> - decodeValue decodeAttributes - in - Decode.index 0 Decode.string - |> Decode.andThen - (\kind -> - case kind of - "Literal" -> - Decode.map2 Literal - (Decode.index 1 decodeAttributes) - (Decode.index 2 decodeLiteral) - - "Constructor" -> - Decode.map2 Constructor - (Decode.index 1 decodeAttributes) - (Decode.index 2 decodeFQName) - - "Tuple" -> - Decode.map2 Tuple - (Decode.index 1 decodeAttributes) - (Decode.index 2 <| Decode.list lazyDecodeValue) - - "List" -> - Decode.map2 List - (Decode.index 1 decodeAttributes) - (Decode.index 2 <| Decode.list lazyDecodeValue) - - "Record" -> - Decode.map2 Record - (Decode.index 1 decodeAttributes) - (Decode.index 2 - (Decode.list - (Decode.map2 Tuple.pair - (Decode.index 0 decodeName) - (Decode.index 1 <| decodeValue decodeAttributes) - ) - ) - ) - - "Variable" -> - Decode.map2 Variable - (Decode.index 1 decodeAttributes) - (Decode.index 2 decodeName) - - "Reference" -> - Decode.map2 Reference - (Decode.index 1 decodeAttributes) - (Decode.index 2 decodeFQName) - - "Field" -> - Decode.map3 Field - (Decode.index 1 decodeAttributes) - (Decode.index 2 <| decodeValue decodeAttributes) - (Decode.index 3 decodeName) - - "FieldFunction" -> - Decode.map2 FieldFunction - (Decode.index 1 decodeAttributes) - (Decode.index 2 decodeName) - - "Apply" -> - Decode.map3 Apply - (Decode.index 1 decodeAttributes) - (Decode.index 2 <| decodeValue decodeAttributes) - (Decode.index 3 <| decodeValue decodeAttributes) - - "Lambda" -> - Decode.map3 Lambda - (Decode.index 1 decodeAttributes) - (Decode.index 2 <| decodePattern decodeAttributes) - (Decode.index 3 <| decodeValue decodeAttributes) - - "LetDefinition" -> - Decode.map4 LetDefinition - (Decode.index 1 decodeAttributes) - (Decode.index 2 decodeName) - (Decode.index 3 <| decodeDefinition decodeAttributes) - (Decode.index 4 <| decodeValue decodeAttributes) - - "LetRecursion" -> - Decode.map3 LetRecursion - (Decode.index 1 decodeAttributes) - (Decode.index 2 - (Decode.list - (Decode.map2 Tuple.pair - (Decode.index 0 decodeName) - (Decode.index 1 <| decodeDefinition decodeAttributes) - ) - |> Decode.map Dict.fromList - ) - ) - (Decode.index 3 <| decodeValue decodeAttributes) - - "Destructure" -> - Decode.map4 Destructure - (Decode.index 1 decodeAttributes) - (Decode.index 2 <| decodePattern decodeAttributes) - (Decode.index 3 <| decodeValue decodeAttributes) - (Decode.index 4 <| decodeValue decodeAttributes) - - "IfThenElse" -> - Decode.map4 IfThenElse - (Decode.index 1 decodeAttributes) - (Decode.index 2 <| decodeValue decodeAttributes) - (Decode.index 3 <| decodeValue decodeAttributes) - (Decode.index 4 <| decodeValue decodeAttributes) - - "PatternMatch" -> - Decode.map3 PatternMatch - (Decode.index 1 decodeAttributes) - (Decode.index 2 <| decodeValue decodeAttributes) - (Decode.index 3 <| - Decode.list - (Decode.map2 Tuple.pair - (decodePattern decodeAttributes) - (decodeValue decodeAttributes) - ) - ) - - "UpdateRecord" -> - Decode.map3 UpdateRecord - (Decode.index 1 decodeAttributes) - (Decode.index 2 <| decodeValue decodeAttributes) - (Decode.index 3 <| - Decode.list <| - Decode.map2 Tuple.pair - decodeName - (decodeValue decodeAttributes) - ) - - "Unit" -> - Decode.map Unit - (Decode.index 1 decodeAttributes) - - other -> - Decode.fail <| "Unknown value type: " ++ other - ) - - -encodePattern : (a -> Encode.Value) -> Pattern a -> Encode.Value -encodePattern encodeAttributes pattern = - case pattern of - WildcardPattern a -> - Encode.list identity - [ Encode.string "WildcardPattern" - , encodeAttributes a - ] - - AsPattern a p name -> - Encode.list identity - [ Encode.string "AsPattern" - , encodeAttributes a - , encodePattern encodeAttributes p - , encodeName name - ] - - TuplePattern a elementPatterns -> - Encode.list identity - [ Encode.string "TuplePattern" - , encodeAttributes a - , elementPatterns |> Encode.list (encodePattern encodeAttributes) - ] - - RecordPattern a fieldNames -> - Encode.list identity - [ Encode.string "RecordPattern" - , encodeAttributes a - , fieldNames |> Encode.list encodeName - ] - - ConstructorPattern a constructorName argumentPatterns -> - Encode.list identity - [ Encode.string "ConstructorPattern" - , encodeAttributes a - , encodeFQName constructorName - , argumentPatterns |> Encode.list (encodePattern encodeAttributes) - ] - - EmptyListPattern a -> - Encode.list identity - [ Encode.string "EmptyListPattern" - , encodeAttributes a - ] - - HeadTailPattern a headPattern tailPattern -> - Encode.list identity - [ Encode.string "HeadTailPattern" - , encodeAttributes a - , encodePattern encodeAttributes headPattern - , encodePattern encodeAttributes tailPattern - ] - - LiteralPattern a value -> - Encode.list identity - [ Encode.string "LiteralPattern" - , encodeAttributes a - , encodeLiteral value - ] - - UnitPattern a -> - Encode.list identity - [ Encode.string "UnitPattern" - , encodeAttributes a - ] - - -decodePattern : Decode.Decoder a -> Decode.Decoder (Pattern a) -decodePattern decodeAttributes = - let - lazyDecodePattern = - Decode.lazy <| - \_ -> - decodePattern decodeAttributes - in - Decode.index 0 Decode.string - |> Decode.andThen - (\kind -> - case kind of - "WildcardPattern" -> - Decode.map WildcardPattern - (Decode.index 1 decodeAttributes) - - "AsPattern" -> - Decode.map3 AsPattern - (Decode.index 1 decodeAttributes) - (Decode.index 2 lazyDecodePattern) - (Decode.index 3 decodeName) - - "TuplePattern" -> - Decode.map2 TuplePattern - (Decode.index 1 decodeAttributes) - (Decode.index 2 <| Decode.list lazyDecodePattern) - - "RecordPattern" -> - Decode.map2 RecordPattern - (Decode.index 1 decodeAttributes) - (Decode.index 2 <| Decode.list decodeName) - - "ConstructorPattern" -> - Decode.map3 ConstructorPattern - (Decode.index 1 decodeAttributes) - (Decode.index 2 decodeFQName) - (Decode.index 3 <| Decode.list lazyDecodePattern) - - "EmptyListPattern" -> - Decode.map EmptyListPattern - (Decode.index 1 decodeAttributes) - - "HeadTailPattern" -> - Decode.map3 HeadTailPattern - (Decode.index 1 decodeAttributes) - (Decode.index 2 lazyDecodePattern) - (Decode.index 3 lazyDecodePattern) - - other -> - Decode.fail <| "Unknown pattern type: " ++ other - ) - - -encodeLiteral : Literal -> Encode.Value -encodeLiteral l = - let - typeTag tag = - ( "@type", Encode.string tag ) - in - case l of - BoolLiteral v -> - Encode.object - [ typeTag "boolLiteral" - , ( "value", Encode.bool v ) - ] - - CharLiteral v -> - Encode.object - [ typeTag "charLiteral" - , ( "value", Encode.string (String.fromChar v) ) - ] - - StringLiteral v -> - Encode.object - [ typeTag "stringLiteral" - , ( "value", Encode.string v ) - ] - - IntLiteral v -> - Encode.object - [ typeTag "intLiteral" - , ( "value", Encode.int v ) - ] - - FloatLiteral v -> - Encode.object - [ typeTag "floatLiteral" - , ( "value", Encode.float v ) - ] - - -decodeLiteral : Decode.Decoder Literal -decodeLiteral = - Decode.field "@type" Decode.string - |> Decode.andThen - (\kind -> - case kind of - "boolLiteral" -> - Decode.map BoolLiteral - (Decode.field "value" Decode.bool) - - "charLiteral" -> - Decode.map CharLiteral - (Decode.field "value" Decode.string - |> Decode.andThen - (\str -> - case String.uncons str of - Just ( ch, _ ) -> - Decode.succeed ch - - Nothing -> - Decode.fail "Single char expected" - ) - ) - - "stringLiteral" -> - Decode.map StringLiteral - (Decode.field "value" Decode.string) - - "intLiteral" -> - Decode.map IntLiteral - (Decode.field "value" Decode.int) - - "floatLiteral" -> - Decode.map FloatLiteral - (Decode.field "value" Decode.float) - - other -> - Decode.fail <| "Unknown literal type: " ++ other - ) - - -encodeSpecification : (a -> Encode.Value) -> Specification a -> Encode.Value -encodeSpecification encodeAttributes spec = - Encode.object - [ ( "inputs" - , spec.inputs - |> Encode.list - (\( argName, argType ) -> - Encode.object - [ ( "argName", encodeName argName ) - , ( "argType", encodeType encodeAttributes argType ) - ] - ) - ) - , ( "output", encodeType encodeAttributes spec.output ) - ] - - -encodeDefinition : (a -> Encode.Value) -> Definition a -> Encode.Value -encodeDefinition encodeAttributes def = - Encode.list identity - [ Encode.string "Definition" - , case def.valueType of - Just valueType -> - encodeType encodeAttributes valueType - - Nothing -> - Encode.null - , def.argumentNames |> Encode.list encodeName - , encodeValue encodeAttributes def.body - ] - - -decodeDefinition : Decode.Decoder a -> Decode.Decoder (Definition a) -decodeDefinition decodeAttributes = - Decode.map3 Definition - (Decode.index 1 (Decode.maybe (decodeType decodeAttributes))) - (Decode.index 2 (Decode.list decodeName)) - (Decode.index 3 (Decode.lazy (\_ -> decodeValue decodeAttributes))) diff --git a/src/Morphir/IR/Value/Codec.elm b/src/Morphir/IR/Value/Codec.elm new file mode 100644 index 000000000..1507281ec --- /dev/null +++ b/src/Morphir/IR/Value/Codec.elm @@ -0,0 +1,569 @@ +module Morphir.IR.Value.Codec exposing (..) + +import Dict +import Json.Decode as Decode +import Json.Encode as Encode +import Morphir.IR.FQName.Codec exposing (decodeFQName, encodeFQName) +import Morphir.IR.Name.Codec exposing (decodeName, encodeName) +import Morphir.IR.Type.Codec exposing (decodeType, encodeType) +import Morphir.IR.Value exposing (Definition, Literal(..), Pattern(..), Specification, Value(..)) + + +encodeValue : (a -> Encode.Value) -> Value a -> Encode.Value +encodeValue encodeAttributes v = + case v of + Literal a value -> + Encode.list identity + [ Encode.string "Literal" + , encodeAttributes a + , encodeLiteral value + ] + + Constructor a fullyQualifiedName -> + Encode.list identity + [ Encode.string "Constructor" + , encodeAttributes a + , encodeFQName fullyQualifiedName + ] + + Tuple a elements -> + Encode.list identity + [ Encode.string "Tuple" + , encodeAttributes a + , elements |> Encode.list (encodeValue encodeAttributes) + ] + + List a items -> + Encode.list identity + [ Encode.string "List" + , encodeAttributes a + , items |> Encode.list (encodeValue encodeAttributes) + ] + + Record a fields -> + Encode.list identity + [ Encode.string "Record" + , encodeAttributes a + , fields + |> Encode.list + (\( fieldName, fieldValue ) -> + Encode.list identity + [ encodeName fieldName + , encodeValue encodeAttributes fieldValue + ] + ) + ] + + Variable a name -> + Encode.list identity + [ Encode.string "Variable" + , encodeAttributes a + , encodeName name + ] + + Reference a fullyQualifiedName -> + Encode.list identity + [ Encode.string "Reference" + , encodeAttributes a + , encodeFQName fullyQualifiedName + ] + + Field a subjectValue fieldName -> + Encode.list identity + [ Encode.string "Field" + , encodeAttributes a + , encodeValue encodeAttributes subjectValue + , encodeName fieldName + ] + + FieldFunction a fieldName -> + Encode.list identity + [ Encode.string "FieldFunction" + , encodeAttributes a + , encodeName fieldName + ] + + Apply a function argument -> + Encode.list identity + [ Encode.string "Apply" + , encodeAttributes a + , encodeValue encodeAttributes function + , encodeValue encodeAttributes argument + ] + + Lambda a argumentPattern body -> + Encode.list identity + [ Encode.string "Lambda" + , encodeAttributes a + , encodePattern encodeAttributes argumentPattern + , encodeValue encodeAttributes body + ] + + LetDefinition a valueName valueDefinition inValue -> + Encode.list identity + [ Encode.string "LetDefinition" + , encodeAttributes a + , encodeName valueName + , encodeDefinition encodeAttributes valueDefinition + , encodeValue encodeAttributes inValue + ] + + LetRecursion a valueDefinitions inValue -> + Encode.list identity + [ Encode.string "LetRecursion" + , encodeAttributes a + , valueDefinitions + |> Dict.toList + |> Encode.list + (\( name, def ) -> + Encode.list identity + [ encodeName name + , encodeDefinition encodeAttributes def + ] + ) + , encodeValue encodeAttributes inValue + ] + + Destructure a pattern valueToDestruct inValue -> + Encode.list identity + [ Encode.string "Destructure" + , encodeAttributes a + , encodePattern encodeAttributes pattern + , encodeValue encodeAttributes valueToDestruct + , encodeValue encodeAttributes inValue + ] + + IfThenElse a condition thenBranch elseBranch -> + Encode.list identity + [ Encode.string "IfThenElse" + , encodeAttributes a + , encodeValue encodeAttributes condition + , encodeValue encodeAttributes thenBranch + , encodeValue encodeAttributes elseBranch + ] + + PatternMatch a branchOutOn cases -> + Encode.list identity + [ Encode.string "PatternMatch" + , encodeAttributes a + , encodeValue encodeAttributes branchOutOn + , cases + |> Encode.list + (\( pattern, body ) -> + Encode.list identity + [ encodePattern encodeAttributes pattern + , encodeValue encodeAttributes body + ] + ) + ] + + UpdateRecord a valueToUpdate fieldsToUpdate -> + Encode.list identity + [ Encode.string "Update" + , encodeAttributes a + , encodeValue encodeAttributes valueToUpdate + , fieldsToUpdate + |> Encode.list + (\( fieldName, fieldValue ) -> + Encode.list identity + [ encodeName fieldName + , encodeValue encodeAttributes fieldValue + ] + ) + ] + + Unit a -> + Encode.list identity + [ Encode.string "Unit" + , encodeAttributes a + ] + + +decodeValue : Decode.Decoder a -> Decode.Decoder (Value a) +decodeValue decodeAttributes = + let + lazyDecodeValue = + Decode.lazy <| + \_ -> + decodeValue decodeAttributes + in + Decode.index 0 Decode.string + |> Decode.andThen + (\kind -> + case kind of + "Literal" -> + Decode.map2 Literal + (Decode.index 1 decodeAttributes) + (Decode.index 2 decodeLiteral) + + "Constructor" -> + Decode.map2 Constructor + (Decode.index 1 decodeAttributes) + (Decode.index 2 decodeFQName) + + "Tuple" -> + Decode.map2 Tuple + (Decode.index 1 decodeAttributes) + (Decode.index 2 <| Decode.list lazyDecodeValue) + + "List" -> + Decode.map2 List + (Decode.index 1 decodeAttributes) + (Decode.index 2 <| Decode.list lazyDecodeValue) + + "Record" -> + Decode.map2 Record + (Decode.index 1 decodeAttributes) + (Decode.index 2 + (Decode.list + (Decode.map2 Tuple.pair + (Decode.index 0 decodeName) + (Decode.index 1 <| decodeValue decodeAttributes) + ) + ) + ) + + "Variable" -> + Decode.map2 Variable + (Decode.index 1 decodeAttributes) + (Decode.index 2 decodeName) + + "Reference" -> + Decode.map2 Reference + (Decode.index 1 decodeAttributes) + (Decode.index 2 decodeFQName) + + "Field" -> + Decode.map3 Field + (Decode.index 1 decodeAttributes) + (Decode.index 2 <| decodeValue decodeAttributes) + (Decode.index 3 decodeName) + + "FieldFunction" -> + Decode.map2 FieldFunction + (Decode.index 1 decodeAttributes) + (Decode.index 2 decodeName) + + "Apply" -> + Decode.map3 Apply + (Decode.index 1 decodeAttributes) + (Decode.index 2 <| decodeValue decodeAttributes) + (Decode.index 3 <| decodeValue decodeAttributes) + + "Lambda" -> + Decode.map3 Lambda + (Decode.index 1 decodeAttributes) + (Decode.index 2 <| decodePattern decodeAttributes) + (Decode.index 3 <| decodeValue decodeAttributes) + + "LetDefinition" -> + Decode.map4 LetDefinition + (Decode.index 1 decodeAttributes) + (Decode.index 2 decodeName) + (Decode.index 3 <| decodeDefinition decodeAttributes) + (Decode.index 4 <| decodeValue decodeAttributes) + + "LetRecursion" -> + Decode.map3 LetRecursion + (Decode.index 1 decodeAttributes) + (Decode.index 2 + (Decode.list + (Decode.map2 Tuple.pair + (Decode.index 0 decodeName) + (Decode.index 1 <| decodeDefinition decodeAttributes) + ) + |> Decode.map Dict.fromList + ) + ) + (Decode.index 3 <| decodeValue decodeAttributes) + + "Destructure" -> + Decode.map4 Destructure + (Decode.index 1 decodeAttributes) + (Decode.index 2 <| decodePattern decodeAttributes) + (Decode.index 3 <| decodeValue decodeAttributes) + (Decode.index 4 <| decodeValue decodeAttributes) + + "IfThenElse" -> + Decode.map4 IfThenElse + (Decode.index 1 decodeAttributes) + (Decode.index 2 <| decodeValue decodeAttributes) + (Decode.index 3 <| decodeValue decodeAttributes) + (Decode.index 4 <| decodeValue decodeAttributes) + + "PatternMatch" -> + Decode.map3 PatternMatch + (Decode.index 1 decodeAttributes) + (Decode.index 2 <| decodeValue decodeAttributes) + (Decode.index 3 <| + Decode.list + (Decode.map2 Tuple.pair + (decodePattern decodeAttributes) + (decodeValue decodeAttributes) + ) + ) + + "UpdateRecord" -> + Decode.map3 UpdateRecord + (Decode.index 1 decodeAttributes) + (Decode.index 2 <| decodeValue decodeAttributes) + (Decode.index 3 <| + Decode.list <| + Decode.map2 Tuple.pair + decodeName + (decodeValue decodeAttributes) + ) + + "Unit" -> + Decode.map Unit + (Decode.index 1 decodeAttributes) + + other -> + Decode.fail <| "Unknown value type: " ++ other + ) + + +encodePattern : (a -> Encode.Value) -> Pattern a -> Encode.Value +encodePattern encodeAttributes pattern = + case pattern of + WildcardPattern a -> + Encode.list identity + [ Encode.string "WildcardPattern" + , encodeAttributes a + ] + + AsPattern a p name -> + Encode.list identity + [ Encode.string "AsPattern" + , encodeAttributes a + , encodePattern encodeAttributes p + , encodeName name + ] + + TuplePattern a elementPatterns -> + Encode.list identity + [ Encode.string "TuplePattern" + , encodeAttributes a + , elementPatterns |> Encode.list (encodePattern encodeAttributes) + ] + + RecordPattern a fieldNames -> + Encode.list identity + [ Encode.string "RecordPattern" + , encodeAttributes a + , fieldNames |> Encode.list encodeName + ] + + ConstructorPattern a constructorName argumentPatterns -> + Encode.list identity + [ Encode.string "ConstructorPattern" + , encodeAttributes a + , encodeFQName constructorName + , argumentPatterns |> Encode.list (encodePattern encodeAttributes) + ] + + EmptyListPattern a -> + Encode.list identity + [ Encode.string "EmptyListPattern" + , encodeAttributes a + ] + + HeadTailPattern a headPattern tailPattern -> + Encode.list identity + [ Encode.string "HeadTailPattern" + , encodeAttributes a + , encodePattern encodeAttributes headPattern + , encodePattern encodeAttributes tailPattern + ] + + LiteralPattern a value -> + Encode.list identity + [ Encode.string "LiteralPattern" + , encodeAttributes a + , encodeLiteral value + ] + + UnitPattern a -> + Encode.list identity + [ Encode.string "UnitPattern" + , encodeAttributes a + ] + + +decodePattern : Decode.Decoder a -> Decode.Decoder (Pattern a) +decodePattern decodeAttributes = + let + lazyDecodePattern = + Decode.lazy <| + \_ -> + decodePattern decodeAttributes + in + Decode.index 0 Decode.string + |> Decode.andThen + (\kind -> + case kind of + "WildcardPattern" -> + Decode.map WildcardPattern + (Decode.index 1 decodeAttributes) + + "AsPattern" -> + Decode.map3 AsPattern + (Decode.index 1 decodeAttributes) + (Decode.index 2 lazyDecodePattern) + (Decode.index 3 decodeName) + + "TuplePattern" -> + Decode.map2 TuplePattern + (Decode.index 1 decodeAttributes) + (Decode.index 2 <| Decode.list lazyDecodePattern) + + "RecordPattern" -> + Decode.map2 RecordPattern + (Decode.index 1 decodeAttributes) + (Decode.index 2 <| Decode.list decodeName) + + "ConstructorPattern" -> + Decode.map3 ConstructorPattern + (Decode.index 1 decodeAttributes) + (Decode.index 2 decodeFQName) + (Decode.index 3 <| Decode.list lazyDecodePattern) + + "EmptyListPattern" -> + Decode.map EmptyListPattern + (Decode.index 1 decodeAttributes) + + "HeadTailPattern" -> + Decode.map3 HeadTailPattern + (Decode.index 1 decodeAttributes) + (Decode.index 2 lazyDecodePattern) + (Decode.index 3 lazyDecodePattern) + + other -> + Decode.fail <| "Unknown pattern type: " ++ other + ) + + +encodeLiteral : Literal -> Encode.Value +encodeLiteral l = + let + typeTag tag = + ( "@type", Encode.string tag ) + in + case l of + BoolLiteral v -> + Encode.object + [ typeTag "boolLiteral" + , ( "value", Encode.bool v ) + ] + + CharLiteral v -> + Encode.object + [ typeTag "charLiteral" + , ( "value", Encode.string (String.fromChar v) ) + ] + + StringLiteral v -> + Encode.object + [ typeTag "stringLiteral" + , ( "value", Encode.string v ) + ] + + IntLiteral v -> + Encode.object + [ typeTag "intLiteral" + , ( "value", Encode.int v ) + ] + + FloatLiteral v -> + Encode.object + [ typeTag "floatLiteral" + , ( "value", Encode.float v ) + ] + + +decodeLiteral : Decode.Decoder Literal +decodeLiteral = + Decode.field "@type" Decode.string + |> Decode.andThen + (\kind -> + case kind of + "boolLiteral" -> + Decode.map BoolLiteral + (Decode.field "value" Decode.bool) + + "charLiteral" -> + Decode.map CharLiteral + (Decode.field "value" Decode.string + |> Decode.andThen + (\str -> + case String.uncons str of + Just ( ch, _ ) -> + Decode.succeed ch + + Nothing -> + Decode.fail "Single char expected" + ) + ) + + "stringLiteral" -> + Decode.map StringLiteral + (Decode.field "value" Decode.string) + + "intLiteral" -> + Decode.map IntLiteral + (Decode.field "value" Decode.int) + + "floatLiteral" -> + Decode.map FloatLiteral + (Decode.field "value" Decode.float) + + other -> + Decode.fail <| "Unknown literal type: " ++ other + ) + + +encodeSpecification : (a -> Encode.Value) -> Specification a -> Encode.Value +encodeSpecification encodeAttributes spec = + Encode.object + [ ( "inputs" + , spec.inputs + |> Encode.list + (\( argName, argType ) -> + Encode.object + [ ( "argName", encodeName argName ) + , ( "argType", encodeType encodeAttributes argType ) + ] + ) + ) + , ( "output", encodeType encodeAttributes spec.output ) + ] + + +encodeDefinition : (a -> Encode.Value) -> Definition a -> Encode.Value +encodeDefinition encodeAttributes def = + Encode.list identity + [ Encode.string "Definition" + , case def.valueType of + Just valueType -> + encodeType encodeAttributes valueType + + Nothing -> + Encode.null + , def.arguments + |> Encode.list + (\( name, a ) -> + Encode.list identity + [ encodeName name + , encodeAttributes a + ] + ) + , encodeValue encodeAttributes def.body + ] + + +decodeDefinition : Decode.Decoder a -> Decode.Decoder (Definition a) +decodeDefinition decodeAttributes = + Decode.map3 Definition + (Decode.index 1 (Decode.maybe (decodeType decodeAttributes))) + (Decode.index 2 (Decode.list (Decode.map2 Tuple.pair decodeName decodeAttributes))) + (Decode.index 3 (Decode.lazy (\_ -> decodeValue decodeAttributes))) diff --git a/tests/Morphir/Elm/FrontendTests.elm b/tests/Morphir/Elm/FrontendTests.elm index af1538074..b1aeec754 100644 --- a/tests/Morphir/Elm/FrontendTests.elm +++ b/tests/Morphir/Elm/FrontendTests.elm @@ -230,7 +230,7 @@ valueTests = moduleDef.value.values |> Dict.get [ "test", "value" ] |> Result.fromMaybe "Could not find test value" - |> Result.map (.value >> Value.getDefinitionBody) + |> Result.map (.value >> .body) ) ) |> resultToExpectation expectedValueIR @@ -246,6 +246,10 @@ valueTests = pvar : String -> Pattern () pvar name = AsPattern () (WildcardPattern ()) (Name.fromString name) + + binary : (() -> Value ()) -> Value () -> Value () -> Value () + binary fun arg1 arg2 = + Apply () (Apply () (fun ()) arg1) arg2 in describe "Values are mapped correctly" [ checkIR "()" <| Unit () @@ -288,24 +292,26 @@ valueTests = , checkIR "case a of\n 1 -> foo\n _ -> bar" <| PatternMatch () (ref "a") [ ( LiteralPattern () (IntLiteral 1), ref "foo" ), ( WildcardPattern (), ref "bar" ) ] , checkIR "a <| b" <| Apply () (ref "a") (ref "b") , checkIR "a |> b" <| Apply () (ref "b") (ref "a") - , checkIR "a || b" <| Bool.or () (ref "a") (ref "b") - , checkIR "a && b" <| Bool.and () (ref "a") (ref "b") - , checkIR "a == b" <| Equality.equal () (ref "a") (ref "b") - , checkIR "a /= b" <| Equality.notEqual () (ref "a") (ref "b") - , checkIR "a < b" <| Comparison.lessThan () (ref "a") (ref "b") - , checkIR "a > b" <| Comparison.greaterThan () (ref "a") (ref "b") - , checkIR "a <= b" <| Comparison.lessThanOrEqual () (ref "a") (ref "b") - , checkIR "a >= b" <| Comparison.greaterThanOrEqual () (ref "a") (ref "b") - , checkIR "a ++ b" <| Appending.append () (ref "a") (ref "b") - , checkIR "a + b" <| Number.add () (ref "a") (ref "b") - , checkIR "a - b" <| Number.subtract () (ref "a") (ref "b") - , checkIR "a * b" <| Number.multiply () (ref "a") (ref "b") - , checkIR "a / b" <| Float.divide () (ref "a") (ref "b") - , checkIR "a // b" <| Int.divide () (ref "a") (ref "b") - , checkIR "a ^ b" <| Number.power () (ref "a") (ref "b") - , checkIR "a << b" <| Composition.composeLeft () (ref "a") (ref "b") - , checkIR "a >> b" <| Composition.composeRight () (ref "a") (ref "b") - , checkIR "a :: b" <| List.construct () (ref "a") (ref "b") + , checkIR "a || b" <| binary Bool.or (ref "a") (ref "b") + , checkIR "a && b" <| binary Bool.and (ref "a") (ref "b") + , checkIR "a == b" <| binary Equality.equal (ref "a") (ref "b") + , checkIR "a /= b" <| binary Equality.notEqual (ref "a") (ref "b") + , checkIR "a < b" <| binary Comparison.lessThan (ref "a") (ref "b") + , checkIR "a > b" <| binary Comparison.greaterThan (ref "a") (ref "b") + , checkIR "a <= b" <| binary Comparison.lessThanOrEqual (ref "a") (ref "b") + , checkIR "a >= b" <| binary Comparison.greaterThanOrEqual (ref "a") (ref "b") + , checkIR "a ++ b" <| binary Appending.append (ref "a") (ref "b") + , checkIR "a + b" <| binary Number.add (ref "a") (ref "b") + , checkIR "a - b" <| binary Number.subtract (ref "a") (ref "b") + , checkIR "a * b" <| binary Number.multiply (ref "a") (ref "b") + , checkIR "a / b" <| binary Float.divide (ref "a") (ref "b") + , checkIR "a // b" <| binary Int.divide (ref "a") (ref "b") + , checkIR "a ^ b" <| binary Number.power (ref "a") (ref "b") + , checkIR "a << b" <| binary Composition.composeLeft (ref "a") (ref "b") + , checkIR "a >> b" <| binary Composition.composeRight (ref "a") (ref "b") + , checkIR "a :: b" <| binary List.construct (ref "a") (ref "b") + , checkIR "::" <| List.construct () + , checkIR "foo (::)" <| Apply () (ref "foo") (List.construct ()) , checkIR (String.join "\n" [ " let" @@ -330,7 +336,7 @@ valueTests = <| LetDefinition () (Name.fromString "foo") - (Definition Nothing [ Name.fromString "a" ] (ref "c")) + (Definition Nothing [ ( Name.fromString "a", () ) ] (ref "c")) (ref "d") , checkIR (String.join "\n" diff --git a/tests/Morphir/IR/NameTests.elm b/tests/Morphir/IR/NameTests.elm index 03a84019f..f62611a78 100644 --- a/tests/Morphir/IR/NameTests.elm +++ b/tests/Morphir/IR/NameTests.elm @@ -1,9 +1,10 @@ module Morphir.IR.NameTests exposing (..) import Expect +import Json.Encode exposing (encode) import Morphir.IR.Name as Name +import Morphir.IR.Name.Codec exposing (encodeName) import Test exposing (..) -import Json.Encode exposing(encode) fromStringTests : Test @@ -87,6 +88,7 @@ toHumanWordsTests = , assert [ "value", "in", "u", "s", "d" ] [ "value", "in", "USD" ] ] + encodeNameTests : Test encodeNameTests = let @@ -94,11 +96,11 @@ encodeNameTests = test ("encodeName " ++ (expectedText ++ " ")) <| \_ -> Name.fromList inList - |> Name.encodeName + |> encodeName |> encode 0 |> Expect.equal expectedText in describe "encodeName" - [ assert ["delta", "sigma", "theta"] """["delta","sigma","theta"]""" - , assert ["sigma","gamma","ro"] """["sigma","gamma","ro"]""" - ] \ No newline at end of file + [ assert [ "delta", "sigma", "theta" ] """["delta","sigma","theta"]""" + , assert [ "sigma", "gamma", "ro" ] """["sigma","gamma","ro"]""" + ] diff --git a/tests/Morphir/IR/PathTests.elm b/tests/Morphir/IR/PathTests.elm index 5b6fe8f15..2ef5340c8 100644 --- a/tests/Morphir/IR/PathTests.elm +++ b/tests/Morphir/IR/PathTests.elm @@ -1,10 +1,12 @@ module Morphir.IR.PathTests exposing (..) import Expect +import Json.Encode exposing (encode) import Morphir.IR.Name as Name import Morphir.IR.Path as Path +import Morphir.IR.Path.Codec exposing (encodePath) import Test exposing (..) -import Json.Encode exposing (encode) + isPrefixOfTests : Test isPrefixOfTests = @@ -31,6 +33,7 @@ isPrefixOfTests = , isPrefixOf [ [ "foo" ], [ "bar" ] ] [ [ "foo" ], [ "bar" ] ] True ] + encodePathTests : Test encodePathTests = let @@ -38,11 +41,11 @@ encodePathTests = test ("encodePath " ++ (expectedJsonText ++ " ")) <| \_ -> Path.fromList input - |> Path.encodePath + |> encodePath |> encode 0 |> Expect.equal expectedJsonText in describe "encodePath" - [ assert (Path.fromList [Name.fromList ["alpha"], Name.fromList ["beta"], Name.fromList ["gamma"]]) """[["alpha"],["beta"],["gamma"]]""" - , assert (Path.fromList [Name.fromList ["alpha","omega"], Name.fromList ["beta","delta"], Name.fromList ["gamma"]]) """[["alpha","omega"],["beta","delta"],["gamma"]]""" - ] \ No newline at end of file + [ assert (Path.fromList [ Name.fromList [ "alpha" ], Name.fromList [ "beta" ], Name.fromList [ "gamma" ] ]) """[["alpha"],["beta"],["gamma"]]""" + , assert (Path.fromList [ Name.fromList [ "alpha", "omega" ], Name.fromList [ "beta", "delta" ], Name.fromList [ "gamma" ] ]) """[["alpha","omega"],["beta","delta"],["gamma"]]""" + ]