hydra-0.13.0: src/main/haskell/Hydra/Sources/Kernel/Terms/Adapt/Simple.hs
module Hydra.Sources.Kernel.Terms.Adapt.Simple where
-- Standard imports for kernel terms modules
import Hydra.Kernel hiding (
adaptFloatType, adaptDataGraph, adaptGraphSchema, adaptIntegerType, adaptLambdaDomains, adaptLiteral,
adaptLiteralType, adaptLiteralTypesMap, adaptLiteralValue, adaptNestedTypes, adaptPrimitive,
adaptTerm, adaptType, adaptTypeScheme,
dataGraphToDefinitions, literalTypeSupported, pushTypeAppsInward, schemaGraphToDefinitions,
termAlternatives, typeAlternatives)
import Hydra.Sources.Libraries
import qualified Hydra.Dsl.Meta.Accessors as Accessors
import qualified Hydra.Dsl.Annotations as Annotations
import qualified Hydra.Dsl.Meta.Ast as Ast
import qualified Hydra.Dsl.Bootstrap as Bootstrap
import qualified Hydra.Dsl.Meta.Coders as Coders
import qualified Hydra.Dsl.Meta.Compute as Compute
import qualified Hydra.Dsl.Meta.Core as Core
import qualified Hydra.Dsl.Meta.Grammar as Grammar
import qualified Hydra.Dsl.Grammars as Grammars
import qualified Hydra.Dsl.Meta.Graph as Graph
import qualified Hydra.Dsl.Meta.Json as Json
import qualified Hydra.Dsl.Meta.Lib.Chars as Chars
import qualified Hydra.Dsl.Meta.Lib.Eithers as Eithers
import qualified Hydra.Dsl.Meta.Lib.Equality as Equality
import qualified Hydra.Dsl.Meta.Lib.Flows as Flows
import qualified Hydra.Dsl.Meta.Lib.Lists as Lists
import qualified Hydra.Dsl.Meta.Lib.Literals as Literals
import qualified Hydra.Dsl.Meta.Lib.Logic as Logic
import qualified Hydra.Dsl.Meta.Lib.Maps as Maps
import qualified Hydra.Dsl.Meta.Lib.Math as Math
import qualified Hydra.Dsl.Meta.Lib.Maybes as Maybes
import qualified Hydra.Dsl.Meta.Lib.Pairs as Pairs
import qualified Hydra.Dsl.Meta.Lib.Sets as Sets
import Hydra.Dsl.Meta.Lib.Strings as Strings
import qualified Hydra.Dsl.Literals as Literals
import qualified Hydra.Dsl.LiteralTypes as LiteralTypes
import qualified Hydra.Dsl.Meta.Base as MetaBase
import qualified Hydra.Dsl.Meta.Terms as MetaTerms
import qualified Hydra.Dsl.Meta.Types as MetaTypes
import qualified Hydra.Dsl.Meta.Module as Module
import qualified Hydra.Dsl.Meta.Parsing as Parsing
import Hydra.Dsl.Meta.Phantoms as Phantoms
import qualified Hydra.Dsl.Prims as Prims
import qualified Hydra.Dsl.Tabular as Tabular
import qualified Hydra.Dsl.Meta.Testing as Testing
import qualified Hydra.Dsl.Terms as Terms
import qualified Hydra.Dsl.Tests as Tests
import qualified Hydra.Dsl.Meta.Topology as Topology
import qualified Hydra.Dsl.Types as Types
import qualified Hydra.Dsl.Meta.Typing as Typing
import qualified Hydra.Dsl.Meta.Util as Util
import qualified Hydra.Dsl.Meta.Variants as Variants
import Hydra.Sources.Kernel.Types.All
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
import qualified Hydra.Sources.Kernel.Terms.Hoisting as Hoisting
import qualified Hydra.Sources.Kernel.Terms.Inference as Inference
import qualified Hydra.Sources.Kernel.Terms.Literals as Literals
import qualified Hydra.Sources.Kernel.Terms.Names as Names
import qualified Hydra.Sources.Kernel.Terms.Reduction as Reduction
import qualified Hydra.Sources.Kernel.Terms.Reflect as Reflect
import qualified Hydra.Sources.Kernel.Terms.Rewriting as Rewriting
import qualified Hydra.Sources.Kernel.Terms.Schemas as Schemas
import qualified Hydra.Sources.Kernel.Terms.Show.Core as ShowCore
import qualified Hydra.Sources.Kernel.Terms.Show.Graph as ShowGraph
ns :: Namespace
ns = Namespace "hydra.adapt.simple"
module_ :: Module
module_ = Module ns elements
[Hoisting.ns, Inference.ns, Literals.ns, Names.ns, Reduction.ns, Reflect.ns, Rewriting.ns, Schemas.ns,
ShowCore.ns, ShowGraph.ns]
kernelTypesNamespaces $
Just "Simple, one-way adapters for types and terms"
where
elements = [
toBinding adaptFloatType,
toBinding adaptDataGraph,
toBinding adaptGraphSchema,
toBinding adaptIntegerType,
toBinding adaptLambdaDomains,
toBinding adaptLiteral,
toBinding adaptLiteralType,
toBinding adaptLiteralTypesMap,
toBinding adaptLiteralValue,
toBinding adaptNestedTypes,
toBinding adaptPrimitive,
toBinding adaptTerm,
toBinding adaptType,
toBinding adaptTypeScheme,
toBinding dataGraphToDefinitions,
toBinding literalTypeSupported,
toBinding pushTypeAppsInward,
toBinding schemaGraphToDefinitions,
toBinding termAlternatives,
toBinding typeAlternatives]
define :: String -> TTerm a -> TBinding a
define = definitionInModule module_
adaptFloatType :: TBinding (LanguageConstraints -> FloatType -> Maybe FloatType)
adaptFloatType = define "adaptFloatType" $
doc "Attempt to adapt a floating-point type using the given language constraints" $
"constraints" ~> "ft" ~>
"supported" <~ Sets.member (var "ft") (Coders.languageConstraintsFloatTypes $ var "constraints") $
"alt" <~ (adaptFloatType @@ var "constraints") $
"forUnsupported" <~ ("ft" ~> cases _FloatType (var "ft")
Nothing [
-- _FloatType_bigfloat>>: constant nothing,
_FloatType_bigfloat>>: constant $ var "alt" @@ Core.floatTypeFloat64, -- TODO: temporary; the only non-lossy alternative for bigfloat is string, but some migration is needed
_FloatType_float32>>: constant $ var "alt" @@ Core.floatTypeFloat64,
_FloatType_float64>>: constant $ var "alt" @@ Core.floatTypeBigfloat]) $
Logic.ifElse (var "supported")
(just $ var "ft")
(var "forUnsupported" @@ var "ft")
adaptDataGraph :: TBinding (LanguageConstraints -> Bool -> Graph -> Flow s Graph)
adaptDataGraph = define "adaptDataGraph" $
doc ("Adapt a graph and its schema to the given language constraints."
<> " The doExpand flag controls eta expansion of partial applications."
<> " Adaptation is type-preserving: binding-level TypeSchemes are adapted (not stripped)."
<> " Note: case statement hoisting is done separately, prior to adaptation.") $
"constraints" ~> "doExpand" ~> "graph0" ~>
"transform" <~ ("graph" ~> "gterm" ~>
"tx" <<~ Schemas.graphToTypeContext @@ var "graph" $
-- Order of operations:
-- 1. Unshadow variables first (prevents capture issues in eta expansion)
-- 2. Eta expand (needs type annotations; creates fully-applied functions)
-- 3. Lift lambdas above lets (structural cleanup)
"gterm1" <~ Rewriting.unshadowVariables @@ (pushTypeAppsInward @@ var "gterm") $
"gterm2" <~ Rewriting.unshadowVariables @@ (Logic.ifElse (var "doExpand")
(pushTypeAppsInward @@ (Reduction.etaExpandTermNew @@ var "tx" @@ var "gterm1"))
(var "gterm1")) $
produce $ Rewriting.liftLambdaAboveLet @@ var "gterm2") $
"litmap" <~ adaptLiteralTypesMap @@ var "constraints" $
"els0" <~ Graph.graphElements (var "graph0") $
"env0" <~ Graph.graphEnvironment (var "graph0") $
"body0" <~ Graph.graphBody (var "graph0") $
"prims0" <~ Graph.graphPrimitives (var "graph0") $
"schema0" <~ Graph.graphSchema (var "graph0") $
"schema1" <<~ optCases (var "schema0")
(produce nothing)
-- ("sg" ~> Flows.fail $ "schema graph: " ++ (ShowGraph.graph @@ var "sg")) $
( "sg" ~>
"tmap0" <<~ Schemas.graphAsTypes @@ var "sg" $
"tmap1" <<~ adaptGraphSchema @@ var "constraints" @@ var "litmap" @@ var "tmap0" $
"emap" <~ Schemas.typesToElements @@ var "tmap1" $
produce $ just $ Graph.graphWithElements (var "sg") (var "emap")) $
"gterm0" <~ Schemas.graphAsTerm @@ var "graph0" $
"gterm1" <<~ Logic.ifElse (var "doExpand")
(var "transform" @@ var "graph0" @@ var "gterm0")
(produce $ var "gterm0") $
"gterm2" <<~ adaptTerm @@ var "constraints" @@ var "litmap" @@ var "gterm1" $
-- Adapt lambda domains in the adapted term.
-- Lambda domains carry pre-adaptation types (e.g. bigfloat) that must be adapted to match
-- the post-adaptation terms (e.g. float64). This preserves type annotations.
"gterm3" <<~ Rewriting.rewriteTermM @@ (adaptLambdaDomains @@ var "constraints" @@ var "litmap") @@ var "gterm2" $
"els1Raw" <~ Schemas.termAsGraph @@ var "gterm3" $
-- Adapt nested let binding TypeSchemes within each top-level binding's term.
-- These TypeSchemes may carry stale types from JSON modules (e.g. bigfloat→float64).
-- Applied per-binding AFTER termAsGraph so that top-level binding TypeSchemes
-- (which carry type-class constraints like Ord) are preserved.
-- Process each binding: adapt nested let TypeSchemes AND adapt top-level TypeSchemes.
-- Adapting (rather than stripping) TypeSchemes converts stale types like bigfloat→float64
-- while preserving type-class constraints like Ord needed by decodeSet.
"processBinding" <~ ("el" ~>
"newTerm" <<~ Rewriting.rewriteTermM @@ (adaptNestedTypes @@ var "constraints" @@ var "litmap") @@ (Core.bindingTerm $ var "el") $
"adaptedType" <<~ optCases (Core.bindingType $ var "el")
(produce nothing)
("ts" ~>
"ts1" <<~ adaptTypeScheme @@ var "constraints" @@ var "litmap" @@ var "ts" $
produce $ just $ var "ts1") $
produce $ Core.binding
(Core.bindingName $ var "el")
(var "newTerm")
(var "adaptedType")) $
"els1" <<~ Flows.mapList (var "processBinding") (var "els1Raw") $
"prims1" <<~ Flows.mapElems (adaptPrimitive @@ var "constraints" @@ var "litmap") (var "prims0") $
produce $ Graph.graph
(var "els1")
(var "env0")
Maps.empty
Core.termUnit
(var "prims1")
(var "schema1")
-- | Rewrite callback for adapting lambda domains in a term.
-- Dispatches on Term variants: for TermFunction, adapts the lambda domain type;
-- for all other variants, returns the term unchanged.
-- This is a top-level function (not inline) so the Python code generator can emit match statements.
adaptLambdaDomains :: TBinding (LanguageConstraints -> M.Map LiteralType LiteralType -> (Term -> Flow s Term) -> Term -> Flow s Term)
adaptLambdaDomains = define "adaptLambdaDomains" $
doc "Rewrite callback for adapting lambda domain types in a term" $
"constraints" ~> "litmap" ~> "recurse" ~> "term" ~>
"rewritten" <<~ var "recurse" @@ var "term" $
cases _Term (var "rewritten")
(Just $ produce $ var "rewritten") [
_Term_function>>: "f" ~>
cases _Function (var "f")
(Just $ produce $ Core.termFunction $ var "f") [
_Function_lambda>>: "l" ~>
"adaptedDomain" <<~ optCases (Core.lambdaDomain $ var "l")
(produce nothing)
("dom" ~>
"dom1" <<~ adaptType @@ var "constraints" @@ var "litmap" @@ var "dom" $
produce $ just $ var "dom1") $
produce $ Core.termFunction $ Core.functionLambda $ Core.lambda
(Core.lambdaParameter $ var "l")
(var "adaptedDomain")
(Core.lambdaBody $ var "l")]]
-- | Rewrite callback for adapting nested let binding TypeSchemes in a term.
-- Dispatches on Term variants: for TermLet, adapts the binding TypeSchemes;
-- for all other variants, returns the term unchanged.
-- This is a top-level function (not inline) so the Python code generator can emit match statements.
adaptNestedTypes :: TBinding (LanguageConstraints -> M.Map LiteralType LiteralType -> (Term -> Flow s Term) -> Term -> Flow s Term)
adaptNestedTypes = define "adaptNestedTypes" $
doc "Rewrite callback for adapting nested let binding TypeSchemes in a term" $
"constraints" ~> "litmap" ~> "recurse" ~> "term" ~>
"rewritten" <<~ var "recurse" @@ var "term" $
cases _Term (var "rewritten")
(Just $ produce $ var "rewritten") [
_Term_let>>: "lt" ~>
"adaptB" <~ ("b" ~>
"adaptedBType" <<~ optCases (Core.bindingType $ var "b")
(produce nothing)
("ts" ~>
"ts1" <<~ adaptTypeScheme @@ var "constraints" @@ var "litmap" @@ var "ts" $
produce $ just $ var "ts1") $
produce $ Core.binding
(Core.bindingName $ var "b")
(Core.bindingTerm $ var "b")
(var "adaptedBType")) $
"adaptedBindings" <<~ Flows.mapList (var "adaptB") (Core.letBindings $ var "lt") $
produce $ Core.termLet $ Core.let_
(var "adaptedBindings")
(Core.letBody $ var "lt")]
adaptGraphSchema :: TBinding (LanguageConstraints -> M.Map LiteralType LiteralType -> M.Map Name Type -> Flow s (M.Map Name Type))
adaptGraphSchema = define "adaptGraphSchema" $
doc "Adapt a schema graph to the given language constraints" $
"constraints" ~> "litmap" ~> "types0" ~>
"mapPair" <~ ("pair" ~>
"name" <~ Pairs.first (var "pair") $
"typ" <~ Pairs.second (var "pair") $
"typ1" <<~ adaptType @@ var "constraints" @@ var "litmap" @@ var "typ" $
produce $ pair (var "name") (var "typ1")) $
"pairs" <<~ Flows.mapList (var "mapPair") (Maps.toList $ var "types0") $
produce $ Maps.fromList (var "pairs")
adaptIntegerType :: TBinding (LanguageConstraints -> IntegerType -> Maybe IntegerType)
adaptIntegerType = define "adaptIntegerType" $
doc "Attempt to adapt an integer type using the given language constraints" $
"constraints" ~> "it" ~>
"supported" <~ Sets.member (var "it") (Coders.languageConstraintsIntegerTypes $ var "constraints") $
"alt" <~ (adaptIntegerType @@ var "constraints") $
"forUnsupported" <~ ("it" ~> cases _IntegerType (var "it")
Nothing [
_IntegerType_bigint>>: constant nothing,
_IntegerType_int8>>: constant $ var "alt" @@ Core.integerTypeUint16,
_IntegerType_int16>>: constant $ var "alt" @@ Core.integerTypeUint32,
_IntegerType_int32>>: constant $ var "alt" @@ Core.integerTypeUint64,
_IntegerType_int64>>: constant $ var "alt" @@ Core.integerTypeBigint,
_IntegerType_uint8>>: constant $ var "alt" @@ Core.integerTypeInt16,
_IntegerType_uint16>>: constant $ var "alt" @@ Core.integerTypeInt32,
_IntegerType_uint32>>: constant $ var "alt" @@ Core.integerTypeInt64,
_IntegerType_uint64>>: constant $ var "alt" @@ Core.integerTypeBigint]) $
Logic.ifElse (var "supported")
(just $ var "it")
(var "forUnsupported" @@ var "it")
adaptLiteral :: TBinding (LiteralType -> Literal -> Literal)
adaptLiteral = define "adaptLiteral" $
doc "Convert a literal to a different type" $
"lt" ~> "l" ~>
cases _Literal (var "l")
Nothing [
_Literal_binary>>: "b" ~> cases _LiteralType (var "lt")
Nothing [
_LiteralType_string>>: constant $ Core.literalString $ Literals.binaryToString $ var "b"],
_Literal_boolean>>: "b" ~> cases _LiteralType (var "lt")
Nothing [
_LiteralType_integer>>: "it" ~> Core.literalInteger $
Literals.bigintToIntegerValue @@ var "it" @@ Logic.ifElse (var "b") (bigint 1) (bigint 0)],
_Literal_float>>: "f" ~> cases _LiteralType (var "lt")
Nothing [
_LiteralType_float>>: "ft" ~> Core.literalFloat $
Literals.bigfloatToFloatValue @@ var "ft" @@ (Literals.floatValueToBigfloat @@ var "f")],
_Literal_integer>>: "i" ~> cases _LiteralType (var "lt")
Nothing [
_LiteralType_integer>>: "it" ~> Core.literalInteger $
Literals.bigintToIntegerValue @@ var "it" @@ (Literals.integerValueToBigint @@ var "i")]]
adaptLiteralType :: TBinding (LanguageConstraints -> LiteralType -> Maybe LiteralType)
adaptLiteralType = define "adaptLiteralType" $
doc "Attempt to adapt a literal type using the given language constraints" $
"constraints" ~> "lt" ~>
"forUnsupported" <~ ("lt" ~> cases _LiteralType (var "lt")
(Just nothing) [
_LiteralType_binary>>: constant $ just Core.literalTypeString,
_LiteralType_boolean>>: constant $ Maybes.map (unaryFunction Core.literalTypeInteger) $
adaptIntegerType @@ var "constraints" @@ Core.integerTypeInt8,
_LiteralType_float>>: "ft" ~> Maybes.map (unaryFunction Core.literalTypeFloat) $
adaptFloatType @@ var "constraints" @@ var "ft",
_LiteralType_integer>>: "it" ~> Maybes.map (unaryFunction Core.literalTypeInteger) $
adaptIntegerType @@ var "constraints" @@ var "it"]) $
Logic.ifElse (literalTypeSupported @@ var "constraints" @@ var "lt")
nothing
(var "forUnsupported" @@ var "lt")
adaptLiteralTypesMap :: TBinding (LanguageConstraints -> M.Map LiteralType LiteralType)
adaptLiteralTypesMap = define "adaptLiteralTypesMap" $
doc "Derive a map of adapted literal types for the given language constraints" $
"constraints" ~>
"tryType" <~ ("lt" ~> optCases (adaptLiteralType @@ var "constraints" @@ var "lt")
nothing
("lt2" ~> just $ pair (var "lt") (var "lt2"))) $
Maps.fromList $ Maybes.cat $ Lists.map (var "tryType") (Reflect.literalTypes)
adaptLiteralValue :: TBinding (M.Map LiteralType LiteralType -> LiteralType -> Literal -> Literal)
adaptLiteralValue = define "adaptLiteralValue" $
doc "Adapt a literal value using the given language constraints" $
"litmap" ~> "lt" ~> "l" ~> optCases (Maps.lookup (var "lt") (var "litmap"))
(Core.literalString $ ShowCore.literal @@ var "l")
("lt2" ~> adaptLiteral @@ var "lt2" @@ var "l")
adaptPrimitive :: TBinding (LanguageConstraints -> M.Map LiteralType LiteralType -> Primitive -> Flow s Primitive)
adaptPrimitive = define "adaptPrimitive" $
doc "Adapt a primitive to the given language constraints, prior to inference" $
"constraints" ~> "litmap" ~> "prim0" ~>
"ts0" <~ Graph.primitiveType (var "prim0") $
"ts1" <<~ adaptTypeScheme @@ var "constraints" @@ var "litmap" @@ var "ts0" $
produce $ Graph.primitiveWithType (var "prim0") (var "ts1")
-- Note: this function could be made more efficient through precomputation of alternatives,
-- similar to what is done for literals.
adaptTerm :: TBinding (LanguageConstraints -> M.Map LiteralType LiteralType -> Term -> Flow Graph Term)
adaptTerm = define "adaptTerm" $
doc "Adapt a term using the given language constraints" $
"constraints" ~> "litmap" ~> "term0" ~>
"rewrite" <~ ("recurse" ~> "term0" ~> lets [
"forSupported">: ("term" ~> cases _Term (var "term")
(Just $ produce $ just $ var "term") [
_Term_literal>>: "l" ~>
"lt" <~ Reflect.literalType @@ var "l" $
produce $ just $ Logic.ifElse (literalTypeSupported @@ var "constraints" @@ var "lt")
(var "term")
(Core.termLiteral $ adaptLiteralValue @@ var "litmap" @@ var "lt" @@ var "l")]),
"forUnsupported">: ("term" ~> lets [
"forNonNull">: ("alts" ~>
"mterm" <<~ var "tryTerm" @@ Lists.head (var "alts") $
optCases (var "mterm")
(var "tryAlts" @@ Lists.tail (var "alts"))
("t" ~> produce $ just $ var "t")),
"tryAlts">: ("alts" ~> Logic.ifElse (Lists.null $ var "alts")
(produce nothing)
(var "forNonNull" @@ var "alts"))] $
"alts0" <<~ termAlternatives @@ var "term" $
var "tryAlts" @@ var "alts0"),
"tryTerm">: ("term" ~>
"supportedVariant" <~ Sets.member
(Reflect.termVariant @@ var "term")
(Coders.languageConstraintsTermVariants $ var "constraints") $
Logic.ifElse (var "supportedVariant")
(var "forSupported" @@ var "term")
(var "forUnsupported" @@ var "term"))] $
"term1" <<~ var "recurse" @@ var "term0" $
-- Type application/lambda wrappers pass through unconditionally.
-- fsub already recursed into their bodies; we must not strip the wrappers
-- because they carry type information needed by typeOf in the coders.
cases _Term (var "term1")
(Just $
"mterm" <<~ var "tryTerm" @@ var "term1" $
optCases (var "mterm")
(Flows.fail $ (string "no alternatives for term: ") ++ (ShowCore.term @@ var "term1"))
("term2" ~> produce $ var "term2"))
[_Term_typeApplication>>: "ta" ~>
"atyp" <<~ adaptType @@ var "constraints" @@ var "litmap" @@ (Core.typeApplicationTermType $ var "ta") $
produce $ Core.termTypeApplication $ Core.typeApplicationTerm
(Core.typeApplicationTermBody $ var "ta")
(var "atyp"),
_Term_typeLambda>>: "_" ~> produce $ var "term1"]) $
Rewriting.rewriteTermM @@ var "rewrite" @@ var "term0"
adaptType :: TBinding (LanguageConstraints -> M.Map LiteralType LiteralType -> Type -> Flow s Type)
adaptType = define "adaptType" $
doc "Adapt a type using the given language constraints" $
"constraints" ~> "litmap" ~> "type0" ~>
lets [
"forSupported">: ("typ" ~> cases _Type (var "typ")
(Just $ just $ var "typ") [
_Type_literal>>: "lt" ~> Logic.ifElse (literalTypeSupported @@ var "constraints" @@ var "lt")
(just $ var "typ")
(optCases (Maps.lookup (var "lt") (var "litmap"))
(just $ Core.typeLiteral Core.literalTypeString)
("lt2" ~> just $ Core.typeLiteral $ var "lt2"))]),
"forUnsupported">: ("typ" ~>
"tryAlts" <~ ("alts" ~> Logic.ifElse (Lists.null $ var "alts")
nothing
(optCases (var "tryType" @@ Lists.head (var "alts"))
(var "tryAlts" @@ Lists.tail (var "alts"))
("t" ~> just $ var "t"))) $
"alts0" <~ typeAlternatives @@ var "typ" $
var "tryAlts" @@ var "alts0"),
"tryType">: ("typ" ~>
"supportedVariant" <~ Sets.member
(Reflect.typeVariant @@ var "typ")
(Coders.languageConstraintsTypeVariants $ var "constraints") $
Logic.ifElse (var "supportedVariant")
(var "forSupported" @@ var "typ")
(var "forUnsupported" @@ var "typ"))] $
"rewrite" <~ ("recurse" ~> "typ" ~>
"type1" <<~ var "recurse" @@ var "typ" $
optCases (var "tryType" @@ var "type1")
(Flows.fail $ (string "no alternatives for type: ") ++ (ShowCore.type_ @@ var "typ"))
("type2" ~> produce $ var "type2")) $
Rewriting.rewriteTypeM @@ var "rewrite" @@ var "type0"
adaptTypeScheme :: TBinding (LanguageConstraints -> M.Map LiteralType LiteralType -> TypeScheme -> Flow s TypeScheme)
adaptTypeScheme = define "adaptTypeScheme" $
doc "Adapt a type scheme to the given language constraints, prior to inference" $
"constraints" ~> "litmap" ~> "ts0" ~>
"vars0" <~ Core.typeSchemeVariables (var "ts0") $
"t0" <~ Core.typeSchemeType (var "ts0") $
"t1" <<~ adaptType @@ var "constraints" @@ var "litmap" @@ var "t0" $
produce $ Core.typeScheme (var "vars0") (var "t1") (Core.typeSchemeConstraints (var "ts0"))
pushTypeAppsInward :: TBinding (Term -> Term)
pushTypeAppsInward = define "pushTypeAppsInward" $
doc ("Normalize a term by pushing TermTypeApplication inward past TermApplication and"
<> " TermFunction (Lambda). This corrects structures produced by poly-let hoisting and"
<> " eta expansion, where type applications from inference end up wrapping term"
<> " applications or lambda abstractions instead of being directly on the polymorphic variable.") $
"term" ~>
lets [
"push">: ("body" ~> "typ" ~> cases _Term (var "body")
-- Default: keep TypeApp as-is
(Just $ Core.termTypeApplication $ Core.typeApplicationTerm (var "body") (var "typ")) [
-- TypeApp(App(f, arg), τ) → go(App(TypeApp(f, τ), arg))
_Term_application>>: "a" ~> var "go" @@
(Core.termApplication $ Core.application
(Core.termTypeApplication $ Core.typeApplicationTerm
(Core.applicationFunction $ var "a")
(var "typ"))
(Core.applicationArgument $ var "a")),
-- TypeApp(Lambda(v, d, body), τ) → go(Lambda(v, d, TypeApp(body, τ)))
_Term_function>>: "f" ~> cases _Function (var "f")
(Just $ Core.termTypeApplication $ Core.typeApplicationTerm
(Core.termFunction $ var "f") (var "typ")) [
_Function_lambda>>: "l" ~> var "go" @@
(Core.termFunction $ Core.functionLambda $ Core.lambda
(Core.lambdaParameter $ var "l")
(Core.lambdaDomain $ var "l")
(Core.termTypeApplication $ Core.typeApplicationTerm
(Core.lambdaBody $ var "l")
(var "typ")))],
-- TypeApp(Let(bindings, body), τ) → go(Let(bindings, TypeApp(body, τ)))
_Term_let>>: "lt" ~> var "go" @@
(Core.termLet $ Core.let_
(Core.letBindings $ var "lt")
(Core.termTypeApplication $ Core.typeApplicationTerm
(Core.letBody $ var "lt")
(var "typ")))]),
"go">: ("t" ~>
"forField" <~ ("fld" ~> Core.fieldWithTerm (var "go" @@ (Core.fieldTerm $ var "fld")) (var "fld")) $
"forElimination" <~ ("elm" ~> cases _Elimination (var "elm") Nothing [
_Elimination_record>>: "p" ~> Core.eliminationRecord (var "p"),
_Elimination_union>>: "cs" ~> Core.eliminationUnion $ Core.caseStatement
(Core.caseStatementTypeName $ var "cs")
(Maybes.map (var "go") (Core.caseStatementDefault $ var "cs"))
(Lists.map (var "forField") (Core.caseStatementCases $ var "cs")),
_Elimination_wrap>>: "name" ~> Core.eliminationWrap $ var "name"]) $
"forFunction" <~ ("fun" ~> cases _Function (var "fun") Nothing [
_Function_elimination>>: "elm" ~> Core.functionElimination $ var "forElimination" @@ var "elm",
_Function_lambda>>: "l" ~> Core.functionLambda $ Core.lambda
(Core.lambdaParameter $ var "l")
(Core.lambdaDomain $ var "l")
(var "go" @@ (Core.lambdaBody $ var "l")),
_Function_primitive>>: "name" ~> Core.functionPrimitive $ var "name"]) $
"forLet" <~ ("lt" ~>
"mapBinding" <~ ("b" ~> Core.binding
(Core.bindingName $ var "b")
(var "go" @@ (Core.bindingTerm $ var "b"))
(Core.bindingType $ var "b")) $
Core.let_
(Lists.map (var "mapBinding") (Core.letBindings $ var "lt"))
(var "go" @@ (Core.letBody $ var "lt"))) $
"forMap" <~ ("m" ~>
"forPair" <~ ("p" ~> pair (var "go" @@ (Pairs.first $ var "p")) (var "go" @@ (Pairs.second $ var "p"))) $
Maps.fromList $ Lists.map (var "forPair") $ Maps.toList $ var "m") $
cases _Term (var "t") Nothing [
_Term_annotated>>: "at" ~> Core.termAnnotated $ Core.annotatedTerm
(var "go" @@ (Core.annotatedTermBody $ var "at"))
(Core.annotatedTermAnnotation $ var "at"),
_Term_application>>: "a" ~> Core.termApplication $ Core.application
(var "go" @@ (Core.applicationFunction $ var "a"))
(var "go" @@ (Core.applicationArgument $ var "a")),
_Term_either>>: "e" ~> Core.termEither $ Eithers.either_
("l" ~> left $ var "go" @@ var "l")
("r" ~> right $ var "go" @@ var "r")
(var "e"),
_Term_function>>: "fun" ~> Core.termFunction $ var "forFunction" @@ var "fun",
_Term_let>>: "lt" ~> Core.termLet $ var "forLet" @@ var "lt",
_Term_list>>: "els" ~> Core.termList $ Lists.map (var "go") (var "els"),
_Term_literal>>: "v" ~> Core.termLiteral $ var "v",
_Term_map>>: "m" ~> Core.termMap $ var "forMap" @@ var "m",
_Term_maybe>>: "m" ~> Core.termMaybe $ Maybes.map (var "go") (var "m"),
_Term_pair>>: "p" ~> Core.termPair $ pair
(var "go" @@ (Pairs.first $ var "p"))
(var "go" @@ (Pairs.second $ var "p")),
_Term_record>>: "r" ~> Core.termRecord $ Core.record
(Core.recordTypeName $ var "r")
(Lists.map (var "forField") (Core.recordFields $ var "r")),
_Term_set>>: "s" ~> Core.termSet $ Sets.fromList $ Lists.map (var "go") $ Sets.toList (var "s"),
_Term_typeApplication>>: "tt" ~>
"body1" <~ var "go" @@ (Core.typeApplicationTermBody $ var "tt") $
var "push" @@ var "body1" @@ (Core.typeApplicationTermType $ var "tt"),
_Term_typeLambda>>: "ta" ~> Core.termTypeLambda $ Core.typeLambda
(Core.typeLambdaParameter $ var "ta")
(var "go" @@ (Core.typeLambdaBody $ var "ta")),
_Term_union>>: "i" ~> Core.termUnion $ Core.injection
(Core.injectionTypeName $ var "i")
(var "forField" @@ (Core.injectionField $ var "i")),
_Term_unit>>: constant Core.termUnit,
_Term_variable>>: "v" ~> Core.termVariable $ var "v",
_Term_wrap>>: "wt" ~> Core.termWrap $ Core.wrappedTerm
(Core.wrappedTermTypeName $ var "wt")
(var "go" @@ (Core.wrappedTermBody $ var "wt"))])] $
var "go" @@ var "term"
dataGraphToDefinitions :: TBinding (LanguageConstraints -> Bool -> Bool -> Bool -> Bool -> Graph -> [Namespace] -> Flow s (Graph, [[TermDefinition]]))
dataGraphToDefinitions = define "dataGraphToDefinitions" $
doc ("Given a data graph along with language constraints and a designated list of namespaces,"
<> " adapt the graph to the language constraints,"
<> " then return the processed graph along with term definitions grouped by namespace (in the order of the input namespaces)."
<> " Inference is performed before adaptation if bindings lack type annotations."
<> " Hoisting must preserve type schemes; if any binding loses its type scheme after hoisting, the pipeline fails."
<> " Adaptation preserves type application/lambda wrappers and adapts embedded types."
<> " Post-adaptation inference is performed to ensure binding TypeSchemes are fully consistent."
<> " The doExpand flag controls eta expansion."
<> " The doHoistCaseStatements flag controls case statement hoisting (needed for Python)."
<> " The doHoistPolymorphicLetBindings flag controls polymorphic let binding hoisting (needed for Java).") $
"constraints" ~>
"doInfer" ~> "doExpand" ~> "doHoistCaseStatements" ~> "doHoistPolymorphicLetBindings" ~>
"graph0" ~> "namespaces" ~>
"namespacesSet" <~ Sets.fromList (var "namespaces") $
"isParentBinding" <~ ("b" ~> optCases (Names.namespaceOf @@ (Core.bindingName $ var "b"))
false
("ns" ~> Sets.member (var "ns") (var "namespacesSet"))) $
-- Steps 0a-2: Case statement hoisting pipeline (only for Python target, currently).
-- 0a: Strip type lambdas so case expressions are visible to the hoister
-- (the hoister does not traverse into type lambdas).
-- 0b: Unshadow variables to prevent capture issues after hoisting.
-- 1: Hoist case statements before inference.
-- 2: Unshadow again after hoisting (hoisting introduces new lambda wrappers).
"hoistCases" <~ ("g" ~>
"graphDetyped" <~ Graph.graphWithElements (var "g")
(Lists.map ("b" ~>
Core.binding (Core.bindingName $ var "b")
(Rewriting.stripTypeLambdas @@ (Core.bindingTerm $ var "b"))
(Core.bindingType $ var "b"))
(Graph.graphElements $ var "g")) $
"gterm0" <~ Schemas.graphAsTerm @@ var "graphDetyped" $
"gterm1" <~ Rewriting.unshadowVariables @@ var "gterm0" $
"newElements" <~ Schemas.termAsGraph @@ var "gterm1" $
"graphu0" <~ Graph.graphWithElements (var "graphDetyped") (var "newElements") $
"graphh1" <<~ Hoisting.hoistCaseStatementsInGraph @@ var "graphu0" $
"gterm2" <~ Schemas.graphAsTerm @@ var "graphh1" $
"gterm3" <~ Rewriting.unshadowVariables @@ var "gterm2" $
"newElements2" <~ Schemas.termAsGraph @@ var "gterm3" $
produce $ Graph.graphWithElements (var "graphh1") (var "newElements2")) $
"hoistPoly" <~ ("graphBefore" ~>
-- "typeContext" <<~ Schemas.graphToTypeContext @@ var "gBefore" $
"letBefore" <~ Schemas.graphAsLet @@ var "graphBefore" $
"letAfter" <~ Hoisting.hoistPolymorphicLetBindings @@ var "isParentBinding" @@ var "letBefore" $
Graph.graphWithElements (var "graphBefore") (Core.letBindings $ var "letAfter")) $
-- Note: this is a rough test of typedness, as it only checks that the top-level bindings are typed.
"checkTyped" <~ ("debugLabel" ~> "g" ~>
"untypedBindings" <~ Lists.map ("b" ~> Core.unName (Core.bindingName $ var "b"))
(Lists.filter ("b" ~> Logic.not $ Maybes.isJust (Core.bindingType $ var "b")) (Graph.graphElements $ var "g")) $
Logic.ifElse (Lists.null $ var "untypedBindings")
(produce $ var "g")
(Flows.fail $ Strings.concat [
string "Found untyped bindings (", var "debugLabel", string "): ",
Strings.intercalate (string ", ") (var "untypedBindings")])) $
-- Normalize: push type applications inward past applications and lambdas.
-- This corrects structures where TypeApp wraps App/Lambda after adaptation and eta expansion.
"normalizeGraph" <~ ("g" ~> Graph.graphWithElements (var "g")
(Lists.map ("b" ~> Core.binding
(Core.bindingName $ var "b")
(pushTypeAppsInward @@ (Core.bindingTerm $ var "b"))
(Core.bindingType $ var "b"))
(Graph.graphElements $ var "g"))) $
-- Step 1: hoist case statements if needed (currently, for the Python target)
"graph1" <<~ Logic.ifElse (var "doHoistCaseStatements")
(var "hoistCases" @@ var "graph0")
(produce $ var "graph0") $
-- Step 2: infer types if necessary
"graph2" <<~ Logic.ifElse (var "doInfer")
(Inference.inferGraphTypes @@ var "graph1")
(var "checkTyped" @@ string "after case hoisting" @@ var "graph1") $
-- Step 3: hoist let bindings if necessary (currently, for the Java target)
"graph3" <<~ Logic.ifElse (var "doHoistPolymorphicLetBindings")
(var "checkTyped" @@ string "after let hoisting"
@@ (var "hoistPoly" @@ var "graph2"))
(produce $ var "graph2") $
-- Step 4: adapt the graph (includes eta expansion if enabled).
-- Adaptation preserves type application/lambda wrappers and adapts embedded types
-- (literal types, lambda domains, TypeSchemes).
"graph4" <<~ Flows.bind
(adaptDataGraph @@ var "constraints" @@ var "doExpand" @@ var "graph3")
(var "checkTyped" @@ (string "after adaptation")) $
-- Step 5: normalize the adapted graph
"graph5" <~ var "normalizeGraph" @@ var "graph4" $
-- Construct term definitions grouped by namespace
"toDef" <~ ("el" ~>
Maybes.map
("ts" ~> Module.termDefinition
(Core.bindingName $ var "el")
(Core.bindingTerm $ var "el")
(var "ts"))
(Core.bindingType $ var "el")) $
-- Filter to elements in the requested namespaces
"selectedElements" <~ Lists.filter
("el" ~> optCases (Names.namespaceOf @@ (Core.bindingName $ var "el"))
false
("ns" ~> Sets.member (var "ns") (var "namespacesSet")))
(Graph.graphElements $ var "graph5") $
-- Group elements by namespace
"elementsByNamespace" <~ Lists.foldl
("acc" ~> "el" ~>
optCases (Names.namespaceOf @@ (Core.bindingName $ var "el"))
(var "acc")
("ns" ~>
"existing" <~ Maybes.maybe (list ([] :: [TTerm Binding])) (unaryFunction Equality.identity) (Maps.lookup (var "ns") (var "acc")) $
Maps.insert (var "ns") (Lists.concat2 (var "existing") (list [var "el"])) (var "acc")))
Maps.empty
(var "selectedElements") $
-- Produce definitions in the order of the input namespaces
"defsGrouped" <~ Lists.map
("ns" ~>
"elsForNs" <~ Maybes.maybe (list ([] :: [TTerm Binding])) (unaryFunction Equality.identity) (Maps.lookup (var "ns") (var "elementsByNamespace")) $
Maybes.cat (Lists.map (var "toDef") (var "elsForNs")))
(var "namespaces") $
produce $ pair
(var "graph5")
(var "defsGrouped")
literalTypeSupported :: TBinding (LanguageConstraints -> LiteralType -> Bool)
literalTypeSupported = define "literalTypeSupported" $
doc "Check if a literal type is supported by the given language constraints" $
"constraints" ~> "lt" ~>
"forType" <~ ("lt" ~> cases _LiteralType (var "lt")
(Just true) [
_LiteralType_float>>: "ft" ~> Sets.member (var "ft") (Coders.languageConstraintsFloatTypes $ var "constraints"),
_LiteralType_integer>>: "it" ~> Sets.member (var "it") (Coders.languageConstraintsIntegerTypes $ var "constraints")]) $
Logic.ifElse
(Sets.member
(Reflect.literalTypeVariant @@ var "lt")
(Coders.languageConstraintsLiteralVariants $ var "constraints"))
(var "forType" @@ var "lt")
false
schemaGraphToDefinitions :: TBinding (LanguageConstraints -> Graph -> [[Name]] -> Flow s (M.Map Name Type, [[TypeDefinition]]))
schemaGraphToDefinitions = define "schemaGraphToDefinitions" $
doc ("Given a schema graph along with language constraints and a designated list of element names,"
<> " adapt the graph to the language constraints,"
<> " then return a corresponding type definition for each element name.") $
"constraints" ~> "graph" ~> "nameLists" ~>
"litmap" <~ adaptLiteralTypesMap @@ var "constraints" $
"tmap0" <<~ Schemas.graphAsTypes @@ var "graph" $
"tmap1" <<~ adaptGraphSchema @@ var "constraints" @@ var "litmap" @@ var "tmap0" $
"toDef" <~ ("pair" ~> Module.typeDefinition (Pairs.first $ var "pair") (Pairs.second $ var "pair")) $
produce $ pair
(var "tmap1")
(Lists.map
("names" ~> Lists.map (var "toDef") $
Lists.map ("n" ~> pair (var "n") (Maybes.fromJust $ Maps.lookup (var "n") (var "tmap1"))) (var "names"))
(var "nameLists"))
-- Flows.fail $ "schema graph for definitions: " ++ (ShowGraph.graph @@ var "graph")
termAlternatives :: TBinding (Term -> Flow Graph [Term])
termAlternatives = define "termAlternatives" $
doc "Find a list of alternatives for a given term, if any" $
"term" ~> cases _Term (var "term")
(Just $ produce $ list ([] :: [TTerm Term])) [
_Term_annotated>>: "at" ~>
"term2" <~ Core.annotatedTermBody (var "at") $
produce $ list [
var "term2"], -- TODO: lossy
_Term_maybe>>: "ot" ~> produce $ list [
Core.termList $ optCases (var "ot")
(list ([] :: [TTerm Term]))
("term2" ~> list [var "term2"])],
_Term_typeLambda>>: "abs" ~>
"term2" <~ Core.typeLambdaBody (var "abs") $
produce $ list [var "term2"],
_Term_typeApplication>>: "ta" ~>
"term2" <~ Core.typeApplicationTermBody (var "ta") $
produce $ list [var "term2"],
_Term_union>>: "inj" ~>
"tname" <~ Core.injectionTypeName (var "inj") $
"field" <~ Core.injectionField (var "inj") $
"fname" <~ Core.fieldName (var "field") $
"fterm" <~ Core.fieldTerm (var "field") $
"forFieldType" <~ ("ft" ~>
"ftname" <~ Core.fieldTypeName (var "ft") $
Core.field (var "fname") $ Core.termMaybe $ Logic.ifElse (Equality.equal (var "ftname") (var "fname"))
(just $ var "fterm")
(nothing)) $
"rt" <<~ Schemas.requireUnionType @@ var "tname" $
produce $ list [
Core.termRecord $ Core.record (var "tname") (Lists.map (var "forFieldType") (Core.rowTypeFields $ var "rt"))],
_Term_unit>>: constant $ produce $ list [
Core.termLiteral $ Core.literalBoolean true],
_Term_wrap>>: "wt" ~>
"term2" <~ Core.wrappedTermBody (var "wt") $
produce $ list [
var "term2"]]
typeAlternatives :: TBinding (Type -> [Type])
typeAlternatives = define "typeAlternatives" $
doc "Find a list of alternatives for a given type, if any" $
"type" ~> cases _Type (var "type")
(Just $ list ([] :: [TTerm Type])) [
_Type_annotated>>: "at" ~>
"type2" <~ Core.annotatedTypeBody (var "at") $
list [var "type2"], -- TODO: lossy
_Type_maybe>>: "ot" ~> list [
Core.typeList $ var "ot"],
_Type_union>>: "rt" ~>
"tname" <~ Core.rowTypeTypeName (var "rt") $
"fields" <~ Core.rowTypeFields (var "rt") $
"toOptField" <~ ("f" ~> Core.fieldType (Core.fieldTypeName $ var "f") (MetaTypes.optional $ Core.fieldTypeType $ var "f")) $
"optFields" <~ Lists.map (var "toOptField") (var "fields") $
list [
Core.typeRecord $ Core.rowType (var "tname") (var "optFields")],
_Type_unit>>: constant $ list [
Core.typeLiteral $ Core.literalTypeBoolean]]