gotyno-hs-1.0.0: src/CodeGeneration/TypeScript.hs
module CodeGeneration.TypeScript (outputModule) where
import CodeGeneration.Utilities (upperCaseFirstCharacter)
import RIO
import qualified RIO.Text as Text
import Types
outputModule :: Module -> Text
outputModule Module {definitions, imports, declarationNames} =
let definitionOutput = definitions & mapMaybe outputDefinition & Text.intercalate "\n\n"
importsOutput = imports & fmap outputImport & mconcat
outputImport (Import Module {name = ModuleName name}) =
mconcat ["import * as ", name, " from \"./", name, "\";\n\n"]
declarationImportOutput =
declarationNames
& fmap
( \(ModuleName name) ->
mconcat ["import * as ", name, " from \"./", name, "\";"]
)
& Text.intercalate "\n"
in mconcat
[ modulePrelude,
"\n\n",
importsOutput,
declarationImportOutput,
if null declarationNames then "" else "\n\n",
definitionOutput
]
modulePrelude :: Text
modulePrelude = "import * as svt from \"simple-validation-tools\";"
outputDefinition :: TypeDefinition -> Maybe Text
outputDefinition (TypeDefinition (DefinitionName name) (Struct (PlainStruct fields))) =
pure $ outputPlainStruct name fields
outputDefinition (TypeDefinition (DefinitionName name) (Struct (GenericStruct typeVariables fields))) =
pure $ outputGenericStruct name typeVariables fields
outputDefinition (TypeDefinition (DefinitionName name) (Union typeTag unionType)) =
pure $ outputUnion name typeTag unionType
outputDefinition (TypeDefinition (DefinitionName name) (Enumeration enumerationValues)) =
pure $ outputEnumeration name enumerationValues
outputDefinition (TypeDefinition (DefinitionName name) (UntaggedUnion unionCases)) =
pure $ outputUntaggedUnion name unionCases
outputDefinition (TypeDefinition (DefinitionName name) (EmbeddedUnion typeTag constructors)) =
pure $ outputEmbeddedUnion name typeTag constructors
outputDefinition
( TypeDefinition
(DefinitionName _name)
(DeclaredType _moduleName _typeVariables)
) =
Nothing
outputEmbeddedUnion :: Text -> FieldName -> [EmbeddedConstructor] -> Text
outputEmbeddedUnion unionName typeTag constructors =
let typeOutput =
outputCaseUnion
unionName
constructorsAsConstructors
[]
constructorsAsConstructors = embeddedConstructorsToConstructors constructors
tagEnumerationOutput = outputUnionTagEnumeration unionName constructorsAsConstructors
constructorTypesOutput = outputEmbeddedConstructorTypes unionName typeTag constructors
caseConstructorsOutput = outputEmbeddedCaseConstructors unionName typeTag constructors
unionTypeGuardOutput = outputUnionTypeGuard typeTag [] unionName constructorsAsConstructors
caseTypeGuardOutput = outputEmbeddedCaseTypeGuards typeTag unionName constructors
unionValidatorOutput = outputUnionValidator [] typeTag unionName constructorsAsConstructors
caseValidatorOutput = outputEmbeddedCaseValidators typeTag unionName constructors
in Text.intercalate
"\n\n"
[ typeOutput,
tagEnumerationOutput,
constructorTypesOutput,
caseConstructorsOutput,
unionTypeGuardOutput,
caseTypeGuardOutput,
unionValidatorOutput,
caseValidatorOutput
]
outputEmbeddedCaseTypeGuards :: FieldName -> Text -> [EmbeddedConstructor] -> Text
outputEmbeddedCaseTypeGuards typeTag unionName =
fmap (outputEmbeddedCaseTypeGuard typeTag unionName)
>>> Text.intercalate "\n\n"
outputEmbeddedCaseTypeGuard :: FieldName -> Text -> EmbeddedConstructor -> Text
outputEmbeddedCaseTypeGuard
(FieldName tag)
unionName
(EmbeddedConstructor (ConstructorName name) Nothing) =
let tagName = unionEnumConstructorTag unionName name
interface = mconcat ["{", tag, ": ", tagName, "}"]
constructorName = upperCaseFirstCharacter name
in mconcat
[ mconcat
[ "export function is",
constructorName,
"(value: unknown): value is ",
constructorName,
" {\n"
],
mconcat [" return svt.isInterface<", constructorName, ">(value, ", interface, ");\n"],
"}"
]
outputEmbeddedCaseTypeGuard
(FieldName tag)
unionName
(EmbeddedConstructor (ConstructorName name) (Just reference)) =
let fields = structFieldsFromReference reference
tagName = unionEnumConstructorTag unionName name
interface = mconcat ["{", tag, ": ", tagName, ", ", fieldTypeGuards, "}"]
fieldTypeGuards = fields & fmap outputStructTypeGuardForField & Text.intercalate ", "
constructorName = upperCaseFirstCharacter name
in mconcat
[ mconcat
[ "export function is",
constructorName,
"(value: unknown): value is ",
constructorName,
" {\n"
],
mconcat [" return svt.isInterface<", constructorName, ">(value, ", interface, ");\n"],
"}"
]
outputEmbeddedCaseValidators :: FieldName -> Text -> [EmbeddedConstructor] -> Text
outputEmbeddedCaseValidators typeTag unionName =
fmap (outputEmbeddedCaseValidator typeTag unionName)
>>> Text.intercalate "\n\n"
outputEmbeddedCaseValidator :: FieldName -> Text -> EmbeddedConstructor -> Text
outputEmbeddedCaseValidator
(FieldName tag)
unionName
(EmbeddedConstructor (ConstructorName name) Nothing) =
let tagName = unionEnumConstructorTag unionName name
interface = mconcat ["{", tag, ": ", tagName, "}"]
constructorName = upperCaseFirstCharacter name
in mconcat
[ mconcat
[ "export function validate",
constructorName,
"(value: unknown): svt.ValidationResult<",
constructorName,
"> {\n"
],
mconcat [" return svt.validate<", constructorName, ">(value, ", interface, ");\n"],
"}"
]
outputEmbeddedCaseValidator
(FieldName tag)
unionName
(EmbeddedConstructor (ConstructorName name) (Just reference)) =
let fields = structFieldsFromReference reference
tagName = unionEnumConstructorTag unionName name
interface = mconcat ["{", tag, ": ", tagName, ", ", fieldValidators, "}"]
fieldValidators = fields & fmap outputValidatorForField & Text.intercalate ", "
constructorName = upperCaseFirstCharacter name
in mconcat
[ mconcat
[ "export function validate",
constructorName,
"(value: unknown): svt.ValidationResult<",
constructorName,
"> {\n"
],
mconcat [" return svt.validate<", constructorName, ">(value, ", interface, ");\n"],
"}"
]
outputEmbeddedConstructorTypes :: Text -> FieldName -> [EmbeddedConstructor] -> Text
outputEmbeddedConstructorTypes unionName fieldName constructors =
constructors & fmap (outputEmbeddedConstructorType unionName fieldName) & Text.intercalate "\n\n"
outputEmbeddedConstructorType :: Text -> FieldName -> EmbeddedConstructor -> Text
outputEmbeddedConstructorType
unionName
(FieldName tag)
(EmbeddedConstructor (ConstructorName name) Nothing) =
let tagFieldOutput = mconcat [" ", tag, ": ", tagValue, ";"]
tagValue = unionEnumConstructorTag unionName name
in mconcat
[ mconcat ["export type ", upperCaseFirstCharacter name, " = {\n"],
mconcat [tagFieldOutput, "\n"],
"};"
]
outputEmbeddedConstructorType
unionName
(FieldName tag)
(EmbeddedConstructor (ConstructorName name) (Just fields)) =
let fieldsOutput = fields & structFieldsFromReference & fmap outputField & Text.intercalate ""
tagFieldOutput = mconcat [" ", tag, ": ", tagValue, ";"]
tagValue = unionEnumConstructorTag unionName name
in mconcat
[ mconcat ["export type ", upperCaseFirstCharacter name, " = {\n"],
mconcat [tagFieldOutput, "\n"],
fieldsOutput,
"};"
]
outputEmbeddedCaseConstructors :: Text -> FieldName -> [EmbeddedConstructor] -> Text
outputEmbeddedCaseConstructors unionName typeTag =
fmap (outputEmbeddedCaseConstructor unionName typeTag)
>>> Text.intercalate "\n\n"
outputEmbeddedCaseConstructor :: Text -> FieldName -> EmbeddedConstructor -> Text
outputEmbeddedCaseConstructor
unionName
(FieldName tag)
(EmbeddedConstructor (ConstructorName name) Nothing) =
let constructorName = upperCaseFirstCharacter name
in mconcat
[ mconcat
[ "export function ",
constructorName,
"(): ",
constructorName,
" {\n"
],
mconcat
[ " return {",
tag,
": ",
unionEnumConstructorTag unionName name,
"};\n"
],
"}"
]
outputEmbeddedCaseConstructor
unionName
(FieldName tag)
(EmbeddedConstructor (ConstructorName name) (Just definitionReference)) =
let constructorName = upperCaseFirstCharacter name
in mconcat
[ mconcat
[ "export function ",
constructorName,
"(data: ",
outputDefinitionReference definitionReference,
"): ",
constructorName,
" {\n"
],
mconcat
[ " return {",
tag,
": ",
unionEnumConstructorTag unionName name,
", ...data};\n"
],
"}"
]
structFieldsFromReference :: DefinitionReference -> [StructField]
structFieldsFromReference
(DefinitionReference (TypeDefinition _name (Struct (PlainStruct fields)))) = fields
structFieldsFromReference _other = error "struct fields from anything other than plain struct"
embeddedConstructorsToConstructors :: [EmbeddedConstructor] -> [Constructor]
embeddedConstructorsToConstructors = fmap embeddedConstructorToConstructor
embeddedConstructorToConstructor :: EmbeddedConstructor -> Constructor
embeddedConstructorToConstructor (EmbeddedConstructor name reference) =
Constructor name (DefinitionReferenceType <$> reference)
outputUntaggedUnion :: Text -> [FieldType] -> Text
outputUntaggedUnion unionName cases =
let typeOutput = mconcat ["export type ", unionName, " = ", unionOutput, ";"]
unionOutput = cases & fmap outputFieldType & Text.intercalate " | "
typeGuardOutput = outputUntaggedUnionTypeGuard unionName cases
validatorOutput = outputUntaggedUnionValidator unionName cases
in Text.intercalate "\n\n" [typeOutput, typeGuardOutput, validatorOutput]
outputUntaggedUnionTypeGuard :: Text -> [FieldType] -> Text
outputUntaggedUnionTypeGuard name cases =
let typeGuards = cases & fmap outputTypeGuardForFieldType & Text.intercalate ", "
in mconcat
[ mconcat ["export function is", name, "(value: unknown): value is ", name, " {\n"],
mconcat [" return [", typeGuards, "].some((typePredicate) => typePredicate(value));\n"],
"}"
]
outputUntaggedUnionValidator :: Text -> [FieldType] -> Text
outputUntaggedUnionValidator name cases =
let validators = cases & fmap outputValidatorForFieldType & Text.intercalate ", "
in mconcat
[ mconcat
[ "export function validate",
name,
"(value: unknown): svt.ValidationResult<",
name,
"> {\n"
],
mconcat [" return svt.validateOneOf<", name, ">(value, [", validators, "]);\n"],
"}"
]
outputEnumeration :: Text -> [EnumerationValue] -> Text
outputEnumeration name values =
let typeOutput = outputEnumerationType name values
typeGuardOutput = outputEnumerationTypeGuard name values
validatorOutput = outputEnumerationValidator name values
in mconcat [typeOutput, "\n\n", typeGuardOutput, "\n\n", validatorOutput]
outputEnumerationType :: Text -> [EnumerationValue] -> Text
outputEnumerationType name values =
let valuesOutput =
values
& fmap
( \(EnumerationValue (EnumerationIdentifier i) literal) ->
mconcat [" ", i, " = ", outputLiteral literal, ",\n"]
)
& mconcat
outputLiteral (LiteralString s) = mconcat ["\"", s, "\""]
outputLiteral (LiteralInteger i) = tshow i
outputLiteral (LiteralFloat f) = tshow f
outputLiteral (LiteralBoolean b) = bool "false" "true" b
in mconcat
[ mconcat ["export enum ", name, " {\n"],
valuesOutput,
"}"
]
outputEnumerationFunction ::
FunctionPrefix ->
ReturnType ->
(Text -> [EnumerationValue] -> Text) ->
Text ->
[EnumerationValue] ->
Text
outputEnumerationFunction
(FunctionPrefix prefix)
(ReturnType returnType)
returnExpression
name
values =
mconcat
[ mconcat ["export function ", prefix, name, "(value: unknown): ", returnType name, " {\n"],
mconcat [" return ", returnExpression name values, ";\n"],
"}"
]
outputEnumerationTypeGuard :: Text -> [EnumerationValue] -> Text
outputEnumerationTypeGuard =
let returnExpression name values =
let valuesOutput =
values
& fmap (\(EnumerationValue (EnumerationIdentifier i) _value) -> name <> "." <> i)
& Text.intercalate ", "
in mconcat ["[", valuesOutput, "].some((v) => v === value)"]
returnType name = "value is " <> name
in outputEnumerationFunction (FunctionPrefix "is") (ReturnType returnType) returnExpression
outputEnumerationValidator :: Text -> [EnumerationValue] -> Text
outputEnumerationValidator =
let returnExpression name values =
let valuesOutput =
values
& fmap (\(EnumerationValue (EnumerationIdentifier i) _value) -> name <> "." <> i)
& Text.intercalate ", "
in mconcat ["svt.validateOneOfLiterals<", name, ">(value, ", "[", valuesOutput, "])"]
returnType name = "svt.ValidationResult<" <> name <> ">"
in outputEnumerationFunction (FunctionPrefix "validate") (ReturnType returnType) returnExpression
outputPlainStruct :: Text -> [StructField] -> Text
outputPlainStruct name fields =
let export = mconcat ["export type ", name, " = {\n"]
fieldsOutput = fields & fmap outputField & mconcat
typeGuardOutput = outputStructTypeGuard name fields []
validatorOutput = outputStructValidator name fields []
in mconcat [export, fieldsOutput, "};\n\n", typeGuardOutput, "\n\n", validatorOutput]
outputGenericStruct :: Text -> [TypeVariable] -> [StructField] -> Text
outputGenericStruct name typeVariables fields =
let fullName = name <> joinTypeVariables typeVariables
typeOutput =
mconcat
[ mconcat ["export type ", fullName, " = {\n"],
fieldsOutput,
"};"
]
fieldsOutput = fields & fmap outputField & mconcat
typeGuardOutput = outputStructTypeGuard name fields typeVariables
validatorOutput = outputStructValidator name fields typeVariables
in mconcat [typeOutput, "\n\n", typeGuardOutput, "\n\n", validatorOutput]
outputStructValidator :: Text -> [StructField] -> [TypeVariable] -> Text
outputStructValidator name fields typeVariables =
let interface =
"{" <> (fields & fmap outputValidatorForField & Text.intercalate ", ") <> "}"
in if null typeVariables
then
mconcat
[ mconcat
[ mconcat
[ "export function validate",
name,
"(value: unknown): svt.ValidationResult<",
name,
"> {\n"
],
mconcat [" return svt.validate<", name, ">(value, ", interface, ");\n"]
],
"}"
]
else
let fullName = name <> joinTypeVariables typeVariables
returnedFunctionName =
("validate" <> fullName) & Text.filter ((`elem` ("<>, " :: String)) >>> not)
in mconcat
[ mconcat
[ "export function validate",
fullName,
"(",
typeVariableValidatorParameters typeVariables,
"): svt.Validator<",
fullName,
"> {\n"
],
mconcat
[ " return function ",
returnedFunctionName,
"(value: unknown): svt.ValidationResult<",
fullName,
"> {\n"
],
mconcat
[ " return svt.validate<",
fullName,
">(value, ",
interface,
");\n"
],
" };\n",
"}"
]
outputValidatorForField :: StructField -> Text
outputValidatorForField (StructField (FieldName fieldName) fieldType) =
mconcat [fieldName, ": ", outputValidatorForFieldType fieldType]
outputValidatorForFieldType :: FieldType -> Text
outputValidatorForFieldType (LiteralType (LiteralString text)) = mconcat ["\"", text, "\""]
outputValidatorForFieldType (LiteralType (LiteralInteger x)) = tshow x
outputValidatorForFieldType (LiteralType (LiteralFloat f)) = tshow f
outputValidatorForFieldType (LiteralType (LiteralBoolean b)) = bool "false" "true" b
outputValidatorForFieldType (BasicType basicType) = outputValidatorForBasicType basicType
outputValidatorForFieldType (ComplexType complexType) = outputValidatorForComplexType complexType
outputValidatorForFieldType (DefinitionReferenceType definitionReference) =
outputValidatorForDefinitionReference definitionReference
outputValidatorForFieldType (RecursiveReferenceType (DefinitionName name)) = "validate" <> name
outputValidatorForFieldType (TypeVariableReferenceType (TypeVariable name)) = "validate" <> name
outputValidatorForDefinitionReference :: DefinitionReference -> Text
outputValidatorForDefinitionReference
( DefinitionReference
( TypeDefinition
(DefinitionName name)
(DeclaredType (ModuleName moduleName) _appliedTypes)
)
) =
mconcat [moduleName, ".validate", upperCaseFirstCharacter name]
outputValidatorForDefinitionReference (DefinitionReference (TypeDefinition (DefinitionName name) _typeData)) =
"validate" <> name
outputValidatorForDefinitionReference
( ImportedDefinitionReference
(ModuleName moduleName)
(TypeDefinition (DefinitionName name) _typeData)
) =
mconcat [moduleName, ".validate", name]
outputValidatorForDefinitionReference
( AppliedGenericReference
appliedTypes
( TypeDefinition
(DefinitionName name)
( DeclaredType
(ModuleName moduleName)
_appliedTypes
)
)
) =
let appliedValidators = appliedTypes & fmap outputValidatorForFieldType & Text.intercalate ", "
in mconcat [moduleName, ".validate", name, "(", appliedValidators, ")"]
outputValidatorForDefinitionReference
( AppliedGenericReference
appliedTypes
(TypeDefinition (DefinitionName name) _typeData)
) =
let appliedValidators = appliedTypes & fmap outputValidatorForFieldType & Text.intercalate ", "
in mconcat ["validate", name, "(", appliedValidators, ")"]
outputValidatorForDefinitionReference
( AppliedImportedGenericReference
(ModuleName moduleName)
(AppliedTypes appliedTypes)
(TypeDefinition (DefinitionName name) _typeData)
) =
let appliedValidators = appliedTypes & fmap outputValidatorForFieldType & Text.intercalate ", "
in mconcat [moduleName, ".validate", name, "(", appliedValidators, ")"]
outputValidatorForDefinitionReference
( GenericDeclarationReference
(ModuleName moduleName)
(DefinitionName name)
(AppliedTypes appliedTypes)
) =
let appliedValidators = appliedTypes & fmap outputValidatorForFieldType & Text.intercalate ", "
maybeAppliedTypes = if null appliedTypes then "" else mconcat ["(", appliedValidators, ")"]
in mconcat [moduleName, ".validate", upperCaseFirstCharacter name, maybeAppliedTypes]
outputValidatorForDefinitionReference
(DeclarationReference (ModuleName moduleName) (DefinitionName name)) =
mconcat [moduleName, ".validate", upperCaseFirstCharacter name]
outputValidatorForBasicType :: BasicTypeValue -> Text
outputValidatorForBasicType BasicString = "svt.validateString"
outputValidatorForBasicType U8 = "svt.validateNumber"
outputValidatorForBasicType U16 = "svt.validateNumber"
outputValidatorForBasicType U32 = "svt.validateNumber"
outputValidatorForBasicType U64 = "svt.validateBigInt"
outputValidatorForBasicType U128 = "svt.validateBigInt"
outputValidatorForBasicType I8 = "svt.validateNumber"
outputValidatorForBasicType I16 = "svt.validateNumber"
outputValidatorForBasicType I32 = "svt.validateNumber"
outputValidatorForBasicType I64 = "svt.validateBigInt"
outputValidatorForBasicType I128 = "svt.validateBigInt"
outputValidatorForBasicType F32 = "svt.validateNumber"
outputValidatorForBasicType F64 = "svt.validateNumber"
outputValidatorForBasicType Boolean = "svt.validateBoolean"
outputValidatorForComplexType :: ComplexTypeValue -> Text
outputValidatorForComplexType (ArrayType _size typeData) =
mconcat ["svt.validateArray(", outputValidatorForFieldType typeData, ")"]
outputValidatorForComplexType (SliceType typeData) =
mconcat ["svt.validateArray(", outputValidatorForFieldType typeData, ")"]
outputValidatorForComplexType (PointerType typeData) =
outputValidatorForFieldType typeData
outputValidatorForComplexType (OptionalType typeData) =
mconcat ["svt.validateOptional(", outputValidatorForFieldType typeData, ")"]
outputStructTypeGuard :: Text -> [StructField] -> [TypeVariable] -> Text
outputStructTypeGuard name fields typeVariables =
let interface =
"{" <> (fields & fmap outputStructTypeGuardForField & Text.intercalate ", ") <> "}"
in if null typeVariables
then
mconcat
[ mconcat
[ mconcat ["export function is", name, "(value: unknown): value is ", name, " {\n"],
mconcat [" return svt.isInterface<", name, ">(value, ", interface, ");\n"]
],
"}"
]
else
let fullName = name <> joinTypeVariables typeVariables
returnedFunctionName =
("is" <> fullName) & Text.filter ((`elem` ("<>, " :: String)) >>> not)
in mconcat
[ mconcat
[ "export function is",
fullName,
"(",
typeVariablePredicateParameters typeVariables,
"): svt.TypePredicate<",
fullName,
"> {\n"
],
mconcat
[ " return function ",
returnedFunctionName,
"(value: unknown): value is ",
fullName,
" {\n"
],
mconcat
[ " return svt.isInterface<",
fullName,
">(value, ",
interface,
");\n"
],
" };\n",
"}"
]
outputStructTypeGuardForField :: StructField -> Text
outputStructTypeGuardForField (StructField (FieldName fieldName) fieldType) =
mconcat [fieldName, ": ", outputTypeGuardForFieldType fieldType]
outputTypeGuardForFieldType :: FieldType -> Text
outputTypeGuardForFieldType (LiteralType (LiteralString text)) = mconcat ["\"", text, "\""]
outputTypeGuardForFieldType (LiteralType (LiteralInteger x)) = tshow x
outputTypeGuardForFieldType (LiteralType (LiteralFloat f)) = tshow f
outputTypeGuardForFieldType (LiteralType (LiteralBoolean b)) = bool "false" "true" b
outputTypeGuardForFieldType (BasicType basicType) = outputTypeGuardForBasicType basicType
outputTypeGuardForFieldType (ComplexType complexType) = outputTypeGuardForComplexType complexType
outputTypeGuardForFieldType (DefinitionReferenceType definitionReference) =
outputTypeGuardForDefinitionReference definitionReference
outputTypeGuardForFieldType (RecursiveReferenceType (DefinitionName name)) = "is" <> name
outputTypeGuardForFieldType (TypeVariableReferenceType (TypeVariable name)) = "is" <> name
outputTypeGuardForDefinitionReference :: DefinitionReference -> Text
outputTypeGuardForDefinitionReference (DefinitionReference (TypeDefinition (DefinitionName name) _typeData)) =
"is" <> name
outputTypeGuardForDefinitionReference
( ImportedDefinitionReference
(ModuleName moduleName)
(TypeDefinition (DefinitionName name) _typeData)
) =
mconcat [moduleName, ".is", name]
outputTypeGuardForDefinitionReference
( AppliedGenericReference
appliedTypes
(TypeDefinition (DefinitionName name) _typeData)
) =
let appliedTypeGuards = appliedTypes & fmap outputTypeGuardForFieldType & Text.intercalate ", "
in mconcat ["is", name, "(", appliedTypeGuards, ")"]
outputTypeGuardForDefinitionReference
( AppliedImportedGenericReference
(ModuleName moduleName)
(AppliedTypes appliedTypes)
(TypeDefinition (DefinitionName name) _typeData)
) =
let appliedTypeGuards = appliedTypes & fmap outputTypeGuardForFieldType & Text.intercalate ", "
in mconcat [moduleName, ".is", name, "(", appliedTypeGuards, ")"]
outputTypeGuardForDefinitionReference
( GenericDeclarationReference
(ModuleName moduleName)
(DefinitionName name)
(AppliedTypes appliedTypes)
) =
let appliedTypeGuards = appliedTypes & fmap outputTypeGuardForFieldType & Text.intercalate ", "
maybeAppliedTypes = if null appliedTypes then "" else mconcat ["(", appliedTypeGuards, ")"]
in mconcat [moduleName, ".is", upperCaseFirstCharacter name, maybeAppliedTypes]
outputTypeGuardForDefinitionReference
(DeclarationReference (ModuleName moduleName) (DefinitionName name)) =
mconcat [moduleName, ".is", upperCaseFirstCharacter name]
outputTypeGuardForBasicType :: BasicTypeValue -> Text
outputTypeGuardForBasicType BasicString = "svt.isString"
outputTypeGuardForBasicType U8 = "svt.isNumber"
outputTypeGuardForBasicType U16 = "svt.isNumber"
outputTypeGuardForBasicType U32 = "svt.isNumber"
outputTypeGuardForBasicType U64 = "svt.isBigInt"
outputTypeGuardForBasicType U128 = "svt.isBigInt"
outputTypeGuardForBasicType I8 = "svt.isNumber"
outputTypeGuardForBasicType I16 = "svt.isNumber"
outputTypeGuardForBasicType I32 = "svt.isNumber"
outputTypeGuardForBasicType I64 = "svt.isBigInt"
outputTypeGuardForBasicType I128 = "svt.isBigInt"
outputTypeGuardForBasicType F32 = "svt.isNumber"
outputTypeGuardForBasicType F64 = "svt.isNumber"
outputTypeGuardForBasicType Boolean = "svt.isBoolean"
outputTypeGuardForComplexType :: ComplexTypeValue -> Text
outputTypeGuardForComplexType (ArrayType _size typeData) =
mconcat ["svt.arrayOf(", outputTypeGuardForFieldType typeData, ")"]
outputTypeGuardForComplexType (SliceType typeData) =
mconcat ["svt.arrayOf(", outputTypeGuardForFieldType typeData, ")"]
outputTypeGuardForComplexType (PointerType typeData) =
outputTypeGuardForFieldType typeData
outputTypeGuardForComplexType (OptionalType typeData) =
mconcat ["svt.optional(", outputTypeGuardForFieldType typeData, ")"]
outputUnion :: Text -> FieldName -> UnionType -> Text
outputUnion name typeTag unionType =
let caseUnionOutput = outputCaseUnion name (constructorsFrom unionType) typeVariables
constructorsFrom (PlainUnion constructors) = constructors
constructorsFrom (GenericUnion _typeVariables constructors) = constructors
unionTagEnumerationOutput = outputUnionTagEnumeration name (constructorsFrom unionType)
caseTypesOutput = outputCaseTypes name typeTag (constructorsFrom unionType)
caseConstructorOutput = outputCaseConstructors name typeTag (constructorsFrom unionType)
unionTypeGuardOutput = outputUnionTypeGuard typeTag typeVariables name (constructorsFrom unionType)
caseTypeGuardOutput = outputCaseTypeGuards name typeTag (constructorsFrom unionType)
unionValidatorOutput =
outputUnionValidator typeVariables typeTag name (constructorsFrom unionType)
caseValidatorOutput = outputCaseValidators typeTag name (constructorsFrom unionType)
typeVariables = case unionType of
PlainUnion _constructors -> []
GenericUnion ts _constructors -> ts
in mconcat
[ caseUnionOutput,
"\n\n",
unionTagEnumerationOutput,
"\n\n",
caseTypesOutput,
"\n\n",
caseConstructorOutput,
"\n\n",
unionTypeGuardOutput,
"\n\n",
caseTypeGuardOutput,
"\n\n",
unionValidatorOutput,
"\n\n",
caseValidatorOutput
]
newtype FunctionPrefix = FunctionPrefix Text
newtype ReturnType = ReturnType (Text -> Text)
newtype ReturnExpression = ReturnExpression (Text -> FieldName -> [Constructor] -> Text)
outputUnionFunction ::
FunctionPrefix ->
ReturnType ->
ReturnExpression ->
FieldName ->
Text ->
[Constructor] ->
Text
outputUnionFunction
(FunctionPrefix prefix)
(ReturnType returnType)
(ReturnExpression returnExpression)
typeTag
unionName
constructors =
mconcat
[ mconcat
[ "export function ",
prefix,
unionName,
"(value: unknown): ",
returnType unionName,
" {\n"
],
mconcat [" return ", returnExpression unionName typeTag constructors, ";\n"],
"}"
]
outputUnionTypeGuard :: FieldName -> [TypeVariable] -> Text -> [Constructor] -> Text
outputUnionTypeGuard typeTag typeVariables unionName constructors =
if null typeVariables
then
let returnExpression _unionName' _tagType constructors' =
let constructorTypeGuards =
constructors'
& fmap
( \(Constructor (ConstructorName constructorName) _payload) ->
"is" <> upperCaseFirstCharacter constructorName
)
& Text.intercalate ", "
in mconcat ["[", constructorTypeGuards, "].some((typePredicate) => typePredicate(value))"]
in outputUnionFunction
(FunctionPrefix "is")
(ReturnType ("value is " <>))
(ReturnExpression returnExpression)
typeTag
unionName
constructors
else
let fullName = unionName <> joinTypeVariables typeVariables
typeVariablePredicates =
typeVariables
& fmap (\(TypeVariable t) -> mconcat ["is", t, ": svt.TypePredicate<", t, ">"])
& Text.intercalate ", "
returnedFunctionName = "is" <> Text.filter ((`elem` ("<>, " :: String)) >>> not) fullName
constructorPredicates =
constructors
& fmap
( \(Constructor (ConstructorName name) maybePayload) ->
let constructorTypeVariables =
fromMaybe [] $ foldMap typeVariablesFrom maybePayload
maybeParameters =
if null constructorTypeVariables
then ""
else "(" <> predicates <> ")"
predicates =
constructorTypeVariables
& fmap (\(TypeVariable t) -> "is" <> t)
& Text.intercalate ", "
in mconcat ["is", upperCaseFirstCharacter name, maybeParameters]
)
& Text.intercalate ", "
in mconcat
[ mconcat
[ "export function is",
fullName,
"(",
typeVariablePredicates,
"): svt.TypePredicate<",
fullName,
"> {\n"
],
mconcat
[ " return function ",
returnedFunctionName,
"(value: unknown): value is ",
fullName,
" {\n"
],
mconcat
[ " return [",
constructorPredicates,
"].some((typePredicate) => typePredicate(value));\n"
],
" };\n",
"}"
]
outputUnionValidator :: [TypeVariable] -> FieldName -> Text -> [Constructor] -> Text
outputUnionValidator typeVariables typeTag@(FieldName tag) unionName constructors =
let constructorTagValidators =
constructors
& fmap
( \(Constructor (ConstructorName constructorName) maybePayload) ->
let tagName = unionEnumConstructorTag unionName constructorName
constructorTypeVariables = fromMaybe [] $ foldMap typeVariablesFrom maybePayload
name =
if null constructorTypeVariables
then constructorName
else
mconcat
[ constructorName,
"(",
typeVariableValidatorNames constructorTypeVariables,
")"
]
in mconcat ["[", tagName, "]: ", "validate", upperCaseFirstCharacter name]
)
& Text.intercalate ", "
in if null typeVariables
then
let returnExpression unionName' (FieldName tag') _constructors' =
mconcat
[ "svt.validateWithTypeTag<",
unionName',
">(value, {",
constructorTagValidators,
"}, \"",
tag',
"\")"
]
in outputUnionFunction
(FunctionPrefix "validate")
(ReturnType (\n -> "svt.ValidationResult<" <> n <> ">"))
(ReturnExpression returnExpression)
typeTag
unionName
constructors
else
let fullName = unionName <> joinTypeVariables typeVariables
returnedFunctionName =
"validate" <> Text.filter ((`elem` ("<>, " :: String)) >>> not) fullName
in mconcat
[ mconcat
[ "export function validate",
fullName,
"(",
typeVariableValidatorParameters typeVariables,
"): svt.Validator<",
fullName,
"> {\n"
],
mconcat
[ " return function ",
returnedFunctionName,
"(value: unknown): svt.ValidationResult<",
fullName,
"> {\n"
],
mconcat
[ " return svt.validateWithTypeTag<",
fullName,
">(value, {",
constructorTagValidators,
"}, \"",
tag,
"\");\n"
],
" };\n",
"}"
]
outputCaseTypeGuards :: Text -> FieldName -> [Constructor] -> Text
outputCaseTypeGuards unionName typeTag =
fmap (outputCaseTypeGuard unionName typeTag) >>> Text.intercalate "\n\n"
outputCaseTypeGuard :: Text -> FieldName -> Constructor -> Text
outputCaseTypeGuard
unionName
(FieldName tag)
(Constructor (ConstructorName name) maybePayload) =
let tagValue = unionEnumConstructorTag unionName name
typeVariables = fromMaybe [] $ foldMap typeVariablesFrom maybePayload
interface =
mconcat $
["{", tag, ": ", tagValue]
<> maybe ["}"] (\p -> [", data: ", outputTypeGuardForFieldType p, "}"]) maybePayload
in if null typeVariables
then
mconcat
[ mconcat ["export function is", upperCaseFirstCharacter name, "(value: unknown): value is ", name, " {\n"],
mconcat [" return svt.isInterface<", name, ">(value, ", interface, ");\n"],
"}"
]
else
let fullName = upperCaseFirstCharacter name <> joinTypeVariables typeVariables
returnedFunctionName = "is" <> Text.filter (\c -> c /= '<' && c /= '>') fullName
in mconcat
[ mconcat
[ "export function is",
fullName,
"(",
typeVariablePredicateParameters typeVariables,
"): svt.TypePredicate<",
fullName,
"> {\n"
],
mconcat
[ " return function ",
returnedFunctionName,
"(value: unknown): value is ",
fullName,
" {\n"
],
mconcat
[ " return svt.isInterface<",
fullName,
">(value, ",
interface,
");\n"
],
" };\n",
"}"
]
typeVariablePredicateParameters :: [TypeVariable] -> Text
typeVariablePredicateParameters =
fmap (\(TypeVariable t) -> mconcat ["is", t, ": svt.TypePredicate<", t, ">"])
>>> Text.intercalate ", "
typeVariableValidatorNames :: [TypeVariable] -> Text
typeVariableValidatorNames =
fmap (\(TypeVariable t) -> "validate" <> t) >>> Text.intercalate ", "
typeVariableValidatorParameters :: [TypeVariable] -> Text
typeVariableValidatorParameters =
fmap (\(TypeVariable t) -> mconcat ["validate", t, ": svt.Validator<", t, ">"])
>>> Text.intercalate ", "
outputCaseValidators :: FieldName -> Text -> [Constructor] -> Text
outputCaseValidators typeTag unionName =
fmap (outputCaseValidator typeTag unionName) >>> Text.intercalate "\n\n"
outputCaseValidator :: FieldName -> Text -> Constructor -> Text
outputCaseValidator
(FieldName tag)
unionName
(Constructor (ConstructorName name) maybePayload) =
let tagValue = unionEnumConstructorTag unionName name
typeVariables = fromMaybe [] $ foldMap typeVariablesFrom maybePayload
interface =
mconcat $
["{", tag, ": ", tagValue]
<> maybe ["}"] (\p -> [", data: ", outputValidatorForFieldType p, "}"]) maybePayload
in if null typeVariables
then
mconcat
[ mconcat
[ "export function validate",
upperCaseFirstCharacter name,
"(value: unknown): svt.ValidationResult<",
name,
"> {\n"
],
mconcat [" return svt.validate<", name, ">(value, ", interface, ");\n"],
"}"
]
else
let fullName = upperCaseFirstCharacter name <> joinTypeVariables typeVariables
returnedFunctionName = "validate" <> Text.filter (\c -> c /= '<' && c /= '>') fullName
in mconcat
[ mconcat
[ "export function validate",
fullName,
"(",
typeVariableValidatorParameters typeVariables,
"): svt.Validator<",
fullName,
"> {\n"
],
mconcat
[ " return function ",
returnedFunctionName,
"(value: unknown): svt.ValidationResult<",
fullName,
"> {\n"
],
mconcat
[ " return svt.validate<",
fullName,
">(value, ",
interface,
");\n"
],
" };\n",
"}"
]
outputCaseUnion :: Text -> [Constructor] -> [TypeVariable] -> Text
outputCaseUnion name constructors typeVariables =
let cases =
constructors
& fmap
( \(Constructor (ConstructorName constructorName) maybePayload) ->
(mconcat [upperCaseFirstCharacter constructorName])
<> maybe
""
(typeVariablesFrom >>> maybeJoinTypeVariables)
maybePayload
)
& Text.intercalate " | "
maybeTypeVariables = if null typeVariables then "" else joinTypeVariables typeVariables
in mconcat ["export type ", name, maybeTypeVariables, " = ", cases, ";"]
typeVariablesFrom :: FieldType -> Maybe [TypeVariable]
typeVariablesFrom (TypeVariableReferenceType typeVariable) = pure [typeVariable]
typeVariablesFrom (ComplexType (ArrayType _size fieldType)) = typeVariablesFrom fieldType
typeVariablesFrom (ComplexType (SliceType fieldType)) = typeVariablesFrom fieldType
typeVariablesFrom (ComplexType (PointerType fieldType)) = typeVariablesFrom fieldType
typeVariablesFrom (ComplexType (OptionalType fieldType)) = typeVariablesFrom fieldType
typeVariablesFrom (RecursiveReferenceType _name) = Nothing
typeVariablesFrom (LiteralType _) = Nothing
typeVariablesFrom (BasicType _) = Nothing
typeVariablesFrom (DefinitionReferenceType definitionReference) =
typeVariablesFromReference definitionReference
typeVariablesFromReference :: DefinitionReference -> Maybe [TypeVariable]
typeVariablesFromReference (DefinitionReference definition) = typeVariablesFromDefinition definition
typeVariablesFromReference (ImportedDefinitionReference _moduleName definition) =
typeVariablesFromDefinition definition
typeVariablesFromReference (AppliedGenericReference fieldTypes _definition) =
let typeVariables = fieldTypes & fmap typeVariablesFrom & catMaybes & join
in if null typeVariables then Nothing else Just typeVariables
typeVariablesFromReference
( AppliedImportedGenericReference
_moduleName
(AppliedTypes fieldTypes)
_definition
) =
let typeVariables = fieldTypes & fmap typeVariablesFrom & catMaybes & join
in if null typeVariables then Nothing else Just typeVariables
typeVariablesFromReference
( GenericDeclarationReference
_moduleName
_definitionName
(AppliedTypes appliedTypes)
) =
let typeVariables = appliedTypes & fmap typeVariablesFrom & catMaybes & join
in if null typeVariables then Nothing else Just typeVariables
typeVariablesFromReference (DeclarationReference _moduleName _definitionName) =
Nothing
typeVariablesFromDefinition :: TypeDefinition -> Maybe [TypeVariable]
typeVariablesFromDefinition (TypeDefinition _name (Struct (PlainStruct _))) = Nothing
typeVariablesFromDefinition (TypeDefinition _name (Union _tagType (PlainUnion _))) = Nothing
typeVariablesFromDefinition (TypeDefinition _name (UntaggedUnion _)) = Nothing
typeVariablesFromDefinition (TypeDefinition _name (Enumeration _)) = Nothing
typeVariablesFromDefinition (TypeDefinition _name (EmbeddedUnion _tagType _constructors)) = Nothing
typeVariablesFromDefinition (TypeDefinition _name (Struct (GenericStruct typeVariables _))) =
pure typeVariables
typeVariablesFromDefinition (TypeDefinition _name (Union _tagType (GenericUnion typeVariables _))) =
pure typeVariables
typeVariablesFromDefinition (TypeDefinition _name (DeclaredType _moduleName typeVariables)) =
pure typeVariables
outputUnionTagEnumeration :: Text -> [Constructor] -> Text
outputUnionTagEnumeration name constructors =
let constructorCasesOutput =
constructors
& fmap
( \(Constructor (ConstructorName constructorName) _payload) ->
mconcat [" ", upperCaseFirstCharacter constructorName, " = \"", constructorName, "\",\n"]
)
& mconcat
in mconcat
[ mconcat ["export enum ", name, "Tag {\n"],
constructorCasesOutput,
"}"
]
outputCaseTypes :: Text -> FieldName -> [Constructor] -> Text
outputCaseTypes unionName typeTag constructors =
constructors
& fmap (outputCaseType unionName typeTag)
& Text.intercalate "\n\n"
outputCaseType :: Text -> FieldName -> Constructor -> Text
outputCaseType
unionName
(FieldName tag)
(Constructor (ConstructorName name) maybePayload) =
let payloadLine = maybe "" (\p -> " data: " <> outputFieldType p <> ";\n") maybePayload
maybeTypeVariables = maybe "" (typeVariablesFrom >>> maybeJoinTypeVariables) maybePayload
in mconcat
[ mconcat ["export type ", upperCaseFirstCharacter name, maybeTypeVariables, " = {\n"],
mconcat [" ", tag, ": ", unionEnumConstructorTag unionName name, ";\n"],
payloadLine,
"};"
]
outputCaseConstructors :: Text -> FieldName -> [Constructor] -> Text
outputCaseConstructors unionName typeTag constructors =
constructors
& fmap (outputCaseConstructor unionName typeTag)
& Text.intercalate "\n\n"
outputCaseConstructor :: Text -> FieldName -> Constructor -> Text
outputCaseConstructor
unionName
(FieldName tag)
(Constructor (ConstructorName name) maybePayload) =
let argumentFieldAndType = maybe "" (\p -> "data: " <> outputFieldType p) maybePayload
maybeTypeVariables = maybe "" joinTypeVariables (maybePayload >>= typeVariablesFrom)
in mconcat
[ mconcat
[ "export function ",
name,
maybeTypeVariables,
"(",
argumentFieldAndType,
"): ",
name,
maybeTypeVariables,
" {\n"
],
mconcat
( [ " return {",
tag,
": ",
unionEnumConstructorTag unionName name
]
<> maybe [] (const [", data"]) maybePayload
)
<> "};\n",
"}"
]
unionEnumConstructorTag :: Text -> Text -> Text
unionEnumConstructorTag unionName constructorName =
mconcat [unionName, "Tag.", upperCaseFirstCharacter constructorName]
outputField :: StructField -> Text
outputField (StructField (FieldName name) fieldType) =
mconcat [" ", name, ": ", outputFieldType fieldType, ";\n"]
outputFieldType :: FieldType -> Text
outputFieldType (LiteralType (LiteralString text)) = mconcat ["\"", text, "\""]
outputFieldType (LiteralType (LiteralInteger x)) = tshow x
outputFieldType (LiteralType (LiteralFloat f)) = tshow f
outputFieldType (LiteralType (LiteralBoolean b)) = bool "false" "true" b
outputFieldType (BasicType basicType) = outputBasicType basicType
outputFieldType (ComplexType (OptionalType fieldType)) =
mconcat [outputFieldType fieldType, " | null | undefined"]
outputFieldType (ComplexType (ArrayType _size fieldType@(ComplexType (OptionalType _)))) =
mconcat ["(", outputFieldType fieldType, ")", "[]"]
outputFieldType (ComplexType (ArrayType _size fieldType)) =
mconcat [outputFieldType fieldType, "[]"]
outputFieldType (ComplexType (SliceType fieldType)) =
mconcat [outputFieldType fieldType, "[]"]
outputFieldType (ComplexType (PointerType fieldType)) = outputFieldType fieldType
outputFieldType (RecursiveReferenceType (DefinitionName name)) = name
outputFieldType (DefinitionReferenceType definitionReference) =
outputDefinitionReference definitionReference
outputFieldType (TypeVariableReferenceType (TypeVariable t)) = t
outputDefinitionReference :: DefinitionReference -> Text
outputDefinitionReference (DefinitionReference (TypeDefinition (DefinitionName name) _)) = name
outputDefinitionReference
( ImportedDefinitionReference
(ModuleName moduleName)
(TypeDefinition (DefinitionName name) _typeData)
) =
mconcat [moduleName, ".", name]
outputDefinitionReference
( AppliedGenericReference
appliedTypes
(TypeDefinition (DefinitionName name) _)
) =
let appliedFieldTypes = appliedTypes & fmap outputFieldType & Text.intercalate ", "
in mconcat [name, "<", appliedFieldTypes, ">"]
outputDefinitionReference
( AppliedImportedGenericReference
(ModuleName moduleName)
(AppliedTypes appliedTypes)
(TypeDefinition (DefinitionName name) _)
) =
let appliedFieldTypes = appliedTypes & fmap outputFieldType & Text.intercalate ", "
in mconcat [moduleName, ".", name, "<", appliedFieldTypes, ">"]
outputDefinitionReference
( GenericDeclarationReference
(ModuleName moduleName)
(DefinitionName name)
(AppliedTypes appliedTypes)
) =
let appliedTypesOutput = appliedTypes & fmap outputFieldType & Text.intercalate ", "
maybeAppliedOutput =
if null appliedTypes then "" else mconcat ["<", appliedTypesOutput, ">"]
in mconcat [moduleName, ".", name, maybeAppliedOutput]
outputDefinitionReference
( DeclarationReference
(ModuleName moduleName)
(DefinitionName name)
) =
mconcat [moduleName, ".", name]
outputBasicType :: BasicTypeValue -> Text
outputBasicType BasicString = "string"
outputBasicType U8 = "number"
outputBasicType U16 = "number"
outputBasicType U32 = "number"
outputBasicType U64 = "bigint"
outputBasicType U128 = "bigint"
outputBasicType I8 = "number"
outputBasicType I16 = "number"
outputBasicType I32 = "number"
outputBasicType I64 = "bigint"
outputBasicType I128 = "bigint"
outputBasicType F32 = "number"
outputBasicType F64 = "number"
outputBasicType Boolean = "boolean"
maybeJoinTypeVariables :: Maybe [TypeVariable] -> Text
maybeJoinTypeVariables = maybe "" joinTypeVariables
joinTypeVariables :: [TypeVariable] -> Text
joinTypeVariables typeVariables =
typeVariables & fmap (\(TypeVariable t) -> t) & Text.intercalate ", " & (\o -> "<" <> o <> ">")