hydra-0.13.0: src/gen-main/haskell/Hydra/Adapt/Simple.hs
-- Note: this is an automatically generated file. Do not edit.
-- | Simple, one-way adapters for types and terms
module Hydra.Adapt.Simple where
import qualified Hydra.Coders as Coders
import qualified Hydra.Compute as Compute
import qualified Hydra.Core as Core
import qualified Hydra.Graph as Graph
import qualified Hydra.Hoisting as Hoisting
import qualified Hydra.Inference as Inference
import qualified Hydra.Lib.Eithers as Eithers
import qualified Hydra.Lib.Equality as Equality
import qualified Hydra.Lib.Flows as Flows
import qualified Hydra.Lib.Lists as Lists
import qualified Hydra.Lib.Literals as Literals
import qualified Hydra.Lib.Logic as Logic
import qualified Hydra.Lib.Maps as Maps
import qualified Hydra.Lib.Maybes as Maybes
import qualified Hydra.Lib.Pairs as Pairs
import qualified Hydra.Lib.Sets as Sets
import qualified Hydra.Lib.Strings as Strings
import qualified Hydra.Literals as Literals_
import qualified Hydra.Module as Module
import qualified Hydra.Names as Names
import qualified Hydra.Reduction as Reduction
import qualified Hydra.Reflect as Reflect
import qualified Hydra.Rewriting as Rewriting
import qualified Hydra.Schemas as Schemas
import qualified Hydra.Show.Core as Core_
import Prelude hiding (Enum, Ordering, decodeFloat, encodeFloat, fail, map, pure, sum)
import qualified Data.ByteString as B
import qualified Data.Int as I
import qualified Data.List as L
import qualified Data.Map as M
import qualified Data.Set as S
-- | Attempt to adapt a floating-point type using the given language constraints
adaptFloatType :: (Coders.LanguageConstraints -> Core.FloatType -> Maybe Core.FloatType)
adaptFloatType constraints ft =
let supported = (Sets.member ft (Coders.languageConstraintsFloatTypes constraints))
in
let alt = (adaptFloatType constraints)
in
let forUnsupported = (\ft -> (\x -> case x of
Core.FloatTypeBigfloat -> (alt Core.FloatTypeFloat64)
Core.FloatTypeFloat32 -> (alt Core.FloatTypeFloat64)
Core.FloatTypeFloat64 -> (alt Core.FloatTypeBigfloat)) ft)
in (Logic.ifElse supported (Just ft) (forUnsupported ft))
-- | 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.
adaptDataGraph :: (Coders.LanguageConstraints -> Bool -> Graph.Graph -> Compute.Flow Graph.Graph Graph.Graph)
adaptDataGraph constraints doExpand graph0 =
let transform = (\graph -> \gterm -> Flows.bind (Schemas.graphToTypeContext graph) (\tx ->
let gterm1 = (Rewriting.unshadowVariables (pushTypeAppsInward gterm))
in
let gterm2 = (Rewriting.unshadowVariables (Logic.ifElse doExpand (pushTypeAppsInward (Reduction.etaExpandTermNew tx gterm1)) gterm1))
in (Flows.pure (Rewriting.liftLambdaAboveLet gterm2))))
in
let litmap = (adaptLiteralTypesMap constraints)
in
let els0 = (Graph.graphElements graph0)
in
let env0 = (Graph.graphEnvironment graph0)
in
let body0 = (Graph.graphBody graph0)
in
let prims0 = (Graph.graphPrimitives graph0)
in
let schema0 = (Graph.graphSchema graph0)
in (Flows.bind (Maybes.maybe (Flows.pure Nothing) (\sg -> Flows.bind (Schemas.graphAsTypes sg) (\tmap0 -> Flows.bind (adaptGraphSchema constraints litmap tmap0) (\tmap1 ->
let emap = (Schemas.typesToElements tmap1)
in (Flows.pure (Just (Graph.Graph {
Graph.graphElements = emap,
Graph.graphEnvironment = (Graph.graphEnvironment sg),
Graph.graphTypes = (Graph.graphTypes sg),
Graph.graphBody = (Graph.graphBody sg),
Graph.graphPrimitives = (Graph.graphPrimitives sg),
Graph.graphSchema = (Graph.graphSchema sg)})))))) schema0) (\schema1 ->
let gterm0 = (Schemas.graphAsTerm graph0)
in (Flows.bind (Logic.ifElse doExpand (transform graph0 gterm0) (Flows.pure gterm0)) (\gterm1 -> Flows.bind (adaptTerm constraints litmap gterm1) (\gterm2 -> Flows.bind (Rewriting.rewriteTermM (adaptLambdaDomains constraints litmap) gterm2) (\gterm3 ->
let els1Raw = (Schemas.termAsGraph gterm3)
in
let processBinding = (\el -> Flows.bind (Rewriting.rewriteTermM (adaptNestedTypes constraints litmap) (Core.bindingTerm el)) (\newTerm -> Flows.bind (Maybes.maybe (Flows.pure Nothing) (\ts -> Flows.bind (adaptTypeScheme constraints litmap ts) (\ts1 -> Flows.pure (Just ts1))) (Core.bindingType el)) (\adaptedType -> Flows.pure (Core.Binding {
Core.bindingName = (Core.bindingName el),
Core.bindingTerm = newTerm,
Core.bindingType = adaptedType}))))
in (Flows.bind (Flows.mapList processBinding els1Raw) (\els1 -> Flows.bind (Flows.mapElems (adaptPrimitive constraints litmap) prims0) (\prims1 -> Flows.pure (Graph.Graph {
Graph.graphElements = els1,
Graph.graphEnvironment = env0,
Graph.graphTypes = Maps.empty,
Graph.graphBody = Core.TermUnit,
Graph.graphPrimitives = prims1,
Graph.graphSchema = schema1}))))))))))
-- | Adapt a schema graph to the given language constraints
adaptGraphSchema :: Ord t0 => (Coders.LanguageConstraints -> M.Map Core.LiteralType Core.LiteralType -> M.Map t0 Core.Type -> Compute.Flow t1 (M.Map t0 Core.Type))
adaptGraphSchema constraints litmap types0 =
let mapPair = (\pair ->
let name = (Pairs.first pair)
in
let typ = (Pairs.second pair)
in (Flows.bind (adaptType constraints litmap typ) (\typ1 -> Flows.pure (name, typ1))))
in (Flows.bind (Flows.mapList mapPair (Maps.toList types0)) (\pairs -> Flows.pure (Maps.fromList pairs)))
-- | Attempt to adapt an integer type using the given language constraints
adaptIntegerType :: (Coders.LanguageConstraints -> Core.IntegerType -> Maybe Core.IntegerType)
adaptIntegerType constraints it =
let supported = (Sets.member it (Coders.languageConstraintsIntegerTypes constraints))
in
let alt = (adaptIntegerType constraints)
in
let forUnsupported = (\it -> (\x -> case x of
Core.IntegerTypeBigint -> Nothing
Core.IntegerTypeInt8 -> (alt Core.IntegerTypeUint16)
Core.IntegerTypeInt16 -> (alt Core.IntegerTypeUint32)
Core.IntegerTypeInt32 -> (alt Core.IntegerTypeUint64)
Core.IntegerTypeInt64 -> (alt Core.IntegerTypeBigint)
Core.IntegerTypeUint8 -> (alt Core.IntegerTypeInt16)
Core.IntegerTypeUint16 -> (alt Core.IntegerTypeInt32)
Core.IntegerTypeUint32 -> (alt Core.IntegerTypeInt64)
Core.IntegerTypeUint64 -> (alt Core.IntegerTypeBigint)) it)
in (Logic.ifElse supported (Just it) (forUnsupported it))
-- | Rewrite callback for adapting lambda domain types in a term
adaptLambdaDomains :: (Coders.LanguageConstraints -> M.Map Core.LiteralType Core.LiteralType -> (t0 -> Compute.Flow t1 Core.Term) -> t0 -> Compute.Flow t1 Core.Term)
adaptLambdaDomains constraints litmap recurse term = (Flows.bind (recurse term) (\rewritten -> (\x -> case x of
Core.TermFunction v1 -> ((\x -> case x of
Core.FunctionLambda v2 -> (Flows.bind (Maybes.maybe (Flows.pure Nothing) (\dom -> Flows.bind (adaptType constraints litmap dom) (\dom1 -> Flows.pure (Just dom1))) (Core.lambdaDomain v2)) (\adaptedDomain -> Flows.pure (Core.TermFunction (Core.FunctionLambda (Core.Lambda {
Core.lambdaParameter = (Core.lambdaParameter v2),
Core.lambdaDomain = adaptedDomain,
Core.lambdaBody = (Core.lambdaBody v2)})))))
_ -> (Flows.pure (Core.TermFunction v1))) v1)
_ -> (Flows.pure rewritten)) rewritten))
-- | Convert a literal to a different type
adaptLiteral :: (Core.LiteralType -> Core.Literal -> Core.Literal)
adaptLiteral lt l = ((\x -> case x of
Core.LiteralBinary v1 -> ((\x -> case x of
Core.LiteralTypeString -> (Core.LiteralString (Literals.binaryToString v1))) lt)
Core.LiteralBoolean v1 -> ((\x -> case x of
Core.LiteralTypeInteger v2 -> (Core.LiteralInteger (Literals_.bigintToIntegerValue v2 (Logic.ifElse v1 1 0)))) lt)
Core.LiteralFloat v1 -> ((\x -> case x of
Core.LiteralTypeFloat v2 -> (Core.LiteralFloat (Literals_.bigfloatToFloatValue v2 (Literals_.floatValueToBigfloat v1)))) lt)
Core.LiteralInteger v1 -> ((\x -> case x of
Core.LiteralTypeInteger v2 -> (Core.LiteralInteger (Literals_.bigintToIntegerValue v2 (Literals_.integerValueToBigint v1)))) lt)) l)
-- | Attempt to adapt a literal type using the given language constraints
adaptLiteralType :: (Coders.LanguageConstraints -> Core.LiteralType -> Maybe Core.LiteralType)
adaptLiteralType constraints lt =
let forUnsupported = (\lt -> (\x -> case x of
Core.LiteralTypeBinary -> (Just Core.LiteralTypeString)
Core.LiteralTypeBoolean -> (Maybes.map (\x -> Core.LiteralTypeInteger x) (adaptIntegerType constraints Core.IntegerTypeInt8))
Core.LiteralTypeFloat v1 -> (Maybes.map (\x -> Core.LiteralTypeFloat x) (adaptFloatType constraints v1))
Core.LiteralTypeInteger v1 -> (Maybes.map (\x -> Core.LiteralTypeInteger x) (adaptIntegerType constraints v1))
_ -> Nothing) lt)
in (Logic.ifElse (literalTypeSupported constraints lt) Nothing (forUnsupported lt))
-- | Derive a map of adapted literal types for the given language constraints
adaptLiteralTypesMap :: (Coders.LanguageConstraints -> M.Map Core.LiteralType Core.LiteralType)
adaptLiteralTypesMap constraints =
let tryType = (\lt -> Maybes.maybe Nothing (\lt2 -> Just (lt, lt2)) (adaptLiteralType constraints lt))
in (Maps.fromList (Maybes.cat (Lists.map tryType Reflect.literalTypes)))
-- | Adapt a literal value using the given language constraints
adaptLiteralValue :: Ord t0 => (M.Map t0 Core.LiteralType -> t0 -> Core.Literal -> Core.Literal)
adaptLiteralValue litmap lt l = (Maybes.maybe (Core.LiteralString (Core_.literal l)) (\lt2 -> adaptLiteral lt2 l) (Maps.lookup lt litmap))
-- | Rewrite callback for adapting nested let binding TypeSchemes in a term
adaptNestedTypes :: (Coders.LanguageConstraints -> M.Map Core.LiteralType Core.LiteralType -> (t0 -> Compute.Flow t1 Core.Term) -> t0 -> Compute.Flow t1 Core.Term)
adaptNestedTypes constraints litmap recurse term = (Flows.bind (recurse term) (\rewritten -> (\x -> case x of
Core.TermLet v1 ->
let adaptB = (\b -> Flows.bind (Maybes.maybe (Flows.pure Nothing) (\ts -> Flows.bind (adaptTypeScheme constraints litmap ts) (\ts1 -> Flows.pure (Just ts1))) (Core.bindingType b)) (\adaptedBType -> Flows.pure (Core.Binding {
Core.bindingName = (Core.bindingName b),
Core.bindingTerm = (Core.bindingTerm b),
Core.bindingType = adaptedBType})))
in (Flows.bind (Flows.mapList adaptB (Core.letBindings v1)) (\adaptedBindings -> Flows.pure (Core.TermLet (Core.Let {
Core.letBindings = adaptedBindings,
Core.letBody = (Core.letBody v1)}))))
_ -> (Flows.pure rewritten)) rewritten))
-- | Adapt a primitive to the given language constraints, prior to inference
adaptPrimitive :: (Coders.LanguageConstraints -> M.Map Core.LiteralType Core.LiteralType -> Graph.Primitive -> Compute.Flow t0 Graph.Primitive)
adaptPrimitive constraints litmap prim0 =
let ts0 = (Graph.primitiveType prim0)
in (Flows.bind (adaptTypeScheme constraints litmap ts0) (\ts1 -> Flows.pure (Graph.Primitive {
Graph.primitiveName = (Graph.primitiveName prim0),
Graph.primitiveType = ts1,
Graph.primitiveImplementation = (Graph.primitiveImplementation prim0)})))
-- | Adapt a term using the given language constraints
adaptTerm :: (Coders.LanguageConstraints -> M.Map Core.LiteralType Core.LiteralType -> Core.Term -> Compute.Flow Graph.Graph Core.Term)
adaptTerm constraints litmap term0 =
let rewrite = (\recurse -> \term0 ->
let forSupported = (\term -> (\x -> case x of
Core.TermLiteral v1 ->
let lt = (Reflect.literalType v1)
in (Flows.pure (Just (Logic.ifElse (literalTypeSupported constraints lt) term (Core.TermLiteral (adaptLiteralValue litmap lt v1)))))
_ -> (Flows.pure (Just term))) term)
forUnsupported = (\term ->
let forNonNull = (\alts -> Flows.bind (tryTerm (Lists.head alts)) (\mterm -> Maybes.maybe (tryAlts (Lists.tail alts)) (\t -> Flows.pure (Just t)) mterm))
tryAlts = (\alts -> Logic.ifElse (Lists.null alts) (Flows.pure Nothing) (forNonNull alts))
in (Flows.bind (termAlternatives term) (\alts0 -> tryAlts alts0)))
tryTerm = (\term ->
let supportedVariant = (Sets.member (Reflect.termVariant term) (Coders.languageConstraintsTermVariants constraints))
in (Logic.ifElse supportedVariant (forSupported term) (forUnsupported term)))
in (Flows.bind (recurse term0) (\term1 -> (\x -> case x of
Core.TermTypeApplication v1 -> (Flows.bind (adaptType constraints litmap (Core.typeApplicationTermType v1)) (\atyp -> Flows.pure (Core.TermTypeApplication (Core.TypeApplicationTerm {
Core.typeApplicationTermBody = (Core.typeApplicationTermBody v1),
Core.typeApplicationTermType = atyp}))))
Core.TermTypeLambda _ -> (Flows.pure term1)
_ -> (Flows.bind (tryTerm term1) (\mterm -> Maybes.maybe (Flows.fail (Strings.cat2 "no alternatives for term: " (Core_.term term1))) (\term2 -> Flows.pure term2) mterm))) term1)))
in (Rewriting.rewriteTermM rewrite term0)
-- | Adapt a type using the given language constraints
adaptType :: (Coders.LanguageConstraints -> M.Map Core.LiteralType Core.LiteralType -> Core.Type -> Compute.Flow t0 Core.Type)
adaptType constraints litmap type0 =
let forSupported = (\typ -> (\x -> case x of
Core.TypeLiteral v1 -> (Logic.ifElse (literalTypeSupported constraints v1) (Just typ) (Maybes.maybe (Just (Core.TypeLiteral Core.LiteralTypeString)) (\lt2 -> Just (Core.TypeLiteral lt2)) (Maps.lookup v1 litmap)))
_ -> (Just typ)) typ)
forUnsupported = (\typ ->
let tryAlts = (\alts -> Logic.ifElse (Lists.null alts) Nothing (Maybes.maybe (tryAlts (Lists.tail alts)) (\t -> Just t) (tryType (Lists.head alts))))
in
let alts0 = (typeAlternatives typ)
in (tryAlts alts0))
tryType = (\typ ->
let supportedVariant = (Sets.member (Reflect.typeVariant typ) (Coders.languageConstraintsTypeVariants constraints))
in (Logic.ifElse supportedVariant (forSupported typ) (forUnsupported typ)))
in
let rewrite = (\recurse -> \typ -> Flows.bind (recurse typ) (\type1 -> Maybes.maybe (Flows.fail (Strings.cat2 "no alternatives for type: " (Core_.type_ typ))) (\type2 -> Flows.pure type2) (tryType type1)))
in (Rewriting.rewriteTypeM rewrite type0)
-- | Adapt a type scheme to the given language constraints, prior to inference
adaptTypeScheme :: (Coders.LanguageConstraints -> M.Map Core.LiteralType Core.LiteralType -> Core.TypeScheme -> Compute.Flow t0 Core.TypeScheme)
adaptTypeScheme constraints litmap ts0 =
let vars0 = (Core.typeSchemeVariables ts0)
in
let t0 = (Core.typeSchemeType ts0)
in (Flows.bind (adaptType constraints litmap t0) (\t1 -> Flows.pure (Core.TypeScheme {
Core.typeSchemeVariables = vars0,
Core.typeSchemeType = t1,
Core.typeSchemeConstraints = (Core.typeSchemeConstraints ts0)})))
-- | 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).
dataGraphToDefinitions :: (Coders.LanguageConstraints -> Bool -> Bool -> Bool -> Bool -> Graph.Graph -> [Module.Namespace] -> Compute.Flow Graph.Graph (Graph.Graph, [[Module.TermDefinition]]))
dataGraphToDefinitions constraints doInfer doExpand doHoistCaseStatements doHoistPolymorphicLetBindings graph0 namespaces =
let namespacesSet = (Sets.fromList namespaces)
in
let isParentBinding = (\b -> Maybes.maybe False (\ns -> Sets.member ns namespacesSet) (Names.namespaceOf (Core.bindingName b)))
in
let hoistCases = (\g ->
let graphDetyped = Graph.Graph {
Graph.graphElements = (Lists.map (\b -> Core.Binding {
Core.bindingName = (Core.bindingName b),
Core.bindingTerm = (Rewriting.stripTypeLambdas (Core.bindingTerm b)),
Core.bindingType = (Core.bindingType b)}) (Graph.graphElements g)),
Graph.graphEnvironment = (Graph.graphEnvironment g),
Graph.graphTypes = (Graph.graphTypes g),
Graph.graphBody = (Graph.graphBody g),
Graph.graphPrimitives = (Graph.graphPrimitives g),
Graph.graphSchema = (Graph.graphSchema g)}
in
let gterm0 = (Schemas.graphAsTerm graphDetyped)
in
let gterm1 = (Rewriting.unshadowVariables gterm0)
in
let newElements = (Schemas.termAsGraph gterm1)
in
let graphu0 = Graph.Graph {
Graph.graphElements = newElements,
Graph.graphEnvironment = (Graph.graphEnvironment graphDetyped),
Graph.graphTypes = (Graph.graphTypes graphDetyped),
Graph.graphBody = (Graph.graphBody graphDetyped),
Graph.graphPrimitives = (Graph.graphPrimitives graphDetyped),
Graph.graphSchema = (Graph.graphSchema graphDetyped)}
in (Flows.bind (Hoisting.hoistCaseStatementsInGraph graphu0) (\graphh1 ->
let gterm2 = (Schemas.graphAsTerm graphh1)
in
let gterm3 = (Rewriting.unshadowVariables gterm2)
in
let newElements2 = (Schemas.termAsGraph gterm3)
in (Flows.pure (Graph.Graph {
Graph.graphElements = newElements2,
Graph.graphEnvironment = (Graph.graphEnvironment graphh1),
Graph.graphTypes = (Graph.graphTypes graphh1),
Graph.graphBody = (Graph.graphBody graphh1),
Graph.graphPrimitives = (Graph.graphPrimitives graphh1),
Graph.graphSchema = (Graph.graphSchema graphh1)})))))
in
let hoistPoly = (\graphBefore ->
let letBefore = (Schemas.graphAsLet graphBefore)
in
let letAfter = (Hoisting.hoistPolymorphicLetBindings isParentBinding letBefore)
in Graph.Graph {
Graph.graphElements = (Core.letBindings letAfter),
Graph.graphEnvironment = (Graph.graphEnvironment graphBefore),
Graph.graphTypes = (Graph.graphTypes graphBefore),
Graph.graphBody = (Graph.graphBody graphBefore),
Graph.graphPrimitives = (Graph.graphPrimitives graphBefore),
Graph.graphSchema = (Graph.graphSchema graphBefore)})
in
let checkTyped = (\debugLabel -> \g ->
let untypedBindings = (Lists.map (\b -> Core.unName (Core.bindingName b)) (Lists.filter (\b -> Logic.not (Maybes.isJust (Core.bindingType b))) (Graph.graphElements g)))
in (Logic.ifElse (Lists.null untypedBindings) (Flows.pure g) (Flows.fail (Strings.cat [
"Found untyped bindings (",
debugLabel,
"): ",
(Strings.intercalate ", " untypedBindings)]))))
in
let normalizeGraph = (\g -> Graph.Graph {
Graph.graphElements = (Lists.map (\b -> Core.Binding {
Core.bindingName = (Core.bindingName b),
Core.bindingTerm = (pushTypeAppsInward (Core.bindingTerm b)),
Core.bindingType = (Core.bindingType b)}) (Graph.graphElements g)),
Graph.graphEnvironment = (Graph.graphEnvironment g),
Graph.graphTypes = (Graph.graphTypes g),
Graph.graphBody = (Graph.graphBody g),
Graph.graphPrimitives = (Graph.graphPrimitives g),
Graph.graphSchema = (Graph.graphSchema g)})
in (Flows.bind (Logic.ifElse doHoistCaseStatements (hoistCases graph0) (Flows.pure graph0)) (\graph1 -> Flows.bind (Logic.ifElse doInfer (Inference.inferGraphTypes graph1) (checkTyped "after case hoisting" graph1)) (\graph2 -> Flows.bind (Logic.ifElse doHoistPolymorphicLetBindings (checkTyped "after let hoisting" (hoistPoly graph2)) (Flows.pure graph2)) (\graph3 -> Flows.bind (Flows.bind (adaptDataGraph constraints doExpand graph3) (checkTyped "after adaptation")) (\graph4 ->
let graph5 = (normalizeGraph graph4)
in
let toDef = (\el -> Maybes.map (\ts -> Module.TermDefinition {
Module.termDefinitionName = (Core.bindingName el),
Module.termDefinitionTerm = (Core.bindingTerm el),
Module.termDefinitionType = ts}) (Core.bindingType el))
in
let selectedElements = (Lists.filter (\el -> Maybes.maybe False (\ns -> Sets.member ns namespacesSet) (Names.namespaceOf (Core.bindingName el))) (Graph.graphElements graph5))
in
let elementsByNamespace = (Lists.foldl (\acc -> \el -> Maybes.maybe acc (\ns ->
let existing = (Maybes.maybe [] Equality.identity (Maps.lookup ns acc))
in (Maps.insert ns (Lists.concat2 existing [
el]) acc)) (Names.namespaceOf (Core.bindingName el))) Maps.empty selectedElements)
in
let defsGrouped = (Lists.map (\ns ->
let elsForNs = (Maybes.maybe [] Equality.identity (Maps.lookup ns elementsByNamespace))
in (Maybes.cat (Lists.map toDef elsForNs))) namespaces)
in (Flows.pure (graph5, defsGrouped)))))))
-- | Check if a literal type is supported by the given language constraints
literalTypeSupported :: (Coders.LanguageConstraints -> Core.LiteralType -> Bool)
literalTypeSupported constraints lt =
let forType = (\lt -> (\x -> case x of
Core.LiteralTypeFloat v1 -> (Sets.member v1 (Coders.languageConstraintsFloatTypes constraints))
Core.LiteralTypeInteger v1 -> (Sets.member v1 (Coders.languageConstraintsIntegerTypes constraints))
_ -> True) lt)
in (Logic.ifElse (Sets.member (Reflect.literalTypeVariant lt) (Coders.languageConstraintsLiteralVariants constraints)) (forType lt) False)
-- | 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.
pushTypeAppsInward :: (Core.Term -> Core.Term)
pushTypeAppsInward term =
let push = (\body -> \typ -> (\x -> case x of
Core.TermApplication v1 -> (go (Core.TermApplication (Core.Application {
Core.applicationFunction = (Core.TermTypeApplication (Core.TypeApplicationTerm {
Core.typeApplicationTermBody = (Core.applicationFunction v1),
Core.typeApplicationTermType = typ})),
Core.applicationArgument = (Core.applicationArgument v1)})))
Core.TermFunction v1 -> ((\x -> case x of
Core.FunctionLambda v2 -> (go (Core.TermFunction (Core.FunctionLambda (Core.Lambda {
Core.lambdaParameter = (Core.lambdaParameter v2),
Core.lambdaDomain = (Core.lambdaDomain v2),
Core.lambdaBody = (Core.TermTypeApplication (Core.TypeApplicationTerm {
Core.typeApplicationTermBody = (Core.lambdaBody v2),
Core.typeApplicationTermType = typ}))}))))
_ -> (Core.TermTypeApplication (Core.TypeApplicationTerm {
Core.typeApplicationTermBody = (Core.TermFunction v1),
Core.typeApplicationTermType = typ}))) v1)
Core.TermLet v1 -> (go (Core.TermLet (Core.Let {
Core.letBindings = (Core.letBindings v1),
Core.letBody = (Core.TermTypeApplication (Core.TypeApplicationTerm {
Core.typeApplicationTermBody = (Core.letBody v1),
Core.typeApplicationTermType = typ}))})))
_ -> (Core.TermTypeApplication (Core.TypeApplicationTerm {
Core.typeApplicationTermBody = body,
Core.typeApplicationTermType = typ}))) body)
go = (\t ->
let forField = (\fld -> Core.Field {
Core.fieldName = (Core.fieldName fld),
Core.fieldTerm = (go (Core.fieldTerm fld))})
in
let forElimination = (\elm -> (\x -> case x of
Core.EliminationRecord v1 -> (Core.EliminationRecord v1)
Core.EliminationUnion v1 -> (Core.EliminationUnion (Core.CaseStatement {
Core.caseStatementTypeName = (Core.caseStatementTypeName v1),
Core.caseStatementDefault = (Maybes.map go (Core.caseStatementDefault v1)),
Core.caseStatementCases = (Lists.map forField (Core.caseStatementCases v1))}))
Core.EliminationWrap v1 -> (Core.EliminationWrap v1)) elm)
in
let forFunction = (\fun -> (\x -> case x of
Core.FunctionElimination v1 -> (Core.FunctionElimination (forElimination v1))
Core.FunctionLambda v1 -> (Core.FunctionLambda (Core.Lambda {
Core.lambdaParameter = (Core.lambdaParameter v1),
Core.lambdaDomain = (Core.lambdaDomain v1),
Core.lambdaBody = (go (Core.lambdaBody v1))}))
Core.FunctionPrimitive v1 -> (Core.FunctionPrimitive v1)) fun)
in
let forLet = (\lt ->
let mapBinding = (\b -> Core.Binding {
Core.bindingName = (Core.bindingName b),
Core.bindingTerm = (go (Core.bindingTerm b)),
Core.bindingType = (Core.bindingType b)})
in Core.Let {
Core.letBindings = (Lists.map mapBinding (Core.letBindings lt)),
Core.letBody = (go (Core.letBody lt))})
in
let forMap = (\m ->
let forPair = (\p -> (go (Pairs.first p), (go (Pairs.second p))))
in (Maps.fromList (Lists.map forPair (Maps.toList m))))
in ((\x -> case x of
Core.TermAnnotated v1 -> (Core.TermAnnotated (Core.AnnotatedTerm {
Core.annotatedTermBody = (go (Core.annotatedTermBody v1)),
Core.annotatedTermAnnotation = (Core.annotatedTermAnnotation v1)}))
Core.TermApplication v1 -> (Core.TermApplication (Core.Application {
Core.applicationFunction = (go (Core.applicationFunction v1)),
Core.applicationArgument = (go (Core.applicationArgument v1))}))
Core.TermEither v1 -> (Core.TermEither (Eithers.either (\l -> Left (go l)) (\r -> Right (go r)) v1))
Core.TermFunction v1 -> (Core.TermFunction (forFunction v1))
Core.TermLet v1 -> (Core.TermLet (forLet v1))
Core.TermList v1 -> (Core.TermList (Lists.map go v1))
Core.TermLiteral v1 -> (Core.TermLiteral v1)
Core.TermMap v1 -> (Core.TermMap (forMap v1))
Core.TermMaybe v1 -> (Core.TermMaybe (Maybes.map go v1))
Core.TermPair v1 -> (Core.TermPair (go (Pairs.first v1), (go (Pairs.second v1))))
Core.TermRecord v1 -> (Core.TermRecord (Core.Record {
Core.recordTypeName = (Core.recordTypeName v1),
Core.recordFields = (Lists.map forField (Core.recordFields v1))}))
Core.TermSet v1 -> (Core.TermSet (Sets.fromList (Lists.map go (Sets.toList v1))))
Core.TermTypeApplication v1 ->
let body1 = (go (Core.typeApplicationTermBody v1))
in (push body1 (Core.typeApplicationTermType v1))
Core.TermTypeLambda v1 -> (Core.TermTypeLambda (Core.TypeLambda {
Core.typeLambdaParameter = (Core.typeLambdaParameter v1),
Core.typeLambdaBody = (go (Core.typeLambdaBody v1))}))
Core.TermUnion v1 -> (Core.TermUnion (Core.Injection {
Core.injectionTypeName = (Core.injectionTypeName v1),
Core.injectionField = (forField (Core.injectionField v1))}))
Core.TermUnit -> Core.TermUnit
Core.TermVariable v1 -> (Core.TermVariable v1)
Core.TermWrap v1 -> (Core.TermWrap (Core.WrappedTerm {
Core.wrappedTermTypeName = (Core.wrappedTermTypeName v1),
Core.wrappedTermBody = (go (Core.wrappedTermBody v1))}))) t))
in (go term)
-- | 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.
schemaGraphToDefinitions :: (Coders.LanguageConstraints -> Graph.Graph -> [[Core.Name]] -> Compute.Flow Graph.Graph (M.Map Core.Name Core.Type, [[Module.TypeDefinition]]))
schemaGraphToDefinitions constraints graph nameLists =
let litmap = (adaptLiteralTypesMap constraints)
in (Flows.bind (Schemas.graphAsTypes graph) (\tmap0 -> Flows.bind (adaptGraphSchema constraints litmap tmap0) (\tmap1 ->
let toDef = (\pair -> Module.TypeDefinition {
Module.typeDefinitionName = (Pairs.first pair),
Module.typeDefinitionType = (Pairs.second pair)})
in (Flows.pure (tmap1, (Lists.map (\names -> Lists.map toDef (Lists.map (\n -> (n, (Maybes.fromJust (Maps.lookup n tmap1)))) names)) nameLists))))))
-- | Find a list of alternatives for a given term, if any
termAlternatives :: (Core.Term -> Compute.Flow Graph.Graph [Core.Term])
termAlternatives term = ((\x -> case x of
Core.TermAnnotated v1 ->
let term2 = (Core.annotatedTermBody v1)
in (Flows.pure [
term2])
Core.TermMaybe v1 -> (Flows.pure [
Core.TermList (Maybes.maybe [] (\term2 -> [
term2]) v1)])
Core.TermTypeLambda v1 ->
let term2 = (Core.typeLambdaBody v1)
in (Flows.pure [
term2])
Core.TermTypeApplication v1 ->
let term2 = (Core.typeApplicationTermBody v1)
in (Flows.pure [
term2])
Core.TermUnion v1 ->
let tname = (Core.injectionTypeName v1)
in
let field = (Core.injectionField v1)
in
let fname = (Core.fieldName field)
in
let fterm = (Core.fieldTerm field)
in
let forFieldType = (\ft ->
let ftname = (Core.fieldTypeName ft)
in Core.Field {
Core.fieldName = fname,
Core.fieldTerm = (Core.TermMaybe (Logic.ifElse (Equality.equal ftname fname) (Just fterm) Nothing))})
in (Flows.bind (Schemas.requireUnionType tname) (\rt -> Flows.pure [
Core.TermRecord (Core.Record {
Core.recordTypeName = tname,
Core.recordFields = (Lists.map forFieldType (Core.rowTypeFields rt))})]))
Core.TermUnit -> (Flows.pure [
Core.TermLiteral (Core.LiteralBoolean True)])
Core.TermWrap v1 ->
let term2 = (Core.wrappedTermBody v1)
in (Flows.pure [
term2])
_ -> (Flows.pure [])) term)
-- | Find a list of alternatives for a given type, if any
typeAlternatives :: (Core.Type -> [Core.Type])
typeAlternatives type_ = ((\x -> case x of
Core.TypeAnnotated v1 ->
let type2 = (Core.annotatedTypeBody v1)
in [
type2]
Core.TypeMaybe v1 -> [
Core.TypeList v1]
Core.TypeUnion v1 ->
let tname = (Core.rowTypeTypeName v1)
in
let fields = (Core.rowTypeFields v1)
in
let toOptField = (\f -> Core.FieldType {
Core.fieldTypeName = (Core.fieldTypeName f),
Core.fieldTypeType = (Core.TypeMaybe (Core.fieldTypeType f))})
in
let optFields = (Lists.map toOptField fields)
in [
Core.TypeRecord (Core.RowType {
Core.rowTypeTypeName = tname,
Core.rowTypeFields = optFields})]
Core.TypeUnit -> [
Core.TypeLiteral Core.LiteralTypeBoolean]
_ -> []) type_)