hydra-typescript-0.17.1: 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.Query as Query
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.Show.Docs as ShowDocs
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
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)
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)
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)
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.binaryToString 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
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"
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)
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.cat2 "$mod_" (Strings.intercalate "_" 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.cat2 "_" (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.fromOptional (tsExprIdent "undefined") (Lists.maybeHead 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.fromOptional (tsExprIdent "undefined") (Lists.maybeHead 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"
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)
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.cat2 "$type_" (Strings.intercalate "_" nsSegs)
in (Right (tsNamedType (Strings.cat [
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))
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}))))))
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)
filterNonLocalNames :: Packaging.ModuleName -> S.Set Core.Name -> S.Set Core.Name
filterNonLocalNames currentNs names =
Sets.fromList (Optionals.cat (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)))
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, [])
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
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}
importsToText :: String -> Packaging.ModuleName -> S.Set Core.Name -> String
importsToText kind currentNs names =
let pairs =
Optionals.cat (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.fromOptional [] (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.fromOptional "" (Lists.maybeHead currentSegs)) "test")
baseUpPrefix = Logic.ifElse (Equality.equal currentDepth 1) "./" (Strings.cat (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.fromOptional "" (Lists.maybeHead targetSegs)) "test")
targetPathSegs =
Logic.ifElse (Logic.and (Equality.equal (Optionals.fromOptional "" (Lists.maybeHead targetSegs)) "lib") (Logic.not (Equality.equal (Packaging.unModuleName ns) "hydra.lib.defaults"))) (Lists.concat2 [
"overlay",
"typescript"] targetSegs) targetSegs
targetPath = Strings.intercalate "/" targetPathSegs
upPrefix =
Logic.ifElse (Logic.and currentIsTest (Logic.not targetIsTest)) (Strings.cat2 baseUpPrefix "../../../main/typescript/hydra/") baseUpPrefix
nsSlug = Strings.intercalate "_" targetSegs
moduleAlias = Logic.ifElse (Equality.equal kind "type") (Strings.cat2 "$type_" nsSlug) (Strings.cat2 "$mod_" nsSlug)
in (Strings.cat [
importKeyword,
" * as ",
moduleAlias,
" from \"",
upPrefix,
targetPath,
".js\";\n"])) (Maps.toList grouped)
in (Strings.cat lines)
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))))
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)
mkDocComment :: Maybe String -> Maybe Syntax.DocumentationComment
mkDocComment mdesc =
Optionals.cases mdesc Nothing (\d -> Logic.ifElse (Equality.equal d "") Nothing (Just (Syntax.DocumentationComment {
Syntax.documentationCommentDescription = (ShowDocs.renderDocStringWith tsDocEntityRef d),
Syntax.documentationCommentTags = []})))
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.cat2 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.cat2 (Serde.toTypeScriptComments d []) "\n\n")
header = Strings.cat2 "// 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.cat [
Serde.toTypeScriptComments d [],
"\n",
itemText]))
body = Strings.intercalate "\n\n" (Lists.map renderItem allItems)
filePath = Names.moduleNameToFilePath Util.CaseConventionCamel (File.FileExtension "ts") (Packaging.moduleName mod)
in (Right (Maps.singleton filePath (Strings.cat [
header,
importsBlock,
(Logic.ifElse (Equality.equal importsBlock "") "" "\n"),
body,
(Logic.ifElse (Equality.equal body "") "" "\n")])))))
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.cat2 " extends " (Strings.intercalate ", " (Lists.map printTypeExpression exts)))
members = Syntax.interfaceDeclarationMembers decl
renderMember = \ps -> Strings.intercalate "\n " (Strings.lines (printPropertySignature ps))
body =
Logic.ifElse (Lists.null members) "" (Strings.cat [
"\n ",
(Strings.intercalate ";\n " (Lists.map renderMember members)),
";\n"])
in (Strings.cat [
"export interface ",
name,
params,
extClause,
" {",
body,
"}\n"])
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"
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)
_ -> ""
printPropertySignature :: Syntax.PropertySignature -> String
printPropertySignature ps =
let mcomments = Syntax.propertySignatureComments ps
line =
Strings.cat [
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.cat [
Serde.toTypeScriptComments (Syntax.documentationCommentDescription dc) (Syntax.documentationCommentTags dc),
"\n",
line]))
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.cat [
"export type ",
name,
params,
" = ",
rhs,
";\n"])
printTypeExpression :: Syntax.TypeExpression -> String
printTypeExpression t =
case t of
Syntax.TypeExpressionIdentifier v0 -> Syntax.unIdentifier v0
Syntax.TypeExpressionLiteral v0 -> printLiteral v0
Syntax.TypeExpressionArray v0 -> Strings.cat [
"ReadonlyArray<",
(printTypeExpression (Syntax.unArrayTypeExpression v0)),
">"]
Syntax.TypeExpressionTuple v0 -> Strings.cat [
"readonly [",
(Strings.intercalate ", " (Lists.map printTypeExpression v0)),
"]"]
Syntax.TypeExpressionUnion v0 -> Strings.intercalate " | " (Lists.map printTypeExpression v0)
Syntax.TypeExpressionIntersection v0 -> Strings.intercalate " & " (Lists.map printTypeExpression v0)
Syntax.TypeExpressionParameterized v0 -> Strings.cat [
printTypeExpression (Syntax.parameterizedTypeExpressionBase v0),
"<",
(Strings.intercalate ", " (Lists.map printTypeExpression (Syntax.parameterizedTypeExpressionArguments v0))),
">"]
Syntax.TypeExpressionOptional v0 -> Strings.cat [
printTypeExpression v0,
" | undefined"]
Syntax.TypeExpressionReadonly v0 -> Strings.cat2 "readonly " (printTypeExpression v0)
Syntax.TypeExpressionObject v0 -> Strings.cat [
"{ ",
(Strings.intercalate "; " (Lists.map printPropertySignature v0)),
" }"]
Syntax.TypeExpressionFunction _ -> "((...args: any[]) => any)"
Syntax.TypeExpressionAny -> "any"
Syntax.TypeExpressionUnknown -> "unknown"
Syntax.TypeExpressionVoid -> "void"
Syntax.TypeExpressionNever -> "never"
_ -> "unknown"
printTypeParameter :: Syntax.TypeParameter -> String
printTypeParameter tp =
let name = Syntax.unIdentifier (Syntax.typeParameterName tp)
constraint = Syntax.typeParameterConstraint tp
in (Optionals.cases constraint name (\c -> Strings.cat [
name,
" extends ",
(printTypeExpression c)]))
printTypeParameterList :: [Syntax.TypeParameter] -> String
printTypeParameterList tps =
Logic.ifElse (Lists.null tps) "" (Strings.cat [
"<",
(Strings.intercalate ", " (Lists.map printTypeParameter tps)),
">"])
sanitizeParamName :: Core.Name -> String
sanitizeParamName n = Formatting.sanitizeWithUnderscores Language.typeScriptReservedWords (Names.localNameOf n)
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.cat (Lists.map (\n -> Maps.lookup n byName) (Lists.concat sccs)))
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 = Variables.freeVariablesInTerm tterm
deps = Lists.filter (\n -> Maps.member n byName) (Sets.toList freeVars)
in (tname, deps)) tdefs
sccs = Sorting.topologicalSortComponents adjacency
in (Optionals.cat (Lists.map (\n -> Maps.lookup n byName) (Lists.concat sccs)))
stripForalls :: Core.Type -> Core.Type
stripForalls t =
let dt = Strip.deannotateType t
in case dt of
Core.TypeForall v0 -> stripForalls (Core.forallTypeBody v0)
_ -> dt
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
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))))
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)}
tsArray :: [Syntax.Expression] -> Syntax.Expression
tsArray elems = Syntax.ExpressionArray (Lists.map (\e -> Syntax.ArrayElementExpression e) elems)
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})
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})
tsAsAny :: Syntax.Expression -> Syntax.Expression
tsAsAny e =
Syntax.ExpressionAsExpression (Syntax.AsExpression {
Syntax.asExpressionExpression = e,
Syntax.asExpressionType = Syntax.TypeExpressionAny})
tsCall :: Syntax.Expression -> [Syntax.Expression] -> Syntax.Expression
tsCall callee args =
Syntax.ExpressionCall (Syntax.CallExpression {
Syntax.callExpressionCallee = callee,
Syntax.callExpressionArguments = args,
Syntax.callExpressionOptional = False})
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.cat2 "{@link " (Strings.cat2 (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.cat2 "`" (Strings.cat2 v0 "`")
Packaging.EntityReferenceTypeExpr v0 -> Strings.cat2 "`" (Strings.cat2 v0 "`")
tsEnvGetGraph :: t0 -> t0
tsEnvGetGraph g = g
tsEnvSetGraph :: t0 -> t1 -> t0
tsEnvSetGraph newG _old = newG
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.cat [
"\"",
(Strings.cat (Lists.map escapeChar (Strings.toList s))),
"\""])
tsExprIdent :: String -> Syntax.Expression
tsExprIdent s = Syntax.ExpressionIdentifier (tsIdent s)
tsExprStr :: String -> Syntax.Expression
tsExprStr s =
Syntax.ExpressionLiteral (Syntax.LiteralString (Syntax.StringLiteral {
Syntax.stringLiteralValue = s,
Syntax.stringLiteralSingleQuote = False}))
tsIdent :: String -> Syntax.Identifier
tsIdent s = Syntax.Identifier s
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})
tsNamedType :: String -> Syntax.TypeExpression
tsNamedType n = Syntax.TypeExpressionIdentifier (tsIdent n)
tsNew :: Syntax.Expression -> [Syntax.Expression] -> Syntax.Expression
tsNew callee args =
Syntax.ExpressionNew (Syntax.CallExpression {
Syntax.callExpressionCallee = callee,
Syntax.callExpressionArguments = args,
Syntax.callExpressionOptional = False})
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)
tsParam :: String -> Syntax.TypeParameter
tsParam n =
Syntax.TypeParameter {
Syntax.typeParameterName = (tsIdent n),
Syntax.typeParameterConstraint = Nothing,
Syntax.typeParameterDefault = Nothing}
tsParamApp1 :: String -> Syntax.TypeExpression -> Syntax.TypeExpression
tsParamApp1 n arg =
Syntax.TypeExpressionParameterized (Syntax.ParameterizedTypeExpression {
Syntax.parameterizedTypeExpressionBase = (tsNamedType n),
Syntax.parameterizedTypeExpressionArguments = [
arg]})
tsParamApp2 :: String -> Syntax.TypeExpression -> Syntax.TypeExpression -> Syntax.TypeExpression
tsParamApp2 n a b =
Syntax.TypeExpressionParameterized (Syntax.ParameterizedTypeExpression {
Syntax.parameterizedTypeExpressionBase = (tsNamedType n),
Syntax.parameterizedTypeExpressionArguments = [
a,
b]})
tsParen :: Syntax.Expression -> Syntax.Expression
tsParen e = Syntax.ExpressionParenthesized e
tsPropSig :: String -> Bool -> Syntax.TypeExpression -> Syntax.PropertySignature
tsPropSig name optional typ = tsPropSigWithDoc name optional typ Nothing
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}
tsReadonlyMap :: Syntax.TypeExpression -> Syntax.TypeExpression -> Syntax.TypeExpression
tsReadonlyMap k v = tsParamApp2 "ReadonlyMap" k v
tsReadonlySet :: Syntax.TypeExpression -> Syntax.TypeExpression
tsReadonlySet t = tsParamApp1 "ReadonlySet" t
tsTuple :: [Syntax.TypeExpression] -> Syntax.TypeExpression
tsTuple ts = Syntax.TypeExpressionTuple ts
tsTypedIdent :: String -> Syntax.TypeExpression -> Syntax.Pattern
tsTypedIdent name typ =
Syntax.PatternTyped (Syntax.TypedPattern {
Syntax.typedPatternPattern = (Syntax.PatternIdentifier (tsIdent name)),
Syntax.typedPatternType = typ})
tsUndefined :: Syntax.Expression
tsUndefined = tsExprIdent "undefined"