hydra-typescript-0.17.3: src/main/haskell/Hydra/TypeScript/Coder.hs
-- Note: this is an automatically generated file. Do not edit.
-- | TypeScript code generator: emits TypeScript type declarations from Hydra modules
module Hydra.TypeScript.Coder where
import qualified Hydra.Analysis as Analysis
import qualified Hydra.Annotations as Annotations
import qualified Hydra.Arity as Arity
import qualified Hydra.Ast as Ast
import qualified Hydra.Coders as Coders
import qualified Hydra.Core as Core
import qualified Hydra.Docs as Docs
import qualified Hydra.Environment as Environment
import qualified Hydra.Error.Checking as Checking
import qualified Hydra.Error.Core as ErrorCore
import qualified Hydra.Error.File as ErrorFile
import qualified Hydra.Error.Packaging as ErrorPackaging
import qualified Hydra.Error.System as ErrorSystem
import qualified Hydra.Errors as Errors
import qualified Hydra.File as File
import qualified Hydra.Formatting as Formatting
import qualified Hydra.Graph as Graph
import qualified Hydra.Json.Model as Model
import qualified Hydra.Lexical as Lexical
import qualified Hydra.Overlay.Haskell.Lib.Eithers as Eithers
import qualified Hydra.Overlay.Haskell.Lib.Equality as Equality
import qualified Hydra.Overlay.Haskell.Lib.Lists as Lists
import qualified Hydra.Overlay.Haskell.Lib.Literals as Literals
import qualified Hydra.Overlay.Haskell.Lib.Logic as Logic
import qualified Hydra.Overlay.Haskell.Lib.Maps as Maps
import qualified Hydra.Overlay.Haskell.Lib.Math as Math
import qualified Hydra.Overlay.Haskell.Lib.Optionals as Optionals
import qualified Hydra.Overlay.Haskell.Lib.Pairs as Pairs
import qualified Hydra.Overlay.Haskell.Lib.Sets as Sets
import qualified Hydra.Overlay.Haskell.Lib.Strings as Strings
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.Print.Docs as PrintDocs
import qualified Hydra.Query as Query
import qualified Hydra.Regex as Regex
import qualified Hydra.Relational as Relational
import qualified Hydra.Rewriting as Rewriting
import qualified Hydra.Scoping as Scoping
import qualified Hydra.Serialization as Serialization
import qualified Hydra.Sorting as Sorting
import qualified Hydra.Strip as Strip
import qualified Hydra.System as System
import qualified Hydra.Tabular as Tabular
import qualified Hydra.Testing as Testing
import qualified Hydra.Time as Time
import qualified Hydra.Topology as Topology
import qualified Hydra.TypeScript.Language as Language
import qualified Hydra.TypeScript.Serde as Serde
import qualified Hydra.TypeScript.Syntax as Syntax
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
-- | Analyze a term as a TypeScript function, using the Graph as the analysis environment
analyzeTypeScriptFunction :: Typing.InferenceContext -> Graph.Graph -> Core.Term -> Either t0 (Typing.FunctionStructure Graph.Graph)
analyzeTypeScriptFunction cx g term = Analysis.analyzeFunctionTerm cx tsEnvGetGraph tsEnvSetGraph g term
-- | Collect the bound parameter names from a chain of nested foralls, in outer-to-inner order; stops at the first non-forall type
collectForallParams :: Core.Type -> [Core.Name]
collectForallParams t =
let dt = Strip.deannotateType t
in case dt of
Core.TypeForall v0 -> Lists.cons (Core.forallTypeParameter v0) (collectForallParams (Core.forallTypeBody v0))
_ -> []
-- | Collect the names of every type referenced in a type tree that belongs to a different namespace than the current module, for computing the imports needed at the top of the emitted .ts file
collectImports :: Packaging.ModuleName -> Core.Type -> S.Set Core.Name
collectImports currentNs t =
let vars = Variables.freeVariablesInType t
in (filterNonLocalNames currentNs vars)
-- | Collect type imports referenced inside a term tree (lambda bodies, type applications, let-binding schemes), supplementing the top-level typeScheme walk
collectInnerTypeImports :: Packaging.ModuleName -> Core.Term -> S.Set Core.Name
collectInnerTypeImports currentNs term =
let subs = Rewriting.subterms term
ownVars =
case (Strip.deannotateTerm term) of
Core.TermLambda v0 -> Optionals.cases (Core.lambdaDomain v0) Sets.empty (\d -> Variables.freeVariablesInType d)
Core.TermTypeApplication v0 -> Variables.freeVariablesInType (Core.typeApplicationTermType v0)
Core.TermTypeLambda _ -> Sets.empty
Core.TermLet v0 -> Lists.foldl (\acc -> \b -> Optionals.cases (Core.bindingTypeScheme b) acc (\ts -> Sets.union acc (Variables.freeVariablesInType (Core.typeSchemeBody ts)))) Sets.empty (Core.letBindings v0)
_ -> Sets.empty
childVars = Lists.foldl (\acc -> \s -> Sets.union acc (collectInnerTypeImports currentNs s)) Sets.empty subs
in (filterNonLocalNames currentNs (Sets.union ownVars childVars))
-- | Like collectImports but walks a Term, gathering free term-level variables that resolve to a different module
collectTermImports :: Packaging.ModuleName -> Core.Term -> S.Set Core.Name
collectTermImports currentNs t =
let vars = Variables.freeVariablesInTerm t
in (filterNonLocalNames currentNs vars)
-- | Find the free variables of a term that are referenced eagerly, i.e. outside of any nested lambda body; used to break false dependency cycles caused by DSL-level thunks such as hydra.parsers.lazy
eagerFreeVariablesInTerm :: Core.Term -> S.Set Core.Name
eagerFreeVariablesInTerm term =
let dfltVars =
\_ -> Lists.foldl (\s -> \t -> Sets.union s (eagerFreeVariablesInTerm t)) Sets.empty (Rewriting.subterms term)
in case term of
Core.TermLambda _ -> Sets.empty
Core.TermLet v0 -> Sets.difference (dfltVars ()) (Sets.fromList (Lists.map (\b -> Core.bindingName b) (Core.letBindings v0)))
Core.TermVariable v0 -> Sets.singleton v0
_ -> dfltVars ()
-- | Encode a let-binding as a TS statement inside an enclosing function body, hoisting lambda-valued bindings as nested function declarations
encodeBindingAsStatement :: Typing.InferenceContext -> Graph.Graph -> Packaging.ModuleName -> Core.Binding -> Syntax.Statement
encodeBindingAsStatement cx g currentNs b =
let bname = Core.bindingName b
lname = Formatting.sanitizeWithUnderscores Language.typeScriptReservedWords (Names.localNameOf bname)
bterm = Core.bindingTerm b
dterm = Strip.deannotateTerm bterm
in case dterm of
Core.TermLambda _ ->
let innerFunDecl =
functionDeclarationFromTerm cx g currentNs lname bterm (Optionals.bind (Core.bindingTypeScheme b) (\ts -> Just (Core.typeSchemeBody ts)))
in (Syntax.StatementFunctionDeclaration innerFunDecl)
_ ->
let expr = encodeTerm cx g currentNs bterm
declarator =
Syntax.VariableDeclarator {
Syntax.variableDeclaratorId = (Syntax.PatternIdentifier (tsIdent lname)),
Syntax.variableDeclaratorInit = (Just expr)}
varDecl =
Syntax.VariableDeclaration {
Syntax.variableDeclarationKind = Syntax.VariableKindConst,
Syntax.variableDeclarationDeclarations = [
declarator]}
in (Syntax.StatementVariableDeclaration varDecl)
-- | Emit a fully-applied primitive call with selected arguments wrapped in thunks, per a parallel list of laziness flags
encodeLazyCall :: Typing.InferenceContext -> Graph.Graph -> Packaging.ModuleName -> Core.Term -> [Core.Term] -> [Bool] -> Syntax.Expression
encodeLazyCall cx g currentNs headTerm args lazyFlags =
let headExpr = encodeTerm cx g currentNs headTerm
paired = Lists.zip args lazyFlags
renderArg =
\p ->
let argTerm = Pairs.first p
isLazy = Pairs.second p
expr = encodeTerm cx g currentNs argTerm
in (Logic.ifElse isLazy (tsArrow [] expr) expr)
argExprs = Lists.map renderArg paired
in (tsCall headExpr argExprs)
-- | Render a Hydra literal as a TypeScript expression
encodeLiteral :: Core.Literal -> Syntax.Expression
encodeLiteral lit =
let litExpr = \lit -> Syntax.ExpressionLiteral lit
numLit = \i -> litExpr (Syntax.LiteralNumber (Syntax.NumericLiteralInteger i))
floatLit = \f -> litExpr (Syntax.LiteralNumber (Syntax.NumericLiteralFloat f))
strLit =
\s -> litExpr (Syntax.LiteralString (Syntax.StringLiteral {
Syntax.stringLiteralValue = s,
Syntax.stringLiteralSingleQuote = False}))
boolLit = \b -> litExpr (Syntax.LiteralBoolean b)
bigIntCall = \txt -> tsCall (tsExprIdent "BigInt") [
strLit txt]
in case lit of
Core.LiteralBinary v0 -> strLit (Literals.binaryToBase64 v0)
Core.LiteralBoolean v0 -> boolLit v0
Core.LiteralDecimal v0 -> numLit (Literals.bigintToInt64 (Literals.decimalToBigint v0))
Core.LiteralString v0 -> strLit v0
Core.LiteralInteger v0 -> case v0 of
Core.IntegerValueBigint v1 -> bigIntCall (Literals.showBigint v1)
Core.IntegerValueInt8 v1 -> numLit (Literals.bigintToInt64 (Literals.int8ToBigint v1))
Core.IntegerValueInt16 v1 -> numLit (Literals.bigintToInt64 (Literals.int16ToBigint v1))
Core.IntegerValueInt32 v1 -> numLit (Literals.bigintToInt64 (Literals.int32ToBigint v1))
Core.IntegerValueInt64 v1 -> bigIntCall (Literals.showInt64 v1)
Core.IntegerValueUint8 v1 -> numLit (Literals.bigintToInt64 (Literals.uint8ToBigint v1))
Core.IntegerValueUint16 v1 -> numLit (Literals.bigintToInt64 (Literals.uint16ToBigint v1))
Core.IntegerValueUint32 v1 -> numLit (Literals.bigintToInt64 (Literals.uint32ToBigint v1))
Core.IntegerValueUint64 v1 -> bigIntCall (Literals.showUint64 v1)
_ -> numLit (Literals.bigintToInt64 (Literals.int32ToBigint 0))
Core.LiteralFloat v0 -> case v0 of
Core.FloatValueFloat32 v1 -> floatLit (Literals.float32ToFloat64 v1)
Core.FloatValueFloat64 v1 -> floatLit v1
_ -> floatLit 0.0
_ -> litExpr Syntax.LiteralNull
-- | Map a Hydra literal type to a TypeScript type expression
encodeLiteralType :: Core.LiteralType -> Syntax.TypeExpression
encodeLiteralType lt =
case lt of
Core.LiteralTypeBinary -> tsParamApp1 "ReadonlyArray" (tsNamedType "number")
Core.LiteralTypeBoolean -> tsNamedType "boolean"
Core.LiteralTypeDecimal -> tsNamedType "number"
Core.LiteralTypeFloat v0 -> case v0 of
Core.FloatTypeFloat32 -> tsNamedType "number"
Core.FloatTypeFloat64 -> tsNamedType "number"
Core.LiteralTypeInteger v0 -> case v0 of
Core.IntegerTypeBigint -> tsNamedType "bigint"
Core.IntegerTypeInt8 -> tsNamedType "number"
Core.IntegerTypeInt16 -> tsNamedType "number"
Core.IntegerTypeInt32 -> tsNamedType "number"
Core.IntegerTypeInt64 -> tsNamedType "bigint"
Core.IntegerTypeUint8 -> tsNamedType "number"
Core.IntegerTypeUint16 -> tsNamedType "number"
Core.IntegerTypeUint32 -> tsNamedType "number"
Core.IntegerTypeUint64 -> tsNamedType "bigint"
Core.LiteralTypeString -> tsNamedType "string"
-- | Build a TS function parameter as a pattern, typed unless the domain is the analyze pass's untyped-variable sentinel
encodeParam :: t0 -> t1 -> Packaging.ModuleName -> Core.Name -> Core.Type -> Syntax.Pattern
encodeParam cx g currentNs pname dom =
let nstr = sanitizeParamName pname
in case (Strip.deannotateType dom) of
Core.TypeVariable _ -> tsTypedIdent nstr Syntax.TypeExpressionAny
_ -> tsTypedIdent nstr (encodeTypeOrAny cx g currentNs dom)
-- | Render a Hydra term as a TypeScript expression
encodeTerm :: Typing.InferenceContext -> Graph.Graph -> Packaging.ModuleName -> Core.Term -> Syntax.Expression
encodeTerm cx g currentNs term =
case term of
Core.TermAnnotated v0 -> encodeTerm cx g currentNs (Core.annotatedTermBody v0)
Core.TermLiteral v0 -> encodeLiteral v0
Core.TermVariable v0 ->
let local = Formatting.sanitizeWithUnderscores Language.typeScriptReservedWords (Names.localNameOf v0)
varExpr =
Optionals.cases (Names.moduleNameOf v0) (tsExprIdent local) (\ns -> Logic.ifElse (Equality.equal (Packaging.unModuleName currentNs) (Packaging.unModuleName ns)) (tsExprIdent local) (
let nsSegs = Lists.drop 1 (Strings.splitOn "." (Packaging.unModuleName ns))
alias = Strings.concat2 "$mod_" (Strings.join "_" nsSegs)
in (tsMember (tsExprIdent alias) local)))
in (Optionals.cases (Lexical.lookupPrimitive g v0) varExpr (\prim ->
let isZeroArityEffect =
Logic.and (Equality.equal (Arity.primitiveArity prim) 0) (Logic.not (Packaging.primitiveDefinitionIsPure (Graph.primitiveDefinition prim)))
in (Logic.ifElse isZeroArityEffect (tsCall varExpr []) varExpr)))
Core.TermLambda v0 ->
let lamTerm = Core.TermLambda v0
fsLE = analyzeTypeScriptFunction cx g lamTerm
fsL =
Eithers.either (\_err -> Typing.FunctionStructure {
Typing.functionStructureTypeParams = [],
Typing.functionStructureParams = [],
Typing.functionStructureBindings = [],
Typing.functionStructureBody = lamTerm,
Typing.functionStructureDomains = [],
Typing.functionStructureCodomain = Nothing,
Typing.functionStructureEnvironment = g}) (\ok -> ok) fsLE
fsLParams = Typing.functionStructureParams fsL
fsLDoms = Typing.functionStructureDomains fsL
fsLBindings = Typing.functionStructureBindings fsL
fsLBody = Typing.functionStructureBody fsL
fsLEnv = Typing.functionStructureEnvironment fsL
innerBody =
Logic.ifElse (Lists.null fsLBindings) fsLBody (Core.TermLet (Core.Let {
Core.letBindings = fsLBindings,
Core.letBody = fsLBody}))
paramAcc =
Lists.foldl (\acc -> \pn ->
let idx = Pairs.first acc
pats = Pairs.second acc
raw = Names.localNameOf pn
uniq = Logic.ifElse (Equality.equal raw "_") (Strings.concat2 "_" (Literals.showInt32 idx)) raw
pat = tsTypedIdent (Formatting.sanitizeWithUnderscores Language.typeScriptReservedWords uniq) Syntax.TypeExpressionAny
in (Math.add idx 1, (Lists.concat2 pats [
pat]))) (0, []) fsLParams
paramPatterns = Pairs.second paramAcc
bExpr = encodeTerm cx fsLEnv currentNs innerBody
in (tsArrowTyped paramPatterns bExpr)
Core.TermApplication v0 ->
let asTerm = Core.TermApplication v0
flat = flattenApplication asTerm
headTerm = Pairs.first flat
args = Pairs.second flat
mName = termHeadVariable headTerm
argc = Lists.length args
lazyMaybe =
Optionals.cases mName Nothing (\n ->
let lazyFlags = lazyFlagsForPrimitive g n
anyLazy = Lists.foldl (\b -> \f -> Logic.or b f) False lazyFlags
in (Logic.ifElse (Logic.and anyLazy (Equality.equal argc (Lists.length lazyFlags))) (Just (encodeLazyCall cx g currentNs headTerm args lazyFlags)) Nothing))
in (Optionals.cases lazyMaybe (
let dHead = Strip.deannotateAndDetypeTerm headTerm
encArgs = Lists.map (encodeTerm cx g currentNs) args
in case dHead of
Core.TermProject v1 -> Logic.ifElse (Lists.null encArgs) (
let headExpr = encodeTerm cx g currentNs headTerm
in headExpr) (
let fname = Formatting.sanitizeWithUnderscores Language.typeScriptReservedWords (Core.unName (Core.projectionFieldName v1))
firstA = Optionals.withDefault (tsExprIdent "undefined") (Lists.head encArgs)
restA = Lists.drop 1 encArgs
fieldExpr = tsMember firstA fname
in (Logic.ifElse (Lists.null restA) fieldExpr (tsCall fieldExpr restA)))
Core.TermUnwrap _ -> Logic.ifElse (Lists.null encArgs) (
let headExpr = encodeTerm cx g currentNs headTerm
in headExpr) (
let firstA = Optionals.withDefault (tsExprIdent "undefined") (Lists.head encArgs)
restA = Lists.drop 1 encArgs
valueExpr = tsMember firstA "value"
in (Logic.ifElse (Lists.null restA) valueExpr (tsCall valueExpr restA)))
_ ->
let headExpr = encodeTerm cx g currentNs headTerm
in (tsCall headExpr encArgs)) (\e -> e))
Core.TermUnit -> tsUndefined
Core.TermList v0 -> tsArray (Lists.map (encodeTerm cx g currentNs) v0)
Core.TermSet v0 -> tsNew (tsExprIdent "Set") [
tsArray (Lists.map (encodeTerm cx g currentNs) (Sets.toList v0))]
Core.TermMap v0 -> tsNew (tsExprIdent "Map") [
tsArray (Lists.map (\entry -> tsArray [
encodeTerm cx g currentNs (Pairs.first entry),
(encodeTerm cx g currentNs (Pairs.second entry))]) (Maps.toList v0))]
Core.TermPair v0 -> tsAsAny (tsArray [
encodeTerm cx g currentNs (Pairs.first v0),
(encodeTerm cx g currentNs (Pairs.second v0))])
Core.TermOptional v0 -> Optionals.cases v0 (tsAsAny (tsObject [
("tag", (tsExprStr "none"))])) (\v -> tsAsAny (tsObject [
("tag", (tsExprStr "given")),
("value", (encodeTerm cx g currentNs v))]))
Core.TermRecord v0 ->
let fields = Core.recordFields v0
in (tsObject (Lists.map (\f -> (
Formatting.sanitizeWithUnderscores Language.typeScriptReservedWords (Core.unName (Core.fieldName f)),
(encodeTerm cx g currentNs (Core.fieldTerm f)))) fields))
Core.TermInject v0 ->
let fname = Core.unName (Core.fieldName (Core.injectionField v0))
fterm = Core.fieldTerm (Core.injectionField v0)
isUnit =
case (Strip.deannotateTerm fterm) of
Core.TermUnit -> True
_ -> False
in (Logic.ifElse isUnit (tsAsAny (tsObject [
("tag", (tsExprStr fname))])) (tsAsAny (tsObject [
("tag", (tsExprStr fname)),
("value", (encodeTerm cx g currentNs fterm))])))
Core.TermWrap v0 -> tsObject [
("value", (encodeTerm cx g currentNs (Core.wrappedTermBody v0)))]
Core.TermLet v0 ->
let lt2 = thunkLazyLet v0
bindings = sortBindingsTopologically (Core.letBindings lt2)
body = Core.letBody lt2
encodedBody = encodeTerm cx g currentNs body
bindingStmts = Lists.map (\b -> encodeBindingAsStatement cx g currentNs b) bindings
returnStmt = Syntax.StatementReturn (Just encodedBody)
stmts = Lists.concat2 bindingStmts [
returnStmt]
iifeArrow =
Syntax.ExpressionArrow (Syntax.ArrowFunctionExpression {
Syntax.arrowFunctionExpressionParams = [],
Syntax.arrowFunctionExpressionBody = (Syntax.ArrowFunctionBodyBlock stmts),
Syntax.arrowFunctionExpressionAsync = False})
in (tsCall iifeArrow [])
Core.TermTypeApplication v0 -> encodeTerm cx g currentNs (Core.typeApplicationTermBody v0)
Core.TermTypeLambda v0 -> encodeTerm cx g currentNs (Core.typeLambdaBody v0)
Core.TermProject v0 ->
let fname = Formatting.sanitizeWithUnderscores Language.typeScriptReservedWords (Core.unName (Core.projectionFieldName v0))
in (tsArrowTyped [
tsTypedIdent "x" Syntax.TypeExpressionAny] (tsMember (tsExprIdent "x") fname))
Core.TermUnwrap _ -> tsArrowTyped [
tsTypedIdent "x" Syntax.TypeExpressionAny] (tsMember (tsExprIdent "x") "value")
Core.TermCases v0 ->
let armFields = Core.caseStatementCases v0
defaultMaybe = Core.caseStatementDefault v0
uVar = "u"
uExpr = tsAsAny (tsExprIdent uVar)
uTag = tsMember uExpr "tag"
uValue = tsMember uExpr "value"
armCases =
Lists.map (\f ->
let fname = Core.unName (Core.caseAlternativeName f)
armExpr = encodeTerm cx g currentNs (Core.caseAlternativeHandler f)
callExpr = tsCall armExpr [
uValue]
in Syntax.SwitchCase {
Syntax.switchCaseTest = (Just (tsExprStr fname)),
Syntax.switchCaseConsequent = [
Syntax.StatementReturn (Just callExpr)]}) armFields
defaultCase =
Optionals.cases defaultMaybe (Syntax.SwitchCase {
Syntax.switchCaseTest = Nothing,
Syntax.switchCaseConsequent = [
Syntax.StatementReturn (Just (tsCall (tsExprIdent "(() => { throw new Error('unmatched case'); })") []))]}) (\dt ->
let dExpr = encodeTerm cx g currentNs dt
in Syntax.SwitchCase {
Syntax.switchCaseTest = Nothing,
Syntax.switchCaseConsequent = [
Syntax.StatementReturn (Just dExpr)]})
allCases = Lists.concat2 armCases [
defaultCase]
switchStmt =
Syntax.StatementSwitch (Syntax.SwitchStatement {
Syntax.switchStatementDiscriminant = uTag,
Syntax.switchStatementCases = allCases})
in (Syntax.ExpressionArrow (Syntax.ArrowFunctionExpression {
Syntax.arrowFunctionExpressionParams = [
Syntax.PatternIdentifier (tsIdent uVar)],
Syntax.arrowFunctionExpressionBody = (Syntax.ArrowFunctionBodyBlock [
switchStmt]),
Syntax.arrowFunctionExpressionAsync = False}))
Core.TermEither v0 -> Eithers.either (\l -> tsAsAny (tsObject [
("tag", (tsExprStr "left")),
("value", (encodeTerm cx g currentNs l))])) (\r -> tsAsAny (tsObject [
("tag", (tsExprStr "right")),
("value", (encodeTerm cx g currentNs r))])) v0
_ -> tsExprIdent "null"
-- | Render a Hydra term definition as a TypeScript module item
encodeTermDefinition :: Typing.InferenceContext -> Graph.Graph -> Packaging.ModuleName -> Packaging.TermDefinition -> (Maybe String, Syntax.ModuleItem)
encodeTermDefinition cx g currentNs td =
let name = Packaging.termDefinitionName td
lname = Formatting.sanitizeWithUnderscores Language.typeScriptReservedWords (Names.localNameOf name)
rawTerm = Packaging.termDefinitionBody td
mdoc = Eithers.either (\_ -> Nothing) (\x_ -> x_) (Annotations.getTermDescription cx g rawTerm)
asExport = \stmt -> Syntax.ModuleItemExport (Syntax.ExportDeclarationDeclaration stmt)
mScheme =
Optionals.bind (Packaging.termDefinitionSignature td) (\sig -> Just (Core.typeSchemeBody (Scoping.termSignatureToTypeScheme sig)))
dterm = Strip.deannotateTerm rawTerm
funDecl = functionDeclarationFromTerm cx g currentNs lname rawTerm mScheme
asFunDecl = asExport (Syntax.StatementFunctionDeclaration funDecl)
item =
case dterm of
Core.TermLambda _ -> asFunDecl
Core.TermTypeLambda _ -> asFunDecl
_ ->
let expr = encodeTerm cx g currentNs rawTerm
declarator =
Syntax.VariableDeclarator {
Syntax.variableDeclaratorId = (Syntax.PatternIdentifier (tsIdent lname)),
Syntax.variableDeclaratorInit = (Just expr)}
varDecl =
Syntax.VariableDeclaration {
Syntax.variableDeclarationKind = Syntax.VariableKindConst,
Syntax.variableDeclarationDeclarations = [
declarator]}
in (asExport (Syntax.StatementVariableDeclaration varDecl))
in (mdoc, item)
-- | Map a Hydra type to a TypeScript type expression
encodeType :: t0 -> t1 -> Packaging.ModuleName -> Core.Type -> Either t2 Syntax.TypeExpression
encodeType cx g currentNs t =
let typ = Strip.deannotateType t
in case typ of
Core.TypeAnnotated v0 -> encodeType cx g currentNs (Core.annotatedTypeBody v0)
Core.TypeApplication v0 ->
let fnTyp = Core.applicationTypeFunction v0
argTyp = Core.applicationTypeArgument v0
in (Eithers.bind (encodeType cx g currentNs fnTyp) (\encFn -> Eithers.bind (encodeType cx g currentNs argTyp) (\encArg -> case encFn of
Syntax.TypeExpressionIdentifier _ -> Right (Syntax.TypeExpressionParameterized (Syntax.ParameterizedTypeExpression {
Syntax.parameterizedTypeExpressionBase = encFn,
Syntax.parameterizedTypeExpressionArguments = [
encArg]}))
Syntax.TypeExpressionParameterized v1 -> Right (Syntax.TypeExpressionParameterized (Syntax.ParameterizedTypeExpression {
Syntax.parameterizedTypeExpressionBase = (Syntax.parameterizedTypeExpressionBase v1),
Syntax.parameterizedTypeExpressionArguments = (Lists.concat2 (Syntax.parameterizedTypeExpressionArguments v1) [
encArg])}))
_ -> Right encFn)))
Core.TypeForall v0 -> encodeType cx g currentNs (Core.forallTypeBody v0)
Core.TypeUnit -> Right Syntax.TypeExpressionVoid
Core.TypeVoid -> Right Syntax.TypeExpressionNever
Core.TypeLiteral v0 -> Right (encodeLiteralType v0)
Core.TypeList v0 -> Eithers.map (\enc -> tsParamApp1 "ReadonlyArray" enc) (encodeType cx g currentNs v0)
Core.TypeSet v0 -> Eithers.map tsReadonlySet (encodeType cx g currentNs v0)
Core.TypeMap v0 -> Eithers.bind (encodeType cx g currentNs (Core.mapTypeKeys v0)) (\kt -> Eithers.bind (encodeType cx g currentNs (Core.mapTypeValues v0)) (\vt -> Right (tsReadonlyMap kt vt)))
Core.TypeOptional v0 -> Eithers.map (\enc -> Syntax.TypeExpressionUnion [
Syntax.TypeExpressionObject [
tsPropSig "tag" False (Syntax.TypeExpressionLiteral (Syntax.LiteralString (Syntax.StringLiteral {
Syntax.stringLiteralValue = "given",
Syntax.stringLiteralSingleQuote = False}))),
(tsPropSig "value" False enc)],
(Syntax.TypeExpressionObject [
tsPropSig "tag" False (Syntax.TypeExpressionLiteral (Syntax.LiteralString (Syntax.StringLiteral {
Syntax.stringLiteralValue = "none",
Syntax.stringLiteralSingleQuote = False})))])]) (encodeType cx g currentNs v0)
Core.TypeEither v0 -> Eithers.bind (encodeType cx g currentNs (Core.eitherTypeLeft v0)) (\lt -> Eithers.bind (encodeType cx g currentNs (Core.eitherTypeRight v0)) (\rt ->
let leftArm =
Syntax.TypeExpressionObject [
tsPropSig "tag" False (Syntax.TypeExpressionLiteral (Syntax.LiteralString (Syntax.StringLiteral {
Syntax.stringLiteralValue = "left",
Syntax.stringLiteralSingleQuote = False}))),
(tsPropSig "value" False lt)]
rightArm =
Syntax.TypeExpressionObject [
tsPropSig "tag" False (Syntax.TypeExpressionLiteral (Syntax.LiteralString (Syntax.StringLiteral {
Syntax.stringLiteralValue = "right",
Syntax.stringLiteralSingleQuote = False}))),
(tsPropSig "value" False rt)]
in (Right (Syntax.TypeExpressionUnion [
leftArm,
rightArm]))))
Core.TypePair v0 -> Eithers.bind (encodeType cx g currentNs (Core.pairTypeFirst v0)) (\ft -> Eithers.bind (encodeType cx g currentNs (Core.pairTypeSecond v0)) (\st -> Right (tsTuple [
ft,
st])))
Core.TypeFunction v0 -> Eithers.bind (encodeType cx g currentNs (Core.functionTypeDomain v0)) (\dom -> Eithers.bind (encodeType cx g currentNs (Core.functionTypeCodomain v0)) (\cod -> Right (Syntax.TypeExpressionFunction (Syntax.FunctionTypeExpression {
Syntax.functionTypeExpressionTypeParameters = [],
Syntax.functionTypeExpressionParameters = [
dom],
Syntax.functionTypeExpressionReturnType = cod}))))
Core.TypeVariable v0 ->
let lname = Formatting.capitalize (Names.localNameOf v0)
in (Optionals.cases (Names.moduleNameOf v0) (Right (tsNamedType lname)) (\ns -> Logic.ifElse (Equality.equal (Packaging.unModuleName currentNs) (Packaging.unModuleName ns)) (Right (tsNamedType lname)) (
let nsSegs = Lists.drop 1 (Strings.splitOn "." (Packaging.unModuleName ns))
typeAlias = Strings.concat2 "$type_" (Strings.join "_" nsSegs)
in (Right (tsNamedType (Strings.concat [
typeAlias,
".",
lname]))))))
Core.TypeWrap v0 -> encodeType cx g currentNs v0
Core.TypeRecord v0 -> Eithers.bind (Eithers.mapList (\ft ->
let fname = Core.unName (Core.fieldTypeName ft)
ftyp = Core.fieldTypeType ft
in (Eithers.bind (encodeType cx g currentNs ftyp) (\sftyp -> Right (tsPropSig fname False sftyp)))) v0) (\members -> Right (Syntax.TypeExpressionObject members))
Core.TypeUnion v0 -> Eithers.bind (Eithers.mapList (\ft ->
let fname = Core.unName (Core.fieldTypeName ft)
ftyp = Core.fieldTypeType ft
in (Eithers.bind (encodeType cx g currentNs ftyp) (\sftyp -> Right (Syntax.TypeExpressionObject [
tsPropSig "tag" False (Syntax.TypeExpressionLiteral (Syntax.LiteralString (Syntax.StringLiteral {
Syntax.stringLiteralValue = fname,
Syntax.stringLiteralSingleQuote = False}))),
(tsPropSig "value" False sftyp)])))) v0) (\arms -> Right (Syntax.TypeExpressionUnion arms))
-- | Encode a Hydra type definition as an interface declaration, a discriminated-union type alias, or a plain type alias
encodeTypeDefinition :: t0 -> Graph.Graph -> Packaging.ModuleName -> Packaging.TypeDefinition -> Either Errors.Error (Maybe String, Syntax.ModuleItem)
encodeTypeDefinition cx g currentNs tdef =
let name = Packaging.typeDefinitionName tdef
typScheme = Packaging.typeDefinitionBody tdef
rawTyp = Core.typeSchemeBody typScheme
lname = Formatting.capitalize (Names.localNameOf name)
in (Eithers.bind (Annotations.getTypeDescription cx g rawTyp) (\mdoc ->
let forallParams = collectForallParams rawTyp
typ = stripForalls rawTyp
typeParams = Lists.map (\v -> tsParam (Formatting.capitalize (Core.unName v))) forallParams
dtyp = Strip.deannotateType typ
in case dtyp of
Core.TypeRecord v0 -> Eithers.bind (Eithers.mapList (\ft ->
let fname = Core.unName (Core.fieldTypeName ft)
ftyp = Core.fieldTypeType ft
in (Eithers.bind (encodeType cx g currentNs ftyp) (\sftyp -> Eithers.bind (Annotations.commentsFromFieldType cx g ft) (\mfdoc -> Right (tsPropSigWithDoc fname False sftyp (mkDocComment mfdoc)))))) v0) (\members -> Right (
mdoc,
(Syntax.ModuleItemInterface (Syntax.InterfaceDeclaration {
Syntax.interfaceDeclarationName = (tsIdent lname),
Syntax.interfaceDeclarationTypeParameters = typeParams,
Syntax.interfaceDeclarationExtends = [],
Syntax.interfaceDeclarationMembers = members}))))
Core.TypeUnion v0 -> Eithers.bind (Eithers.mapList (\ft ->
let fname = Core.unName (Core.fieldTypeName ft)
ftyp = Core.fieldTypeType ft
dtyp2 = Strip.deannotateType ftyp
in case dtyp2 of
Core.TypeUnit -> Right (Syntax.TypeExpressionObject [
tsPropSig "tag" False (Syntax.TypeExpressionLiteral (Syntax.LiteralString (Syntax.StringLiteral {
Syntax.stringLiteralValue = fname,
Syntax.stringLiteralSingleQuote = False})))])
_ -> Eithers.bind (encodeType cx g currentNs ftyp) (\sftyp -> Right (Syntax.TypeExpressionObject [
tsPropSig "tag" False (Syntax.TypeExpressionLiteral (Syntax.LiteralString (Syntax.StringLiteral {
Syntax.stringLiteralValue = fname,
Syntax.stringLiteralSingleQuote = False}))),
(tsPropSig "value" False sftyp)]))) v0) (\arms -> Right (
mdoc,
(Syntax.ModuleItemTypeAlias (Syntax.TypeAliasDeclaration {
Syntax.typeAliasDeclarationName = (tsIdent lname),
Syntax.typeAliasDeclarationTypeParameters = typeParams,
Syntax.typeAliasDeclarationType = (Syntax.TypeExpressionUnion arms)}))))
Core.TypeWrap v0 -> Eithers.bind (encodeType cx g currentNs v0) (\sftyp -> Right (
mdoc,
(Syntax.ModuleItemInterface (Syntax.InterfaceDeclaration {
Syntax.interfaceDeclarationName = (tsIdent lname),
Syntax.interfaceDeclarationTypeParameters = typeParams,
Syntax.interfaceDeclarationExtends = [],
Syntax.interfaceDeclarationMembers = [
tsPropSig "value" False sftyp]}))))
_ -> Eithers.bind (encodeType cx g currentNs typ) (\styp -> Right (
mdoc,
(Syntax.ModuleItemTypeAlias (Syntax.TypeAliasDeclaration {
Syntax.typeAliasDeclarationName = (tsIdent lname),
Syntax.typeAliasDeclarationTypeParameters = typeParams,
Syntax.typeAliasDeclarationType = styp}))))))
-- | Try to encode a Hydra type as a TS type expression, falling back to any if encodeType fails
encodeTypeOrAny :: t0 -> t1 -> Packaging.ModuleName -> Core.Type -> Syntax.TypeExpression
encodeTypeOrAny cx g currentNs typ =
Eithers.either (\_e -> Syntax.TypeExpressionAny) (\te -> te) (encodeType cx g currentNs typ)
-- | Keep only names whose module differs from the current module's
filterNonLocalNames :: Packaging.ModuleName -> S.Set Core.Name -> S.Set Core.Name
filterNonLocalNames currentNs names =
Sets.fromList (Optionals.givens (Lists.map (\n -> Optionals.cases (Names.moduleNameOf n) Nothing (\nameNs -> Logic.ifElse (Equality.equal (Packaging.unModuleName currentNs) (Packaging.unModuleName nameNs)) Nothing (Just n))) (Sets.toList names)))
-- | Walk an application spine, returning the innermost head term and its arguments in application order
flattenApplication :: Core.Term -> (Core.Term, [Core.Term])
flattenApplication t =
let dt = Strip.deannotateTerm t
in case dt of
Core.TermApplication v0 ->
let inner = flattenApplication (Core.applicationFunction v0)
head_ = Pairs.first inner
prevArgs = Pairs.second inner
in (head_, (Lists.concat2 prevArgs (Lists.singleton (Core.applicationArgument v0))))
_ -> (t, [])
-- | Rewrite free occurrences of the given target names from x to x(undefined), forcing a thunked binding created by thunkLazyLet
forceLazyRefs :: S.Set Core.Name -> Core.Term -> Core.Term
forceLazyRefs targets0 term0 =
Rewriting.rewriteTermWithContext (\recurse0 -> \targets -> \term -> case term of
Core.TermVariable v0 -> Logic.ifElse (Sets.member v0 targets) (Core.TermApplication (Core.Application {
Core.applicationFunction = (Core.TermVariable v0),
Core.applicationArgument = Core.TermUnit})) term
Core.TermLambda v0 ->
let innerTargets = Sets.delete (Core.lambdaParameter v0) targets
in (recurse0 innerTargets term)
Core.TermLet v0 ->
let boundNames = Sets.fromList (Lists.map Core.bindingName (Core.letBindings v0))
innerTargets = Sets.difference targets boundNames
in (recurse0 innerTargets term)
_ -> recurse0 targets term) targets0 term0
-- | Build a TS function declaration from a Hydra term by peeling lambdas and let bindings into explicit parameters, statements, and a body
functionDeclarationFromTerm :: Typing.InferenceContext -> Graph.Graph -> Packaging.ModuleName -> String -> Core.Term -> Maybe Core.Type -> Syntax.FunctionDeclaration
functionDeclarationFromTerm cx g currentNs lname term _mScheme =
let fsE = analyzeTypeScriptFunction cx g term
fs =
Eithers.either (\_err -> Typing.FunctionStructure {
Typing.functionStructureTypeParams = [],
Typing.functionStructureParams = [],
Typing.functionStructureBindings = [],
Typing.functionStructureBody = term,
Typing.functionStructureDomains = [],
Typing.functionStructureCodomain = Nothing,
Typing.functionStructureEnvironment = g}) (\ok -> ok) fsE
fsParams = Typing.functionStructureParams fs
fsDoms = Typing.functionStructureDomains fs
fsBindings0 = Typing.functionStructureBindings fs
fsBody0 = Typing.functionStructureBody fs
thunked = thunkLazyBindings fsBindings0 fsBody0
fsBindings = Pairs.first thunked
fsBody = Pairs.second thunked
fsEnv = Typing.functionStructureEnvironment fs
domPad = Core.TypeVariable (Core.Name "_")
fsDomsPadded = Lists.concat2 fsDoms (Lists.replicate (Math.sub (Lists.length fsParams) (Lists.length fsDoms)) domPad)
paramPatterns =
Lists.map (\pair -> encodeParam cx fsEnv currentNs (Pairs.first pair) (Pairs.second pair)) (Lists.zip fsParams fsDomsPadded)
sortedBindings = sortBindingsTopologically fsBindings
bindingStmts = Lists.map (\b -> encodeBindingAsStatement cx fsEnv currentNs b) sortedBindings
bodyExpr = encodeTerm cx fsEnv currentNs fsBody
returnStmt = Syntax.StatementReturn (Just bodyExpr)
block = Lists.concat2 bindingStmts [
returnStmt]
in Syntax.FunctionDeclaration {
Syntax.functionDeclarationId = (tsIdent lname),
Syntax.functionDeclarationParams = paramPatterns,
Syntax.functionDeclarationBody = block,
Syntax.functionDeclarationAsync = False,
Syntax.functionDeclarationGenerator = False}
-- | Render a set of qualified names as TypeScript import statements grouped by source module
importsToText :: String -> Packaging.ModuleName -> S.Set Core.Name -> String
importsToText kind currentNs names =
let pairs =
Optionals.givens (Lists.map (\n -> Optionals.cases (Names.moduleNameOf n) Nothing (\ns -> Logic.ifElse (Equality.equal (Packaging.unModuleName currentNs) (Packaging.unModuleName ns)) Nothing (Just (ns, n)))) (Sets.toList names))
transformLocal =
\s -> Logic.ifElse (Equality.equal kind "type") (Formatting.capitalize s) (Formatting.sanitizeWithUnderscores Language.typeScriptReservedWords s)
importKeyword = Logic.ifElse (Equality.equal kind "type") "import type" "import"
grouped =
Lists.foldl (\acc -> \p ->
let ns = Pairs.first p
n = Pairs.second p
local = transformLocal (Names.localNameOf n)
existing = Optionals.withDefault [] (Maps.lookup ns acc)
in (Maps.insert ns (Lists.cons local existing) acc)) Maps.empty pairs
currentSegs = Lists.drop 1 (Strings.splitOn "." (Packaging.unModuleName currentNs))
currentDepth = Lists.length currentSegs
currentIsTest =
Logic.and (Logic.not (Lists.null currentSegs)) (Equality.equal (Optionals.withDefault "" (Lists.head currentSegs)) "test")
baseUpPrefix =
Logic.ifElse (Equality.equal currentDepth 1) "./" (Strings.concat (Lists.replicate (Math.sub currentDepth 1) "../"))
lines =
Lists.map (\entry ->
let ns = Pairs.first entry
locals = Pairs.second entry
targetSegs = Lists.drop 1 (Strings.splitOn "." (Packaging.unModuleName ns))
targetIsTest =
Logic.and (Logic.not (Lists.null targetSegs)) (Equality.equal (Optionals.withDefault "" (Lists.head targetSegs)) "test")
targetPathSegs =
Logic.ifElse (Equality.equal (Optionals.withDefault "" (Lists.head targetSegs)) "lib") (Lists.concat2 [
"overlay",
"typescript"] targetSegs) targetSegs
targetPath = Strings.join "/" targetPathSegs
upPrefix =
Logic.ifElse (Logic.and currentIsTest (Logic.not targetIsTest)) (Strings.concat2 baseUpPrefix "../../../main/typescript/hydra/") baseUpPrefix
nsSlug = Strings.join "_" targetSegs
moduleAlias = Logic.ifElse (Equality.equal kind "type") (Strings.concat2 "$type_" nsSlug) (Strings.concat2 "$mod_" nsSlug)
in (Strings.concat [
importKeyword,
" * as ",
moduleAlias,
" from \"",
upPrefix,
targetPath,
".js\";\n"])) (Maps.toList grouped)
in (Strings.concat lines)
-- | Look up a primitive by name and return its per-parameter laziness flags in parameter order
lazyFlagsForPrimitive :: Graph.Graph -> Core.Name -> [Bool]
lazyFlagsForPrimitive g name =
Optionals.cases (Maps.lookup name (Graph.graphPrimitives g)) [] (\prim -> Lists.map (\p -> Typing.parameterIsLazy p) (Typing.termSignatureParameters (Packaging.primitiveDefinitionSignature (Graph.primitiveDefinition prim))))
-- | True when a let-binding's value should be thunked to preserve Haskell's lazy evaluation semantics
letBindingIsThunkCandidate :: Core.Binding -> Bool
letBindingIsThunkCandidate b =
let dterm = Strip.deannotateAndDetypeTerm (Core.bindingTerm b)
isLambda =
case dterm of
Core.TermLambda _ -> True
_ -> False
freeVars = Variables.freeVariablesInTerm (Core.bindingTerm b)
callsShow =
Lists.foldl (\acc -> \n -> Logic.or acc (Optionals.cases (Names.moduleNameOf n) False (\mn -> Equality.equal (Lists.take 2 (Strings.splitOn "." (Packaging.unModuleName mn))) [
"hydra",
"show"]))) False (Sets.toList freeVars)
in (Logic.and (Logic.not isLambda) callsShow)
-- | Build a documentation comment from an optional description string, or nothing if the description is missing or empty
mkDocComment :: Maybe String -> Maybe Syntax.DocumentationComment
mkDocComment mdesc =
Optionals.cases mdesc Nothing (\d -> Logic.ifElse (Equality.equal d "") Nothing (Just (Syntax.DocumentationComment {
Syntax.documentationCommentDescription = (PrintDocs.renderDocStringWith tsDocEntityRef d),
Syntax.documentationCommentTags = []})))
-- | Convert a Hydra module to a map from .ts file path to TypeScript source
moduleToTypeScript :: Packaging.Module -> [Packaging.Definition] -> Typing.InferenceContext -> Graph.Graph -> Either Errors.Error (M.Map String String)
moduleToTypeScript mod defs cx g =
let currentNs = Packaging.moduleName mod
partitioned = Environment.partitionDefinitions defs
typeDefs = Pairs.first partitioned
rawTermDefs = Pairs.second partitioned
termDefs = sortTermDefsTopologically currentNs rawTermDefs
typeImportsFromTypes =
Lists.foldl (\acc -> \td -> Sets.union acc (collectImports currentNs (Core.typeSchemeBody (Packaging.typeDefinitionBody td)))) Sets.empty typeDefs
typeImportsFromTerms =
Lists.foldl (\acc -> \td -> Optionals.cases (Packaging.termDefinitionSignature td) acc (\sig -> Sets.union acc (collectImports currentNs (Core.typeSchemeBody (Scoping.termSignatureToTypeScheme sig))))) Sets.empty termDefs
typeImportsFromInner =
Lists.foldl (\acc -> \td -> Sets.union acc (collectInnerTypeImports currentNs (Packaging.termDefinitionBody td))) Sets.empty termDefs
typeImports = Sets.union (Sets.union typeImportsFromTypes typeImportsFromTerms) typeImportsFromInner
termImports =
Lists.foldl (\acc -> \td -> Sets.union acc (collectTermImports currentNs (Packaging.termDefinitionBody td))) Sets.empty termDefs
typeImportsBlock = importsToText "type" currentNs typeImports
termImportsBlock = importsToText "value" currentNs termImports
importsBlock = Strings.concat2 typeImportsBlock termImportsBlock
in (Eithers.bind (Eithers.mapList (encodeTypeDefinition cx g currentNs) typeDefs) (\typeItems ->
let termItems = Lists.map (encodeTermDefinition cx g currentNs) termDefs
allItems = Lists.concat2 typeItems termItems
mModuleDoc = Optionals.bind (Packaging.moduleMetadata mod) (\em -> Packaging.entityMetadataDescription em)
moduleDocText = Optionals.cases mModuleDoc "" (\d -> Strings.concat2 (Serde.toTypeScriptComments d []) "\n\n")
header = Strings.concat2 "// Note: this is an automatically generated file. Do not edit.\n\n" moduleDocText
renderItem =
\docAndItem ->
let mdoc = Pairs.first docAndItem
item = Pairs.second docAndItem
itemText = printModuleItem item
in (Optionals.cases mdoc itemText (\d -> Strings.concat [
Serde.toTypeScriptComments d [],
"\n",
itemText]))
body = Strings.join "\n\n" (Lists.map renderItem allItems)
filePath = Names.moduleNameToFilePath Util.CaseConventionCamel (File.FileExtension "ts") (Packaging.moduleName mod)
in (Right (Maps.singleton filePath (Strings.concat [
header,
importsBlock,
(Logic.ifElse (Equality.equal importsBlock "") "" "\n"),
body,
(Logic.ifElse (Equality.equal body "") "" "\n")])))))
-- | Render an interface declaration
printInterfaceDeclaration :: Syntax.InterfaceDeclaration -> String
printInterfaceDeclaration decl =
let name = Syntax.unIdentifier (Syntax.interfaceDeclarationName decl)
params = printTypeParameterList (Syntax.interfaceDeclarationTypeParameters decl)
exts = Syntax.interfaceDeclarationExtends decl
extClause =
Logic.ifElse (Lists.null exts) "" (Strings.concat2 " extends " (Strings.join ", " (Lists.map printTypeExpression exts)))
members = Syntax.interfaceDeclarationMembers decl
renderMember = \ps -> Strings.join "\n " (Strings.lines (printPropertySignature ps))
body =
Logic.ifElse (Lists.null members) "" (Strings.concat [
"\n ",
(Strings.join ";\n " (Lists.map renderMember members)),
";\n"])
in (Strings.concat [
"export interface ",
name,
params,
extClause,
" {",
body,
"}\n"])
-- | Render a TypeScript literal as source text
printLiteral :: Syntax.Literal -> String
printLiteral lit =
case lit of
Syntax.LiteralString v0 -> tsEscapeString (Syntax.stringLiteralValue v0)
Syntax.LiteralBoolean v0 -> Logic.ifElse v0 "true" "false"
Syntax.LiteralNull -> "null"
Syntax.LiteralUndefined -> "undefined"
_ -> "null"
-- | Render a top-level module item
printModuleItem :: Syntax.ModuleItem -> String
printModuleItem mi =
case mi of
Syntax.ModuleItemInterface v0 -> printInterfaceDeclaration v0
Syntax.ModuleItemTypeAlias v0 -> printTypeAliasDeclaration v0
Syntax.ModuleItemStatement _ -> Serialization.printExpr (Serde.moduleItemToExpr mi)
Syntax.ModuleItemImport _ -> Serialization.printExpr (Serde.moduleItemToExpr mi)
Syntax.ModuleItemExport _ -> Serialization.printExpr (Serde.moduleItemToExpr mi)
_ -> ""
-- | Render a property signature, with an optional JSDoc comment prepended
printPropertySignature :: Syntax.PropertySignature -> String
printPropertySignature ps =
let mcomments = Syntax.propertySignatureComments ps
line =
Strings.concat [
Logic.ifElse (Syntax.propertySignatureReadonly ps) "readonly " "",
(Syntax.unIdentifier (Syntax.propertySignatureName ps)),
(Logic.ifElse (Syntax.propertySignatureOptional ps) "?" ""),
": ",
(printTypeExpression (Syntax.propertySignatureType ps))]
in (Optionals.cases mcomments line (\dc -> Strings.concat [
Serde.toTypeScriptComments (Syntax.documentationCommentDescription dc) (Syntax.documentationCommentTags dc),
"\n",
line]))
-- | Render a type alias declaration
printTypeAliasDeclaration :: Syntax.TypeAliasDeclaration -> String
printTypeAliasDeclaration decl =
let name = Syntax.unIdentifier (Syntax.typeAliasDeclarationName decl)
params = printTypeParameterList (Syntax.typeAliasDeclarationTypeParameters decl)
rhs = printTypeExpression (Syntax.typeAliasDeclarationType decl)
in (Strings.concat [
"export type ",
name,
params,
" = ",
rhs,
";\n"])
-- | Render a TypeScript type expression as source text
printTypeExpression :: Syntax.TypeExpression -> String
printTypeExpression t =
case t of
Syntax.TypeExpressionIdentifier v0 -> Syntax.unIdentifier v0
Syntax.TypeExpressionLiteral v0 -> printLiteral v0
Syntax.TypeExpressionArray v0 -> Strings.concat [
"ReadonlyArray<",
(printTypeExpression (Syntax.unArrayTypeExpression v0)),
">"]
Syntax.TypeExpressionTuple v0 -> Strings.concat [
"readonly [",
(Strings.join ", " (Lists.map printTypeExpression v0)),
"]"]
Syntax.TypeExpressionUnion v0 -> Strings.join " | " (Lists.map printTypeExpression v0)
Syntax.TypeExpressionIntersection v0 -> Strings.join " & " (Lists.map printTypeExpression v0)
Syntax.TypeExpressionParameterized v0 -> Strings.concat [
printTypeExpression (Syntax.parameterizedTypeExpressionBase v0),
"<",
(Strings.join ", " (Lists.map printTypeExpression (Syntax.parameterizedTypeExpressionArguments v0))),
">"]
Syntax.TypeExpressionOptional v0 -> Strings.concat [
printTypeExpression v0,
" | undefined"]
Syntax.TypeExpressionReadonly v0 -> Strings.concat2 "readonly " (printTypeExpression v0)
Syntax.TypeExpressionObject v0 -> Strings.concat [
"{ ",
(Strings.join "; " (Lists.map printPropertySignature v0)),
" }"]
Syntax.TypeExpressionFunction _ -> "((...args: any[]) => any)"
Syntax.TypeExpressionAny -> "any"
Syntax.TypeExpressionUnknown -> "unknown"
Syntax.TypeExpressionVoid -> "void"
Syntax.TypeExpressionNever -> "never"
_ -> "unknown"
-- | Render one generic type parameter, with an optional extends constraint
printTypeParameter :: Syntax.TypeParameter -> String
printTypeParameter tp =
let name = Syntax.unIdentifier (Syntax.typeParameterName tp)
constraint = Syntax.typeParameterConstraint tp
in (Optionals.cases constraint name (\c -> Strings.concat [
name,
" extends ",
(printTypeExpression c)]))
-- | Render a generic parameter list, or the empty string when there are no parameters
printTypeParameterList :: [Syntax.TypeParameter] -> String
printTypeParameterList tps =
Logic.ifElse (Lists.null tps) "" (Strings.concat [
"<",
(Strings.join ", " (Lists.map printTypeParameter tps)),
">"])
-- | Sanitize a Hydra parameter name into a valid, non-reserved TS identifier
sanitizeParamName :: Core.Name -> String
sanitizeParamName n = Formatting.sanitizeWithUnderscores Language.typeScriptReservedWords (Names.localNameOf n)
-- | Reorder let-bindings so each appears after the sibling bindings it depends on, avoiding JS temporal-dead-zone errors
sortBindingsTopologically :: [Core.Binding] -> [Core.Binding]
sortBindingsTopologically bindings =
let byName = Maps.fromList (Lists.map (\b -> (Core.bindingName b, b)) bindings)
adjacency =
Lists.map (\b ->
let bname = Core.bindingName b
bterm = Core.bindingTerm b
freeVars = Variables.freeVariablesInTerm bterm
deps = Lists.filter (\n -> Maps.member n byName) (Sets.toList freeVars)
in (bname, deps)) bindings
sccs = Sorting.topologicalSortComponents adjacency
in (Optionals.givens (Lists.map (\n -> Maps.lookup n byName) (Lists.concat sccs)))
-- | Reorder term definitions so each appears after the intra-module definitions it depends on
sortTermDefsTopologically :: t0 -> [Packaging.TermDefinition] -> [Packaging.TermDefinition]
sortTermDefsTopologically currentNs tdefs =
let byName = Maps.fromList (Lists.map (\td -> (Packaging.termDefinitionName td, td)) tdefs)
adjacency =
Lists.map (\td ->
let tname = Packaging.termDefinitionName td
tterm = Packaging.termDefinitionBody td
freeVars = eagerFreeVariablesInTerm tterm
deps = Lists.filter (\n -> Maps.member n byName) (Sets.toList freeVars)
in (tname, deps)) tdefs
sccs = Sorting.topologicalSortComponents adjacency
in (Optionals.givens (Lists.map (\n -> Maps.lookup n byName) (Lists.concat sccs)))
-- | Strip leading forall quantifiers from a type, returning the innermost body
stripForalls :: Core.Type -> Core.Type
stripForalls t =
let dt = Strip.deannotateType t
in case dt of
Core.TypeForall v0 -> stripForalls (Core.forallTypeBody v0)
_ -> dt
-- | If a term reduces, through annotations and type applications, to a variable reference, return its name
termHeadVariable :: Core.Term -> Maybe Core.Name
termHeadVariable t =
let dt = Strip.deannotateTerm t
in case dt of
Core.TermVariable v0 -> Just v0
Core.TermTypeApplication v0 -> termHeadVariable (Core.typeApplicationTermBody v0)
_ -> Nothing
-- | The bindings-and-body core of thunkLazyLet, shared by the Term_let encoder and the lifted-binding path in functionDeclarationFromTerm
thunkLazyBindings :: [Core.Binding] -> Core.Term -> ([Core.Binding], Core.Term)
thunkLazyBindings bindings body =
let candidates = Lists.filter (\b -> letBindingIsThunkCandidate b) bindings
in (Logic.ifElse (Lists.null candidates) (bindings, body) (
let targets = Sets.fromList (Lists.map Core.bindingName candidates)
wrapCandidate =
\b -> Logic.ifElse (letBindingIsThunkCandidate b) (Core.Binding {
Core.bindingName = (Core.bindingName b),
Core.bindingTerm = (Core.TermLambda (Core.Lambda {
Core.lambdaParameter = (Core.Name "_"),
Core.lambdaDomain = Nothing,
Core.lambdaBody = (forceLazyRefs targets (Core.bindingTerm b))})),
Core.bindingTypeScheme = (Core.bindingTypeScheme b)}) (Core.Binding {
Core.bindingName = (Core.bindingName b),
Core.bindingTerm = (forceLazyRefs targets (Core.bindingTerm b)),
Core.bindingTypeScheme = (Core.bindingTypeScheme b)})
in (Lists.map wrapCandidate bindings, (forceLazyRefs targets body))))
-- | Thunk every let-binding for which letBindingIsThunkCandidate holds, and rewrite forced references to it accordingly
thunkLazyLet :: Core.Let -> Core.Let
thunkLazyLet lt =
let result = thunkLazyBindings (Core.letBindings lt) (Core.letBody lt)
in Core.Let {
Core.letBindings = (Pairs.first result),
Core.letBody = (Pairs.second result)}
-- | An array expression: [e1, e2, ...]
tsArray :: [Syntax.Expression] -> Syntax.Expression
tsArray elems = Syntax.ExpressionArray (Lists.map (\e -> Syntax.ArrayElementExpression e) elems)
-- | An untyped arrow function with an expression body
tsArrow :: [String] -> Syntax.Expression -> Syntax.Expression
tsArrow params body =
Syntax.ExpressionArrow (Syntax.ArrowFunctionExpression {
Syntax.arrowFunctionExpressionParams = (Lists.map (\p -> Syntax.PatternIdentifier (tsIdent p)) params),
Syntax.arrowFunctionExpressionBody = (Syntax.ArrowFunctionBodyExpression body),
Syntax.arrowFunctionExpressionAsync = False})
-- | A typed arrow function with typed parameter patterns
tsArrowTyped :: [Syntax.Pattern] -> Syntax.Expression -> Syntax.Expression
tsArrowTyped patterns body =
Syntax.ExpressionArrow (Syntax.ArrowFunctionExpression {
Syntax.arrowFunctionExpressionParams = patterns,
Syntax.arrowFunctionExpressionBody = (Syntax.ArrowFunctionBodyExpression body),
Syntax.arrowFunctionExpressionAsync = False})
-- | Wrap an expression in a TypeScript 'as any' cast
tsAsAny :: Syntax.Expression -> Syntax.Expression
tsAsAny e =
Syntax.ExpressionAsExpression (Syntax.AsExpression {
Syntax.asExpressionExpression = e,
Syntax.asExpressionType = Syntax.TypeExpressionAny})
-- | A call expression, parenthesizing the callee when it's an arrow function or other ambiguous call target
tsCall :: Syntax.Expression -> [Syntax.Expression] -> Syntax.Expression
tsCall callee args =
Syntax.ExpressionCall (Syntax.CallExpression {
Syntax.callExpressionCallee = callee,
Syntax.callExpressionArguments = args,
Syntax.callExpressionOptional = False})
-- | A conditional (ternary) expression
tsCond :: Syntax.Expression -> Syntax.Expression -> Syntax.Expression -> Syntax.Expression
tsCond test cons alt =
Syntax.ExpressionConditional (Syntax.ConditionalExpression {
Syntax.conditionalExpressionTest = test,
Syntax.conditionalExpressionConsequent = cons,
Syntax.conditionalExpressionAlternate = alt})
-- | Render a 'EntityReference' as TSDoc link syntax
tsDocEntityRef :: Packaging.EntityReference -> String
tsDocEntityRef x =
case x of
Packaging.EntityReferenceDefinition v0 -> Strings.concat2 "{@link " (Strings.concat2 (case v0 of
Packaging.DefinitionReferencePrimitive v1 -> Names.localNameOf v1
Packaging.DefinitionReferenceTerm v1 -> Names.localNameOf v1
Packaging.DefinitionReferenceType v1 -> Names.localNameOf v1) "}")
Packaging.EntityReferenceModule v0 -> Packaging.unModuleName v0
Packaging.EntityReferencePackage v0 -> Packaging.unPackageName v0
Packaging.EntityReferenceTermExpr v0 -> Strings.concat2 "`" (Strings.concat2 v0 "`")
Packaging.EntityReferenceTypeExpr v0 -> Strings.concat2 "`" (Strings.concat2 v0 "`")
-- | Identity getter for analyzeFunctionTerm when the environment is a Graph
tsEnvGetGraph :: t0 -> t0
tsEnvGetGraph g = g
-- | Setter for analyzeFunctionTerm when the environment is a Graph
tsEnvSetGraph :: t0 -> t1 -> t0
tsEnvSetGraph newG _old = newG
-- | Escape a Hydra string for embedding as a double-quoted TypeScript string literal
tsEscapeString :: String -> String
tsEscapeString s =
let escapeChar =
\c -> Logic.ifElse (Equality.equal c 34) "\\\"" (Logic.ifElse (Equality.equal c 92) "\\\\" (Logic.ifElse (Equality.equal c 10) "\\n" (Logic.ifElse (Equality.equal c 13) "\\r" (Logic.ifElse (Equality.equal c 9) "\\t" (Logic.ifElse (Equality.equal c 8) "\\b" (Logic.ifElse (Equality.equal c 12) "\\f" (Strings.fromList (Lists.pure c))))))))
in (Strings.concat [
"\"",
(Strings.concat (Lists.map escapeChar (Strings.toList s))),
"\""])
-- | A bare identifier expression
tsExprIdent :: String -> Syntax.Expression
tsExprIdent s = Syntax.ExpressionIdentifier (tsIdent s)
-- | A string-literal expression
tsExprStr :: String -> Syntax.Expression
tsExprStr s =
Syntax.ExpressionLiteral (Syntax.LiteralString (Syntax.StringLiteral {
Syntax.stringLiteralValue = s,
Syntax.stringLiteralSingleQuote = False}))
-- | Wrap a string into a TypeScript identifier
tsIdent :: String -> Syntax.Identifier
tsIdent s = Syntax.Identifier s
-- | A member-access expression: obj.prop
tsMember :: Syntax.Expression -> String -> Syntax.Expression
tsMember obj prop =
Syntax.ExpressionMember (Syntax.MemberExpression {
Syntax.memberExpressionObject = obj,
Syntax.memberExpressionProperty = (tsExprIdent prop),
Syntax.memberExpressionComputed = False,
Syntax.memberExpressionOptional = False})
-- | A bare named type reference
tsNamedType :: String -> Syntax.TypeExpression
tsNamedType n = Syntax.TypeExpressionIdentifier (tsIdent n)
-- | A new-expression: new C(args)
tsNew :: Syntax.Expression -> [Syntax.Expression] -> Syntax.Expression
tsNew callee args =
Syntax.ExpressionNew (Syntax.CallExpression {
Syntax.callExpressionCallee = callee,
Syntax.callExpressionArguments = args,
Syntax.callExpressionOptional = False})
-- | An object literal with identifier-style keys
tsObject :: [(String, Syntax.Expression)] -> Syntax.Expression
tsObject props =
Syntax.ExpressionObject (Lists.map (\kv ->
let k = Pairs.first kv
v = Pairs.second kv
in Syntax.Property {
Syntax.propertyKey = (tsExprIdent k),
Syntax.propertyValue = v,
Syntax.propertyKind = Syntax.PropertyKindInit,
Syntax.propertyComputed = False,
Syntax.propertyShorthand = False}) props)
-- | A generic type parameter with no constraint
tsParam :: String -> Syntax.TypeParameter
tsParam n =
Syntax.TypeParameter {
Syntax.typeParameterName = (tsIdent n),
Syntax.typeParameterConstraint = Nothing,
Syntax.typeParameterDefault = Nothing}
-- | A parameterized type with one type argument
tsParamApp1 :: String -> Syntax.TypeExpression -> Syntax.TypeExpression
tsParamApp1 n arg =
Syntax.TypeExpressionParameterized (Syntax.ParameterizedTypeExpression {
Syntax.parameterizedTypeExpressionBase = (tsNamedType n),
Syntax.parameterizedTypeExpressionArguments = [
arg]})
-- | A parameterized type with two type arguments
tsParamApp2 :: String -> Syntax.TypeExpression -> Syntax.TypeExpression -> Syntax.TypeExpression
tsParamApp2 n a b =
Syntax.TypeExpressionParameterized (Syntax.ParameterizedTypeExpression {
Syntax.parameterizedTypeExpressionBase = (tsNamedType n),
Syntax.parameterizedTypeExpressionArguments = [
a,
b]})
-- | Wrap an expression in parentheses when its serialized form needs grouping
tsParen :: Syntax.Expression -> Syntax.Expression
tsParen e = Syntax.ExpressionParenthesized e
-- | A readonly property signature, with the name sanitized for TS reserved words
tsPropSig :: String -> Bool -> Syntax.TypeExpression -> Syntax.PropertySignature
tsPropSig name optional typ = tsPropSigWithDoc name optional typ Nothing
-- | A readonly property signature with an optional JSDoc comment above the property line
tsPropSigWithDoc :: String -> Bool -> Syntax.TypeExpression -> Maybe Syntax.DocumentationComment -> Syntax.PropertySignature
tsPropSigWithDoc name optional typ mcomments =
let safe = Formatting.sanitizeWithUnderscores Language.typeScriptReservedWords name
in Syntax.PropertySignature {
Syntax.propertySignatureName = (tsIdent safe),
Syntax.propertySignatureType = typ,
Syntax.propertySignatureOptional = optional,
Syntax.propertySignatureReadonly = True,
Syntax.propertySignatureComments = mcomments}
-- | A ReadonlyMap type with the given key and value types
tsReadonlyMap :: Syntax.TypeExpression -> Syntax.TypeExpression -> Syntax.TypeExpression
tsReadonlyMap k v = tsParamApp2 "ReadonlyMap" k v
-- | A ReadonlySet type with the given element type
tsReadonlySet :: Syntax.TypeExpression -> Syntax.TypeExpression
tsReadonlySet t = tsParamApp1 "ReadonlySet" t
-- | A tuple type
tsTuple :: [Syntax.TypeExpression] -> Syntax.TypeExpression
tsTuple ts = Syntax.TypeExpressionTuple ts
-- | A typed-identifier pattern for a function parameter with a known domain type
tsTypedIdent :: String -> Syntax.TypeExpression -> Syntax.Pattern
tsTypedIdent name typ =
Syntax.PatternTyped (Syntax.TypedPattern {
Syntax.typedPatternPattern = (Syntax.PatternIdentifier (tsIdent name)),
Syntax.typedPatternType = typ})
-- | The undefined value as an expression
tsUndefined :: Syntax.Expression
tsUndefined = tsExprIdent "undefined"