hydra-kernel-0.16.0: src/main/haskell/Hydra/Adapt.hs
-- Note: this is an automatically generated file. Do not edit.
-- | Simple, one-way adapters for types and terms
module Hydra.Adapt where
import qualified Hydra.Annotations as Annotations
import qualified Hydra.Ast as Ast
import qualified Hydra.Coders as Coders
import qualified Hydra.Core as Core
import qualified Hydra.Dependencies as Dependencies
import qualified Hydra.Environment as Environment
import qualified Hydra.Error.Checking as Checking
import qualified Hydra.Error.Core as ErrorCore
import qualified Hydra.Error.Packaging as ErrorPackaging
import qualified Hydra.Errors as Errors
import qualified Hydra.Graph as Graph
import qualified Hydra.Hoisting as Hoisting
import qualified Hydra.Inference as Inference
import qualified Hydra.Json.Model as Model
import qualified Hydra.Lexical as Lexical
import qualified Hydra.Haskell.Lib.Eithers as Eithers
import qualified Hydra.Haskell.Lib.Equality as Equality
import qualified Hydra.Haskell.Lib.Lists as Lists
import qualified Hydra.Haskell.Lib.Literals as LibLiterals
import qualified Hydra.Haskell.Lib.Logic as Logic
import qualified Hydra.Haskell.Lib.Maps as Maps
import qualified Hydra.Haskell.Lib.Optionals as Optionals
import qualified Hydra.Haskell.Lib.Pairs as Pairs
import qualified Hydra.Haskell.Lib.Sets as Sets
import qualified Hydra.Haskell.Lib.Strings as Strings
import qualified Hydra.Literals as Literals
import qualified Hydra.Names as Names
import qualified Hydra.Packaging as Packaging
import qualified Hydra.Parsing as Parsing
import qualified Hydra.Paths as Paths
import qualified Hydra.Query as Query
import qualified Hydra.Reduction as Reduction
import qualified Hydra.Reflect as Reflect
import qualified Hydra.Relational as Relational
import qualified Hydra.Resolution as Resolution
import qualified Hydra.Rewriting as Rewriting
import qualified Hydra.Scoping as Scoping
import qualified Hydra.Show.Core as ShowCore
import qualified Hydra.Show.Errors as ShowErrors
import qualified Hydra.Show.Graph as ShowGraph
import qualified Hydra.Strip as Strip
import qualified Hydra.Tabular as Tabular
import qualified Hydra.Testing as Testing
import qualified Hydra.Topology as Topology
import qualified Hydra.Typed as Typed
import qualified Hydra.Typing as Typing
import qualified Hydra.Util as Util
import qualified Hydra.Validation as Validation
import qualified Hydra.Variables as Variables
import qualified Hydra.Variants as Variants
import Prelude hiding (Enum, Ordering, decodeFloat, encodeFloat, fail, map, pure, sum)
import qualified Data.Scientific as Sci
import qualified Data.Map as M
import qualified Data.Set as S
-- | 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. The els0 parameter provides the original ordered bindings. Returns both the adapted graph and the ordered adapted bindings.
adaptDataGraph :: Coders.LanguageConstraints -> Bool -> [Core.Binding] -> t0 -> Graph.Graph -> Either Errors.Error (Graph.Graph, [Core.Binding])
adaptDataGraph constraints doExpand els0 cx graph0 =
let transformTerm =
\g -> \term ->
let tx = g
t1 = Variables.unshadowVariables (pushTypeAppsInward term)
t2 = Variables.unshadowVariables (Logic.ifElse doExpand (pushTypeAppsInward (Reduction.etaExpandTerm tx t1)) t1)
in (Dependencies.liftLambdaAboveLet t2)
transformBinding =
\g -> \el -> Core.Binding {
Core.bindingName = (Core.bindingName el),
Core.bindingTerm = (transformTerm g (Core.bindingTerm el)),
Core.bindingTypeScheme = (Core.bindingTypeScheme el)}
litmap = adaptLiteralTypesMap constraints
prims0 = Graph.graphPrimitives graph0
schemaTypes0 = Graph.graphSchemaTypes graph0
schemaBindings = Environment.typesToDefinitions (Maps.map (\ts -> Scoping.typeSchemeToFType ts) schemaTypes0)
in (Eithers.bind (Logic.ifElse (Maps.null schemaTypes0) (Right Maps.empty) (Eithers.bind (Eithers.bimap (\e -> Errors.ErrorDecoding e) (\x -> x) (Environment.graphAsTypes graph0 schemaBindings)) (\tmap0 -> Eithers.bind (adaptGraphSchema constraints litmap tmap0) (\tmap1 -> Right (Maps.map (\t -> Resolution.typeToTypeScheme t) tmap1))))) (\schemaResult ->
let adaptedSchemaTypes = schemaResult
adaptBinding =
\el ->
let transformed = transformBinding graph0 el
wrapped =
Core.TermLet (Core.Let {
Core.letBindings = (Lists.pure transformed),
Core.letBody = Core.TermUnit})
in (Eithers.bind (adaptTerm constraints litmap cx graph0 wrapped) (\adapted -> Rewriting.rewriteTermM (adaptLambdaDomains constraints litmap) adapted))
in (Eithers.bind (Eithers.mapList adaptBinding els0) (\adaptedTerms ->
let els1Raw = Lists.concat (Lists.map Environment.termAsBindings adaptedTerms)
processBinding =
\el -> Eithers.bind (Rewriting.rewriteTermM (adaptNestedTypes constraints litmap) (Core.bindingTerm el)) (\newTerm -> Eithers.bind (Optionals.cases (Core.bindingTypeScheme el) (Right Nothing) (\ts -> Eithers.bind (adaptTypeScheme constraints litmap ts) (\ts1 -> Right (Just ts1)))) (\adaptedType -> Right (Core.Binding {
Core.bindingName = (Core.bindingName el),
Core.bindingTerm = newTerm,
Core.bindingTypeScheme = adaptedType})))
in (Eithers.bind (Eithers.mapList processBinding els1Raw) (\els1 -> Eithers.bind (Eithers.mapList (\kv -> Eithers.bind (adaptPrimitive constraints litmap (Pairs.second kv)) (\prim1 -> Right (Pairs.first kv, prim1))) (Maps.toList prims0)) (\primPairs ->
let prims1 = Maps.fromList primPairs
adaptedGraphRaw = Lexical.buildGraph els1 Maps.empty prims1
adaptedGraph =
Graph.Graph {
Graph.graphBoundTerms = (Graph.graphBoundTerms adaptedGraphRaw),
Graph.graphBoundTypes = (Graph.graphBoundTypes adaptedGraphRaw),
Graph.graphClassConstraints = (Graph.graphClassConstraints adaptedGraphRaw),
Graph.graphLambdaVariables = (Graph.graphLambdaVariables adaptedGraphRaw),
Graph.graphMetadata = (Graph.graphMetadata adaptedGraphRaw),
Graph.graphPrimitives = (Graph.graphPrimitives adaptedGraphRaw),
Graph.graphSchemaTypes = adaptedSchemaTypes,
Graph.graphTypeVariables = (Graph.graphTypeVariables adaptedGraphRaw)}
in (Right (adaptedGraph, els1)))))))))
-- | 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)
alt = adaptFloatType constraints
forUnsupported =
\ft2 -> case ft2 of
Core.FloatTypeFloat32 -> alt Core.FloatTypeFloat64
Core.FloatTypeFloat64 -> alt Core.FloatTypeFloat32
in (Logic.ifElse supported (Just ft) (forUnsupported ft))
-- | 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 -> Either Errors.Error (M.Map t0 Core.Type))
adaptGraphSchema constraints litmap types0 =
let mapPair =
\pair ->
let name = Pairs.first pair
typ = Pairs.second pair
in (Eithers.bind (adaptType constraints litmap typ) (\typ1 -> Right (name, typ1)))
in (Eithers.bind (Eithers.mapList mapPair (Maps.toList types0)) (\pairs -> Right (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)
alt = adaptIntegerType constraints
forUnsupported =
\it2 -> case it2 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
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 -> Either Errors.Error Core.Term) -> t0 -> Either Errors.Error Core.Term
adaptLambdaDomains constraints litmap recurse term =
Eithers.bind (recurse term) (\rewritten -> case rewritten of
Core.TermLambda v0 -> Eithers.bind (Optionals.cases (Core.lambdaDomain v0) (Right Nothing) (\dom -> Eithers.bind (adaptType constraints litmap dom) (\dom1 -> Right (Just dom1)))) (\adaptedDomain -> Right (Core.TermLambda (Core.Lambda {
Core.lambdaParameter = (Core.lambdaParameter v0),
Core.lambdaDomain = adaptedDomain,
Core.lambdaBody = (Core.lambdaBody v0)})))
_ -> Right rewritten)
-- | Convert a literal to a different type
adaptLiteral :: Core.LiteralType -> Core.Literal -> Core.Literal
adaptLiteral lt l =
case l of
Core.LiteralBinary v0 -> case lt of
Core.LiteralTypeString -> Core.LiteralString (LibLiterals.binaryToString v0)
Core.LiteralBoolean v0 -> case lt of
Core.LiteralTypeInteger v1 -> Core.LiteralInteger (Literals.bigintToIntegerValue v1 (Logic.ifElse v0 1 0))
Core.LiteralDecimal v0 -> case lt of
Core.LiteralTypeFloat _ -> Core.LiteralFloat (Core.FloatValueFloat64 (LibLiterals.decimalToFloat64 v0))
Core.LiteralTypeString -> Core.LiteralString (LibLiterals.showDecimal v0)
Core.LiteralFloat v0 -> case lt of
Core.LiteralTypeFloat v1 -> Core.LiteralFloat (case v1 of
Core.FloatTypeFloat32 -> Core.FloatValueFloat32 (case v0 of
Core.FloatValueFloat32 v3 -> v3
Core.FloatValueFloat64 v3 -> LibLiterals.float64ToFloat32 v3)
Core.FloatTypeFloat64 -> Core.FloatValueFloat64 (case v0 of
Core.FloatValueFloat32 v3 -> LibLiterals.float32ToFloat64 v3
Core.FloatValueFloat64 v3 -> v3))
Core.LiteralInteger v0 -> case lt of
Core.LiteralTypeInteger v1 -> Core.LiteralInteger (Literals.bigintToIntegerValue v1 (Literals.integerValueToBigint v0))
-- | Attempt to adapt a literal type using the given language constraints
adaptLiteralType :: Coders.LanguageConstraints -> Core.LiteralType -> Maybe Core.LiteralType
adaptLiteralType constraints lt =
let forUnsupported =
\lt2 -> case lt2 of
Core.LiteralTypeBinary -> Just Core.LiteralTypeString
Core.LiteralTypeBoolean -> Optionals.map (\x -> Core.LiteralTypeInteger x) (adaptIntegerType constraints Core.IntegerTypeInt8)
Core.LiteralTypeDecimal -> Just (Core.LiteralTypeFloat Core.FloatTypeFloat64)
Core.LiteralTypeFloat v0 -> Optionals.map (\x -> Core.LiteralTypeFloat x) (adaptFloatType constraints v0)
Core.LiteralTypeInteger v0 -> Optionals.map (\x -> Core.LiteralTypeInteger x) (adaptIntegerType constraints v0)
_ -> Nothing
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 -> Optionals.cases (adaptLiteralType constraints lt) Nothing (\lt2 -> Just (lt, lt2))
in (Maps.fromList (Optionals.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 =
Optionals.cases (Maps.lookup lt litmap) (Core.LiteralString (ShowCore.literal l)) (\lt2 -> adaptLiteral lt2 l)
-- | Rewrite callback for adapting nested let binding TypeSchemes in a term
adaptNestedTypes :: Coders.LanguageConstraints -> M.Map Core.LiteralType Core.LiteralType -> (t0 -> Either Errors.Error Core.Term) -> t0 -> Either Errors.Error Core.Term
adaptNestedTypes constraints litmap recurse term =
Eithers.bind (recurse term) (\rewritten -> case rewritten of
Core.TermLet v0 ->
let adaptB =
\b -> Eithers.bind (Optionals.cases (Core.bindingTypeScheme b) (Right Nothing) (\ts -> Eithers.bind (adaptTypeScheme constraints litmap ts) (\ts1 -> Right (Just ts1)))) (\adaptedBType -> Right (Core.Binding {
Core.bindingName = (Core.bindingName b),
Core.bindingTerm = (Core.bindingTerm b),
Core.bindingTypeScheme = adaptedBType}))
in (Eithers.bind (Eithers.mapList adaptB (Core.letBindings v0)) (\adaptedBindings -> Right (Core.TermLet (Core.Let {
Core.letBindings = adaptedBindings,
Core.letBody = (Core.letBody v0)}))))
_ -> Right rewritten)
-- | Adapt a primitive to the given language constraints, prior to inference
adaptPrimitive :: Coders.LanguageConstraints -> M.Map Core.LiteralType Core.LiteralType -> Graph.Primitive -> Either Errors.Error Graph.Primitive
adaptPrimitive constraints litmap prim0 =
let def0 = Graph.primitiveDefinition prim0
in (Eithers.bind (adaptTermSignature constraints litmap (Packaging.primitiveDefinitionSignature def0)) (\sig1 ->
let def1 =
Packaging.PrimitiveDefinition {
Packaging.primitiveDefinitionName = (Packaging.primitiveDefinitionName def0),
Packaging.primitiveDefinitionMetadata = (Packaging.primitiveDefinitionMetadata def0),
Packaging.primitiveDefinitionSignature = sig1,
Packaging.primitiveDefinitionIsPure = (Packaging.primitiveDefinitionIsPure def0),
Packaging.primitiveDefinitionIsTotal = (Packaging.primitiveDefinitionIsTotal def0),
Packaging.primitiveDefinitionDefaultImplementation = (Packaging.primitiveDefinitionDefaultImplementation def0)}
in (Right (Graph.Primitive {
Graph.primitiveDefinition = def1,
Graph.primitiveImplementation = (Graph.primitiveImplementation prim0)}))))
-- | Adapt a term using the given language constraints
adaptTerm :: Coders.LanguageConstraints -> M.Map Core.LiteralType Core.LiteralType -> t0 -> Graph.Graph -> Core.Term -> Either Errors.Error Core.Term
adaptTerm constraints litmap cx graph term0 =
let rewrite =
\recurse -> \term02 ->
let forSupported =
\term -> case term of
Core.TermLiteral v0 ->
let lt = Reflect.literalType v0
in (Right (Just (Logic.ifElse (literalTypeSupported constraints lt) term (Core.TermLiteral (adaptLiteralValue litmap lt v0)))))
_ -> Right (Just term)
forUnsupported =
\term ->
let tryAlts =
\alts -> Optionals.cases (Lists.uncons alts) (Right Nothing) (\uc -> Eithers.bind (tryTerm (Pairs.first uc)) (\mterm -> Optionals.cases mterm (tryAlts (Pairs.second uc)) (\t -> Right (Just t))))
in (Eithers.bind (termAlternatives cx graph 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 (Eithers.bind (recurse term02) (\term1 -> case term1 of
Core.TermAnnotated _ -> Right term1
Core.TermTypeApplication v0 -> Eithers.bind (adaptType constraints litmap (Core.typeApplicationTermType v0)) (\atyp -> Right (Core.TermTypeApplication (Core.TypeApplicationTerm {
Core.typeApplicationTermBody = (Core.typeApplicationTermBody v0),
Core.typeApplicationTermType = atyp})))
Core.TermTypeLambda _ -> Right term1
_ -> Eithers.bind (tryTerm term1) (\mterm -> Optionals.cases mterm (Left (Errors.ErrorOther (Errors.OtherError (Strings.cat2 "no alternatives for term: " (ShowCore.term term1))))) (\term2 -> Right term2))))
in (Rewriting.rewriteTermM rewrite term0)
-- | Adapt a term using the constraints of a given language
adaptTermForLanguage :: Coders.Language -> t0 -> Graph.Graph -> Core.Term -> Either Errors.Error Core.Term
adaptTermForLanguage lang cx g term =
let constraints = Coders.languageConstraints lang
litmap = adaptLiteralTypesMap constraints
in (adaptTerm constraints litmap cx g term)
-- | Adapt the types within a term signature to the given language constraints, in place. Parameter names, descriptions, and per-parameter isLazy flags, as well as type parameters, are preserved; only the parameter and result types are adapted. Unlike routing through TypeScheme (the type-only view), this retains the full TermSignature metadata, including primitive laziness flags.
adaptTermSignature :: Coders.LanguageConstraints -> M.Map Core.LiteralType Core.LiteralType -> Typing.TermSignature -> Either Errors.Error Typing.TermSignature
adaptTermSignature constraints litmap sig0 =
let result0 = Typing.termSignatureResult sig0
in (Eithers.bind (adaptType constraints litmap (Typing.resultType result0)) (\resultType1 -> Eithers.bind (Eithers.mapList (\p -> Eithers.map (\ty1 -> Typing.Parameter {
Typing.parameterName = (Typing.parameterName p),
Typing.parameterDescription = (Typing.parameterDescription p),
Typing.parameterType = ty1,
Typing.parameterIsLazy = (Typing.parameterIsLazy p)}) (adaptType constraints litmap (Typing.parameterType p))) (Typing.termSignatureParameters sig0)) (\params1 -> Right (Typing.TermSignature {
Typing.termSignatureTypeParameters = (Typing.termSignatureTypeParameters sig0),
Typing.termSignatureParameters = params1,
Typing.termSignatureResult = Typing.Result {
Typing.resultDescription = (Typing.resultDescription result0),
Typing.resultType = resultType1}}))))
-- | Adapt a type using the given language constraints
adaptType :: Coders.LanguageConstraints -> M.Map Core.LiteralType Core.LiteralType -> Core.Type -> Either Errors.Error Core.Type
adaptType constraints litmap type0 =
let forSupported =
\typ -> case typ of
Core.TypeLiteral v0 -> Logic.ifElse (literalTypeSupported constraints v0) (Just typ) (Optionals.cases (Maps.lookup v0 litmap) (Just (Core.TypeLiteral Core.LiteralTypeString)) (\lt2 -> Just (Core.TypeLiteral lt2)))
_ -> Just typ
forUnsupported =
\typ ->
let tryAlts =
\alts -> Optionals.bind (Lists.uncons alts) (\uc -> Optionals.cases (tryType (Pairs.first uc)) (tryAlts (Pairs.second uc)) (\t -> Just t))
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))
rewrite =
\recurse -> \typ -> Eithers.bind (recurse typ) (\type1 -> Optionals.cases (tryType type1) (Left (Errors.ErrorOther (Errors.OtherError (Strings.cat2 "no alternatives for type: " (ShowCore.type_ typ))))) (\type2 -> Right type2))
in (Rewriting.rewriteTypeM rewrite type0)
-- | Adapt a type using the constraints of a given language
adaptTypeForLanguage :: Coders.Language -> Core.Type -> Either Errors.Error Core.Type
adaptTypeForLanguage lang typ =
let constraints = Coders.languageConstraints lang
litmap = adaptLiteralTypesMap constraints
in (adaptType constraints litmap typ)
-- | Adapt a type scheme to the given language constraints, prior to inference
adaptTypeScheme :: Coders.LanguageConstraints -> M.Map Core.LiteralType Core.LiteralType -> Core.TypeScheme -> Either Errors.Error Core.TypeScheme
adaptTypeScheme constraints litmap ts0 =
let vars0 = Core.typeSchemeVariables ts0
t0 = Core.typeSchemeBody ts0
in (Eithers.bind (adaptType constraints litmap t0) (\t1 -> Right (Core.TypeScheme {
Core.typeSchemeVariables = vars0,
Core.typeSchemeBody = t1,
Core.typeSchemeConstraints = (Core.typeSchemeConstraints ts0)})))
-- | Compose two coders into a single coder
composeCoders :: Coders.Coder t0 t1 -> Coders.Coder t1 t2 -> Coders.Coder t0 t2
composeCoders c1 c2 =
Coders.Coder {
Coders.coderEncode = (\cx -> \a -> Eithers.bind (Coders.coderEncode c1 cx a) (\b1 -> Coders.coderEncode c2 cx b1)),
Coders.coderDecode = (\cx -> \c -> Eithers.bind (Coders.coderDecode c2 cx c) (\b2 -> Coders.coderDecode c1 cx b2))}
-- | Given a data graph along with language constraints, original ordered bindings, 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). The originalBindings parameter provides the original ordered bindings (from module elements).
dataGraphToDefinitions :: Coders.LanguageConstraints -> Bool -> Bool -> Bool -> Bool -> [Core.Binding] -> Graph.Graph -> [Packaging.ModuleName] -> Typing.InferenceContext -> Either Errors.Error (Graph.Graph, [[Packaging.TermDefinition]])
dataGraphToDefinitions constraints doInfer doExpand doHoistCaseStatements doHoistPolymorphicLetBindings originalBindings graph0 namespaces cx =
let namespacesSet = Sets.fromList namespaces
isParentBinding =
\b -> Optionals.cases (Names.moduleNameOf (Core.bindingName b)) False (\ns -> Sets.member ns namespacesSet)
hoistCases =
\bindings ->
let stripped =
Lists.map (\b -> Core.Binding {
Core.bindingName = (Core.bindingName b),
Core.bindingTerm = (Strip.stripTypeLambdas (Core.bindingTerm b)),
Core.bindingTypeScheme = (Core.bindingTypeScheme b)}) bindings
term0 =
Core.TermLet (Core.Let {
Core.letBindings = stripped,
Core.letBody = Core.TermUnit})
unshadowed0 = Environment.termAsBindings (Variables.unshadowVariables term0)
hoisted = Hoisting.hoistCaseStatementsInGraph unshadowed0
term1 =
Core.TermLet (Core.Let {
Core.letBindings = hoisted,
Core.letBody = Core.TermUnit})
in (Environment.termAsBindings (Variables.unshadowVariables term1))
hoistPoly =
\bindings ->
let letBefore =
Core.Let {
Core.letBindings = bindings,
Core.letBody = Core.TermUnit}
letAfter = Hoisting.hoistPolymorphicLetBindings isParentBinding letBefore
in (Core.letBindings letAfter)
qualifyUntyped =
\b ->
let nm = Core.unName (Core.bindingName b)
in (Optionals.cases (Names.moduleNameOf (Core.bindingName b)) (Strings.cat2 "(no module) " nm) (\ns -> Strings.cat [
Packaging.unModuleName ns,
" :: ",
nm]))
checkBindingsTyped =
\debugLabel -> \bindings ->
let untypedBindings =
Lists.map qualifyUntyped (Lists.filter (\b -> Logic.not (Optionals.isGiven (Core.bindingTypeScheme b))) bindings)
in (Logic.ifElse (Lists.null untypedBindings) (Right bindings) (Left (Errors.ErrorOther (Errors.OtherError (Strings.cat [
"Found ",
(LibLiterals.showInt32 (Lists.length untypedBindings)),
" untyped binding(s) (",
debugLabel,
"); each must carry a type scheme at this stage. ",
"This usually means stale dist/json field shapes after a kernel record rename ",
"(regenerate the affected package's JSON). Offending bindings (module :: name): ",
(Strings.intercalate ", " untypedBindings)])))))
normalizeBindings =
\bindings -> Lists.map (\b -> Core.Binding {
Core.bindingName = (Core.bindingName b),
Core.bindingTerm = (pushTypeAppsInward (Core.bindingTerm b)),
Core.bindingTypeScheme = (Core.bindingTypeScheme b)}) bindings
rebuildGraph =
\bindings ->
let g = Lexical.buildGraph bindings Maps.empty (Graph.graphPrimitives graph0)
in Graph.Graph {
Graph.graphBoundTerms = (Graph.graphBoundTerms g),
Graph.graphBoundTypes = (Graph.graphBoundTypes g),
Graph.graphClassConstraints = (Graph.graphClassConstraints g),
Graph.graphLambdaVariables = (Graph.graphLambdaVariables g),
Graph.graphMetadata = (Graph.graphMetadata g),
Graph.graphPrimitives = (Graph.graphPrimitives g),
Graph.graphSchemaTypes = (Graph.graphSchemaTypes graph0),
Graph.graphTypeVariables = (Graph.graphTypeVariables g)}
bins0 = originalBindings
bins1 = Logic.ifElse doHoistCaseStatements (hoistCases bins0) bins0
in (Eithers.bind (Logic.ifElse doInfer (Eithers.map (\result -> Pairs.second (Pairs.first result)) (Inference.inferGraphTypes cx bins1 (rebuildGraph bins1))) (checkBindingsTyped "after case hoisting" bins1)) (\bins2 -> Eithers.bind (Logic.ifElse doHoistPolymorphicLetBindings (checkBindingsTyped "after let hoisting" (hoistPoly bins2)) (Right bins2)) (\bins3 -> Eithers.bind (adaptDataGraph constraints doExpand bins3 cx (rebuildGraph bins3)) (\adaptResult ->
let adapted = Pairs.first adaptResult
adaptedBindings = Pairs.second adaptResult
in (Eithers.bind (checkBindingsTyped "after adaptation" adaptedBindings) (\bins4 ->
let bins5Raw = normalizeBindings bins4
peelOne =
\t -> case t of
Core.TermTypeLambda v0 -> Core.typeLambdaBody v0
Core.TermTypeApplication v0 -> Core.typeApplicationTermBody v0
_ -> t
extractAnn =
\t -> case t of
Core.TermAnnotated v0 -> Just (Core.annotatedTermAnnotation v0)
_ -> Nothing
findAnn =
\t ->
let t1 = peelOne t
t2 = peelOne t1
t3 = peelOne t2
in (Optionals.cases (extractAnn t) (Optionals.cases (extractAnn t1) (Optionals.cases (extractAnn t2) (extractAnn t3) (\a -> Just a)) (\a -> Just a)) (\a -> Just a))
originalAnnotations =
Maps.fromList (Optionals.cat (Lists.map (\b -> Optionals.cases (findAnn (Core.bindingTerm b)) Nothing (\ann -> Just (Core.bindingName b, ann))) originalBindings))
reattachAnnotation =
\b -> Optionals.cases (Maps.lookup (Core.bindingName b) originalAnnotations) b (\ann -> Core.Binding {
Core.bindingName = (Core.bindingName b),
Core.bindingTerm = case (Core.bindingTerm b) of
Core.TermAnnotated v0 -> Core.TermAnnotated (Core.AnnotatedTerm {
Core.annotatedTermBody = (Core.annotatedTermBody v0),
Core.annotatedTermAnnotation = (Annotations.wrapAnnotationMap (Maps.union (Annotations.getAnnotationMap (Core.annotatedTermAnnotation v0)) (Annotations.getAnnotationMap ann)))})
_ -> Core.TermAnnotated (Core.AnnotatedTerm {
Core.annotatedTermBody = (Core.bindingTerm b),
Core.annotatedTermAnnotation = ann}),
Core.bindingTypeScheme = (Core.bindingTypeScheme b)})
bins5 = Lists.map reattachAnnotation bins5Raw
toDef =
\el -> Optionals.map (\ts -> Packaging.TermDefinition {
Packaging.termDefinitionName = (Core.bindingName el),
Packaging.termDefinitionMetadata = Nothing,
Packaging.termDefinitionSignature = (Just (Scoping.typeSchemeToTermSignature ts)),
Packaging.termDefinitionBody = (Core.bindingTerm el)}) (Core.bindingTypeScheme el)
selectedElements =
Lists.filter (\el -> Optionals.cases (Names.moduleNameOf (Core.bindingName el)) False (\ns -> Sets.member ns namespacesSet)) bins5
elementsByNamespace =
Lists.foldl (\acc -> \el -> Optionals.cases (Names.moduleNameOf (Core.bindingName el)) acc (\ns ->
let existing = Optionals.cases (Maps.lookup ns acc) [] Equality.identity
in (Maps.insert ns (Lists.concat2 existing [
el]) acc))) Maps.empty selectedElements
defsGrouped =
Lists.map (\ns ->
let elsForNs = Optionals.cases (Maps.lookup ns elementsByNamespace) [] Equality.identity
in (Optionals.cat (Lists.map toDef elsForNs))) namespaces
g = Lexical.buildGraph bins5 Maps.empty (Graph.graphPrimitives adapted)
in (Right (
Graph.Graph {
Graph.graphBoundTerms = (Graph.graphBoundTerms g),
Graph.graphBoundTypes = (Graph.graphBoundTypes g),
Graph.graphClassConstraints = (Graph.graphClassConstraints g),
Graph.graphLambdaVariables = (Graph.graphLambdaVariables g),
Graph.graphMetadata = (Graph.graphMetadata g),
Graph.graphPrimitives = (Graph.graphPrimitives g),
Graph.graphSchemaTypes = (Graph.graphSchemaTypes adapted),
Graph.graphTypeVariables = (Graph.graphTypeVariables g)},
defsGrouped))))))))
-- | Check if a literal type is supported by the given language constraints
literalTypeSupported :: Coders.LanguageConstraints -> Core.LiteralType -> Bool
literalTypeSupported constraints lt =
let forType =
\lt2 -> case lt2 of
Core.LiteralTypeFloat v0 -> Sets.member v0 (Coders.languageConstraintsFloatTypes constraints)
Core.LiteralTypeInteger v0 -> Sets.member v0 (Coders.languageConstraintsIntegerTypes constraints)
_ -> True
in (Logic.ifElse (Sets.member (Reflect.literalTypeVariant lt) (Coders.languageConstraintsLiteralVariants constraints)) (forType lt) False)
-- | Prepare a float type, substituting unsupported types
prepareFloatType :: Ord t0 => (Core.FloatType -> (Core.FloatType, ((Core.FloatValue -> Core.FloatValue), (S.Set t0))))
prepareFloatType ft =
case ft of
Core.FloatTypeFloat32 -> (
Core.FloatTypeFloat32,
(
(\v -> case v of
Core.FloatValueFloat32 v1 -> Core.FloatValueFloat32 v1
_ -> v),
Sets.empty))
Core.FloatTypeFloat64 -> (
Core.FloatTypeFloat64,
(
(\v -> case v of
Core.FloatValueFloat64 v1 -> Core.FloatValueFloat64 v1
_ -> v),
Sets.empty))
-- | Prepare an integer type, substituting unsupported types
prepareIntegerType :: Core.IntegerType -> (Core.IntegerType, ((Core.IntegerValue -> Core.IntegerValue), (S.Set String)))
prepareIntegerType it =
case it of
Core.IntegerTypeBigint -> (
Core.IntegerTypeInt64,
(
(\v -> case v of
Core.IntegerValueBigint v1 -> Core.IntegerValueInt64 (LibLiterals.bigintToInt64 v1)
_ -> v),
(Sets.fromList [
"replace arbitrary-precision integers with 64-bit integers"])))
Core.IntegerTypeUint8 -> (
Core.IntegerTypeInt8,
(
(\v -> case v of
Core.IntegerValueUint8 v1 -> Core.IntegerValueInt8 (LibLiterals.bigintToInt8 (LibLiterals.uint8ToBigint v1))
_ -> v),
(Sets.fromList [
"replace unsigned 8-bit integers with signed 8-bit integers"])))
Core.IntegerTypeUint32 -> (
Core.IntegerTypeInt32,
(
(\v -> case v of
Core.IntegerValueUint32 v1 -> Core.IntegerValueInt32 (LibLiterals.bigintToInt32 (LibLiterals.uint32ToBigint v1))
_ -> v),
(Sets.fromList [
"replace unsigned 32-bit integers with signed 32-bit integers"])))
Core.IntegerTypeUint64 -> (
Core.IntegerTypeInt64,
(
(\v -> case v of
Core.IntegerValueUint64 v1 -> Core.IntegerValueInt64 (LibLiterals.bigintToInt64 (LibLiterals.uint64ToBigint v1))
_ -> v),
(Sets.fromList [
"replace unsigned 64-bit integers with signed 64-bit integers"])))
_ -> prepareSame it
-- | Prepare a literal type, substituting unsupported types
prepareLiteralType :: Core.LiteralType -> (Core.LiteralType, ((Core.Literal -> Core.Literal), (S.Set String)))
prepareLiteralType at =
case at of
Core.LiteralTypeBinary -> (
Core.LiteralTypeString,
(
(\v -> case v of
Core.LiteralBinary v1 -> Core.LiteralString (LibLiterals.binaryToString v1)
_ -> v),
(Sets.fromList [
"replace binary strings with character strings"])))
Core.LiteralTypeDecimal -> (
Core.LiteralTypeFloat Core.FloatTypeFloat64,
(
(\v -> case v of
Core.LiteralDecimal v1 -> Core.LiteralFloat (Core.FloatValueFloat64 (LibLiterals.decimalToFloat64 v1))
_ -> v),
(Sets.fromList [
"replace arbitrary-precision decimal numbers with 64-bit floating-point numbers (doubles)"])))
Core.LiteralTypeFloat v0 ->
let result = prepareFloatType v0
rtyp = Pairs.first result
rep = Pairs.first (Pairs.second result)
msgs = Pairs.second (Pairs.second result)
in (
Core.LiteralTypeFloat rtyp,
(
(\v -> case v of
Core.LiteralFloat v1 -> Core.LiteralFloat (rep v1)
_ -> v),
msgs))
Core.LiteralTypeInteger v0 ->
let result = prepareIntegerType v0
rtyp = Pairs.first result
rep = Pairs.first (Pairs.second result)
msgs = Pairs.second (Pairs.second result)
in (
Core.LiteralTypeInteger rtyp,
(
(\v -> case v of
Core.LiteralInteger v1 -> Core.LiteralInteger (rep v1)
_ -> v),
msgs))
_ -> prepareSame at
-- | Return a value unchanged with identity transform and no messages
prepareSame :: Ord t2 => (t0 -> (t0, ((t1 -> t1), (S.Set t2))))
prepareSame x = (x, ((\y -> y), Sets.empty))
-- | Prepare a type, substituting unsupported literal types
prepareType :: t0 -> Core.Type -> (Core.Type, ((Core.Term -> Core.Term), (S.Set String)))
prepareType cx typ =
case (Strip.deannotateType typ) of
Core.TypeLiteral v0 ->
let result = prepareLiteralType v0
rtyp = Pairs.first result
rep = Pairs.first (Pairs.second result)
msgs = Pairs.second (Pairs.second result)
in (
Core.TypeLiteral rtyp,
(
(\v -> case v of
Core.TermLiteral v1 -> Core.TermLiteral (rep v1)
_ -> v),
msgs))
_ -> prepareSame typ
-- | Normalize a term by pushing TermTypeApplication inward past TermApplication and TermLambda. 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 -> case body of
Core.TermAnnotated v0 -> Core.TermAnnotated (Core.AnnotatedTerm {
Core.annotatedTermBody = (push (Core.annotatedTermBody v0) typ),
Core.annotatedTermAnnotation = (Core.annotatedTermAnnotation v0)})
Core.TermApplication v0 -> go (Core.TermApplication (Core.Application {
Core.applicationFunction = (Core.TermTypeApplication (Core.TypeApplicationTerm {
Core.typeApplicationTermBody = (Core.applicationFunction v0),
Core.typeApplicationTermType = typ})),
Core.applicationArgument = (Core.applicationArgument v0)}))
Core.TermLambda v0 -> go (Core.TermLambda (Core.Lambda {
Core.lambdaParameter = (Core.lambdaParameter v0),
Core.lambdaDomain = (Core.lambdaDomain v0),
Core.lambdaBody = (Core.TermTypeApplication (Core.TypeApplicationTerm {
Core.typeApplicationTermBody = (Core.lambdaBody v0),
Core.typeApplicationTermType = typ}))}))
Core.TermLet v0 -> go (Core.TermLet (Core.Let {
Core.letBindings = (Core.letBindings v0),
Core.letBody = (Core.TermTypeApplication (Core.TypeApplicationTerm {
Core.typeApplicationTermBody = (Core.letBody v0),
Core.typeApplicationTermType = typ}))}))
_ -> Core.TermTypeApplication (Core.TypeApplicationTerm {
Core.typeApplicationTermBody = body,
Core.typeApplicationTermType = typ})
go =
\t ->
let forField =
\fld -> Core.Field {
Core.fieldName = (Core.fieldName fld),
Core.fieldTerm = (go (Core.fieldTerm fld))}
forCaseAlternative =
\alt -> Core.CaseAlternative {
Core.caseAlternativeName = (Core.caseAlternativeName alt),
Core.caseAlternativeHandler = (go (Core.caseAlternativeHandler alt))}
forLet =
\lt ->
let mapBinding =
\b -> Core.Binding {
Core.bindingName = (Core.bindingName b),
Core.bindingTerm = (go (Core.bindingTerm b)),
Core.bindingTypeScheme = (Core.bindingTypeScheme b)}
in Core.Let {
Core.letBindings = (Lists.map mapBinding (Core.letBindings lt)),
Core.letBody = (go (Core.letBody lt))}
forMap =
\m ->
let forPair = \p -> (go (Pairs.first p), (go (Pairs.second p)))
in (Maps.fromList (Lists.map forPair (Maps.toList m)))
in case t of
Core.TermAnnotated v0 -> Core.TermAnnotated (Core.AnnotatedTerm {
Core.annotatedTermBody = (go (Core.annotatedTermBody v0)),
Core.annotatedTermAnnotation = (Core.annotatedTermAnnotation v0)})
Core.TermApplication v0 -> Core.TermApplication (Core.Application {
Core.applicationFunction = (go (Core.applicationFunction v0)),
Core.applicationArgument = (go (Core.applicationArgument v0))})
Core.TermCases v0 -> Core.TermCases (Core.CaseStatement {
Core.caseStatementTypeName = (Core.caseStatementTypeName v0),
Core.caseStatementDefault = (Optionals.map go (Core.caseStatementDefault v0)),
Core.caseStatementCases = (Lists.map forCaseAlternative (Core.caseStatementCases v0))})
Core.TermEither v0 -> Core.TermEither (Eithers.either (\l -> Left (go l)) (\r -> Right (go r)) v0)
Core.TermLambda v0 -> Core.TermLambda (Core.Lambda {
Core.lambdaParameter = (Core.lambdaParameter v0),
Core.lambdaDomain = (Core.lambdaDomain v0),
Core.lambdaBody = (go (Core.lambdaBody v0))})
Core.TermLet v0 -> Core.TermLet (forLet v0)
Core.TermList v0 -> Core.TermList (Lists.map go v0)
Core.TermLiteral v0 -> Core.TermLiteral v0
Core.TermMap v0 -> Core.TermMap (forMap v0)
Core.TermOptional v0 -> Core.TermOptional (Optionals.map go v0)
Core.TermPair v0 -> Core.TermPair (go (Pairs.first v0), (go (Pairs.second v0)))
Core.TermProject v0 -> Core.TermProject v0
Core.TermRecord v0 -> Core.TermRecord (Core.Record {
Core.recordTypeName = (Core.recordTypeName v0),
Core.recordFields = (Lists.map forField (Core.recordFields v0))})
Core.TermSet v0 -> Core.TermSet (Sets.fromList (Lists.map go (Sets.toList v0)))
Core.TermTypeApplication v0 ->
let body1 = go (Core.typeApplicationTermBody v0)
in (push body1 (Core.typeApplicationTermType v0))
Core.TermTypeLambda v0 -> Core.TermTypeLambda (Core.TypeLambda {
Core.typeLambdaParameter = (Core.typeLambdaParameter v0),
Core.typeLambdaBody = (go (Core.typeLambdaBody v0))})
Core.TermInject v0 -> Core.TermInject (Core.Injection {
Core.injectionTypeName = (Core.injectionTypeName v0),
Core.injectionField = (forField (Core.injectionField v0))})
Core.TermUnit -> Core.TermUnit
Core.TermUnwrap v0 -> Core.TermUnwrap v0
Core.TermVariable v0 -> Core.TermVariable v0
Core.TermWrap v0 -> Core.TermWrap (Core.WrappedTerm {
Core.wrappedTermTypeName = (Core.wrappedTermTypeName v0),
Core.wrappedTermBody = (go (Core.wrappedTermBody v0))})
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]] -> t0 -> Either Errors.Error (M.Map Core.Name Core.Type, [[Packaging.TypeDefinition]])
schemaGraphToDefinitions constraints graph nameLists cx =
let litmap = adaptLiteralTypesMap constraints
in (Eithers.bind (Eithers.bimap (\e -> Errors.ErrorDecoding e) (\x -> x) (Environment.graphAsTypes graph (Lexical.graphToBindings graph))) (\tmap0 -> Eithers.bind (adaptGraphSchema constraints litmap tmap0) (\tmap1 ->
let toDef =
\pair -> Packaging.TypeDefinition {
Packaging.typeDefinitionName = (Pairs.first pair),
Packaging.typeDefinitionMetadata = Nothing,
Packaging.typeDefinitionBody = Core.TypeScheme {
Core.typeSchemeVariables = [],
Core.typeSchemeBody = (Pairs.second pair),
Core.typeSchemeConstraints = Nothing}}
in (Right (
tmap1,
(Lists.map (\names -> Lists.map toDef (Optionals.mapOptional (\n -> Optionals.map (\t -> (n, t)) (Maps.lookup n tmap1)) names)) nameLists))))))
-- | Given a target language and a source type, produce an adapter which rewrites the type and its terms according to the language's constraints. The encode direction adapts terms; the decode direction is identity.
simpleLanguageAdapter :: Coders.Language -> t0 -> Graph.Graph -> Core.Type -> Either Errors.Error (Coders.Adapter Core.Type Core.Type Core.Term Core.Term)
simpleLanguageAdapter lang cx g typ =
let constraints = Coders.languageConstraints lang
litmap = adaptLiteralTypesMap constraints
in (Eithers.bind (adaptType constraints litmap typ) (\adaptedType -> Right (Coders.Adapter {
Coders.adapterIsLossy = False,
Coders.adapterSource = typ,
Coders.adapterTarget = adaptedType,
Coders.adapterCoder = Coders.Coder {
Coders.coderEncode = (\cx2 -> \term -> adaptTerm constraints litmap cx2 g term),
Coders.coderDecode = (\cx2 -> \term -> Right term)}})))
-- | Find a list of alternatives for a given term, if any
termAlternatives :: t0 -> Graph.Graph -> Core.Term -> Either Errors.Error [Core.Term]
termAlternatives cx graph term =
case term of
Core.TermAnnotated v0 ->
let term2 = Core.annotatedTermBody v0
in (Right [
term2])
Core.TermOptional v0 -> Right [
Core.TermList (Optionals.cases v0 [] (\term2 -> [
term2]))]
Core.TermTypeLambda v0 ->
let term2 = Core.typeLambdaBody v0
in (Right [
term2])
Core.TermTypeApplication v0 ->
let term2 = Core.typeApplicationTermBody v0
in (Right [
term2])
Core.TermInject v0 ->
let tname = Core.injectionTypeName v0
field = Core.injectionField v0
fname = Core.fieldName field
fterm = Core.fieldTerm field
forFieldType =
\ft ->
let ftname = Core.fieldTypeName ft
in Core.Field {
Core.fieldName = fname,
Core.fieldTerm = (Core.TermOptional (Logic.ifElse (Equality.equal ftname fname) (Just fterm) Nothing))}
in (Eithers.bind (Resolution.requireUnionType cx graph tname) (\rt -> Right [
Core.TermRecord (Core.Record {
Core.recordTypeName = tname,
Core.recordFields = (Lists.map forFieldType rt)})]))
Core.TermUnit -> Right [
Core.TermLiteral (Core.LiteralBoolean True)]
Core.TermWrap v0 ->
let term2 = Core.wrappedTermBody v0
in (Right [
term2])
_ -> Right []
-- | Find a list of alternatives for a given type, if any
typeAlternatives :: Core.Type -> [Core.Type]
typeAlternatives type_ =
case type_ of
Core.TypeAnnotated v0 ->
let type2 = Core.annotatedTypeBody v0
in [
type2]
Core.TypeOptional v0 -> [
Core.TypeList v0]
Core.TypeUnion v0 ->
let toOptField =
\f -> Core.FieldType {
Core.fieldTypeName = (Core.fieldTypeName f),
Core.fieldTypeType = (Core.TypeOptional (Core.fieldTypeType f))}
optFields = Lists.map toOptField v0
in [
Core.TypeRecord optFields]
Core.TypeUnit -> [
Core.TypeLiteral Core.LiteralTypeBoolean]
Core.TypeVoid -> [
Core.TypeUnit]
_ -> []