hydra-0.12.0: src/main/haskell/Hydra/Sources/Haskell/Coder.hs
{-# LANGUAGE OverloadedStrings #-}
module Hydra.Sources.Haskell.Coder where
-- Standard imports for term-level sources outside of the kernel
import Hydra.Kernel
import Hydra.Sources.Libraries
import qualified Hydra.Dsl.Accessors as Accessors
import qualified Hydra.Dsl.Annotations as Anns
import qualified Hydra.Dsl.Ast as Ast
import qualified Hydra.Dsl.Coders as Coders
import qualified Hydra.Dsl.Compute as Compute
import qualified Hydra.Dsl.Core as Core
import qualified Hydra.Dsl.Grammar as Grammar
import qualified Hydra.Dsl.Graph as Graph
import qualified Hydra.Dsl.Json as Json
import qualified Hydra.Dsl.Lib.Chars as Chars
import qualified Hydra.Dsl.Lib.Equality as Equality
import qualified Hydra.Dsl.Lib.Flows as Flows
import qualified Hydra.Dsl.Lib.Lists as Lists
import qualified Hydra.Dsl.Lib.Literals as Literals
import qualified Hydra.Dsl.Lib.Logic as Logic
import qualified Hydra.Dsl.Lib.Maps as Maps
import qualified Hydra.Dsl.Lib.Math as Math
import qualified Hydra.Dsl.Lib.Optionals as Optionals
import qualified Hydra.Dsl.Lib.Sets as Sets
import Hydra.Dsl.Lib.Strings as Strings
import qualified Hydra.Dsl.Mantle as Mantle
import qualified Hydra.Dsl.Module as Module
import Hydra.Dsl.Phantoms as Phantoms
import qualified Hydra.Dsl.TTerms as TTerms
import qualified Hydra.Dsl.TTypes as TTypes
import qualified Hydra.Dsl.Tabular as Tabular
import qualified Hydra.Dsl.Terms as Terms
import qualified Hydra.Dsl.Topology as Topology
import qualified Hydra.Dsl.Types as Types
import qualified Hydra.Dsl.Typing as Typing
import qualified Hydra.Sources.Kernel.Types.All as KernelTypes
import qualified Hydra.Sources.Kernel.Terms.Adapt.Literals as AdaptLiterals
import qualified Hydra.Sources.Kernel.Terms.Adapt.Modules as AdaptModules
import qualified Hydra.Sources.Kernel.Terms.Adapt.Terms as AdaptTerms
import qualified Hydra.Sources.Kernel.Terms.Adapt.Utils as AdaptUtils
import qualified Hydra.Sources.Kernel.Terms.Annotations as Annotations
import qualified Hydra.Sources.Kernel.Terms.Arity as Arity
import qualified Hydra.Sources.Kernel.Terms.Constants as Constants
import qualified Hydra.Sources.Kernel.Terms.Decode.Core as DecodeCore
import qualified Hydra.Sources.Kernel.Terms.Decoding as Decoding
import qualified Hydra.Sources.Kernel.Terms.Describe.Core as DescribeCore
import qualified Hydra.Sources.Kernel.Terms.Describe.Mantle as DescribeMantle
import qualified Hydra.Sources.Kernel.Terms.Encode.Core as EncodeCore
import qualified Hydra.Sources.Kernel.Terms.Extract.Core as ExtractCore
import qualified Hydra.Sources.Kernel.Terms.Extract.Mantle as ExtractMantle
import qualified Hydra.Sources.Kernel.Terms.Formatting as Formatting
import qualified Hydra.Sources.Kernel.Terms.Grammars as Grammars
import qualified Hydra.Sources.Kernel.Terms.Inference as Inference
import qualified Hydra.Sources.Kernel.Terms.Languages as Languages
import qualified Hydra.Sources.Kernel.Terms.Lexical as Lexical
import qualified Hydra.Sources.Kernel.Terms.Literals as Literals
import qualified Hydra.Sources.Kernel.Terms.Monads as Monads
import qualified Hydra.Sources.Kernel.Terms.Names as Names
import qualified Hydra.Sources.Kernel.Terms.Reduction as Reduction
import qualified Hydra.Sources.Kernel.Terms.Rewriting as Rewriting
import qualified Hydra.Sources.Kernel.Terms.Schemas as Schemas
import qualified Hydra.Sources.Kernel.Terms.Serialization as Serialization
import qualified Hydra.Sources.Kernel.Terms.Show.Accessors as ShowAccessors
import qualified Hydra.Sources.Kernel.Terms.Show.Core as ShowCore
import qualified Hydra.Sources.Kernel.Terms.Show.Graph as ShowGraph
import qualified Hydra.Sources.Kernel.Terms.Show.Mantle as ShowMantle
import qualified Hydra.Sources.Kernel.Terms.Show.Typing as ShowTyping
import qualified Hydra.Sources.Kernel.Terms.Sorting as Sorting
import qualified Hydra.Sources.Kernel.Terms.Substitution as Substitution
import qualified Hydra.Sources.Kernel.Terms.Tarjan as Tarjan
import qualified Hydra.Sources.Kernel.Terms.Templates as Templates
import qualified Hydra.Sources.Kernel.Terms.Unification as Unification
import qualified Hydra.Sources.Kernel.Terms.Variants as Variants
import Prelude hiding ((++))
import qualified Data.Int as I
import qualified Data.List as L
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.Maybe as Y
-- Additional imports
import qualified Hydra.Ext.Haskell.Ast as H
import qualified Hydra.Sources.Haskell.Language as HaskellLanguage
import qualified Hydra.Sources.Haskell.Ast as HaskellAst
import qualified Hydra.Sources.Haskell.Serde as HaskellSerde
import qualified Hydra.Sources.Haskell.Utils as HaskellUtils
type HaskellNamespaces = Namespaces H.ModuleName
haskellCoderDefinition :: String -> TTerm a -> TBinding a
haskellCoderDefinition = definitionInModule haskellCoderModule
haskellCoderModule :: Module
haskellCoderModule = Module ns elements
[HaskellSerde.haskellSerdeModule, HaskellUtils.haskellUtilsModule,
AdaptModules.module_, Rewriting.module_, Serialization.module_]
(HaskellAst.haskellAstModule:KernelTypes.kernelTypesModules) $
Just "Functions for encoding Hydra modules as Haskell modules"
where
ns = Namespace "hydra.ext.haskell.coder"
elements = [
el includeTypeDefinitionsDef,
el useCoreImportDef,
el keyHaskellVarDef,
el adaptTypeToHaskellAndEncodeDef,
el constantForFieldNameDef,
el constantForTypeNameDef,
el constructModuleDef,
el encodeFunctionDef,
el encodeLiteralDef,
el encodeTermDef,
el encodeTypeDef,
el encodeTypeWithClassAssertionsDef,
el findOrdVariablesDef,
el getImplicitTypeClassesDef,
el moduleToHaskellModuleDef,
el moduleToHaskellDef,
el nameDeclsDef,
el toDataDeclarationDef,
el toTypeDeclarationsDef,
el typeDeclDef]
-- TODO: make these settings configurable
includeTypeDefinitionsDef :: TBinding Bool
includeTypeDefinitionsDef = haskellCoderDefinition "includeTypeDefinitions" $
false
useCoreImportDef :: TBinding Bool
useCoreImportDef = haskellCoderDefinition "useCoreImport" $
true
keyHaskellVarDef :: TBinding Name
keyHaskellVarDef = haskellCoderDefinition "keyHaskellVar" $
wrap _Name $ string "haskellVar"
adaptTypeToHaskellAndEncodeDef :: TBinding (HaskellNamespaces -> Type -> Flow Graph H.Type)
adaptTypeToHaskellAndEncodeDef = haskellCoderDefinition "adaptTypeToHaskellAndEncode" $
lambda "namespaces" $
ref AdaptModules.adaptTypeToLanguageAndEncodeDef @@ (ref HaskellLanguage.haskellLanguageDef) @@ (ref encodeTypeDef @@ var "namespaces")
constantForFieldNameDef :: TBinding (Name -> Name -> String)
constantForFieldNameDef = haskellCoderDefinition "constantForFieldName" $
lambda "tname" $ lambda "fname" $
Strings.cat $ list [
string "_",
ref Names.localNameOfDef @@ var "tname",
string "_",
Core.unName $ var "fname"]
constantForTypeNameDef :: TBinding (Name -> String)
constantForTypeNameDef = haskellCoderDefinition "constantForTypeName" $
lambda "tname" $
Strings.cat2 (string "_") (ref Names.localNameOfDef @@ var "tname")
constructModuleDef :: TBinding (HaskellNamespaces -> Module -> M.Map Type (Coder Graph Graph Term H.Expression) -> [(Binding, TypedTerm)] -> Flow Graph H.Module)
constructModuleDef = haskellCoderDefinition "constructModule" $ lambdas ["namespaces", "mod", "coders", "pairs"] $ lets [
"h">: lambda "namespace" $
unwrap _Namespace @@ var "namespace",
"createDeclarations">: lambda "g" $ lambda "pair" $ lets [
"el">: first $ var "pair",
"tt">: second $ var "pair",
"term">: Core.typedTermTerm $ var "tt",
"typ">: Core.typedTermType $ var "tt"] $
Logic.ifElse (ref Annotations.isNativeTypeDef @@ var "el")
(ref toTypeDeclarationsDef @@ var "namespaces" @@ var "el" @@ var "term")
(bind "d" (ref toDataDeclarationDef @@ var "coders" @@ var "namespaces" @@ var "pair") $
Flows.pure $ list [var "d"]),
"importName">: lambda "name" $
wrap H._ModuleName $ Strings.intercalate (string ".") (Lists.map (ref Formatting.capitalizeDef) (Strings.splitOn (string ".") (var "name"))),
"imports">: Lists.concat2 (var "domainImports") (var "standardImports"),
"domainImports">: lets [
"toImport">: lambda "pair" $ lets [
"namespace">: first $ var "pair",
"alias">: second $ var "pair",
"name">: var "h" @@ var "namespace"] $
record H._Import [
H._Import_qualified>>: true,
H._Import_module>>: var "importName" @@ var "name",
H._Import_as>>: just $ var "alias",
H._Import_spec>>: nothing]] $
Lists.map (var "toImport") (Maps.toList $ Module.namespacesMapping $ var "namespaces"),
"standardImports">: lets [
"toImport">: lambda "triple" $ lets [
"name">: first $ first $ var "triple",
"malias">: second $ first $ var "triple",
"hidden">: second $ var "triple",
"spec">: Logic.ifElse (Lists.null $ var "hidden")
nothing
(just $ inject H._SpecImport H._SpecImport_hiding $ Lists.map (lambda "n" $ record H._ImportExportSpec [
H._ImportExportSpec_modifier>>: nothing,
H._ImportExportSpec_name>>: ref HaskellUtils.simpleNameDef @@ var "n",
H._ImportExportSpec_subspec>>: nothing]) (var "hidden"))] $
record H._Import [
H._Import_qualified>>: Optionals.isJust $ var "malias",
H._Import_module>>: wrap H._ModuleName $ var "name",
H._Import_as>>: Optionals.map (unaryFunction $ wrap H._ModuleName) (var "malias"),
H._Import_spec>>: var "spec"]] $
Lists.map (var "toImport") $ list [
pair (pair (string "Prelude") nothing) (list $ string <$> [
"Enum", "Ordering", "fail", "map", "pure", "sum"]),
pair (pair (string "Data.Int") (just $ string "I")) (list []),
pair (pair (string "Data.List") (just $ string "L")) (list []),
pair (pair (string "Data.Map") (just $ string "M")) (list []),
pair (pair (string "Data.Set") (just $ string "S")) (list [])]] $
bind "g" (ref Monads.getStateDef) $
bind "declLists" (Flows.mapList (var "createDeclarations" @@ var "g") (var "pairs")) $ lets [
"decls">: Lists.concat $ var "declLists",
"mc">: Module.moduleDescription $ var "mod"] $
Flows.pure $ record H._Module [
H._Module_head>>: just $ record H._ModuleHead [
H._ModuleHead_comments>>: var "mc",
H._ModuleHead_name>>: var "importName" @@ (var "h" @@ (Module.moduleNamespace $ var "mod")),
H._ModuleHead_exports>>: list []],
H._Module_imports>>: var "imports",
H._Module_declarations>>: var "decls"]
encodeFunctionDef :: TBinding (HaskellNamespaces -> Function -> Flow Graph H.Expression)
encodeFunctionDef = haskellCoderDefinition "encodeFunction" $
lambda "namespaces" $ lambda "fun" $
cases _Function (var "fun") Nothing [
_Function_elimination>>: lambda "e" $
cases _Elimination (var "e") Nothing [
_Elimination_wrap>>: lambda "name" $
Flows.pure $ inject H._Expression H._Expression_variable $ ref HaskellUtils.elementReferenceDef @@ var "namespaces" @@
(ref Names.qnameDef @@ (Optionals.fromJust $ ref Names.namespaceOfDef @@ var "name") @@ (ref HaskellUtils.newtypeAccessorNameDef @@ var "name")),
_Elimination_product>>: lambda "proj" $ lets [
"arity">: Core.tupleProjectionArity $ var "proj",
"idx">: Core.tupleProjectionIndex $ var "proj"] $
Logic.ifElse (Equality.equal (var "arity") (int32 2))
(Flows.pure $ ref HaskellUtils.hsvarDef @@ Logic.ifElse (Equality.equal (var "idx") (int32 0)) (string "fst") (string "snd"))
(Flows.fail $ string "Eliminations for tuples of arity > 2 are not supported yet in the Haskell coder"),
_Elimination_record>>: lambda "proj" $ lets [
"dn">: Core.projectionTypeName $ var "proj",
"fname">: Core.projectionField $ var "proj"] $
Flows.pure $ inject H._Expression H._Expression_variable $ ref HaskellUtils.recordFieldReferenceDef @@ var "namespaces" @@ var "dn" @@ var "fname",
_Elimination_union>>: lambda "stmt" $ lets [
"dn">: Core.caseStatementTypeName $ var "stmt",
"def">: Core.caseStatementDefault $ var "stmt",
"fields">: Core.caseStatementCases $ var "stmt",
"caseExpr">:
bind "rt" (ref Lexical.withSchemaContextDef @@ (ref Schemas.requireUnionTypeDef @@ var "dn")) $ lets [
"fieldMap">: Maps.fromList $ Lists.map (var "toFieldMapEntry") (Core.rowTypeFields $ var "rt"),
"toFieldMapEntry">: lambda "f" $
pair (Core.fieldTypeName $ var "f") (var "f")] $
bind "ecases" (Flows.mapList (var "toAlt" @@ var "fieldMap") (var "fields")) $
bind "dcases" (Optionals.cases (var "def")
(Flows.pure $ list []) $
(lambda "d" $
bind "cs" (Flows.map (unaryFunction $ wrap H._CaseRhs) $ ref encodeTermDef @@ var "namespaces" @@ var "d") $ lets [
"lhs">: inject H._Pattern H._Pattern_name $ ref HaskellUtils.rawNameDef @@ (ref Constants.ignoredVariableDef),
"alt">: record H._Alternative [
H._Alternative_pattern>>: var "lhs",
H._Alternative_rhs>>: var "cs",
H._Alternative_binds>>: nothing]] $
Flows.pure $ list [var "alt"])) $
Flows.pure $ inject H._Expression H._Expression_case $ record H._CaseExpression [
H._CaseExpression_case>>: ref HaskellUtils.hsvarDef @@ string "x",
H._CaseExpression_alternatives>>: Lists.concat2 (var "ecases") (var "dcases")],
"toAlt">: lambdas ["fieldMap", "field"] $ lets [
"fn">: Core.fieldName $ var "field",
"fun'">: Core.fieldTerm $ var "field"] $
ref Annotations.withDepthDef @@ ref keyHaskellVarDef @@ (
lambda "depth" $ lets [
"v0">: Strings.cat2 (string "v") (Literals.showInt32 $ var "depth"),
"raw">: TTerms.apply (var "fun'") (Core.termVariable $ Core.name $ var "v0"),
"rhsTerm">: ref Rewriting.simplifyTermDef @@ var "raw",
"v1">: Logic.ifElse (ref Rewriting.isFreeVariableInTermDef @@ (wrap _Name $ var "v0") @@ var "rhsTerm")
(ref Constants.ignoredVariableDef)
(var "v0"),
"hname">: ref HaskellUtils.unionFieldReferenceDef @@ var "namespaces" @@ var "dn" @@ var "fn"] $
bind "args"
(Optionals.cases (Maps.lookup (var "fn") (var "fieldMap"))
(Flows.fail $ Strings.cat $ list [string "field ", Literals.showString $ (Core.unName $ var "fn"),
string " not found in ", Literals.showString $ (Core.unName $ var "dn")])
(lambda "fieldType" $ lets [
"ft">: Core.fieldTypeType $ var "fieldType",
"noArgs">: Flows.pure $ list [],
"singleArg">: Flows.pure $ list [inject H._Pattern H._Pattern_name $ ref HaskellUtils.rawNameDef @@ var "v1"]] $
cases _Type (ref Rewriting.deannotateTypeDef @@ var "ft")
(Just $ var "singleArg") [
_Type_unit>>: constant $ var "noArgs"])) $ lets [
"lhs">: ref HaskellUtils.applicationPatternDef @@ var "hname" @@ var "args"] $
bind "rhs" (Flows.map (unaryFunction $ wrap H._CaseRhs) $ ref encodeTermDef @@ var "namespaces" @@ var "rhsTerm") $
Flows.pure $ record H._Alternative [
H._Alternative_pattern>>: var "lhs",
H._Alternative_rhs>>: var "rhs",
H._Alternative_binds>>: nothing])] $
Flows.map (ref HaskellUtils.hslambdaDef @@ (ref HaskellUtils.rawNameDef @@ string "x")) (var "caseExpr")],
_Function_lambda>>: lambda "lam" $ lets [
"v">: Core.lambdaParameter $ var "lam",
"body">: Core.lambdaBody $ var "lam"] $
Flows.bind (ref encodeTermDef @@ var "namespaces" @@ var "body") $ lambda "hbody" $
Flows.pure $ ref HaskellUtils.hslambdaDef @@ (ref HaskellUtils.elementReferenceDef @@ var "namespaces" @@ var "v") @@ var "hbody",
_Function_primitive>>: lambda "name" $
Flows.pure $ inject H._Expression H._Expression_variable $ ref HaskellUtils.elementReferenceDef @@ var "namespaces" @@ var "name"]
encodeLiteralDef :: TBinding (Literal -> Flow Graph H.Expression)
encodeLiteralDef = haskellCoderDefinition "encodeLiteral" $
lambda "l" $
cases _Literal (var "l")
(Just $ Flows.fail $ Strings.cat2 (string "literal value ") (ref ShowCore.literalDef @@ var "l")) [
_Literal_boolean>>: lambda "b" $
Flows.pure $ ref HaskellUtils.hsvarDef @@ Logic.ifElse (var "b") (string "True") (string "False"),
_Literal_float>>: lambda "fv" $
cases _FloatValue (var "fv") Nothing [
_FloatValue_float32>>: lambda "f" $
Flows.pure $ ref HaskellUtils.hslitDef @@ (inject H._Literal H._Literal_float $ var "f"),
_FloatValue_float64>>: lambda "f" $
Flows.pure $ ref HaskellUtils.hslitDef @@ (inject H._Literal H._Literal_double $ var "f"),
_FloatValue_bigfloat>>: lambda "f" $
Flows.pure $ ref HaskellUtils.hslitDef @@ (inject H._Literal H._Literal_double $ Literals.bigfloatToFloat64 $ var "f")],
_Literal_integer>>: lambda "iv" $
cases _IntegerValue (var "iv") Nothing [
_IntegerValue_bigint>>: lambda "i" $
Flows.pure $ ref HaskellUtils.hslitDef @@ (inject H._Literal H._Literal_integer $ var "i"),
_IntegerValue_int8>>: lambda "i" $
Flows.pure $ ref HaskellUtils.hslitDef @@ (inject H._Literal H._Literal_integer $ Literals.int8ToBigint $ var "i"),
_IntegerValue_int16>>: lambda "i" $
Flows.pure $ ref HaskellUtils.hslitDef @@ (inject H._Literal H._Literal_integer $ Literals.int16ToBigint $ var "i"),
_IntegerValue_int32>>: lambda "i" $
Flows.pure $ ref HaskellUtils.hslitDef @@ (inject H._Literal H._Literal_int $ var "i"),
_IntegerValue_int64>>: lambda "i" $
Flows.pure $ ref HaskellUtils.hslitDef @@ (inject H._Literal H._Literal_integer $ Literals.int64ToBigint $ var "i"),
_IntegerValue_uint8>>: lambda "i" $
Flows.pure $ ref HaskellUtils.hslitDef @@ (inject H._Literal H._Literal_integer $ Literals.uint8ToBigint $ var "i"),
_IntegerValue_uint16>>: lambda "i" $
Flows.pure $ ref HaskellUtils.hslitDef @@ (inject H._Literal H._Literal_integer $ Literals.uint16ToBigint $ var "i"),
_IntegerValue_uint32>>: lambda "i" $
Flows.pure $ ref HaskellUtils.hslitDef @@ (inject H._Literal H._Literal_integer $ Literals.uint32ToBigint $ var "i"),
_IntegerValue_uint64>>: lambda "i" $
Flows.pure $ ref HaskellUtils.hslitDef @@ (inject H._Literal H._Literal_integer $ Literals.uint64ToBigint $ var "i")],
_Literal_string>>: lambda "s" $
Flows.pure $ ref HaskellUtils.hslitDef @@ (inject H._Literal H._Literal_string $ var "s")]
encodeTermDef :: TBinding (HaskellNamespaces -> Term -> Flow Graph H.Expression)
encodeTermDef = haskellCoderDefinition "encodeTerm" $
lambda "namespaces" $ lambda "term" $ lets [
"encode">: ref encodeTermDef @@ var "namespaces"] $
cases _Term (ref Rewriting.deannotateTermDef @@ var "term")
(Just $ Flows.fail $ Strings.cat2 (string "unexpected term: ") (ref ShowCore.termDef @@ var "term")) [
_Term_application>>: lambda "app" $ lets [
"fun">: Core.applicationFunction $ var "app",
"arg">: Core.applicationArgument $ var "app"] $
Flows.bind (var "encode" @@ var "fun") $ lambda "hfun" $
Flows.bind (var "encode" @@ var "arg") $ lambda "harg" $
Flows.pure $ ref HaskellUtils.hsappDef @@ var "hfun" @@ var "harg",
_Term_function>>: lambda "f" $
ref encodeFunctionDef @@ var "namespaces" @@ var "f",
_Term_let>>: lambda "letTerm" $ lets [
"bindings">: Core.letBindings $ var "letTerm",
"env">: Core.letEnvironment $ var "letTerm",
"encodeBinding">: lambda "binding" $ lets [
"name">: Core.bindingName $ var "binding",
"term'">: Core.bindingTerm $ var "binding",
"hname">: ref HaskellUtils.simpleNameDef @@ (Core.unName $ var "name")] $
bind "hexpr" (var "encode" @@ var "term'") $
Flows.pure $ inject H._LocalBinding H._LocalBinding_value $ ref HaskellUtils.simpleValueBindingDef @@ var "hname" @@ var "hexpr" @@ nothing] $
bind "hbindings" (Flows.mapList (var "encodeBinding") (var "bindings")) $
bind "hinner" (var "encode" @@ var "env") $
Flows.pure $ inject H._Expression H._Expression_let $ record H._LetExpression [
H._LetExpression_bindings>>: var "hbindings",
H._LetExpression_inner>>: var "hinner"],
_Term_list>>: lambda "els" $
Flows.bind (Flows.mapList (var "encode") (var "els")) $ lambda "helems" $
Flows.pure $ inject H._Expression H._Expression_list $ var "helems",
_Term_literal>>: lambda "v" $
ref encodeLiteralDef @@ var "v",
_Term_map>>: lambda "m" $ lets [
"lhs">: ref HaskellUtils.hsvarDef @@ string "M.fromList",
"encodePair">: lambda "pair" $ lets [
"k">: first $ var "pair",
"v">: second $ var "pair",
"hk">: var "encode" @@ var "k",
"hv">: var "encode" @@ var "v"] $
Flows.map
(unaryFunction $ inject H._Expression H._Expression_tuple)
(Flows.sequence $ list [var "hk", var "hv"])] $
bind "rhs" (Flows.map
(unaryFunction $ inject H._Expression H._Expression_list)
(Flows.mapList (var "encodePair") $ Maps.toList (var "m"))) $
Flows.pure $ ref HaskellUtils.hsappDef @@ var "lhs" @@ var "rhs",
_Term_optional>>: lambda "m" $
Optionals.cases (var "m")
(Flows.pure $ ref HaskellUtils.hsvarDef @@ string "Nothing") $
lambda "t" $
Flows.bind (var "encode" @@ var "t") $ lambda "ht" $
Flows.pure $ ref HaskellUtils.hsappDef @@ (ref HaskellUtils.hsvarDef @@ string "Just") @@ var "ht",
_Term_product>>: lambda "terms" $
Flows.bind (Flows.mapList (var "encode") (var "terms")) $ lambda "hterms" $
Flows.pure $ inject H._Expression H._Expression_tuple $ var "hterms",
_Term_record>>: lambda "record" $ lets [
"sname">: Core.recordTypeName $ var "record",
"fields">: Core.recordFields $ var "record",
"toFieldUpdate">: lambda "field" $ lets [
"fn">: Core.fieldName $ var "field",
"ft">: Core.fieldTerm $ var "field",
"fieldRef">: ref HaskellUtils.recordFieldReferenceDef @@ var "namespaces" @@ var "sname" @@ var "fn"] $
bind "hft" (var "encode" @@ var "ft") $
Flows.pure $ record H._FieldUpdate [
H._FieldUpdate_name>>: var "fieldRef",
H._FieldUpdate_value>>: var "hft"],
"typeName">: ref HaskellUtils.elementReferenceDef @@ var "namespaces" @@ var "sname"] $
bind "updates" (Flows.mapList (var "toFieldUpdate") (var "fields")) $
Flows.pure $ inject H._Expression H._Expression_constructRecord $ record H._ConstructRecordExpression [
H._ConstructRecordExpression_name>>: var "typeName",
H._ConstructRecordExpression_fields>>: var "updates"],
_Term_set>>: lambda "s" $ lets [
"lhs">: ref HaskellUtils.hsvarDef @@ string "S.fromList" ] $
bind "rhs" (ref encodeTermDef @@ var "namespaces" @@ (inject _Term _Term_list $ Sets.toList $ var "s")) $
Flows.pure $ ref HaskellUtils.hsappDef @@ var "lhs" @@ var "rhs",
_Term_typeLambda>>: lambda "abs" $ lets [
"term1">: Core.typeLambdaBody $ var "abs"] $
var "encode" @@ var "term1",
_Term_typeApplication>>: lambda "typed" $ lets [
"term1">: Core.typedTermTerm $ var "typed"] $
var "encode" @@ var "term1",
_Term_union>>: lambda "injection" $ lets [
"sname">: Core.injectionTypeName $ var "injection",
"field">: Core.injectionField $ var "injection",
"fn">: Core.fieldName $ var "field",
"ft">: Core.fieldTerm $ var "field",
"lhs">: inject H._Expression H._Expression_variable $ ref HaskellUtils.unionFieldReferenceDef @@ var "namespaces" @@ var "sname" @@ var "fn",
"dflt">: Flows.map (ref HaskellUtils.hsappDef @@ var "lhs") (var "encode" @@ var "ft")] $
cases _Term (ref Rewriting.deannotateTermDef @@ var "ft")
(Just $ var "dflt") [
_Term_unit>>: constant $ Flows.pure $ var "lhs"],
_Term_unit>>: constant $ Flows.pure $ inject H._Expression H._Expression_tuple $ list [],
_Term_variable>>: lambda "name" $
Flows.pure $ inject H._Expression H._Expression_variable $ ref HaskellUtils.elementReferenceDef @@ var "namespaces" @@ var "name",
_Term_wrap>>: lambda "wrapped" $ lets [
"tname">: Core.wrappedTermTypeName $ var "wrapped",
"term'">: Core.wrappedTermObject $ var "wrapped",
"lhs">: inject H._Expression H._Expression_variable $ ref HaskellUtils.elementReferenceDef @@ var "namespaces" @@ var "tname"] $
bind "rhs" (var "encode" @@ var "term'") $
Flows.pure $ ref HaskellUtils.hsappDef @@ var "lhs" @@ var "rhs"]
encodeTypeDef :: TBinding (HaskellNamespaces -> Type -> Flow Graph H.Type)
encodeTypeDef = haskellCoderDefinition "encodeType" $
lambda "namespaces" $
lambda "typ" $ lets [
"encode">: ref encodeTypeDef @@ var "namespaces",
"ref">: lambda "name" $
Flows.pure $ inject H._Type H._Type_variable $ ref HaskellUtils.elementReferenceDef @@ var "namespaces" @@ var "name",
"unitTuple">: inject H._Type H._Type_tuple $ list []] $
trace "encode type" $
cases _Type (ref Rewriting.deannotateTypeDef @@ var "typ")
(Just $ Flows.fail $ Strings.cat2 (string "unexpected type: ") (ref ShowCore.typeDef @@ var "typ")) [
_Type_application>>: lambda "app" $ lets [
"lhs">: Core.applicationTypeFunction $ var "app",
"rhs">: Core.applicationTypeArgument $ var "app"] $
Flows.bind (var "encode" @@ var "lhs") $ lambda "hlhs" $
Flows.bind (var "encode" @@ var "rhs") $ lambda "hrhs" $
Flows.pure $ ref HaskellUtils.toTypeApplicationDef @@ list [var "hlhs", var "hrhs"],
_Type_function>>: lambda "funType" $ lets [
"dom">: Core.functionTypeDomain $ var "funType",
"cod">: Core.functionTypeCodomain $ var "funType"] $
Flows.bind (var "encode" @@ var "dom") $ lambda "hdom" $
Flows.bind (var "encode" @@ var "cod") $ lambda "hcod" $
Flows.pure $ inject H._Type H._Type_function $ record H._FunctionType [
H._FunctionType_domain>>: var "hdom",
H._FunctionType_codomain>>: var "hcod"],
_Type_forall>>: lambda "forallType" $ lets [
"v">: Core.forallTypeParameter $ var "forallType",
"body">: Core.forallTypeBody $ var "forallType"] $
var "encode" @@ var "body",
_Type_list>>: lambda "lt" $
Flows.bind (var "encode" @@ var "lt") $ lambda "hlt" $
Flows.pure $ inject H._Type H._Type_list $ var "hlt",
_Type_literal>>: lambda "lt" $
cases _LiteralType (var "lt")
(Just $ Flows.fail $ Strings.cat2 (string "unexpected literal type: ") (ref ShowCore.literalTypeDef @@ var "lt")) [
_LiteralType_boolean>>: constant $
Flows.pure $ inject H._Type H._Type_variable $ ref HaskellUtils.rawNameDef @@ string "Bool",
_LiteralType_float>>: lambda "ft" $
cases _FloatType (var "ft") Nothing [
_FloatType_float32>>: constant $
Flows.pure $ inject H._Type H._Type_variable $ ref HaskellUtils.rawNameDef @@ string "Float",
_FloatType_float64>>: constant $
Flows.pure $ inject H._Type H._Type_variable $ ref HaskellUtils.rawNameDef @@ string "Double",
_FloatType_bigfloat>>: constant $
Flows.pure $ inject H._Type H._Type_variable $ ref HaskellUtils.rawNameDef @@ string "Double"],
_LiteralType_integer>>: lambda "it" $
cases _IntegerType (var "it")
(Just $ Flows.fail $ Strings.cat2 (string "unexpected integer type: ") (ref ShowCore.integerTypeDef @@ var "it")) [
_IntegerType_bigint>>: constant $
Flows.pure $ inject H._Type H._Type_variable $ ref HaskellUtils.rawNameDef @@ string "Integer",
_IntegerType_int8>>: constant $
Flows.pure $ inject H._Type H._Type_variable $ ref HaskellUtils.rawNameDef @@ string "I.Int8",
_IntegerType_int16>>: constant $
Flows.pure $ inject H._Type H._Type_variable $ ref HaskellUtils.rawNameDef @@ string "I.Int16",
_IntegerType_int32>>: constant $
Flows.pure $ inject H._Type H._Type_variable $ ref HaskellUtils.rawNameDef @@ string "Int",
_IntegerType_int64>>: constant $
Flows.pure $ inject H._Type H._Type_variable $ ref HaskellUtils.rawNameDef @@ string "I.Int64"],
_LiteralType_string>>: constant $
Flows.pure $ inject H._Type H._Type_variable $ ref HaskellUtils.rawNameDef @@ string "String"],
_Type_map>>: lambda "mapType" $ lets [
"kt">: Core.mapTypeKeys $ var "mapType",
"vt">: Core.mapTypeValues $ var "mapType"] $
Flows.map
(ref HaskellUtils.toTypeApplicationDef)
(Flows.sequence $ list [
Flows.pure $ inject H._Type H._Type_variable $ ref HaskellUtils.rawNameDef @@ string "M.Map",
var "encode" @@ var "kt",
var "encode" @@ var "vt"]),
_Type_optional>>: lambda "ot" $
Flows.map
(ref HaskellUtils.toTypeApplicationDef)
(Flows.sequence $ list [
Flows.pure $ inject H._Type H._Type_variable $ ref HaskellUtils.rawNameDef @@ string "Maybe",
var "encode" @@ var "ot"]),
_Type_product>>: lambda "types" $
Flows.bind (Flows.mapList (var "encode") (var "types")) $ lambda "htypes" $
Flows.pure $ inject H._Type H._Type_tuple $ var "htypes",
_Type_record>>: lambda "rt" $ var "ref" @@ (Core.rowTypeTypeName $ var "rt"),
_Type_set>>: lambda "st" $
Flows.map
(ref HaskellUtils.toTypeApplicationDef)
(Flows.sequence $ list [
Flows.pure $ inject H._Type H._Type_variable $ ref HaskellUtils.rawNameDef @@ string "S.Set",
var "encode" @@ var "st"]),
_Type_union>>: lambda "rt" $ lets [
"typeName">: Core.rowTypeTypeName $ var "rt"] $
var "ref" @@ var "typeName",
_Type_unit>>: constant $ Flows.pure $ var "unitTuple",
_Type_variable>>: lambda "v1" $ var "ref" @@ var "v1",
_Type_wrap>>: lambda "wrapped" $ lets [
"name">: Core.wrappedTypeTypeName $ var "wrapped"] $
var "ref" @@ var "name"]
encodeTypeWithClassAssertionsDef :: TBinding (HaskellNamespaces -> M.Map Name (S.Set TypeClass) -> Type -> Flow Graph H.Type)
encodeTypeWithClassAssertionsDef = haskellCoderDefinition "encodeTypeWithClassAssertions" $
lambda "namespaces" $ lambda "explicitClasses" $ lambda "typ" $ lets [
"classes">: Maps.union (var "explicitClasses") (ref getImplicitTypeClassesDef @@ var "typ"),
"implicitClasses">: ref getImplicitTypeClassesDef @@ var "typ",
"encodeAssertion">: lambda "pair" $ lets [
"name">: first $ var "pair",
"cls">: second $ var "pair",
"hname">: ref HaskellUtils.rawNameDef @@ cases _TypeClass (var "cls") Nothing [
_TypeClass_equality>>: constant $ string "Eq",
_TypeClass_ordering>>: constant $ string "Ord"],
"htype">: inject H._Type H._Type_variable $ ref HaskellUtils.rawNameDef @@ (Core.unName $ var "name")] $
inject H._Assertion H._Assertion_class $ record H._ClassAssertion [
H._ClassAssertion_name>>: var "hname",
H._ClassAssertion_types>>: list [var "htype"]],
"assertPairs">: Lists.concat $ Lists.map (var "toPairs") (Maps.toList $ var "classes"),
"toPairs">: lambda "mapEntry" $ lets [
"name">: first $ var "mapEntry",
"clsSet">: second $ var "mapEntry",
"toPair">: lambda "c" $
pair (var "name") (var "c")] $
Lists.map (var "toPair") (Sets.toList $ var "clsSet")] $
ref Monads.withTraceDef @@ (string "encode with assertions") @@
(bind "htyp" (ref adaptTypeToHaskellAndEncodeDef @@ var "namespaces" @@ var "typ") $
Logic.ifElse (Lists.null $ var "assertPairs")
(Flows.pure $ var "htyp") (lets [
"encoded">: Lists.map (var "encodeAssertion") (var "assertPairs"),
"hassert">: Logic.ifElse (Equality.gt (Lists.length $ var "encoded") (int32 1))
(Lists.head $ var "encoded")
(inject H._Assertion H._Assertion_tuple $ var "encoded")] $
Flows.pure $ inject H._Type H._Type_ctx $ record H._ContextType [
H._ContextType_ctx>>: var "hassert",
H._ContextType_type>>: var "htyp"]))
findOrdVariablesDef :: TBinding (Type -> S.Set Name)
findOrdVariablesDef = haskellCoderDefinition "findOrdVariables" $
lambda "typ" $ lets [
"fold">: lambda "names" $ lambda "typ'" $
cases _Type (var "typ'")
(Just $ var "names") [
_Type_map>>: lambda "mapType" $ lets [
"kt">: Core.mapTypeKeys $ var "mapType"] $
var "tryType" @@ var "names" @@ var "kt",
_Type_set>>: lambda "et" $
var "tryType" @@ var "names" @@ var "et"],
"isTypeVariable">: lambda "v" $ lets [
"nameStr">: Core.unName $ var "v",
"hasNoNamespace">: Optionals.isNothing $ ref Names.namespaceOfDef @@ var "v",
"startsWithT">: Equality.equal (Strings.charAt (int32 0) (var "nameStr")) (int32 116)] $ -- 't' character
Logic.and (var "hasNoNamespace") (var "startsWithT"),
"tryType">: lambda "names" $ lambda "t" $
cases _Type (ref Rewriting.deannotateTypeDef @@ var "t")
(Just $ var "names") [
_Type_variable>>: lambda "v" $
Logic.ifElse (var "isTypeVariable" @@ var "v")
(Sets.insert (var "v") (var "names"))
(var "names")]] $
ref Rewriting.foldOverTypeDef @@ Coders.traversalOrderPre @@ var "fold" @@ Sets.empty @@ var "typ"
getImplicitTypeClassesDef :: TBinding (Type -> M.Map Name (S.Set TypeClass))
getImplicitTypeClassesDef = haskellCoderDefinition "getImplicitTypeClasses" $
lambda "typ" $ lets [
"toPair">: lambda "name" $
pair (var "name") (Sets.fromList $ list [Graph.typeClassOrdering])] $
Maps.fromList $ Lists.map (var "toPair") (Sets.toList $ ref findOrdVariablesDef @@ var "typ")
moduleToHaskellModuleDef :: TBinding (Module -> Flow Graph H.Module)
moduleToHaskellModuleDef = haskellCoderDefinition "moduleToHaskellModule" $
lambda "mod" $
bind "namespaces" (ref HaskellUtils.namespacesForModuleDef @@ var "mod") $
ref AdaptModules.transformModuleDef @@ (ref HaskellLanguage.haskellLanguageDef) @@ (ref encodeTermDef @@ var "namespaces") @@ (ref constructModuleDef @@ var "namespaces") @@ var "mod"
moduleToHaskellDef :: TBinding (Module -> Flow Graph (M.Map String String))
moduleToHaskellDef = haskellCoderDefinition "moduleToHaskell" $ lambda "mod" $
bind "hsmod" (ref moduleToHaskellModuleDef @@ var "mod") $ lets [
"s">: ref Serialization.printExprDef @@ (ref Serialization.parenthesizeDef @@ (ref HaskellSerde.moduleToExprDef @@ var "hsmod")),
"filepath">: ref Names.namespaceToFilePathDef @@ Mantle.caseConventionPascal @@ (wrap _FileExtension $ string "hs") @@ (Module.moduleNamespace $ var "mod")] $
Flows.pure $ Maps.singleton (var "filepath") (var "s")
nameDeclsDef :: TBinding (Graph -> HaskellNamespaces -> Name -> Type -> [H.DeclarationWithComments])
nameDeclsDef = haskellCoderDefinition "nameDecls" $
lambda "g" $ lambda "namespaces" $ lambda "name" $ lambda "typ" $ lets [
"nm">: Core.unName $ var "name",
"toDecl">: lambda "n" $ lambda "pair" $ lets [
"k">: first $ var "pair",
"v">: second $ var "pair",
"decl">: inject H._Declaration H._Declaration_valueBinding $ inject H._ValueBinding H._ValueBinding_simple $ record H._SimpleValueBinding [
H._SimpleValueBinding_pattern>>: ref HaskellUtils.applicationPatternDef @@ (ref HaskellUtils.simpleNameDef @@ var "k") @@ list [],
H._SimpleValueBinding_rhs>>: wrap H._RightHandSide $ inject H._Expression H._Expression_application $ record H._ApplicationExpression [
H._ApplicationExpression_function>>: inject H._Expression H._Expression_variable $ ref HaskellUtils.elementReferenceDef @@ var "namespaces" @@ var "n",
H._ApplicationExpression_argument>>: inject H._Expression H._Expression_literal $ inject H._Literal H._Literal_string $ var "v"],
H._SimpleValueBinding_localBindings>>: nothing]] $
record H._DeclarationWithComments [
H._DeclarationWithComments_body>>: var "decl",
H._DeclarationWithComments_comments>>: nothing],
"nameDecl">: pair (ref constantForTypeNameDef @@ var "name") (var "nm"),
"fieldDecls">: Lists.map (var "toConstant") (ref Lexical.fieldsOfDef @@ var "typ"),
"toConstant">: lambda "fieldType" $ lets [
"fname">: Core.fieldTypeName $ var "fieldType"] $
pair (ref constantForFieldNameDef @@ var "name" @@ var "fname") (Core.unName $ var "fname")] $
Logic.ifElse (ref useCoreImportDef)
(Lists.cons (var "toDecl" @@ Core.nameLift _Name @@ var "nameDecl") (Lists.map (var "toDecl" @@ Core.nameLift _Name) (var "fieldDecls")))
(list [])
toDataDeclarationDef :: TBinding (M.Map Type (Coder Graph Graph Term H.Expression) -> HaskellNamespaces -> (Binding, TypedTerm) -> Flow Graph H.DeclarationWithComments)
toDataDeclarationDef = haskellCoderDefinition "toDataDeclaration" $
lambdas ["coders", "namespaces", "pair"] $ lets [
"el">: first $ var "pair",
"tt">: second $ var "pair",
"term">: Core.typedTermTerm $ var "tt",
"typ">: Core.typedTermType $ var "tt",
"coder">: Optionals.fromJust $ Maps.lookup (var "typ") (var "coders"),
"hname">: ref HaskellUtils.simpleNameDef @@ (ref Names.localNameOfDef @@ (Core.bindingName $ var "el")),
"rewriteValueBinding">: lambda "vb" $
cases H._ValueBinding (var "vb") Nothing [
H._ValueBinding_simple>>: lambda "simple" $ lets [
"pattern'">: project H._SimpleValueBinding H._SimpleValueBinding_pattern @@ var "simple",
"rhs">: project H._SimpleValueBinding H._SimpleValueBinding_rhs @@ var "simple",
"bindings">: project H._SimpleValueBinding H._SimpleValueBinding_localBindings @@ var "simple"] $
cases H._Pattern (var "pattern'")
(Just $ var "vb") [
H._Pattern_application>>: lambda "appPat" $ lets [
"name'">: project H._ApplicationPattern H._ApplicationPattern_name @@ var "appPat",
"args">: project H._ApplicationPattern H._ApplicationPattern_args @@ var "appPat",
"rhsExpr">: unwrap H._RightHandSide @@ var "rhs"] $
cases H._Expression (var "rhsExpr")
(Just $ var "vb") [
H._Expression_lambda>>: lambda "lambda'" $ lets [
"vars">: project H._LambdaExpression H._LambdaExpression_bindings @@ var "lambda'",
"body">: project H._LambdaExpression H._LambdaExpression_inner @@ var "lambda'",
"newPattern">: ref HaskellUtils.applicationPatternDef @@ var "name'" @@ (Lists.concat2 (var "args") (var "vars")),
"newRhs">: wrap H._RightHandSide $ var "body"] $
var "rewriteValueBinding" @@ (inject H._ValueBinding H._ValueBinding_simple $ record H._SimpleValueBinding [
H._SimpleValueBinding_pattern>>: var "newPattern",
H._SimpleValueBinding_rhs>>: var "newRhs",
H._SimpleValueBinding_localBindings>>: var "bindings"])]]],
"toDecl">: lambda "comments" $ lambda "hname'" $ lambda "term'" $ lambda "coder'" $ lambda "bindings" $
cases _Term (ref Rewriting.deannotateTermDef @@ var "term'")
(Just $
bind "hterm" (Compute.coderEncode (var "coder'") @@ (var "term'")) $ lets [
"vb">: ref HaskellUtils.simpleValueBindingDef @@ var "hname'" @@ var "hterm" @@ var "bindings"] $
bind "explicitClasses" (ref Annotations.getTypeClassesDef @@ (ref Rewriting.removeTypesFromTermDef @@ (Core.bindingTerm $ var "el"))) $
bind "htype" (ref encodeTypeWithClassAssertionsDef @@ var "namespaces" @@ var "explicitClasses" @@ var "typ") $ lets [
"decl">: inject H._Declaration H._Declaration_typedBinding $ record H._TypedBinding [
H._TypedBinding_typeSignature>>: record H._TypeSignature [
H._TypeSignature_name>>: var "hname'",
H._TypeSignature_type>>: var "htype"],
H._TypedBinding_valueBinding>>: var "rewriteValueBinding" @@ var "vb"]] $
Flows.pure $ record H._DeclarationWithComments [
H._DeclarationWithComments_body>>: var "decl",
H._DeclarationWithComments_comments>>: var "comments"]) [
_Term_let>>: lambda "letTerm" $ lets [
-- A "let" constant cannot be predicted in advance, so we construct a coder on the fly.
-- This makes program code with "let" terms more expensive to transform than simple data.
"lbindings">: Core.letBindings $ var "letTerm",
"env">: Core.letEnvironment $ var "letTerm",
"toBinding">: lambda "hname''" $ lambda "hterm'" $
inject H._LocalBinding H._LocalBinding_value $ ref HaskellUtils.simpleValueBindingDef @@ var "hname''" @@ var "hterm'" @@ nothing,
"ts">: Lists.map (lambda "binding" $ Core.typeSchemeType $ Optionals.fromJust $ Core.bindingType $ var "binding") (var "lbindings")] $
bind "coders'" (Flows.mapList (lambda "t" $ ref AdaptModules.constructCoderDef @@ (ref HaskellLanguage.haskellLanguageDef) @@ (ref encodeTermDef @@ var "namespaces") @@ var "t") (var "ts")) $ lets [
"hnames">: Lists.map (lambda "binding" $ ref HaskellUtils.simpleNameDef @@ (Core.unName $ Core.bindingName $ var "binding")) (var "lbindings"),
"terms">: Lists.map (unaryFunction $ Core.bindingTerm) (var "lbindings")] $
bind "hterms" (Flows.sequence $ Lists.zipWith (lambdas ["e", "t"] $ Compute.coderEncode (var "e") @@ var "t") (var "coders'") (var "terms")) $ lets [
"hbindings">: Lists.zipWith (var "toBinding") (var "hnames") (var "hterms")] $
var "toDecl" @@ var "comments" @@ var "hname'" @@ var "env" @@ var "coder'" @@ (just $ wrap H._LocalBindings $ var "hbindings")]] $
bind "comments" (ref Annotations.getTermDescriptionDef @@ var "term") $
var "toDecl" @@ var "comments" @@ var "hname" @@ var "term" @@ var "coder" @@ nothing
toTypeDeclarationsDef :: TBinding (HaskellNamespaces -> Binding -> Term -> Flow Graph [H.DeclarationWithComments])
toTypeDeclarationsDef = haskellCoderDefinition "toTypeDeclarations" $
lambda "namespaces" $ lambda "el" $ lambda "term" $ lets [
"elementName">: Core.bindingName $ var "el",
"lname">: ref Names.localNameOfDef @@ var "elementName",
"hname">: ref HaskellUtils.simpleNameDef @@ var "lname",
"declHead">: lambdas ["name", "vars'"] $ Logic.ifElse (Lists.null $ var "vars'")
(inject H._DeclarationHead H._DeclarationHead_simple $ var "name")
(lets [
"h">: Lists.head $ var "vars'",
"rest">: Lists.tail $ var "vars'",
"hvar">: wrap H._Variable $ ref HaskellUtils.simpleNameDef @@ (Core.unName $ var "h")] $
inject H._DeclarationHead H._DeclarationHead_application $ record H._ApplicationDeclarationHead [
H._ApplicationDeclarationHead_function>>: var "declHead" @@ var "name" @@ var "rest",
H._ApplicationDeclarationHead_operand>>: var "hvar"]),
"newtypeCons">: lambda "el'" $ lambda "typ'" $ lets [
"hname">: ref HaskellUtils.simpleNameDef @@ (ref HaskellUtils.newtypeAccessorNameDef @@ (Core.bindingName $ var "el'"))] $
bind "htype" (ref adaptTypeToHaskellAndEncodeDef @@ var "namespaces" @@ var "typ'") $ lets [
"hfield">: record H._FieldWithComments [
H._FieldWithComments_field>>: record H._Field [
H._Field_name>>: var "hname",
H._Field_type>>: var "htype"],
H._FieldWithComments_comments>>: nothing],
"constructorName">: ref HaskellUtils.simpleNameDef @@ (ref Names.localNameOfDef @@ (Core.bindingName $ var "el'"))] $
Flows.pure $ record H._ConstructorWithComments [
H._ConstructorWithComments_body>>: inject H._Constructor H._Constructor_record $ record H._RecordConstructor [
H._RecordConstructor_name>>: var "constructorName",
H._RecordConstructor_fields>>: list [var "hfield"]],
H._ConstructorWithComments_comments>>: nothing],
"recordCons">: lambda "lname'" $ lambda "fields" $ lets [
"toField">: lambda "fieldType" $ lets [
"fname">: Core.fieldTypeName $ var "fieldType",
"ftype">: Core.fieldTypeType $ var "fieldType",
"hname'">: ref HaskellUtils.simpleNameDef @@ Strings.cat2
(ref Formatting.decapitalizeDef @@ var "lname'")
(ref Formatting.capitalizeDef @@ (Core.unName $ var "fname"))] $
bind "htype" (ref adaptTypeToHaskellAndEncodeDef @@ var "namespaces" @@ var "ftype") $
bind "comments" (ref Annotations.getTypeDescriptionDef @@ var "ftype") $
Flows.pure $ record H._FieldWithComments [
H._FieldWithComments_field>>: record H._Field [
H._Field_name>>: var "hname'",
H._Field_type>>: var "htype"],
H._FieldWithComments_comments>>: var "comments"]] $
bind "hFields" (Flows.mapList (var "toField") (var "fields")) $
Flows.pure $ record H._ConstructorWithComments [
H._ConstructorWithComments_body>>: inject H._Constructor H._Constructor_record $ record H._RecordConstructor [
H._RecordConstructor_name>>: ref HaskellUtils.simpleNameDef @@ var "lname'",
H._RecordConstructor_fields>>: var "hFields"],
H._ConstructorWithComments_comments>>: nothing],
"unionCons">: lambda "g'" $ lambda "lname'" $ lambda "fieldType" $ lets [
"fname">: Core.fieldTypeName $ var "fieldType",
"ftype">: Core.fieldTypeType $ var "fieldType",
"deconflict">: lambda "name" $ lets [
"tname">: ref Names.unqualifyNameDef @@ record _QualifiedName [
_QualifiedName_namespace>>: just $ first $ Module.namespacesFocus $ var "namespaces",
_QualifiedName_local>>: var "name"]] $
Logic.ifElse (Optionals.isJust $ Maps.lookup (var "tname") (Graph.graphElements $ var "g'"))
(var "deconflict" @@ Strings.cat2 (var "name") (string "_"))
(var "name")] $
bind "comments" (ref Annotations.getTypeDescriptionDef @@ var "ftype") $ lets [
"nm">: var "deconflict" @@ Strings.cat2 (ref Formatting.capitalizeDef @@ var "lname'") (ref Formatting.capitalizeDef @@ (Core.unName $ var "fname"))] $
bind "typeList" (Logic.ifElse (Equality.equal (ref Rewriting.deannotateTypeDef @@ var "ftype") TTypes.unit)
(Flows.pure $ list []) $
Flows.bind (ref adaptTypeToHaskellAndEncodeDef @@ var "namespaces" @@ var "ftype") $ lambda "htype" $
Flows.pure $ list [var "htype"]) $
Flows.pure $ record H._ConstructorWithComments [
H._ConstructorWithComments_body>>: inject H._Constructor H._Constructor_ordinary $ record H._OrdinaryConstructor [
H._OrdinaryConstructor_name>>: ref HaskellUtils.simpleNameDef @@ var "nm",
H._OrdinaryConstructor_fields>>: var "typeList"],
H._ConstructorWithComments_comments>>: var "comments"]] $
ref Monads.withTraceDef @@ (Strings.cat2 (string "type element ") (Core.unName $ var "elementName")) @@ (
bind "g" (ref Monads.getStateDef) $
bind "t" (ref DecodeCore.typeDef @@ var "term") $
bind "isSer" (ref Schemas.isSerializableDef @@ var "el") $ lets [
"deriv">: wrap H._Deriving $ Logic.ifElse (var "isSer")
(Lists.map (ref HaskellUtils.rawNameDef) (list [string "Eq", string "Ord", string "Read", string "Show"]))
(list []),
"unpackResult">: ref HaskellUtils.unpackForallTypeDef @@ var "g" @@ var "t",
"vars">: first $ var "unpackResult",
"t'">: second $ var "unpackResult",
"hd">: var "declHead" @@ var "hname" @@ (Lists.reverse $ var "vars")] $
bind "decl" (cases _Type (ref Rewriting.deannotateTypeDef @@ var "t'")
(Just $ bind "htype" (ref adaptTypeToHaskellAndEncodeDef @@ var "namespaces" @@ var "t") $
Flows.pure $ inject H._Declaration H._Declaration_type $ record H._TypeDeclaration [
H._TypeDeclaration_name>>: var "hd",
H._TypeDeclaration_type>>: var "htype"]) [
_Type_record>>: lambda "rt" $
bind "cons" (var "recordCons" @@ var "lname" @@ (Core.rowTypeFields $ var "rt")) $
Flows.pure $ inject H._Declaration H._Declaration_data $ record H._DataDeclaration [
H._DataDeclaration_keyword>>: unitVariant H._DataOrNewtype H._DataOrNewtype_data,
H._DataDeclaration_context>>: list [],
H._DataDeclaration_head>>: var "hd",
H._DataDeclaration_constructors>>: list [var "cons"],
H._DataDeclaration_deriving>>: list [var "deriv"]],
_Type_union>>: lambda "rt" $
bind "cons" (Flows.mapList (var "unionCons" @@ var "g" @@ var "lname") (Core.rowTypeFields $ var "rt")) $
Flows.pure $ inject H._Declaration H._Declaration_data $ record H._DataDeclaration [
H._DataDeclaration_keyword>>: unitVariant H._DataOrNewtype H._DataOrNewtype_data,
H._DataDeclaration_context>>: list [],
H._DataDeclaration_head>>: var "hd",
H._DataDeclaration_constructors>>: var "cons",
H._DataDeclaration_deriving>>: list [var "deriv"]],
_Type_wrap>>: lambda "wrapped" $ lets [
"tname">: Core.wrappedTypeTypeName $ var "wrapped",
"wt">: Core.wrappedTypeObject $ var "wrapped"] $
bind "cons" (var "newtypeCons" @@ var "el" @@ var "wt") $
Flows.pure $ inject H._Declaration H._Declaration_data $ record H._DataDeclaration [
H._DataDeclaration_keyword>>: unitVariant H._DataOrNewtype H._DataOrNewtype_newtype,
H._DataDeclaration_context>>: list [],
H._DataDeclaration_head>>: var "hd",
H._DataDeclaration_constructors>>: list [var "cons"],
H._DataDeclaration_deriving>>: list [var "deriv"]]]) $
bind "comments" (ref Annotations.getTermDescriptionDef @@ var "term") $
bind "tdecls" (Logic.ifElse (ref includeTypeDefinitionsDef)
(Flows.bind (ref typeDeclDef @@ var "namespaces" @@ var "elementName" @@ var "t") $ lambda "decl'" $
Flows.pure $ list [var "decl'"])
(Flows.pure $ list [])) $ lets [
"mainDecl">: record H._DeclarationWithComments [
H._DeclarationWithComments_body>>: var "decl",
H._DeclarationWithComments_comments>>: var "comments"],
"nameDecls'">: ref nameDeclsDef @@ var "g" @@ var "namespaces" @@ var "elementName" @@ var "t"] $
Flows.pure $ Lists.concat $ list [list [var "mainDecl"], var "nameDecls'", var "tdecls"])
typeDeclDef :: TBinding (HaskellNamespaces -> Name -> Type -> Flow Graph H.DeclarationWithComments)
typeDeclDef = haskellCoderDefinition "typeDecl" $
lambda "namespaces" $ lambda "name" $ lambda "typ" $ lets [
"typeName">: lambda "ns" $ lambda "name'" $
ref Names.qnameDef @@ var "ns" @@ (var "typeNameLocal" @@ var "name'"),
"typeNameLocal">: lambda "name'" $
Strings.cat $ list [string "_", ref Names.localNameOfDef @@ var "name'", string "_type_"],
"rawTerm">: ref EncodeCore.typeDef @@ var "typ",
"rewrite">: lambda "recurse" $ lambda "term" $ lets [
"variantResult">: ref Decoding.variantDef @@ Core.nameLift _Type @@ var "term",
"forType">: lambda "field" $ lets [
"fname">: Core.fieldName $ var "field",
"fterm">: Core.fieldTerm $ var "field"] $
Logic.ifElse (Equality.equal (var "fname") $ Core.nameLift _Type_record)
nothing
(Logic.ifElse (Equality.equal (var "fname") $ Core.nameLift _Type_variable)
(Optionals.bind (ref Decoding.nameDef @@ var "fterm") (var "forVariableType"))
nothing),
"forVariableType">: lambda "name''" $ lets [
"qname">: ref Names.qualifyNameDef @@ var "name''",
"mns">: Module.qualifiedNameNamespace $ var "qname",
"local">: Module.qualifiedNameLocal $ var "qname"] $
Optionals.map (lambda "ns" $ Core.termVariable $ ref Names.qnameDef @@ var "ns" @@ (Strings.cat $ list [string "_", var "local", string "_type_"])) (var "mns")] $
Optionals.fromMaybe (var "recurse" @@ var "term") (Optionals.bind (var "variantResult") (var "forType")),
"finalTerm">: ref Rewriting.rewriteTermDef @@ var "rewrite" @@ var "rawTerm"] $
-- Note: consider constructing this coder just once, then reusing it
bind "coder" (ref AdaptModules.constructCoderDef @@ (ref HaskellLanguage.haskellLanguageDef) @@ (ref encodeTermDef @@ var "namespaces") @@ (Core.typeVariable $ Core.nameLift _Type)) $
bind "expr" (Compute.coderEncode (var "coder") @@ var "finalTerm") $ lets [
"rhs">: wrap H._RightHandSide $ var "expr",
"hname">: ref HaskellUtils.simpleNameDef @@ (var "typeNameLocal" @@ var "name"),
"pat">: ref HaskellUtils.applicationPatternDef @@ var "hname" @@ list [],
"decl">: inject H._Declaration H._Declaration_valueBinding $ inject H._ValueBinding H._ValueBinding_simple $ record H._SimpleValueBinding [
H._SimpleValueBinding_pattern>>: var "pat",
H._SimpleValueBinding_rhs>>: var "rhs",
H._SimpleValueBinding_localBindings>>: nothing]] $
Flows.pure $ record H._DeclarationWithComments [
H._DeclarationWithComments_body>>: var "decl",
H._DeclarationWithComments_comments>>: nothing]