diff --git a/LICENSE.txt b/LICENSE.txt new file mode 100644 --- /dev/null +++ b/LICENSE.txt @@ -0,0 +1,22 @@ +Copyright 2021 Rickard Andersson + +Redistribution and use in source and binary forms, with or without modification, +are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON +ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,60 @@ +module Main where + +import qualified Library +import Options.Applicative +import Prelude + +-- This `main` function just delegates to the library's definition of `main` +main :: IO () +main = do + let parserOptions = + info + (parseOptions <**> helper) + ( fullDesc <> progDesc programDescription + <> header ("gotyno - " <> programDescription) + ) + programDescription = "Compile type definitions into encoders/decoders for languages" + options <- execParser parserOptions + + Library.runMain options + +parseOptions :: Parser Library.Options +parseOptions = + Library.Options + <$> parseLanguages + <*> switch (long "watch" <> short 'w' <> help "Watch files and recompile automatically") + <*> switch (long "verbose" <> short 'v' <> help "Output info about compilation") + <*> some (argument str (metavar "GOTYNOFILE")) + +parseLanguages :: Parser Library.Languages +parseLanguages = + Library.Languages + <$> option + (maybeReader parseOutputDestination) + ( long "typescript" + <> long "ts" + <> help "Set TypeScript output" + <> value Nothing + <> metavar "=|-|PATH" + ) + <*> option + (maybeReader parseOutputDestination) + ( long "fsharp" + <> long "fs" + <> help "Set FSharp output" + <> value Nothing + <> metavar "=|-|PATH" + ) + <*> option + (maybeReader parseOutputDestination) + ( long "python" + <> long "py" + <> help "Set Python output" + <> value Nothing + <> metavar "=|-|PATH" + ) + +parseOutputDestination :: String -> Maybe (Maybe Library.OutputDestination) +parseOutputDestination "=" = pure $ Just Library.SameAsInput +parseOutputDestination "-" = pure $ Just Library.StandardOut +parseOutputDestination other = pure $ Just $ Library.OutputPath other diff --git a/gotyno-hs.cabal b/gotyno-hs.cabal new file mode 100644 --- /dev/null +++ b/gotyno-hs.cabal @@ -0,0 +1,208 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.34.4. +-- +-- see: https://github.com/sol/hpack + +name: gotyno-hs +version: 1.0.0 +synopsis: A type definition compiler supporting multiple output languages. +description: Compiles type definitions into F#, TypeScript and Python, with validators/decoders/encoders. +category: Compiler +maintainer: Rickard Andersson +license: BSD2 +license-file: LICENSE.txt +build-type: Simple + +library + exposed-modules: + CodeGeneration.FSharp + CodeGeneration.Python + CodeGeneration.TypeScript + CodeGeneration.Utilities + Library + Parsing + Types + other-modules: + Paths_gotyno_hs + hs-source-dirs: + src + default-extensions: + ApplicativeDo + BangPatterns + BinaryLiterals + ConstraintKinds + DataKinds + DefaultSignatures + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveTraversable + DeriveLift + DerivingStrategies + DoAndIfThenElse + DuplicateRecordFields + EmptyDataDecls + EmptyCase + ExistentialQuantification + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + InstanceSigs + KindSignatures + LambdaCase + MultiParamTypeClasses + MultiWayIf + NamedFieldPuns + NoImplicitPrelude + OverloadedStrings + PartialTypeSignatures + PatternGuards + PolyKinds + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeFamilies + TypeSynonymInstances + ViewPatterns + TypeApplications + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints + build-depends: + base >=4.9.1.0 && <5 + , fsnotify + , megaparsec + , pretty-show + , rio + , text + default-language: Haskell2010 + +executable gotyno-hs + main-is: Main.hs + other-modules: + Paths_gotyno_hs + hs-source-dirs: + app + default-extensions: + ApplicativeDo + BangPatterns + BinaryLiterals + ConstraintKinds + DataKinds + DefaultSignatures + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveTraversable + DeriveLift + DerivingStrategies + DoAndIfThenElse + DuplicateRecordFields + EmptyDataDecls + EmptyCase + ExistentialQuantification + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + InstanceSigs + KindSignatures + LambdaCase + MultiParamTypeClasses + MultiWayIf + NamedFieldPuns + NoImplicitPrelude + OverloadedStrings + PartialTypeSignatures + PatternGuards + PolyKinds + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeFamilies + TypeSynonymInstances + ViewPatterns + TypeApplications + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.9.1.0 && <5 + , fsnotify + , gotyno-hs + , megaparsec + , optparse-applicative + , pretty-show + , rio + , text + default-language: Haskell2010 + +test-suite gotyno-hs-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + ParsingSpec + Paths_gotyno_hs + hs-source-dirs: + test + default-extensions: + ApplicativeDo + BangPatterns + BinaryLiterals + ConstraintKinds + DataKinds + DefaultSignatures + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveTraversable + DeriveLift + DerivingStrategies + DoAndIfThenElse + DuplicateRecordFields + EmptyDataDecls + EmptyCase + ExistentialQuantification + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + InstanceSigs + KindSignatures + LambdaCase + MultiParamTypeClasses + MultiWayIf + NamedFieldPuns + NoImplicitPrelude + OverloadedStrings + PartialTypeSignatures + PatternGuards + PolyKinds + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeFamilies + TypeSynonymInstances + ViewPatterns + TypeApplications + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -Wall + build-depends: + base >=4.9.1.0 && <5 + , fsnotify + , gotyno-hs + , hspec >=2.0.0 + , megaparsec + , pretty-show + , rio + , text + default-language: Haskell2010 diff --git a/src/CodeGeneration/FSharp.hs b/src/CodeGeneration/FSharp.hs new file mode 100644 --- /dev/null +++ b/src/CodeGeneration/FSharp.hs @@ -0,0 +1,913 @@ +module CodeGeneration.FSharp (outputModule) where + +import CodeGeneration.Utilities (upperCaseFirstCharacter) +import RIO +import qualified RIO.List.Partial as PartialList +import qualified RIO.Text as Text +import Types + +outputModule :: Module -> Text +outputModule Module {name = ModuleName name, definitions, imports} = + 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"] + in mconcat [modulePrelude (fsharpifyModuleName name), definitionOutput] + +fsharpifyModuleName :: Text -> Text +fsharpifyModuleName = upperCaseFirstCharacter + +modulePrelude :: Text -> Text +modulePrelude name = + mconcat + [ mconcat ["module ", name, "\n\n"], + "open Thoth.Json.Net\n\n" + ] + +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 _name (DeclaredType _moduleName _typeVariables)) = Nothing + +outputEmbeddedUnion :: Text -> FieldName -> [EmbeddedConstructor] -> Text +outputEmbeddedUnion unionName fieldName@(FieldName tag) constructors = + let typeOutput = + outputCaseUnion + unionName + constructorsAsConstructors + [] + constructorsAsConstructors = embeddedConstructorsToConstructors constructors + constructorDecodersOutput = outputEmbeddedConstructorDecoders unionName constructors + tagDecoderPairsOutput = + constructors + & fmap + ( \(EmbeddedConstructor (ConstructorName name) _reference) -> + mconcat + [ " \"", + name, + "\", ", + unionName, + ".", + upperCaseFirstCharacter name, + "Decoder\n" + ] + ) + & mconcat + decoderOutput = + mconcat + [ mconcat [" static member Decoder: Decoder<", unionName, "> =\n"], + " GotynoCoders.decodeWithTypeTag\n", + mconcat [" \"", tag, "\"\n"], + " [|\n", + tagDecoderPairsOutput, + " |]" + ] + constructorCasesOutput = + constructors + & fmap (outputEmbeddedCase fieldName) + & Text.intercalate "\n\n" + encoderOutput = + mconcat + [ mconcat [" static member Encoder =\n"], + " function\n", + constructorCasesOutput + ] + in Text.intercalate + "\n\n" + [ typeOutput, + constructorDecodersOutput, + decoderOutput, + encoderOutput + ] + +outputEmbeddedCase :: FieldName -> EmbeddedConstructor -> Text +outputEmbeddedCase (FieldName tag) (EmbeddedConstructor (ConstructorName name) Nothing) = + mconcat + [ mconcat [" | ", upperCaseFirstCharacter name, " payload ->\n"], + " Encode.object\n", + " [\n", + mconcat [" \"", tag, "\", Encode.string \"", name, "\"\n"], + " ]" + ] +outputEmbeddedCase (FieldName tag) (EmbeddedConstructor (ConstructorName name) (Just reference)) = + let fields = structFieldsFromReference reference + fieldsEncoderOutput = + fields + & fmap + ( outputEncoderForFieldWithValueName "payload" + >>> (" " <>) + >>> (<> "\n") + ) + & mconcat + in mconcat + [ mconcat [" | ", upperCaseFirstCharacter name, " payload ->\n"], + " Encode.object\n", + " [\n", + mconcat [" \"", tag, "\", Encode.string \"", name, "\"\n"], + fieldsEncoderOutput, + " ]" + ] + +outputEmbeddedConstructorDecoders :: Text -> [EmbeddedConstructor] -> Text +outputEmbeddedConstructorDecoders unionName = + fmap (outputEmbeddedConstructorDecoder unionName) >>> Text.intercalate "\n\n" + +outputEmbeddedConstructorDecoder :: Text -> EmbeddedConstructor -> Text +outputEmbeddedConstructorDecoder unionName (EmbeddedConstructor (ConstructorName name) Nothing) = + let constructorName = upperCaseFirstCharacter name + in mconcat + [ mconcat + [" static member ", constructorName, "Decoder: Decoder<", unionName, "> =\n"], + mconcat [" Decode.object (fun get -> ", constructorName, ")"] + ] +outputEmbeddedConstructorDecoder + unionName + ( EmbeddedConstructor + (ConstructorName name) + (Just reference) + ) = + let structFields = structFieldsFromReference reference + structFieldDecoders = + structFields + & fmap (outputDecoderForField >>> (" " <>) >>> (<> "\n")) + & mconcat + constructorName = upperCaseFirstCharacter name + in mconcat + [ mconcat + [" static member ", constructorName, "Decoder: Decoder<", unionName, "> =\n"], + " Decode.object (fun get ->\n", + mconcat [" ", constructorName, " {\n"], + structFieldDecoders, + " }\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 ["type ", unionName, " =\n", unionOutput] + unionOutput = cases & fmap outputCaseLine & Text.intercalate "\n" + outputCaseLine fieldType = + mconcat + [ " | ", + unionName, + fieldTypeName fieldType, + " of ", + outputFieldType fieldType + ] + decoderOutput = outputUntaggedUnionDecoder unionName cases + encoderOutput = outputUntaggedUnionEncoder unionName cases + in Text.intercalate "\n\n" [typeOutput, decoderOutput, encoderOutput] + +outputUntaggedUnionDecoder :: Text -> [FieldType] -> Text +outputUntaggedUnionDecoder name cases = + let caseDecodersOutput = cases & fmap decoderForCase & Text.intercalate "\n\n" + decoderForCase fieldType = + let caseName = name <> fieldTypeName fieldType + in mconcat + [ mconcat [" static member ", caseName, "Decoder: Decoder<", name, "> =\n"], + mconcat [" Decode.map ", caseName, " ", decoderForFieldType fieldType] + ] + oneOfListOutput = + cases & fmap oneOfCaseOutput & mconcat + oneOfCaseOutput caseFieldType = + mconcat [" ", name, ".", name, fieldTypeName caseFieldType, "Decoder\n"] + in mconcat + [ caseDecodersOutput, + "\n\n", + mconcat [" static member Decoder: Decoder<", name, "> =\n"], + mconcat [" Decode.oneOf\n"], + mconcat [" [\n"], + oneOfListOutput, + mconcat [" ]"] + ] + +outputUntaggedUnionEncoder :: Text -> [FieldType] -> Text +outputUntaggedUnionEncoder name cases = + let caseEncodersOutput = cases & fmap encoderForCase & Text.intercalate "\n\n" + encoderForCase caseFieldType = + mconcat + [ mconcat + [" | ", name, fieldTypeName caseFieldType, " payload ->\n"], + mconcat + [" ", encoderForFieldType ("", "") caseFieldType, " payload"] + ] + in mconcat + [ " static member Encoder =\n", + " function\n", + caseEncodersOutput + ] + +outputEnumeration :: Text -> [EnumerationValue] -> Text +outputEnumeration name values = + let typeOutput = outputEnumerationType name values + decoderOutput = outputEnumerationDecoder name values + encoderOutput = outputEnumerationEncoder values + in mconcat [typeOutput, "\n\n", decoderOutput, "\n\n", encoderOutput] + +outputEnumerationType :: Text -> [EnumerationValue] -> Text +outputEnumerationType name values = + let valuesOutput = + values + & fmap + ( \(EnumerationValue (EnumerationIdentifier i) _literal) -> + mconcat [" | ", fsharpifyConstructorName i] + ) + & Text.intercalate "\n" + in mconcat [mconcat ["type ", name, " =\n"], valuesOutput] + +fsharpifyConstructorName :: Text -> Text +fsharpifyConstructorName = upperCaseFirstCharacter + +outputEnumerationDecoder :: Text -> [EnumerationValue] -> Text +outputEnumerationDecoder unionName values = + let valuesOutput = + values + & fmap + ( \(EnumerationValue (EnumerationIdentifier i) value) -> + mconcat [outputLiteral value, ", ", fsharpifyConstructorName i] + ) + & Text.intercalate "; " + outputLiteral (LiteralString s) = "\"" <> s <> "\"" + outputLiteral (LiteralBoolean b) = bool "false" "true" b + outputLiteral (LiteralInteger i) = tshow i + outputLiteral (LiteralFloat f) = tshow f + valuesDecoder = + values + & PartialList.head + & ( \case + (EnumerationValue _identifier (LiteralString _s)) -> + decoderForBasicType BasicString + (EnumerationValue _identifier (LiteralBoolean _s)) -> + decoderForBasicType Boolean + (EnumerationValue _identifier (LiteralInteger _s)) -> + decoderForBasicType I32 + (EnumerationValue _identifier (LiteralFloat _s)) -> + decoderForBasicType F32 + ) + in mconcat + [ mconcat [" static member Decoder: Decoder<", unionName, "> =\n"], + mconcat [" GotynoCoders.decodeOneOf ", valuesDecoder, " [|", valuesOutput, "|]"] + ] + +outputEnumerationEncoder :: [EnumerationValue] -> Text +outputEnumerationEncoder values = + let caseOutput = + values + & fmap caseEncoder + & Text.intercalate "\n" + caseEncoder (EnumerationValue (EnumerationIdentifier i) (LiteralString s)) = + mconcat [" | ", fsharpifyConstructorName i, " -> Encode.string \"", s, "\""] + caseEncoder (EnumerationValue (EnumerationIdentifier i) (LiteralBoolean b)) = + let value = bool "false" "true" b + in mconcat [" | ", fsharpifyConstructorName i, " -> Encode.boolean ", value] + caseEncoder (EnumerationValue (EnumerationIdentifier i) (LiteralInteger integer)) = + mconcat [" | ", fsharpifyConstructorName i, " -> Encode.int32 ", tshow integer] + caseEncoder (EnumerationValue (EnumerationIdentifier i) (LiteralFloat f)) = + mconcat [" | ", fsharpifyConstructorName i, " -> Encode.float32 ", tshow f] + in mconcat + [ mconcat [" static member Encoder =\n"], + mconcat [" function\n"], + caseOutput + ] + +outputPlainStruct :: Text -> [StructField] -> Text +outputPlainStruct name fields = + let fieldsOutput = fields & fmap (outputField 8) & mconcat + decoderOutput = outputStructDecoder name fields [] + encoderOutput = outputStructEncoder fields [] + in mconcat + [ mconcat ["type ", name, " =\n"], + " {\n", + fieldsOutput, + " }\n\n", + decoderOutput, + "\n\n", + encoderOutput + ] + +outputGenericStruct :: Text -> [TypeVariable] -> [StructField] -> Text +outputGenericStruct name typeVariables fields = + let fullName = name <> joinTypeVariables typeVariables + typeOutput = + mconcat + [ mconcat ["type ", fullName, " =\n"], + " {\n", + fieldsOutput, + " }" + ] + fieldsOutput = fields & fmap (outputField 8) & mconcat + decoderOutput = outputStructDecoder name fields typeVariables + encoderOutput = outputStructEncoder fields typeVariables + in mconcat [typeOutput, "\n\n", decoderOutput, "\n\n", encoderOutput] + +outputStructDecoder :: Text -> [StructField] -> [TypeVariable] -> Text +outputStructDecoder name fields typeVariables = + let prelude = + mconcat [" static member Decoder", maybeArguments, ": Decoder<", fullName, "> =\n"] + fullName = + if null typeVariables then name else mconcat [name, joinTypeVariables typeVariables] + maybeArguments = typeVariableDecodersAsArguments typeVariables + interface = + fields & fmap (outputDecoderForField >>> addIndentation) & Text.intercalate "\n" + addIndentation = (" " <>) + in mconcat + [ mconcat + [ prelude, + " Decode.object (fun get ->\n", + " {\n", + mconcat [interface, "\n"], + " }\n", + " )" + ] + ] + +outputStructEncoder :: [StructField] -> [TypeVariable] -> Text +outputStructEncoder fields typeVariables = + let prelude = + mconcat [" static member Encoder", maybeArguments, " value =\n"] + maybeArguments = typeVariableEncodersAsArguments typeVariables + interface = + fields & fmap (outputEncoderForField >>> addIndentation) & Text.intercalate "\n" + addIndentation = (" " <>) + in mconcat + [ mconcat + [ prelude, + " Encode.object\n", + " [\n", + mconcat [interface, "\n"], + " ]" + ] + ] + +outputDecoderForField :: StructField -> Text +outputDecoderForField (StructField (FieldName fieldName) (ComplexType (OptionalType fieldType))) = + mconcat + [ upperCaseFirstCharacter fieldName, + " = ", + "get.Optional.Field", + " \"", + fieldName, + "\" ", + decoderForFieldType fieldType + ] +outputDecoderForField (StructField (FieldName fieldName) fieldType) = + mconcat + [ upperCaseFirstCharacter fieldName, + " = ", + "get.Required.Field", + " \"", + fieldName, + "\" ", + decoderForFieldType fieldType + ] + +outputEncoderForField :: StructField -> Text +outputEncoderForField = outputEncoderForFieldWithValueName "value" + +outputEncoderForFieldWithValueName :: Text -> StructField -> Text +outputEncoderForFieldWithValueName + _valueName + (StructField (FieldName fieldName) fieldType@(LiteralType _)) = + mconcat ["\"", fieldName, "\", ", encoderForFieldType ("", "") fieldType] +outputEncoderForFieldWithValueName valueName (StructField (FieldName fieldName) fieldType) = + mconcat + [ "\"", + fieldName, + "\", ", + encoderForFieldType ("", "") fieldType, + " ", + valueName, + ".", + upperCaseFirstCharacter fieldName + ] + +decoderForFieldType :: FieldType -> Text +decoderForFieldType (LiteralType literalType) = decoderForLiteralType literalType +decoderForFieldType (BasicType basicType) = decoderForBasicType basicType +decoderForFieldType (ComplexType complexType) = decoderForComplexType complexType +decoderForFieldType (DefinitionReferenceType definitionReference) = + decoderForDefinitionReference definitionReference +decoderForFieldType (TypeVariableReferenceType (TypeVariable name)) = "decode" <> name +decoderForFieldType (RecursiveReferenceType (DefinitionName name)) = name <> ".Decoder" + +decoderForBasicType :: BasicTypeValue -> Text +decoderForBasicType BasicString = "Decode.string" +decoderForBasicType U8 = "Decode.byte" +decoderForBasicType U16 = "Decode.uint16" +decoderForBasicType U32 = "Decode.uint32" +decoderForBasicType U64 = "Decode.uint64" +decoderForBasicType U128 = "Decode.uint128" +decoderForBasicType I8 = "Decode.int8" +decoderForBasicType I16 = "Decode.int16" +decoderForBasicType I32 = "Decode.int32" +decoderForBasicType I64 = "Decode.int64" +decoderForBasicType I128 = "Decode.int128" +decoderForBasicType F32 = "Decode.float32" +decoderForBasicType F64 = "Decode.float64" +decoderForBasicType Boolean = "Decode.bool" + +decoderForLiteralType :: LiteralTypeValue -> Text +decoderForLiteralType (LiteralString s) = "(GotynoCoders.decodeLiteralString \"" <> s <> "\")" +decoderForLiteralType (LiteralInteger i) = "(GotynoCoders.decodeLiteralInteger " <> tshow i <> ")" +decoderForLiteralType (LiteralFloat f) = "(GotynoCoders.decodeLiteralFloat " <> tshow f <> ")" +decoderForLiteralType (LiteralBoolean b) = + "(GotynoCoders.decodeLiteralBoolean " <> bool "false" "true" b <> ")" + +decoderForComplexType :: ComplexTypeValue -> Text +decoderForComplexType (PointerType fieldType) = decoderForFieldType fieldType +decoderForComplexType (ArrayType _size fieldType) = + mconcat ["(Decode.list ", decoderForFieldType fieldType, ")"] +decoderForComplexType (SliceType fieldType) = + mconcat ["(Decode.list ", decoderForFieldType fieldType, ")"] +decoderForComplexType (OptionalType fieldType) = + mconcat ["(Decode.option ", decoderForFieldType fieldType, ")"] + +decoderForDefinitionReference :: DefinitionReference -> Text +decoderForDefinitionReference + ( DefinitionReference + (TypeDefinition (DefinitionName name) _typeData) + ) = + name <> ".Decoder" +decoderForDefinitionReference + ( ImportedDefinitionReference + (ModuleName moduleName) + (TypeDefinition (DefinitionName name) _typeData) + ) = + mconcat [fsharpifyModuleName moduleName, ".", name, ".Decoder"] +decoderForDefinitionReference + ( AppliedGenericReference + appliedTypes + (TypeDefinition (DefinitionName name) _typeData) + ) = + let appliedDecoders = appliedTypes & fmap decoderForFieldType & Text.intercalate " " + in mconcat ["(", name, ".Decoder ", appliedDecoders, ")"] +decoderForDefinitionReference + ( AppliedImportedGenericReference + (ModuleName moduleName) + (AppliedTypes appliedTypes) + (TypeDefinition (DefinitionName name) _typeData) + ) = + let appliedDecoders = appliedTypes & fmap decoderForFieldType & Text.intercalate " " + in mconcat ["(", fsharpifyModuleName moduleName, ".", name, ".Decoder ", appliedDecoders, ")"] +decoderForDefinitionReference + ( GenericDeclarationReference + (ModuleName moduleName) + (DefinitionName name) + (AppliedTypes appliedTypes) + ) = + let appliedDecoders = appliedTypes & fmap decoderForFieldType & Text.intercalate " " + in mconcat ["(", fsharpifyModuleName moduleName, ".", name, ".Decoder ", appliedDecoders, ")"] +decoderForDefinitionReference + (DeclarationReference (ModuleName moduleName) (DefinitionName name)) = + mconcat [fsharpifyModuleName moduleName, ".", name, ".Decoder"] + +encoderForFieldType :: (Text, Text) -> FieldType -> Text +encoderForFieldType (_l, _r) (LiteralType literalType) = encoderForLiteralType literalType +encoderForFieldType (_l, _r) (BasicType basicType) = encoderForBasicType basicType +encoderForFieldType (_l, _r) (ComplexType complexType@(PointerType _)) = + encoderForComplexType complexType +encoderForFieldType (l, r) (ComplexType complexType) = l <> encoderForComplexType complexType <> r +encoderForFieldType (_l, _r) (DefinitionReferenceType definitionReference) = + encoderForDefinitionReference definitionReference +encoderForFieldType (_l, _r) (TypeVariableReferenceType (TypeVariable name)) = "encode" <> name +encoderForFieldType (_l, _r) (RecursiveReferenceType (DefinitionName name)) = name <> ".Encoder" + +encoderForBasicType :: BasicTypeValue -> Text +encoderForBasicType BasicString = "Encode.string" +encoderForBasicType U8 = "Encode.byte" +encoderForBasicType U16 = "Encode.uint16" +encoderForBasicType U32 = "Encode.uint32" +encoderForBasicType U64 = "Encode.uint64" +encoderForBasicType U128 = "Encode.uint128" +encoderForBasicType I8 = "Encode.int8" +encoderForBasicType I16 = "Encode.int16" +encoderForBasicType I32 = "Encode.int32" +encoderForBasicType I64 = "Encode.int64" +encoderForBasicType I128 = "Encode.int128" +encoderForBasicType F32 = "Encode.float32" +encoderForBasicType F64 = "Encode.float64" +encoderForBasicType Boolean = "Encode.bool" + +encoderForLiteralType :: LiteralTypeValue -> Text +encoderForLiteralType (LiteralString s) = "Encode.string \"" <> s <> "\"" +encoderForLiteralType (LiteralInteger i) = "Encode.int32 " <> tshow i +encoderForLiteralType (LiteralFloat f) = "Encode.float32 " <> tshow f +encoderForLiteralType (LiteralBoolean b) = + "Encode.bool " <> bool "false" "true" b + +encoderForComplexType :: ComplexTypeValue -> Text +encoderForComplexType (PointerType fieldType) = encoderForFieldType ("", "") fieldType +encoderForComplexType (ArrayType _size fieldType) = + mconcat ["GotynoCoders.encodeList ", encoderForFieldType ("(", ")") fieldType] +encoderForComplexType (SliceType fieldType) = + mconcat ["GotynoCoders.encodeList ", encoderForFieldType ("(", ")") fieldType] +encoderForComplexType (OptionalType fieldType) = + mconcat ["Encode.option ", encoderForFieldType ("(", ")") fieldType, ""] + +encoderForDefinitionReference :: DefinitionReference -> Text +encoderForDefinitionReference + ( DefinitionReference + (TypeDefinition (DefinitionName name) _typeData) + ) = + name <> ".Encoder" +encoderForDefinitionReference + ( ImportedDefinitionReference + (ModuleName moduleName) + (TypeDefinition (DefinitionName name) _typeData) + ) = + mconcat [fsharpifyModuleName moduleName, ".", name, ".Encoder"] +encoderForDefinitionReference + ( AppliedGenericReference + appliedTypes + (TypeDefinition (DefinitionName name) _typeData) + ) = + let appliedEncoders = appliedTypes & fmap (encoderForFieldType ("", "")) & Text.intercalate " " + in mconcat ["(", name, ".Encoder ", appliedEncoders, ")"] +encoderForDefinitionReference + ( AppliedImportedGenericReference + (ModuleName moduleName) + (AppliedTypes appliedTypes) + (TypeDefinition (DefinitionName name) _typeData) + ) = + let appliedEncoders = appliedTypes & fmap (encoderForFieldType ("", "")) & Text.intercalate " " + in mconcat ["(", fsharpifyModuleName moduleName, ".", name, ".Encoder ", appliedEncoders, ")"] +encoderForDefinitionReference + ( GenericDeclarationReference + (ModuleName moduleName) + (DefinitionName name) + (AppliedTypes appliedTypes) + ) = + let appliedEncoders = appliedTypes & fmap (encoderForFieldType ("", "")) & Text.intercalate " " + in mconcat ["(", fsharpifyModuleName moduleName, ".", name, ".Encoder ", appliedEncoders, ")"] +encoderForDefinitionReference + (DeclarationReference (ModuleName moduleName) (DefinitionName name)) = + mconcat [fsharpifyModuleName moduleName, ".", name, ".Encoder"] + +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 + decoderOutput = outputUnionDecoder typeTag name (constructorsFrom unionType) typeVariables + encoderOutput = outputUnionEncoder typeTag (constructorsFrom unionType) typeVariables + typeVariables = case unionType of + PlainUnion _constructors -> [] + GenericUnion ts _constructors -> ts + in Text.intercalate + "\n\n" + [ caseUnionOutput, + decoderOutput, + encoderOutput + ] + +outputUnionDecoder :: FieldName -> Text -> [Constructor] -> [TypeVariable] -> Text +outputUnionDecoder (FieldName tag) unionName constructors typeVariables = + let constructorDecodersOutput = + constructors + & fmap (outputConstructorDecoder unionName typeVariables) + & Text.intercalate "\n\n" + tagAndDecoderOutput = + constructors + & fmap + ( \(Constructor (ConstructorName name) payload) -> + let payloadTypeVariables = fromMaybe [] $ foldMap typeVariablesFrom payload + maybeDecoderArguments = typeVariableDecodersAsArguments payloadTypeVariables + in mconcat + [ " \"", + name, + "\", ", + unionName, + ".", + upperCaseFirstCharacter name, + "Decoder", + maybeDecoderArguments, + "\n" + ] + ) + & mconcat + fullName = + if null typeVariables + then unionName + else mconcat [unionName, joinTypeVariables typeVariables] + maybeArguments = typeVariableDecodersAsArguments typeVariables + in mconcat + [ mconcat [constructorDecodersOutput, "\n\n"], + mconcat [" static member Decoder", maybeArguments, ": Decoder<", fullName, "> =\n"], + mconcat [" GotynoCoders.decodeWithTypeTag\n"], + mconcat [" \"", tag, "\"\n"], + mconcat [" [|\n"], + tagAndDecoderOutput, + mconcat [" |]"] + ] + +typeVariableDecodersAsArguments :: [TypeVariable] -> Text +typeVariableDecodersAsArguments [] = "" +typeVariableDecodersAsArguments typeVariables = + " " <> (decodersForTypeVariables typeVariables & Text.intercalate " ") + +decodersForTypeVariables :: [TypeVariable] -> [Text] +decodersForTypeVariables = fmap (TypeVariableReferenceType >>> decoderForFieldType) + +typeVariableEncodersAsArguments :: [TypeVariable] -> Text +typeVariableEncodersAsArguments [] = "" +typeVariableEncodersAsArguments typeVariables = + " " <> (encodersForTypeVariables typeVariables & Text.intercalate " ") + +encodersForTypeVariables :: [TypeVariable] -> [Text] +encodersForTypeVariables = fmap (TypeVariableReferenceType >>> encoderForFieldType ("", "")) + +outputConstructorDecoder :: Text -> [TypeVariable] -> Constructor -> Text +outputConstructorDecoder unionName typeVariables (Constructor (ConstructorName name) maybePayload) = + let decoder = maybe alwaysSucceedingDecoder decoderWithDataField maybePayload + constructorName = upperCaseFirstCharacter name + alwaysSucceedingDecoder = mconcat ["Decode.succeed ", constructorName] + payloadTypeVariables = fromMaybe [] $ foldMap typeVariablesFrom maybePayload + maybeArguments = typeVariableDecodersAsArguments payloadTypeVariables + fullName = + if null typeVariables + then unionName + else mconcat [unionName, joinTypeVariables typeVariables] + decoderWithDataField payload = + mconcat + [ "Decode.object (fun get -> ", + constructorName, + "(get.Required.Field \"data\" ", + decoderForFieldType payload, + "))" + ] + in mconcat + [ mconcat + [ " static member ", + constructorName, + "Decoder", + maybeArguments, + ": Decoder<", + fullName, + "> =\n" + ], + mconcat [" ", decoder] + ] + +outputUnionEncoder :: FieldName -> [Constructor] -> [TypeVariable] -> Text +outputUnionEncoder typeTag constructors typeVariables = + let caseEncodingOutput = + constructors & fmap (outputConstructorEncoder typeTag) & Text.intercalate "\n\n" + maybeArguments = typeVariableEncodersAsArguments typeVariables + in mconcat + [ mconcat [" static member Encoder", maybeArguments, " =\n"], + mconcat [" function\n"], + caseEncodingOutput + ] + +outputConstructorEncoder :: FieldName -> Constructor -> Text +outputConstructorEncoder (FieldName tag) (Constructor (ConstructorName name) maybePayload) = + let dataPart = maybe "" encoderWithDataField maybePayload + typeTagPart = mconcat ["\"", tag, "\", Encode.string \"", name, "\""] + dataIndentation = " " + encoderWithDataField payload = + mconcat ["\n", dataIndentation, "\"data\", ", encoderForFieldType ("", "") payload, " payload"] + interface = mconcat ["[ ", typeTagPart, dataPart, " ]"] + maybePayloadPart = maybe "" (const " payload") maybePayload + in mconcat + [ mconcat [" | ", upperCaseFirstCharacter name, maybePayloadPart, " ->\n"], + mconcat [" Encode.object ", interface] + ] + +outputCaseUnion :: Text -> [Constructor] -> [TypeVariable] -> Text +outputCaseUnion name constructors typeVariables = + let cases = + constructors + & fmap + ( \(Constructor (ConstructorName constructorName) maybePayload) -> + let payload = maybe "" (outputFieldType >>> (" of " <>)) maybePayload + in mconcat [" | ", upperCaseFirstCharacter constructorName, payload] + ) + & Text.intercalate "\n" + maybeTypeVariables = if null typeVariables then "" else joinTypeVariables typeVariables + in mconcat + [ mconcat ["type ", name, maybeTypeVariables, " =\n"], + 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 fieldTypes) + ) = + let typeVariables = fieldTypes & 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 + +outputField :: Int -> StructField -> Text +outputField indentation (StructField (FieldName name) fieldType) = + let indent = Text.pack $ replicate indentation ' ' + in indent <> mconcat [upperCaseFirstCharacter name, ": ", outputFieldType fieldType, "\n"] + +outputFieldType :: FieldType -> Text +outputFieldType (LiteralType (LiteralString _text)) = outputBasicType BasicString +outputFieldType (LiteralType (LiteralInteger _x)) = outputBasicType I32 +outputFieldType (LiteralType (LiteralFloat _f)) = outputBasicType F32 +outputFieldType (LiteralType (LiteralBoolean _b)) = outputBasicType Boolean +outputFieldType (BasicType basicType) = outputBasicType basicType +outputFieldType (ComplexType (OptionalType fieldType)) = + mconcat ["option<", outputFieldType fieldType, ">"] +outputFieldType (ComplexType (ArrayType _size fieldType)) = + mconcat ["list<", outputFieldType fieldType, ">"] +outputFieldType (ComplexType (SliceType fieldType)) = + mconcat ["list<", outputFieldType fieldType, ">"] +outputFieldType (ComplexType (PointerType fieldType)) = outputFieldType fieldType +outputFieldType (RecursiveReferenceType (DefinitionName name)) = name +outputFieldType (DefinitionReferenceType definitionReference) = + outputDefinitionReference definitionReference +outputFieldType (TypeVariableReferenceType (TypeVariable t)) = fsharpifyTypeVariable t + +fsharpifyTypeVariable :: Text -> Text +fsharpifyTypeVariable t = t & Text.toLower & ("'" <>) + +outputDefinitionReference :: DefinitionReference -> Text +outputDefinitionReference (DefinitionReference (TypeDefinition (DefinitionName name) _)) = name +outputDefinitionReference + ( ImportedDefinitionReference + (ModuleName moduleName) + (TypeDefinition (DefinitionName name) _typeData) + ) = + mconcat [fsharpifyModuleName 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 [fsharpifyModuleName moduleName, ".", name, "<", appliedFieldTypes, ">"] +outputDefinitionReference + ( GenericDeclarationReference + (ModuleName moduleName) + (DefinitionName name) + (AppliedTypes appliedTypes) + ) = + let appliedFieldTypes = appliedTypes & fmap outputFieldType & Text.intercalate ", " + maybeAppliedOutput = if null appliedTypes then "" else mconcat ["<", appliedFieldTypes, ">"] + in mconcat [fsharpifyModuleName moduleName, ".", name, maybeAppliedOutput] +outputDefinitionReference (DeclarationReference (ModuleName moduleName) (DefinitionName name)) = + mconcat [fsharpifyModuleName moduleName, ".", name] + +outputBasicType :: BasicTypeValue -> Text +outputBasicType BasicString = "string" +outputBasicType U8 = "uint8" +outputBasicType U16 = "uint16" +outputBasicType U32 = "uint32" +outputBasicType U64 = "uint64" +outputBasicType U128 = "uint128" +outputBasicType I8 = "int8" +outputBasicType I16 = "int16" +outputBasicType I32 = "int32" +outputBasicType I64 = "int64" +outputBasicType I128 = "int128" +outputBasicType F32 = "float32" +outputBasicType F64 = "float64" +outputBasicType Boolean = "bool" + +fieldTypeName :: FieldType -> Text +fieldTypeName (LiteralType _) = error "Just don't use literals in untagged unions" +fieldTypeName (RecursiveReferenceType _) = + error "Just don't use recursive references in untagged unions" +fieldTypeName (BasicType BasicString) = "String" +fieldTypeName (BasicType F32) = "F32" +fieldTypeName (BasicType F64) = "F64" +fieldTypeName (BasicType U8) = "U8" +fieldTypeName (BasicType U16) = "U16" +fieldTypeName (BasicType U32) = "U32" +fieldTypeName (BasicType U64) = "U64" +fieldTypeName (BasicType U128) = "U128" +fieldTypeName (BasicType I8) = "I8" +fieldTypeName (BasicType I16) = "I16" +fieldTypeName (BasicType I32) = "I32" +fieldTypeName (BasicType I64) = "I64" +fieldTypeName (BasicType I128) = "I128" +fieldTypeName (BasicType Boolean) = "Boolean" +fieldTypeName (TypeVariableReferenceType (TypeVariable t)) = t +fieldTypeName (ComplexType (ArrayType _ arrayFieldType)) = + "ArrayOf" <> fieldTypeName arrayFieldType +fieldTypeName (ComplexType (SliceType sliceFieldType)) = + "SliceOf" <> fieldTypeName sliceFieldType +fieldTypeName (ComplexType (PointerType pointerFieldType)) = fieldTypeName pointerFieldType +fieldTypeName (ComplexType (OptionalType optionalFieldType)) = + "OptionalOf" <> fieldTypeName optionalFieldType +fieldTypeName + ( DefinitionReferenceType + (DefinitionReference (TypeDefinition (DefinitionName definitionName) _)) + ) = + definitionName +fieldTypeName + ( DefinitionReferenceType + (ImportedDefinitionReference _ (TypeDefinition (DefinitionName definitionName) _)) + ) = + definitionName +fieldTypeName + ( DefinitionReferenceType + ( AppliedGenericReference + fieldTypes + (TypeDefinition (DefinitionName definitionName) _) + ) + ) = + mconcat [definitionName, "Of", fieldTypes & fmap fieldTypeName & mconcat] +fieldTypeName + ( DefinitionReferenceType + ( AppliedImportedGenericReference + _moduleName + (AppliedTypes fieldTypes) + (TypeDefinition (DefinitionName definitionName) _) + ) + ) = + mconcat [definitionName, "Of", fieldTypes & fmap fieldTypeName & mconcat] +fieldTypeName + ( DefinitionReferenceType + ( GenericDeclarationReference + (ModuleName _moduleName) + (DefinitionName definitionName) + (AppliedTypes fieldTypes) + ) + ) = + mconcat [definitionName, "Of", fieldTypes & fmap fieldTypeName & mconcat] +fieldTypeName + (DefinitionReferenceType (DeclarationReference _moduleName (DefinitionName definitionName))) = + definitionName + +joinTypeVariables :: [TypeVariable] -> Text +joinTypeVariables typeVariables = + typeVariables + & fmap (\(TypeVariable t) -> fsharpifyTypeVariable t) + & Text.intercalate ", " + & (\o -> "<" <> o <> ">") diff --git a/src/CodeGeneration/Python.hs b/src/CodeGeneration/Python.hs new file mode 100644 --- /dev/null +++ b/src/CodeGeneration/Python.hs @@ -0,0 +1,1264 @@ +module CodeGeneration.Python (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 & Text.intercalate "\n" + outputImport (Import Module {name = ModuleName importName}) = + mconcat ["from . import ", importName] + declarationImportsOutput = + declarationNames + & fmap + ( \(ModuleName name) -> + mconcat ["from . import ", name] + ) + & Text.intercalate "\n" + in mconcat + [ mconcat + [ "import json\n", + "import typing\n", + "from dataclasses import dataclass\n", + "from gotyno_validation import validation\n", + "from gotyno_validation import encoding\n\n" + ], + importsOutput, + if null imports then "" else "\n\n", + declarationImportsOutput, + if null declarationNames then "" else "\n\n", + definitionOutput + ] + +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 _name (DeclaredType _moduleName _typeVariables)) = Nothing + +outputEmbeddedUnion :: Text -> FieldName -> [EmbeddedConstructor] -> Text +outputEmbeddedUnion unionName fieldName constructors = + let baseClassOutput = + outputUnionBaseClass + unionName + fieldName + (embeddedConstructorsToConstructors constructors) + [] + casesOutput = outputEmbeddedUnionCases unionName fieldName constructors + in mconcat [baseClassOutput, "\n\n", casesOutput] + +outputEmbeddedUnionCases :: Text -> FieldName -> [EmbeddedConstructor] -> Text +outputEmbeddedUnionCases unionName fieldName = + fmap (outputEmbeddedUnionCase unionName fieldName) >>> Text.intercalate "\n\n" + +outputEmbeddedUnionCase :: Text -> FieldName -> EmbeddedConstructor -> Text +outputEmbeddedUnionCase + unionName + tag + constructor@(EmbeddedConstructor (ConstructorName name) Nothing) = + let validatorOutput = outputEmbeddedConstructorDecoder tag constructor + encoderOutput = outputEmbeddedConstructorEncoder tag constructor + in mconcat + [ "@dataclass\n", + mconcat ["class ", upperCaseFirstCharacter name, "(", unionName, "):\n"], + validatorOutput, + "\n\n", + encoderOutput + ] +outputEmbeddedUnionCase + unionName + tag + constructor@(EmbeddedConstructor (ConstructorName name) (Just reference)) = + let structFields = structFieldsFromReference reference + typesOutput = + structFields + & fmap + ( \(StructField (FieldName n) fieldType) -> + mconcat [" ", n, ": ", outputFieldType fieldType] + ) + & Text.intercalate "\n" + validatorOutput = outputEmbeddedConstructorDecoder tag constructor + encoderOutput = outputEmbeddedConstructorEncoder tag constructor + in mconcat + [ "@dataclass\n", + mconcat ["class ", upperCaseFirstCharacter name, "(", unionName, "):\n"], + typesOutput, + "\n\n", + validatorOutput, + "\n\n", + encoderOutput + ] + +outputEmbeddedConstructorDecoder :: FieldName -> EmbeddedConstructor -> Text +outputEmbeddedConstructorDecoder + (FieldName tag) + (EmbeddedConstructor (ConstructorName name) Nothing) = + let typeName = upperCaseFirstCharacter name + in mconcat + [ " @staticmethod\n", + mconcat [" def validate(value: validation.Unknown) -> validation.ValidationResult['", typeName, "']:\n"], + mconcat + [ " return validation.validate_with_type_tag_and_validator(value, '", + tag, + "', '", + name, + "', validation.validate_unknown, ", + typeName, + ")\n\n" + ], + " @staticmethod\n", + mconcat + [ " def decode(string: typing.Union[str, bytes]) -> validation.ValidationResult['", + typeName, + "']:\n" + ], + mconcat [" return validation.validate_from_string(string, ", typeName, ".validate)"] + ] +outputEmbeddedConstructorDecoder + (FieldName tag) + (EmbeddedConstructor (ConstructorName name) (Just reference)) = + let typeName = upperCaseFirstCharacter name + DefinitionName referenceName = nameOfReference reference + in mconcat + [ " @staticmethod\n", + mconcat [" def validate(value: validation.Unknown) -> validation.ValidationResult['", typeName, "']:\n"], + mconcat + [ " return validation.validate_with_type_tag_and_validator(value, '", + tag, + "', '", + name, + "', ", + referenceName, + ".validate, ", + typeName, + ")\n\n" + ], + " @staticmethod\n", + mconcat + [ " def decode(string: typing.Union[str, bytes]) -> validation.ValidationResult['", + typeName, + "']:\n" + ], + mconcat [" return validation.validate_from_string(string, ", typeName, ".validate)"] + ] + +outputEmbeddedConstructorEncoder :: FieldName -> EmbeddedConstructor -> Text +outputEmbeddedConstructorEncoder + (FieldName tag) + (EmbeddedConstructor (ConstructorName name) Nothing) = + let interface = mconcat ["{'", tag, "': '", name, "'}"] + in mconcat + [ " def to_json(self) -> typing.Dict[str, typing.Any]:\n", + mconcat [" return ", interface, "\n\n"], + " def encode(self) -> str:\n", + " return json.dumps(self.to_json())" + ] +outputEmbeddedConstructorEncoder + (FieldName tag) + (EmbeddedConstructor (ConstructorName name) (Just reference)) = + let DefinitionName referenceName = nameOfReference reference + interface = mconcat ["{'", tag, "': '", name, "', **", referenceName, ".to_json(self)}"] + in mconcat + [ " def to_json(self) -> typing.Dict[str, typing.Any]:\n", + mconcat [" return ", interface, "\n\n"], + " def encode(self) -> str:\n", + " return json.dumps(self.to_json())" + ] + +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 [unionName, " = ", "typing.Union[", unionOutput, "]"] + unionOutput = cases & fmap outputCase & Text.intercalate ", " + outputCase fieldType = outputFieldType fieldType + interfaceOutput = outputUntaggedUnionInterface unionName cases + in mconcat [typeOutput, "\n", interfaceOutput] + +outputUntaggedUnionInterface :: Text -> [FieldType] -> Text +outputUntaggedUnionInterface unionName cases = + let oneOfValidatorsOutput = + mconcat + [ "[", + cases + & fmap validatorForFieldType + & Text.intercalate ", ", + "]" + ] + oneOfToJSONInterface = + mconcat + [ "{", + cases + & fmap + ( \fieldType -> + fieldTypeName fieldType <> ": " <> encoderForFieldType ("", "") fieldType + ) + & Text.intercalate ", ", + "}" + ] + in mconcat + [ mconcat ["class ", unionName, "Interface:\n"], + " @staticmethod\n", + mconcat + [ " def validate(value: validation.Unknown) -> validation.ValidationResult['", + unionName, + "']:\n" + ], + mconcat + [ " return validation.validate_one_of(value, ", + oneOfValidatorsOutput, + ")\n\n" + ], + " @staticmethod\n", + mconcat + [ " def decode(string: typing.Union[str, bytes]) -> validation.ValidationResult['", + unionName, + "']:\n" + ], + mconcat + [ " return validation.validate_from_string(string, ", + unionName, + "Interface.validate)\n\n" + ], + " @staticmethod\n", + " def to_json(value) -> typing.Any:\n", + mconcat + [" return encoding.one_of_to_json(value, ", oneOfToJSONInterface, ")\n\n"], + " @staticmethod\n", + " def encode(value) -> str:\n", + " return json.dumps(value.to_json())" + ] + +outputEnumeration :: Text -> [EnumerationValue] -> Text +outputEnumeration name values = + let typeOutput = outputEnumerationType name values + validatorOutput = outputEnumerationValidator name + decoderOutput = outputEnumerationDecoder name + encoderOutput = outputEnumerationEncoder + in mconcat [typeOutput, "\n\n", validatorOutput, "\n\n", decoderOutput, "\n\n", encoderOutput] + +outputEnumerationType :: Text -> [EnumerationValue] -> Text +outputEnumerationType name values = + let valuesOutput = + values + & fmap + ( \(EnumerationValue (EnumerationIdentifier i) literal) -> + mconcat [" ", i, " = ", literalValue literal] + ) + & Text.intercalate "\n" + literalValue (LiteralString s) = "'" <> s <> "'" + literalValue (LiteralInteger i) = tshow i + literalValue (LiteralFloat f) = tshow f + literalValue (LiteralBoolean b) = tshow b + in mconcat [mconcat ["class ", name, "(enum.Enum):\n"], valuesOutput] + +outputEnumerationValidator :: Text -> Text +outputEnumerationValidator name = + mconcat + [ " @staticmethod\n", + mconcat + [ " def validate(value: validation.Unknown) -> validation.ValidationResult['", + name, + "']:\n" + ], + mconcat [" return validation.validate_enumeration_member(value, ", name, ")"] + ] + +outputEnumerationDecoder :: Text -> Text +outputEnumerationDecoder name = + mconcat + [ " @staticmethod\n", + mconcat + [ " def decode(string: typing.Union[str, bytes]) -> validation.ValidationResult['", + name, + "']:\n" + ], + mconcat [" return validation.validate_from_string(string, ", name, ".validate)"] + ] + +outputEnumerationEncoder :: Text +outputEnumerationEncoder = + mconcat + [ " def to_json(self) -> typing.Any:\n", + " return self.value\n\n", + " def encode(self) -> str:\n", + " return str(self.value)" + ] + +outputPlainStruct :: Text -> [StructField] -> Text +outputPlainStruct name fields = + let fieldsOutput = fields & fmap (outputField 4) & Text.intercalate "\n" + validatorOutput = outputStructValidator name fields [] + encoderOutput = outputStructEncoder fields [] + decoderOutput = outputStructDecoder name [] + in mconcat + [ mconcat ["@dataclass(frozen=True)\nclass ", name, ":\n"], + fieldsOutput, + "\n\n", + validatorOutput, + "\n\n", + decoderOutput, + "\n\n", + encoderOutput + ] + +outputGenericStruct :: Text -> [TypeVariable] -> [StructField] -> Text +outputGenericStruct name typeVariables fields = + let fullName = mconcat [name, "(typing.Generic", joinTypeVariables typeVariables, ")"] + typeOutput = + mconcat + [ mconcat ["@dataclass(frozen=True)\nclass ", fullName, ":\n"], + fieldsOutput + ] + fieldsOutput = fields & fmap (outputField 4) & Text.intercalate "\n" + validatorOutput = outputStructValidator name fields typeVariables + decoderOutput = outputStructDecoder name typeVariables + encoderOutput = outputStructEncoder fields typeVariables + typeVariableOutput = typeVariables & fmap outputTypeVariableDefinition & Text.intercalate "\n" + outputTypeVariableDefinition (TypeVariable t) = mconcat [t, " = typing.TypeVar('", t, "')"] + in mconcat + [ typeVariableOutput, + "\n", + typeOutput, + "\n\n", + validatorOutput, + "\n\n", + decoderOutput, + "\n\n", + encoderOutput + ] + +outputStructValidator :: Text -> [StructField] -> [TypeVariable] -> Text +outputStructValidator name fields typeVariables = + let validateFunctionOutput = + if null typeVariables + then plainValidator + else genericValidator + fullName = + if null typeVariables + then name + else mconcat [name, joinTypeVariables typeVariables] + plainValidator = + mconcat + [ mconcat + [ " def validate(value: validation.Unknown) -> validation.ValidationResult['", + name, + "']:\n" + ], + mconcat + [ " return validation.validate_interface(value, ", + interface, + ", ", + name, + ")" + ] + ] + genericValidator = + let validatorName = + mconcat + [ "validate_", + name, + typeVariables & fmap (\(TypeVariable t) -> t) & Text.intercalate "" + ] + in mconcat + [ mconcat + [ " def validate(", + typeVariableValidatorsAsArguments typeVariables, + ") -> validation.Validator['", + fullName, + "']:\n" + ], + mconcat + [ " def ", + validatorName, + "(value: validation.Unknown) -> validation.ValidationResult['", + fullName, + "']:\n" + ], + mconcat + [ " return validation.validate_interface(value, ", + interface, + ", ", + name, + ")\n" + ], + mconcat [" return ", validatorName] + ] + interface = + mconcat ["{", fields & fmap outputValidatorForField & Text.intercalate ", ", "}"] + in mconcat [" @staticmethod\n", validateFunctionOutput] + +outputStructDecoder :: Text -> [TypeVariable] -> Text +outputStructDecoder name typeVariables = + let decodeFunctionOutput = + if null typeVariables + then plainDecoder + else genericDecoder + fullName = + if null typeVariables + then name + else mconcat [name, joinTypeVariables typeVariables] + plainDecoder = + mconcat + [ mconcat + [ mconcat + [ " def decode(string: typing.Union[str, bytes]) -> validation.ValidationResult['", + name, + "']:\n" + ] + ], + mconcat [" return validation.validate_from_string(string, ", name, ".validate)"] + ] + genericDecoder = + mconcat + [ mconcat + [ " def decode(string: typing.Union[str, bytes], ", + validatorArguments, + ") -> validation.ValidationResult['", + fullName, + "']:\n" + ], + mconcat + [ " return validation.validate_from_string(string, ", + name, + ".validate(", + typeVariables + & fmap (TypeVariableReferenceType >>> validatorForFieldType) + & Text.intercalate ", ", + "))" + ] + ] + validatorArguments = + typeVariableValidatorsAsArguments typeVariables + in mconcat [" @staticmethod\n", decodeFunctionOutput] + +outputStructEncoder :: [StructField] -> [TypeVariable] -> Text +outputStructEncoder fields typeVariables = + let interface = + mconcat + ["{", fields & fmap outputEncoderForField & Text.intercalate ", ", "}"] + maybeTypeVariableToJSONArguments = + if null typeVariables + then "" + else + ", " + <> ( typeVariables + & fmap + ( \(TypeVariable t) -> + mconcat [t, "_to_json: encoding.ToJSON[", t, "]"] + ) + & Text.intercalate ", " + ) + maybePassedInToJSONs = + if null typeVariables + then "" + else typeVariables & fmap (\(TypeVariable t) -> t <> "_to_json") & Text.intercalate ", " + in mconcat + [ mconcat [" def to_json(self", maybeTypeVariableToJSONArguments, ") -> typing.Dict[str, typing.Any]:\n"], + mconcat [" return ", interface, "\n\n"], + mconcat [" def encode(self", maybeTypeVariableToJSONArguments, ") -> str:\n"], + mconcat [" return json.dumps(self.to_json(", maybePassedInToJSONs, "))"] + ] + +outputValidatorForField :: StructField -> Text +outputValidatorForField (StructField (FieldName fieldName) fieldType) = + mconcat + [ "'", + fieldName, + "': ", + validatorForFieldType fieldType + ] + +outputEncoderForField :: StructField -> Text +outputEncoderForField + (StructField (FieldName fieldName) fieldType@(LiteralType _)) = + mconcat ["'", fieldName, "': ", encoderForFieldType ("", "") fieldType] +outputEncoderForField + (StructField (FieldName fieldName) basicType@(BasicType t)) + | t `elem` [U64, U128, I64, I128] = + mconcat + [ "'", + fieldName, + "': ", + encoderForFieldType ("", "") basicType, + "(self.", + fieldName, + ")" + ] + | otherwise = mconcat ["'", fieldName, "': self.", fieldName] +outputEncoderForField + ( StructField + (FieldName fieldName) + (DefinitionReferenceType (AppliedGenericReference appliedTypeVariables _definition)) + ) = + let passedInToJSONs = + appliedTypeVariables & fmap (encoderForFieldType ("", "")) & Text.intercalate ", " + in mconcat ["'", fieldName, "': self.", fieldName, ".to_json(", passedInToJSONs, ")"] +outputEncoderForField + ( StructField + (FieldName fieldName) + ( DefinitionReferenceType + ( AppliedImportedGenericReference + _moduleName + (AppliedTypes appliedTypeVariables) + _definition + ) + ) + ) = + let passedInToJSONs = + appliedTypeVariables & fmap (encoderForFieldType ("", "")) & Text.intercalate ", " + in mconcat ["'", fieldName, "': self.", fieldName, ".to_json(", passedInToJSONs, ")"] +outputEncoderForField (StructField (FieldName fieldName) fieldType) = + mconcat + [ "'", + fieldName, + "': ", + encoderForFieldType ("", "") fieldType, + "(self.", + fieldName, + ")" + ] + +encoderForFieldType :: (Text, Text) -> FieldType -> Text +encoderForFieldType (_l, _r) (LiteralType literalType) = encoderForLiteralType literalType +encoderForFieldType (_l, _r) (BasicType basicType) = encoderForBasicType basicType +encoderForFieldType (l, r) (ComplexType complexType) = l <> encoderForComplexType complexType <> r +encoderForFieldType (_l, _r) (DefinitionReferenceType definitionReference) = + encoderForDefinitionReference definitionReference +encoderForFieldType (_l, _r) (TypeVariableReferenceType (TypeVariable name)) = name <> "_to_json" +encoderForFieldType (_l, _r) (RecursiveReferenceType (DefinitionName name)) = name <> ".to_json" + +encoderForBasicType :: BasicTypeValue -> Text +encoderForBasicType U64 = "encoding.bigint_to_json" +encoderForBasicType U128 = "encoding.bigint_to_json" +encoderForBasicType I64 = "encoding.bigint_to_json" +encoderForBasicType I128 = "encoding.bigint_to_json" +encoderForBasicType _ = "encoding.basic_to_json" + +encoderForLiteralType :: LiteralTypeValue -> Text +encoderForLiteralType (LiteralString s) = "'" <> s <> "'" +encoderForLiteralType (LiteralInteger i) = tshow i +encoderForLiteralType (LiteralFloat f) = tshow f +encoderForLiteralType (LiteralBoolean b) = tshow b + +encoderForComplexType :: ComplexTypeValue -> Text +encoderForComplexType (PointerType fieldType) = encoderForFieldType ("", "") fieldType +encoderForComplexType (ArrayType _size fieldType) = + mconcat ["encoding.list_to_json(", encoderForFieldType ("(", ")") fieldType, ")"] +encoderForComplexType (SliceType fieldType) = + mconcat ["encoding.list_to_json(", encoderForFieldType ("(", ")") fieldType, ")"] +encoderForComplexType (OptionalType fieldType) = + mconcat ["encoding.optional_to_json(", encoderForFieldType ("(", ")") fieldType, ")"] + +encoderForDefinitionReference :: DefinitionReference -> Text +encoderForDefinitionReference + ( DefinitionReference + (TypeDefinition (DefinitionName name) _typeData) + ) = + name <> ".to_json" +encoderForDefinitionReference + ( ImportedDefinitionReference + (ModuleName moduleName) + (TypeDefinition (DefinitionName name) _typeData) + ) = + mconcat [moduleName, ".", name, ".to_json"] +encoderForDefinitionReference + ( AppliedGenericReference + appliedTypes + (TypeDefinition (DefinitionName name) _typeData) + ) = + let appliedEncoders = appliedTypes & fmap (encoderForFieldType ("", "")) & Text.intercalate " " + in mconcat [name, ".to_json(", appliedEncoders, ")"] +encoderForDefinitionReference + ( AppliedImportedGenericReference + (ModuleName moduleName) + (AppliedTypes appliedTypes) + (TypeDefinition (DefinitionName name) _typeData) + ) = + let appliedEncoders = appliedTypes & fmap (encoderForFieldType ("", "")) & Text.intercalate " " + in mconcat [moduleName, ".", name, ".to_json(", appliedEncoders, ")"] +encoderForDefinitionReference + ( GenericDeclarationReference + (ModuleName moduleName) + (DefinitionName name) + (AppliedTypes appliedTypes) + ) = + let appliedEncoders = appliedTypes & fmap (encoderForFieldType ("", "")) & Text.intercalate " " + in mconcat [moduleName, ".", name, ".to_json(", appliedEncoders, ")"] +encoderForDefinitionReference + (DeclarationReference (ModuleName moduleName) (DefinitionName name)) = + mconcat [moduleName, ".", name, ".to_json"] + +validatorForFieldType :: FieldType -> Text +validatorForFieldType (LiteralType literalType) = validatorForLiteralType literalType +validatorForFieldType (BasicType basicType) = validatorForBasicType basicType +validatorForFieldType (ComplexType complexType) = validatorForComplexType complexType +validatorForFieldType (DefinitionReferenceType definitionReference) = + decoderForDefinitionReference definitionReference +validatorForFieldType (TypeVariableReferenceType (TypeVariable name)) = "validate_" <> name +validatorForFieldType (RecursiveReferenceType (DefinitionName name)) = name <> ".decode" + +validatorForBasicType :: BasicTypeValue -> Text +validatorForBasicType BasicString = "validation.validate_string" +validatorForBasicType U8 = "validation.validate_int" +validatorForBasicType U16 = "validation.validate_int" +validatorForBasicType U32 = "validation.validate_int" +validatorForBasicType U64 = "validation.validate_bigint" +validatorForBasicType U128 = "validation.validate_bigint" +validatorForBasicType I8 = "validation.validate_int" +validatorForBasicType I16 = "validation.validate_int" +validatorForBasicType I32 = "validation.validate_int" +validatorForBasicType I64 = "validation.validate_bigint" +validatorForBasicType I128 = "validation.validate_bigint" +validatorForBasicType F32 = "validation.validate_float" +validatorForBasicType F64 = "validation.validate_float" +validatorForBasicType Boolean = "validation.validate_bool" + +validatorForLiteralType :: LiteralTypeValue -> Text +validatorForLiteralType (LiteralString s) = "validation.validate_literal(\'" <> s <> "\')" +validatorForLiteralType (LiteralInteger i) = "validation.validate_literal(" <> tshow i <> ")" +validatorForLiteralType (LiteralFloat f) = "validation.validate_literal(" <> tshow f <> ")" +validatorForLiteralType (LiteralBoolean b) = "validation.validate_literal(" <> tshow b <> ")" + +validatorForComplexType :: ComplexTypeValue -> Text +validatorForComplexType (PointerType fieldType) = validatorForFieldType fieldType +validatorForComplexType (ArrayType _size fieldType) = + mconcat ["validation.validate_list(", validatorForFieldType fieldType, ")"] +validatorForComplexType (SliceType fieldType) = + mconcat ["validation.validate_list(", validatorForFieldType fieldType, ")"] +validatorForComplexType (OptionalType fieldType) = + mconcat ["validation.validate_optional(", validatorForFieldType fieldType, ")"] + +decoderForDefinitionReference :: DefinitionReference -> Text +decoderForDefinitionReference + ( DefinitionReference + (TypeDefinition (DefinitionName name) _typeData) + ) = + name <> ".validate" +decoderForDefinitionReference + ( ImportedDefinitionReference + (ModuleName moduleName) + (TypeDefinition (DefinitionName name) _typeData) + ) = + mconcat [moduleName, ".", name, ".validate"] +decoderForDefinitionReference + ( AppliedGenericReference + appliedTypes + (TypeDefinition (DefinitionName name) _typeData) + ) = + let appliedDecoders = appliedTypes & fmap validatorForFieldType & Text.intercalate " " + in mconcat [name, ".validate(", appliedDecoders, ")"] +decoderForDefinitionReference + ( AppliedImportedGenericReference + (ModuleName moduleName) + (AppliedTypes appliedTypes) + (TypeDefinition (DefinitionName name) _typeData) + ) = + let appliedDecoders = appliedTypes & fmap validatorForFieldType & Text.intercalate " " + in mconcat [moduleName, ".", name, ".validate(", appliedDecoders, ")"] +decoderForDefinitionReference + ( GenericDeclarationReference + (ModuleName moduleName) + (DefinitionName name) + (AppliedTypes appliedTypes) + ) = + let appliedDecoders = appliedTypes & fmap validatorForFieldType & Text.intercalate " " + in mconcat [moduleName, ".", name, ".validate(", appliedDecoders, ")"] +decoderForDefinitionReference + (DeclarationReference (ModuleName moduleName) (DefinitionName name)) = + mconcat [moduleName, ".", name, ".validate"] + +outputUnion :: Text -> FieldName -> UnionType -> Text +outputUnion name typeTag unionType = + let baseClassOutput = outputUnionBaseClass name typeTag (constructorsFrom unionType) typeVariables + casesOutput = outputUnionCases fullUnionName typeVariables typeTag (constructorsFrom unionType) + fullUnionName = + if null typeVariables + then name + else mconcat [name, joinTypeVariables typeVariables] + constructorsFrom (PlainUnion constructors) = constructors + constructorsFrom (GenericUnion _typeVariables constructors) = constructors + typeVariables = case unionType of + PlainUnion _constructors -> [] + GenericUnion ts _constructors -> ts + maybeTypeVariableOutput = + if null typeVariables + then "" + else + typeVariables + & fmap (\(TypeVariable t) -> mconcat [t, " = typing.TypeVar('", t, "')"]) + & Text.intercalate "\n" + & (<> "\n") + in mconcat [maybeTypeVariableOutput, baseClassOutput, "\n\n", casesOutput] + +outputUnionBaseClass :: Text -> FieldName -> [Constructor] -> [TypeVariable] -> Text +outputUnionBaseClass name tag constructors typeVariables = + let validatorOutput = outputUnionValidator name tag constructors typeVariables + decoderOutput = outputUnionDecoder name typeVariables + maybeGenericNotation = + if null typeVariables + then "" + else mconcat ["(typing.Generic", joinTypeVariables typeVariables, ")"] + maybeTypeVariableToJSONArguments = + if null typeVariables + then "" + else + mconcat + [ ", ", + typeVariables + & fmap (\(TypeVariable t) -> mconcat [t, "_to_json: encoding.ToJSON[", t, "]"]) + & Text.intercalate "," + ] + stubsOutput = + mconcat + [ " def to_json(self", + maybeTypeVariableToJSONArguments, + ") -> typing.Dict[str, typing.Any]:\n", + mconcat + [ " raise NotImplementedError('`to_json` is not implemented for base class `", + name, + "`')\n\n" + ], + " def encode(self) -> str:\n", + mconcat + [ " raise NotImplementedError('`encode` is not implemented for base class `", + name, + "`')" + ] + ] + in mconcat + [ mconcat ["class ", name, maybeGenericNotation, ":\n"], + validatorOutput, + "\n\n", + decoderOutput, + "\n\n", + stubsOutput + ] + +outputUnionValidator :: Text -> FieldName -> [Constructor] -> [TypeVariable] -> Text +outputUnionValidator name (FieldName tag) constructors typeVariables = + let taggedValidators = + constructors + & fmap + ( \(Constructor (ConstructorName constructorName) maybePayload) -> + let payloadTypeVariables = + fromMaybe [] $ foldMap typeVariablesFrom maybePayload + maybeTypeVariableValidatorArguments = + if null payloadTypeVariables + then "" + else + mconcat + [ "(", + payloadTypeVariables + & fmap (\(TypeVariable t) -> "validate_" <> t) + & Text.intercalate + ", ", + ")" + ] + in mconcat + [ "'", + constructorName, + "': ", + upperCaseFirstCharacter constructorName, + ".validate", + maybeTypeVariableValidatorArguments + ] + ) + & Text.intercalate ", " + interface = "{" <> taggedValidators <> "}" + functionHead [] = + mconcat [" def validate(value: validation.Unknown) -> validation.ValidationResult['", name, "']:\n"] + functionHead typeVariables' = + mconcat + [ " def validate(", + typeVariableValidatorsAsArguments typeVariables', + ") -> validation.Validator['", + fullName, + "']:\n" + ] + functionBody [] = + mconcat [" return validation.validate_with_type_tags(value, '", tag, "', ", interface, ")"] + functionBody typeVariables' = + let validatorName = + "validate_" <> name <> (typeVariables' & fmap (\(TypeVariable t) -> t) & mconcat) + in mconcat + [ mconcat + [ " def ", + validatorName, + "(value: validation.Unknown) -> validation.ValidationResult['", + fullName, + "']:\n" + ], + mconcat + [ " return validation.validate_with_type_tags(value, '", + tag, + "', ", + interface, + ")\n" + ], + mconcat [" return ", validatorName] + ] + fullName = + if null typeVariables + then name + else mconcat [name, joinTypeVariables typeVariables] + in mconcat + [ " @staticmethod\n", + functionHead typeVariables, + functionBody typeVariables + ] + +outputUnionDecoder :: Text -> [TypeVariable] -> Text +outputUnionDecoder unionName typeVariables = + let maybeTypeVariableValidatorArguments = + if null typeVariables + then "" + else + mconcat + [ ", ", + typeVariables + & fmap + ( \(TypeVariable t) -> + mconcat + [ "validate_" <> t, + ": validation.Validator[", + t, + "]" + ] + ) + & Text.intercalate + ", " + ] + maybePassedInValidators = + if null typeVariables + then "" + else + mconcat + [ "(", + typeVariables + & fmap (\(TypeVariable t) -> "validate_" <> t) + & Text.intercalate ", ", + ")" + ] + fullName = + if null typeVariables + then unionName + else mconcat [unionName, joinTypeVariables typeVariables] + in mconcat + [ " @staticmethod\n", + mconcat + [ " def decode(string: typing.Union[str, bytes]", + maybeTypeVariableValidatorArguments, + ") -> validation.ValidationResult['", + fullName, + "']:\n" + ], + mconcat + [ " return validation.validate_from_string(string, ", + unionName, + ".validate", + maybePassedInValidators, + ")" + ] + ] + +outputUnionCases :: Text -> [TypeVariable] -> FieldName -> [Constructor] -> Text +outputUnionCases unionName unionTypeVariables tag = + fmap (outputUnionCase unionName unionTypeVariables tag) >>> Text.intercalate "\n\n" + +outputUnionCase :: Text -> [TypeVariable] -> FieldName -> Constructor -> Text +outputUnionCase + unionName + unionTypeVariables + fieldName@(FieldName tag) + constructor@(Constructor (ConstructorName name) maybePayload) = + let payloadTypeVariables = + fromMaybe [] $ foldMap typeVariablesFrom maybePayload + fullName = + if null payloadTypeVariables + then name + else mconcat [name, joinTypeVariables payloadTypeVariables] + maybeDataField = + maybePayload & maybe "" (outputFieldType >>> (" data: " <>) >>> (<> "\n\n")) + interface = + mconcat ["{", maybePayload & maybe "" (validatorForFieldType >>> ("'data': " <>)), "}"] + validatorOutput = + mconcat + [ " @staticmethod\n", + validatorFunctionHead payloadTypeVariables, + validatorFunctionBody payloadTypeVariables + ] + validatorFunctionHead [] = + mconcat [" def validate(value: validation.Unknown) -> validation.ValidationResult['", name, "']:\n"] + validatorFunctionHead typeVariables = + mconcat + [ " def validate(", + typeVariableValidatorsAsArguments typeVariables, + ") -> validation.Validator['", + fullName, + "']:\n" + ] + validatorFunctionBody [] = + mconcat + [ " return validation.validate_with_type_tag(value, '", + tag, + "', '", + name, + "', ", + interface, + ", ", + name, + ")" + ] + validatorFunctionBody typeVariables = + let validatorName = + "validate_" <> name <> (typeVariables & fmap (\(TypeVariable t) -> t) & mconcat) + in mconcat + [ mconcat + [ " def ", + validatorName, + "(value: validation.Unknown) -> validation.ValidationResult['", + fullName, + "']:\n" + ], + mconcat + [ " return validation.validate_with_type_tag(value, '", + tag, + "', '", + name, + "', ", + interface, + ", ", + name, + ")\n" + ], + mconcat [" return ", validatorName] + ] + decoderOutput = + let maybeTypeVariableValidatorArguments = + if null payloadTypeVariables + then "" + else + mconcat + [ ", ", + payloadTypeVariables + & fmap (\(TypeVariable t) -> mconcat ["validate_" <> t, ": validation.Validator[", t, "]"]) + & Text.intercalate ", " + ] + maybePassedInValidators = + if null payloadTypeVariables + then "" + else + mconcat + [ "(", + payloadTypeVariables + & fmap (\(TypeVariable t) -> "validate_" <> t) + & Text.intercalate ", ", + ")" + ] + in mconcat + [ " @staticmethod\n", + mconcat + [ " def decode(string: typing.Union[str, bytes]", + maybeTypeVariableValidatorArguments, + ") -> validation.ValidationResult['", + fullName, + "']:\n" + ], + mconcat + [ " return validation.validate_from_string(string, ", + name, + ".validate", + maybePassedInValidators, + ")" + ] + ] + encoderOutput = outputEncoderForUnionConstructor unionTypeVariables fieldName constructor + in mconcat + [ "@dataclass(frozen=True)\n", + mconcat ["class ", name, "(", unionName, "):\n"], + maybeDataField, + validatorOutput, + "\n\n", + decoderOutput, + "\n\n", + encoderOutput + ] + +outputEncoderForUnionConstructor :: [TypeVariable] -> FieldName -> Constructor -> Text +outputEncoderForUnionConstructor + unionTypeVariables + (FieldName tag) + (Constructor (ConstructorName name) maybePayload) = + let maybeDataField = + maybe "" (dataEncoder >>> (", 'data': " <>)) maybePayload + dataEncoder (BasicType _) = "self.data" + dataEncoder (DefinitionReferenceType _) = + mconcat ["self.data.to_json(", maybePassedInToJSONs, ")"] + dataEncoder fieldType = mconcat [encoderForFieldType ("", "") fieldType, "(self.data)"] + maybeTypeVariableToJSONArguments = + if null unionTypeVariables + then "" + else + mconcat + [ ", ", + unionTypeVariables + & fmap + ( \(TypeVariable t) -> + mconcat [t, "_to_json: encoding.ToJSON[", t, "]"] + ) + & Text.intercalate ", " + ] + interface = mconcat ["{", mconcat ["'", tag, "': '", name, "'", maybeDataField], "}"] + maybePassedInToJSONs = + if null unionTypeVariables + then "" + else + unionTypeVariables + & fmap (\(TypeVariable t) -> t <> "_to_json") + & Text.intercalate ", " + in mconcat + [ mconcat [" def to_json(self", maybeTypeVariableToJSONArguments, ") -> typing.Dict[str, typing.Any]:\n"], + mconcat [" return ", interface, "\n\n"], + mconcat [" def encode(self", maybeTypeVariableToJSONArguments, ") -> str:\n"], + mconcat [" return json.dumps(self.to_json(", maybePassedInToJSONs, "))"] + ] + +typeVariableValidatorsAsArguments :: [TypeVariable] -> Text +typeVariableValidatorsAsArguments [] = "" +typeVariableValidatorsAsArguments typeVariables = + let types = fmap (\(TypeVariable t) -> mconcat ["validation.Validator[", t, "]"]) typeVariables + in typeVariables + & validatorsForTypeVariables + & zip types + & fmap (\(t, v) -> v <> ": " <> t) + & Text.intercalate ", " + +validatorsForTypeVariables :: [TypeVariable] -> [Text] +validatorsForTypeVariables = fmap (TypeVariableReferenceType >>> validatorForFieldType) + +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 fieldTypes) + ) = + let typeVariables = fieldTypes & 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 + +outputField :: Int -> StructField -> Text +outputField indentation (StructField (FieldName name) fieldType) = + let indent = Text.pack $ replicate indentation ' ' + in indent <> mconcat [name, ": ", outputFieldType fieldType] + +outputFieldType :: FieldType -> Text +outputFieldType (LiteralType (LiteralString text)) = "typing.Literal['" <> text <> "']" +outputFieldType (LiteralType (LiteralInteger x)) = "typing.Literal['" <> tshow x <> "']" +outputFieldType (LiteralType (LiteralFloat f)) = "typing.Literal['" <> tshow f <> "']" +outputFieldType (LiteralType (LiteralBoolean b)) = "typing.Literal['" <> tshow b <> "']" +outputFieldType (BasicType basicType) = outputBasicType basicType +outputFieldType (ComplexType (OptionalType fieldType)) = + mconcat ["typing.Optional[", outputFieldType fieldType, "]"] +outputFieldType (ComplexType (ArrayType _size fieldType)) = + mconcat ["typing.List[", outputFieldType fieldType, "]"] +outputFieldType (ComplexType (SliceType fieldType)) = + mconcat ["typing.List[", 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 appliedFieldTypes = appliedTypes & fmap outputFieldType & Text.intercalate ", " + maybeAppliedOutput = if null appliedTypes then "" else mconcat ["[", appliedFieldTypes, "]"] + in mconcat [moduleName, ".", name, maybeAppliedOutput] +outputDefinitionReference (DeclarationReference (ModuleName moduleName) (DefinitionName name)) = + mconcat [moduleName, ".", name] + +outputBasicType :: BasicTypeValue -> Text +outputBasicType BasicString = "str" +outputBasicType U8 = "int" +outputBasicType U16 = "int" +outputBasicType U32 = "int" +outputBasicType U64 = "int" +outputBasicType U128 = "int" +outputBasicType I8 = "int" +outputBasicType I16 = "int" +outputBasicType I32 = "int" +outputBasicType I64 = "int" +outputBasicType I128 = "int" +outputBasicType F32 = "float" +outputBasicType F64 = "float" +outputBasicType Boolean = "bool" + +fieldTypeName :: FieldType -> Text +fieldTypeName (LiteralType _) = error "Just don't use literals in untagged unions" +fieldTypeName (RecursiveReferenceType _) = + error "Just don't use recursive references in untagged unions" +fieldTypeName (BasicType BasicString) = "str" +fieldTypeName (BasicType F32) = "float" +fieldTypeName (BasicType F64) = "float" +fieldTypeName (BasicType U8) = "int" +fieldTypeName (BasicType U16) = "int" +fieldTypeName (BasicType U32) = "int" +fieldTypeName (BasicType U64) = "int" +fieldTypeName (BasicType U128) = "int" +fieldTypeName (BasicType I8) = "int" +fieldTypeName (BasicType I16) = "int" +fieldTypeName (BasicType I32) = "int" +fieldTypeName (BasicType I64) = "int" +fieldTypeName (BasicType I128) = "int" +fieldTypeName (BasicType Boolean) = "bool" +fieldTypeName (TypeVariableReferenceType (TypeVariable t)) = t +fieldTypeName (ComplexType (ArrayType _ _arrayFieldType)) = "list" +fieldTypeName (ComplexType (SliceType _sliceFieldType)) = "list" +fieldTypeName (ComplexType (PointerType pointerFieldType)) = fieldTypeName pointerFieldType +fieldTypeName (ComplexType (OptionalType optionalFieldType)) = fieldTypeName optionalFieldType +fieldTypeName + ( DefinitionReferenceType + (DefinitionReference (TypeDefinition (DefinitionName definitionName) _)) + ) = + definitionName +fieldTypeName + ( DefinitionReferenceType + (ImportedDefinitionReference _ (TypeDefinition (DefinitionName definitionName) _)) + ) = + definitionName +fieldTypeName + ( DefinitionReferenceType + ( AppliedGenericReference + _fieldTypes + (TypeDefinition (DefinitionName definitionName) _) + ) + ) = + definitionName +fieldTypeName + ( DefinitionReferenceType + ( AppliedImportedGenericReference + _moduleName + (AppliedTypes _fieldTypes) + (TypeDefinition (DefinitionName definitionName) _) + ) + ) = + definitionName +fieldTypeName + ( DefinitionReferenceType + ( GenericDeclarationReference + (ModuleName _moduleName) + (DefinitionName definitionName) + (AppliedTypes _fieldTypes) + ) + ) = + definitionName +fieldTypeName + (DefinitionReferenceType (DeclarationReference _moduleName (DefinitionName definitionName))) = + definitionName + +joinTypeVariables :: [TypeVariable] -> Text +joinTypeVariables typeVariables = + typeVariables + & fmap (\(TypeVariable t) -> t) + & Text.intercalate ", " + & (\o -> "[" <> o <> "]") + +nameOfReference :: DefinitionReference -> DefinitionName +nameOfReference (DefinitionReference (TypeDefinition name _)) = name +nameOfReference (ImportedDefinitionReference _moduleName (TypeDefinition name _)) = name +nameOfReference (AppliedGenericReference _fieldTypes (TypeDefinition name _)) = name +nameOfReference (AppliedImportedGenericReference _moduleName _fieldTypes (TypeDefinition name _)) = + name +nameOfReference (GenericDeclarationReference _moduleName name _fieldTypes) = name +nameOfReference (DeclarationReference _moduleName name) = name diff --git a/src/CodeGeneration/TypeScript.hs b/src/CodeGeneration/TypeScript.hs new file mode 100644 --- /dev/null +++ b/src/CodeGeneration/TypeScript.hs @@ -0,0 +1,1227 @@ +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 <> ">") diff --git a/src/CodeGeneration/Utilities.hs b/src/CodeGeneration/Utilities.hs new file mode 100644 --- /dev/null +++ b/src/CodeGeneration/Utilities.hs @@ -0,0 +1,11 @@ +module CodeGeneration.Utilities where + +import RIO +import qualified RIO.Char as Char +import qualified RIO.Text as Text + +upperCaseFirstCharacter :: Text -> Text +upperCaseFirstCharacter t = + case Text.uncons t of + Just (c, rest) -> Text.cons (Char.toUpper c) rest + Nothing -> t diff --git a/src/Library.hs b/src/Library.hs new file mode 100644 --- /dev/null +++ b/src/Library.hs @@ -0,0 +1,125 @@ +module Library where + +import qualified CodeGeneration.FSharp as FSharp +import qualified CodeGeneration.Python as Python +import qualified CodeGeneration.TypeScript as TypeScript +import qualified Data.Text.IO as TextIO +import qualified Parsing +import RIO +import qualified RIO.Directory as Directory +import qualified RIO.FilePath as FilePath +import qualified RIO.List as List +import qualified RIO.Time as Time +import qualified System.FSNotify as FSNotify +import Types +import Prelude (print, putStrLn) + +data OutputDestination + = SameAsInput + | OutputPath !FilePath + | StandardOut + deriving (Eq, Show) + +data Languages = Languages + { typescript :: !(Maybe OutputDestination), + fsharp :: !(Maybe OutputDestination), + python :: !(Maybe OutputDestination) + } + deriving (Eq, Show) + +data Options = Options + { languages :: !Languages, + watchMode :: !Bool, + verbose :: !Bool, + inputs :: ![FilePath] + } + deriving (Eq, Show) + +runMain :: Options -> IO () +runMain + Options + { languages = languages@Languages {typescript, fsharp, python}, + inputs, + watchMode, + verbose + } = do + when watchMode $ do + watchInputs inputs languages verbose + start <- Time.getCurrentTime + maybeModules <- Parsing.parseModules inputs + postParsing <- Time.getCurrentTime + case maybeModules of + Right modules -> do + startTS <- Time.getCurrentTime + forM_ typescript $ outputLanguage modules TypeScript.outputModule "ts" + endTS <- Time.getCurrentTime + startFS <- Time.getCurrentTime + forM_ fsharp $ outputLanguage modules FSharp.outputModule "fs" + endFS <- Time.getCurrentTime + startPython <- Time.getCurrentTime + forM_ python $ outputLanguage modules Python.outputModule "py" + endPython <- Time.getCurrentTime + end <- Time.getCurrentTime + let diff = Time.diffUTCTime end start + diffParsing = Time.diffUTCTime postParsing start + diffTS = Time.diffUTCTime endTS startTS + diffFS = Time.diffUTCTime endFS startFS + diffPython = Time.diffUTCTime endPython startPython + when verbose $ do + putStrLn $ "Parsing took: " <> show diffParsing + putStrLn $ "Outputting TypeScript took: " <> show diffTS + putStrLn $ "Outputting FSharp took: " <> show diffFS + putStrLn $ "Outputting Python took: " <> show diffPython + putStrLn $ "Entire compilation took: " <> show diff + Left errors -> forM_ errors putStrLn + +outputLanguage :: [Module] -> (Module -> Text) -> FilePath -> OutputDestination -> IO () +outputLanguage modules outputFunction extension outputDestination = do + let outputs = modules & fmap outputFunction & zip modules + case outputDestination of + StandardOut -> do + outputs & reverse & forM_ $ \(_module, output) -> TextIO.putStrLn output + SameAsInput -> do + forM_ outputs $ \(Module {sourceFile}, output) -> do + let pathForOutput = FilePath.replaceExtensions sourceFile extension + writeFileUtf8 pathForOutput output + OutputPath outputDirectory -> do + forM_ outputs $ \(Module {sourceFile}, output) -> do + let pathForOutput = + FilePath.replaceDirectory sourceFile outputDirectory + & flip FilePath.replaceExtensions extension + basePath = FilePath.takeDirectory pathForOutput + Directory.createDirectoryIfMissing True basePath + writeFileUtf8 pathForOutput output + +watchInputs :: [FilePath] -> Languages -> Bool -> IO () +watchInputs relativeInputs Languages {typescript, fsharp, python} verbose = do + inputs <- traverse Directory.makeAbsolute relativeInputs + let compileEverything = do + maybeModules <- Parsing.parseModules relativeInputs + case maybeModules of + Right modules -> do + forM_ typescript $ outputLanguage modules TypeScript.outputModule "ts" + forM_ fsharp $ outputLanguage modules FSharp.outputModule "fs" + forM_ python $ outputLanguage modules Python.outputModule "py" + Left errors -> + forM_ errors putStrLn + debounceInterval = 0.01 :: Time.NominalDiffTime + fsNotifyConfig = FSNotify.defaultConfig {FSNotify.confDebounce = FSNotify.Debounce debounceInterval} + compileEverything + FSNotify.withManagerConf fsNotifyConfig $ \watchManager -> do + let inputDirectories = inputs & fmap FilePath.takeDirectory & List.nub + eventPredicate (FSNotify.Modified modifiedInput _modificationTime _someBool) = + modifiedInput `elem` inputs + eventPredicate _otherEvents = False + forM_ inputDirectories $ \inputDirectory -> do + putStrLn $ "Watching directory: '" <> inputDirectory <> "'" + FSNotify.watchDir + watchManager + inputDirectory + eventPredicate + ( \event -> do + when verbose (print event) + compileEverything + ) + forever $ threadDelay 1000000 diff --git a/src/Parsing.hs b/src/Parsing.hs new file mode 100644 --- /dev/null +++ b/src/Parsing.hs @@ -0,0 +1,622 @@ +module Parsing where + +import RIO + ( Bool (..), + Char, + Either (..), + FilePath, + IO, + IORef, + Int, + Maybe (..), + RIO, + Set, + Show, + String, + Text, + Void, + any, + ask, + compare, + const, + error, + for, + fromMaybe, + isLeft, + maybe, + mconcat, + mempty, + modifyIORef, + newIORef, + not, + pure, + readFileUtf8, + readIORef, + runRIO, + show, + writeIORef, + ($), + ($>), + (&), + (*>), + (.), + (<$), + (<$>), + (<*), + (<>), + (==), + (>>>), + ) +import qualified RIO.FilePath as FilePath +import qualified RIO.List as List +import qualified RIO.Set as Set +import RIO.Text (pack, unpack) +import qualified RIO.Text as Text +import System.IO (putStrLn) +import Text.Megaparsec +import Text.Megaparsec.Char +import Text.Megaparsec.Char.Lexer +import Text.Show.Pretty (pPrint) +import Types + +data AppState = AppState + { modulesReference :: !(IORef [Module]), + currentImportsReference :: !(IORef [Import]), + currentDeclarationNamesReference :: !(IORef (Set ModuleName)), + currentDefinitionsReference :: !(IORef [TypeDefinition]), + currentDefinitionNameReference :: !(IORef (Maybe DefinitionName)) + } + +type Parser = ParsecT Void Text (RIO AppState) + +parseModules :: [FilePath] -> IO (Either [String] [Module]) +parseModules files = do + modulesReference <- newIORef [] + currentDefinitionsReference <- newIORef [] + currentImportsReference <- newIORef [] + currentDeclarationNamesReference <- newIORef Set.empty + currentDefinitionNameReference <- newIORef Nothing + let state = + AppState + { currentDefinitionsReference, + currentDefinitionNameReference, + currentImportsReference, + currentDeclarationNamesReference, + modulesReference + } + results <- for files $ \f -> do + let moduleName = f & FilePath.takeBaseName & pack & ModuleName + fileContents <- readFileUtf8 f + maybeModule <- run state fileContents $ moduleP moduleName f + case maybeModule of + Right module' -> do + addModule module' modulesReference + pure $ Right module' + Left e -> pure $ Left $ mconcat ["Error parsing module '", f, "': \n", errorBundlePretty e] + + case List.partition isLeft results of + ([], maybeModules) -> + pure $ Right $ List.map partialFromRight maybeModules + (errors, _modules) -> + pure $ Left $ List.map partialFromLeft errors + +run :: AppState -> Text -> Parser a -> IO (Either (ParseErrorBundle Text Void) a) +run state text parser = do + let parserResult = runParserT parser "" text + runRIO state parserResult + +test :: (Show a) => AppState -> Text -> Parser a -> IO () +test state text parser = do + result <- run state text parser + case result of + Right successValue -> pPrint successValue + Left e -> putStrLn $ errorBundlePretty e + +moduleP :: ModuleName -> FilePath -> Parser Module +moduleP name sourceFile = do + imports <- fromMaybe [] <$> optional (sepEndBy1 importP newline <* newline) + addImports imports + definitions <- sepBy1 typeDefinitionP (newline <* newline) <* eof + declarationNames <- Set.toList <$> getDeclarationNames + clearDeclarationNames + clearDefinitions + pure Module {name, imports, definitions, sourceFile, declarationNames} + +addImports :: [Import] -> Parser () +addImports imports = do + AppState {currentImportsReference} <- ask + writeIORef currentImportsReference imports + +addDeclarationName :: ModuleName -> Parser () +addDeclarationName moduleName = do + AppState {currentDeclarationNamesReference} <- ask + modifyIORef currentDeclarationNamesReference (Set.insert moduleName) + +getDeclarationNames :: Parser (Set ModuleName) +getDeclarationNames = do + AppState {currentDeclarationNamesReference} <- ask + readIORef currentDeclarationNamesReference + +clearDeclarationNames :: Parser () +clearDeclarationNames = do + AppState {currentDeclarationNamesReference} <- ask + writeIORef currentDeclarationNamesReference Set.empty + +importP :: Parser Import +importP = do + string "import " + importName <- some (alphaNumChar <|> char '_') + maybeModule <- getModule importName + case maybeModule of + Just module' -> do + pure $ Import module' + Nothing -> + reportError $ "Unknown module referenced: " <> importName + +getModule :: String -> Parser (Maybe Module) +getModule importName = do + AppState {modulesReference} <- ask + modules <- readIORef modulesReference + pure $ List.find (\Module {name = ModuleName name} -> name == pack importName) modules + +addModule :: Module -> IORef [Module] -> IO () +addModule module' modulesReference = do + modifyIORef modulesReference (module' :) + +typeDefinitionP :: Parser TypeDefinition +typeDefinitionP = do + keyword <- choice $ List.map string ["struct", "untagged union", "union", "enum", "declare"] + definition <- case keyword of + "struct" -> + char ' ' *> structP + "union" -> do + maybeTagType <- optional $ do + _ <- char '(' + tagTypeP <* char ')' + let tagType = fromMaybe (StandardTypeTag $ FieldName "type") maybeTagType + char ' ' *> case tagType of + StandardTypeTag fieldName -> + unionP fieldName + EmbeddedTypeTag fieldName -> + embeddedUnionP fieldName + "untagged union" -> + char ' ' *> untaggedUnionP + "enum" -> + char ' ' *> enumerationP + "declare" -> + char ' ' *> declarationP + other -> + reportError $ "Unknown type definition keyword: " <> unpack other + addDefinition definition + pure definition + +declarationP :: Parser TypeDefinition +declarationP = do + externalModule <- (pack >>> ModuleName) <$> some (alphaNumChar <|> char '_') <* char '.' + name <- readCurrentDefinitionName + typeVariables <- + (fromMaybe [] >>> List.map TypeVariable) + <$> optional (between (char '<') (char '>') typeVariablesP) + addDeclarationName externalModule + pure $ TypeDefinition name $ DeclaredType externalModule typeVariables + +untaggedUnionP :: Parser TypeDefinition +untaggedUnionP = do + name <- readCurrentDefinitionName <* string " {\n" + cases <- untaggedUnionCasesP + char '}' + pure $ TypeDefinition name $ UntaggedUnion cases + +untaggedUnionCasesP :: Parser [FieldType] +untaggedUnionCasesP = do + some untaggedUnionCaseP + +untaggedUnionCaseP :: Parser FieldType +untaggedUnionCaseP = + string " " *> fieldTypeP [] <* newline + +tagTypeP :: Parser TagType +tagTypeP = do + maybeTagName <- optional $ string "tag = " *> fieldNameP + many $ string ", " + maybeEmbedded <- optional $ TypeTag <$> string "embedded" + let tagField = fromMaybe (FieldName "type") maybeTagName + pure $ maybe (StandardTypeTag tagField) (const $ EmbeddedTypeTag tagField) maybeEmbedded + +readCurrentDefinitionName :: Parser DefinitionName +readCurrentDefinitionName = do + name <- definitionNameP + setCurrentDefinitionName name + pure name + +structP :: Parser TypeDefinition +structP = do + name <- readCurrentDefinitionName <* char ' ' + maybeTypeVariables <- optional $ between (char '<') (char '>') typeVariablesP + string "{\n" + case maybeTypeVariables of + Just typeVariables -> genericStructP name $ List.map TypeVariable typeVariables + Nothing -> plainStructP name + +genericStructP :: DefinitionName -> [TypeVariable] -> Parser TypeDefinition +genericStructP name typeVariables = do + fields <- fieldsP typeVariables + char '}' + pure $ TypeDefinition name $ Struct $ GenericStruct typeVariables fields + +plainStructP :: DefinitionName -> Parser TypeDefinition +plainStructP name = do + fields <- fieldsP [] + char '}' + pure $ TypeDefinition name $ Struct $ PlainStruct fields + +constructorsP :: [TypeVariable] -> Parser [Constructor] +constructorsP = some . constructorP + +constructorP :: [TypeVariable] -> Parser Constructor +constructorP typeVariables = do + string " " + name <- constructorNameP + maybeColon <- optional $ string ": " + payload <- case maybeColon of + Just _ -> Just <$> fieldTypeP typeVariables + Nothing -> pure Nothing + newline + pure $ Constructor (ConstructorName name) payload + +constructorNameP :: Parser Text +constructorNameP = do + firstLetter <- alphaNumChar + rest <- many alphaNumChar + pure $ pack $ firstLetter : rest + +unionP :: FieldName -> Parser TypeDefinition +unionP typeTag = do + name <- readCurrentDefinitionName <* char ' ' + maybeTypeVariables <- optional $ between (char '<') (char '>') typeVariablesP + string "{\n" + case maybeTypeVariables of + Just typeVariables -> genericUnionP typeTag name $ List.map TypeVariable typeVariables + Nothing -> plainUnionP typeTag name + +embeddedUnionP :: FieldName -> Parser TypeDefinition +embeddedUnionP typeTag = do + name <- readCurrentDefinitionName <* string " {\n" + constructors <- embeddedUnionStructConstructorsP [] + _ <- char '}' + pure $ TypeDefinition name (EmbeddedUnion typeTag constructors) + +genericUnionP :: FieldName -> DefinitionName -> [TypeVariable] -> Parser TypeDefinition +genericUnionP typeTag name typeVariables = do + constructors <- constructorsP typeVariables + _ <- char '}' + let union = Union typeTag unionType + unionType = GenericUnion typeVariables constructors + pure $ TypeDefinition name union + +embeddedUnionStructConstructorsP :: [TypeVariable] -> Parser [EmbeddedConstructor] +embeddedUnionStructConstructorsP typeVariables = + some $ embeddedUnionStructConstructorP typeVariables + +embeddedUnionStructConstructorP :: [TypeVariable] -> Parser EmbeddedConstructor +embeddedUnionStructConstructorP typeVariables = do + constructorName <- string " " *> embeddedConstructorNameP + maybeDefinition <- + choice + [ Nothing <$ newline, + Just <$> (string ": " *> structReferenceP typeVariables <* newline) + ] + pure $ EmbeddedConstructor (ConstructorName constructorName) maybeDefinition + +structReferenceP :: [TypeVariable] -> Parser DefinitionReference +structReferenceP typeVariables = do + definition <- definitionReferenceP typeVariables + case definition of + (DefinitionReference (TypeDefinition _name (Struct (PlainStruct _)))) -> + pure definition + (ImportedDefinitionReference _moduleName (TypeDefinition _name (Struct (PlainStruct _)))) -> + pure definition + (AppliedGenericReference _appliedTypes (TypeDefinition _name (Struct (PlainStruct _)))) -> + pure definition + ( AppliedImportedGenericReference + _moduleName + _appliedTypes + (TypeDefinition _name (Struct (PlainStruct _))) + ) -> pure definition + other -> reportError $ mconcat ["Expected plain struct reference, got: ", show other] + +embeddedConstructorNameP :: Parser Text +embeddedConstructorNameP = pack <$> some alphaNumChar + +enumerationP :: Parser TypeDefinition +enumerationP = do + name <- definitionNameP + setCurrentDefinitionName name + string " {\n" + values <- enumerationValuesP + char '}' + pure $ TypeDefinition name $ Enumeration values + +enumerationValuesP :: Parser [EnumerationValue] +enumerationValuesP = some enumerationValueP + +enumerationValueP :: Parser EnumerationValue +enumerationValueP = do + string " " + identifier <- (pack >>> EnumerationIdentifier) <$> someTill alphaNumChar (string " = ") + value <- literalP <* newline + pure $ EnumerationValue identifier value + +plainUnionP :: FieldName -> DefinitionName -> Parser TypeDefinition +plainUnionP typeTag name = do + constructors <- constructorsP [] + _ <- char '}' + pure $ TypeDefinition name $ Union typeTag (PlainUnion constructors) + +typeVariablesP :: Parser [Text] +typeVariablesP = sepBy1 pascalWordP (string ", ") + +pascalWordP :: Parser Text +pascalWordP = do + initialUppercaseCharacter <- upperChar + ((initialUppercaseCharacter :) >>> pack) <$> many alphaNumChar + +fieldsP :: [TypeVariable] -> Parser [StructField] +fieldsP = some . fieldP + +fieldP :: [TypeVariable] -> Parser StructField +fieldP typeVariables = do + string " " + name <- fieldNameP + string ": " + fieldType <- fieldTypeP typeVariables + newline + pure $ StructField name fieldType + +fieldNameP :: Parser FieldName +fieldNameP = do + initialAlphaChar <- lowerChar <|> upperChar + ((initialAlphaChar :) >>> pack >>> FieldName) <$> some (alphaNumChar <|> char '_') + +definitionNameP :: Parser DefinitionName +definitionNameP = do + initialTitleCaseCharacter <- upperChar + ((initialTitleCaseCharacter :) >>> pack >>> DefinitionName) <$> many alphaNumChar + +setCurrentDefinitionName :: DefinitionName -> Parser () +setCurrentDefinitionName name = do + AppState {currentDefinitionNameReference} <- ask + writeIORef currentDefinitionNameReference (Just name) + +recursiveReferenceP :: Parser DefinitionName +recursiveReferenceP = do + AppState {currentDefinitionNameReference} <- ask + maybeCurrentDefinitionName <- readIORef currentDefinitionNameReference + case maybeCurrentDefinitionName of + Just currentDefinitionName@(DefinitionName n) -> do + _ <- string n + pure currentDefinitionName + Nothing -> + reportError "Recursive reference not valid when we have no current definition name" + +definitionReferenceP :: [TypeVariable] -> Parser DefinitionReference +definitionReferenceP typeVariables = do + definitions <- getDefinitions + let definitionNames = + definitions + & List.map (\(TypeDefinition (DefinitionName n) _typeData) -> n) + & List.sortBy (\n1 n2 -> compare (Text.length n2) (Text.length n1)) + soughtName@(DefinitionName n) <- DefinitionName <$> choice (List.map string definitionNames) + maybeDefinition <- getDefinition soughtName + maybeTypeVariables <- + optional $ between (char '<') (char '>') $ sepBy1 (fieldTypeP typeVariables) (string ", ") + case maybeDefinition of + Just (TypeDefinition name' (DeclaredType moduleName _typeVariables)) -> + case maybeTypeVariables of + Nothing -> + pure $ DeclarationReference moduleName name' + Just appliedTypes -> + pure $ GenericDeclarationReference moduleName name' (AppliedTypes appliedTypes) + Just definition -> do + case maybeTypeVariables of + Just appliedTypeVariables -> + pure $ AppliedGenericReference appliedTypeVariables definition + Nothing -> + pure $ DefinitionReference definition + Nothing -> reportError $ mconcat ["Unknown type reference: ", unpack n] + +getDefinitions :: Parser [TypeDefinition] +getDefinitions = do + AppState {currentDefinitionsReference} <- ask + readIORef currentDefinitionsReference + +getDefinition :: DefinitionName -> Parser (Maybe TypeDefinition) +getDefinition name = do + AppState {currentDefinitionsReference} <- ask + definitions <- readIORef currentDefinitionsReference + pure $ + List.find (\(TypeDefinition definitionName _typeData) -> name == definitionName) definitions + +addDefinition :: TypeDefinition -> Parser () +addDefinition definition@(TypeDefinition (DefinitionName definitionName) _typeData) = do + AppState {currentDefinitionsReference} <- ask + definitions <- readIORef currentDefinitionsReference + if not (hasDefinition definition definitions) + then modifyIORef currentDefinitionsReference (definition :) + else reportError $ "Duplicate definition with name '" <> unpack definitionName <> "'" + +clearDefinitions :: Parser () +clearDefinitions = do + AppState {currentDefinitionsReference} <- ask + writeIORef currentDefinitionsReference mempty + +hasDefinition :: TypeDefinition -> [TypeDefinition] -> Bool +hasDefinition (TypeDefinition name _typeData) = + any (\(TypeDefinition name' _typeData) -> name == name') + +fieldTypeP :: [TypeVariable] -> Parser FieldType +fieldTypeP typeVariables = + choice + [ LiteralType <$> literalP, + ComplexType <$> complexTypeP typeVariables, + TypeVariableReferenceType <$> typeVariableReferenceP typeVariables, + DefinitionReferenceType <$> definitionReferenceP typeVariables, + BasicType <$> basicTypeValueP, + DefinitionReferenceType <$> importedReferenceP typeVariables, + RecursiveReferenceType <$> recursiveReferenceP + ] + +typeVariableReferenceP :: [TypeVariable] -> Parser TypeVariable +typeVariableReferenceP typeVariables = + TypeVariable <$> choice (List.map (\(TypeVariable t) -> string t) typeVariables) + +importedReferenceP :: [TypeVariable] -> Parser DefinitionReference +importedReferenceP typeVariables = do + imports <- getImports + moduleName <- + choice (List.map (\(Import Module {name = ModuleName name}) -> string name) imports) <* char '.' + definitionName@(DefinitionName n) <- definitionNameP + maybeModule <- getImport moduleName + case maybeModule of + Just (Import Module {name = sourceModule, definitions}) -> do + case List.find (\(TypeDefinition name _typeData) -> name == definitionName) definitions of + Just definition@(TypeDefinition foundDefinitionName typeData) -> do + maybeTypeVariables <- + optional $ between (char '<') (char '>') $ sepBy1 (fieldTypeP typeVariables) (string ", ") + pure $ case maybeTypeVariables of + Just appliedTypeVariables -> + AppliedImportedGenericReference + (ModuleName moduleName) + (AppliedTypes appliedTypeVariables) + definition + Nothing -> + ImportedDefinitionReference sourceModule $ TypeDefinition foundDefinitionName typeData + Nothing -> + reportError $ + mconcat + [ "Unknown definition in module '", + unpack moduleName, + "': ", + unpack n + ] + Nothing -> + reportError $ "Unknown module referenced, not in imports: " <> unpack moduleName + +getImports :: Parser [Import] +getImports = do + AppState {currentImportsReference} <- ask + readIORef currentImportsReference + +getImport :: Text -> Parser (Maybe Import) +getImport soughtName = do + AppState {currentImportsReference} <- ask + imports <- readIORef currentImportsReference + pure $ List.find (\(Import Module {name = ModuleName name}) -> soughtName == name) imports + +reportError :: String -> Parser a +reportError = ErrorFail >>> Set.singleton >>> fancyFailure + +basicTypeValueP :: Parser BasicTypeValue +basicTypeValueP = choice [uintP, intP, floatP, booleanP, basicStringP] + +complexTypeP :: [TypeVariable] -> Parser ComplexTypeValue +complexTypeP typeVariables = + choice + [ sliceTypeP typeVariables, + arrayTypeP typeVariables, + optionalTypeP typeVariables, + pointerTypeP typeVariables + ] + +sliceTypeP :: [TypeVariable] -> Parser ComplexTypeValue +sliceTypeP typeVariables = SliceType <$> precededBy (string "[]") (fieldTypeP typeVariables) + +arrayTypeP :: [TypeVariable] -> Parser ComplexTypeValue +arrayTypeP typeVariables = do + size <- between (char '[') (char ']') decimal + ArrayType size <$> fieldTypeP typeVariables + +optionalTypeP :: [TypeVariable] -> Parser ComplexTypeValue +optionalTypeP typeVariables = OptionalType <$> precededBy (char '?') (fieldTypeP typeVariables) + +pointerTypeP :: [TypeVariable] -> Parser ComplexTypeValue +pointerTypeP typeVariables = PointerType <$> precededBy (char '*') (fieldTypeP typeVariables) + +precededBy :: Parser ignored -> Parser a -> Parser a +precededBy precededParser parser = do + _ <- precededParser + parser + +integerSizes :: [Int] +integerSizes = [8, 16, 32, 64, 128] + +integerTypeParsers :: Text -> [Parser Text] +integerTypeParsers prefix = List.map (show >>> pack >>> (prefix <>) >>> string) integerSizes + +uintP :: Parser BasicTypeValue +uintP = do + uint <- choice $ integerTypeParsers "U" + case uint of + "U8" -> pure U8 + "U16" -> pure U16 + "U32" -> pure U32 + "U64" -> pure U64 + "U128" -> pure U128 + other -> reportError $ "Invalid size for Ux: " <> unpack other + +intP :: Parser BasicTypeValue +intP = do + int <- choice $ integerTypeParsers "I" + case int of + "I8" -> pure I8 + "I16" -> pure I16 + "I32" -> pure I32 + "I64" -> pure I64 + "I128" -> pure I128 + other -> reportError $ "Invalid size for Ix: " <> unpack other + +floatP :: Parser BasicTypeValue +floatP = do + int <- choice [string "F32", "F64"] + case int of + "F32" -> pure F32 + "F64" -> pure F64 + other -> reportError $ "Invalid size for Fx: " <> unpack other + +booleanP :: Parser BasicTypeValue +booleanP = string "Boolean" $> Boolean + +basicStringP :: Parser BasicTypeValue +basicStringP = string "String" $> BasicString + +literalP :: Parser LiteralTypeValue +literalP = choice [literalStringP, literalIntegerP, literalFloatP, literalBooleanP] + +literalStringP :: Parser LiteralTypeValue +literalStringP = (pack >>> LiteralString) <$> between (char '"') (char '"') (many stringCharacterP) + +stringCharacterP :: Parser Char +stringCharacterP = alphaNumChar <|> spaceChar + +literalIntegerP :: Parser LiteralTypeValue +literalIntegerP = LiteralInteger <$> decimal + +literalFloatP :: Parser LiteralTypeValue +literalFloatP = LiteralFloat <$> float + +literalBooleanP :: Parser LiteralTypeValue +literalBooleanP = LiteralBoolean <$> choice [trueP, falseP] + +trueP :: Parser Bool +trueP = string "true" $> True + +falseP :: Parser Bool +falseP = string "false" $> False + +partialFromRight :: Either l r -> r +partialFromRight (Right r) = r +partialFromRight (Left _l) = error "Unable to get `Right` from `Left`" + +partialFromLeft :: Either l r -> l +partialFromLeft (Left l) = l +partialFromLeft (Right _r) = error "Unable to get `Left` from `Right`" diff --git a/src/Types.hs b/src/Types.hs new file mode 100644 --- /dev/null +++ b/src/Types.hs @@ -0,0 +1,137 @@ +module Types where + +import RIO + +data Module = Module + { name :: !ModuleName, + imports :: ![Import], + declarationNames :: ![ModuleName], + definitions :: ![TypeDefinition], + sourceFile :: !FilePath + } + deriving (Eq, Show) + +newtype ModuleName = ModuleName Text + deriving (Eq, Show, Ord) + +newtype Import = Import Module + deriving (Eq, Show) + +newtype DefinitionName = DefinitionName Text + deriving (Eq, Show) + +data TypeDefinition = TypeDefinition !DefinitionName !TypeData + deriving (Eq, Show) + +data ImportedTypeDefinition = ImportedTypeDefinition + { sourceModule :: !ModuleName, + name :: !DefinitionName, + typeData :: !TypeData + } + deriving (Eq, Show) + +newtype TypeTag = TypeTag Text + deriving (Eq, Show) + +newtype TypeVariable = TypeVariable Text + deriving (Eq, Show) + +newtype ConstructorName = ConstructorName Text + deriving (Eq, Show) + +newtype FieldName = FieldName Text + deriving (Eq, Show) + +newtype EnumerationIdentifier = EnumerationIdentifier Text + deriving (Eq, Show) + +-- | Defines what type tag field a union should have as well as the type tag location. +data TagType + = -- | The union has the type tag with the rest of the payload. + EmbeddedTypeTag FieldName + | -- | The union has the type tag outside of the payload, wrapping it. + StandardTypeTag FieldName + deriving (Eq, Show) + +data TypeData + = Struct !StructType + | Union !FieldName !UnionType + | EmbeddedUnion !FieldName ![EmbeddedConstructor] + | UntaggedUnion ![FieldType] + | Enumeration ![EnumerationValue] + | DeclaredType !ModuleName ![TypeVariable] + deriving (Eq, Show) + +data EmbeddedConstructor = EmbeddedConstructor !ConstructorName !(Maybe DefinitionReference) + deriving (Eq, Show) + +data StructType + = PlainStruct ![StructField] + | GenericStruct ![TypeVariable] ![StructField] + deriving (Eq, Show) + +data UnionType + = PlainUnion ![Constructor] + | GenericUnion ![TypeVariable] ![Constructor] + deriving (Eq, Show) + +data Constructor = Constructor !ConstructorName !(Maybe FieldType) + deriving (Eq, Show) + +data StructField = StructField !FieldName !FieldType + deriving (Eq, Show) + +data EnumerationValue = EnumerationValue !EnumerationIdentifier !LiteralTypeValue + deriving (Eq, Show) + +data FieldType + = LiteralType !LiteralTypeValue + | BasicType !BasicTypeValue + | ComplexType !ComplexTypeValue + | DefinitionReferenceType !DefinitionReference + | RecursiveReferenceType !DefinitionName + | TypeVariableReferenceType !TypeVariable + deriving (Eq, Show) + +data DefinitionReference + = DefinitionReference !TypeDefinition + | ImportedDefinitionReference !ModuleName !TypeDefinition + | AppliedGenericReference ![FieldType] !TypeDefinition + | AppliedImportedGenericReference !ModuleName !AppliedTypes !TypeDefinition + | DeclarationReference !ModuleName !DefinitionName + | GenericDeclarationReference !ModuleName !DefinitionName !AppliedTypes + deriving (Eq, Show) + +newtype AppliedTypes = AppliedTypes [FieldType] + deriving (Eq, Show) + +data BasicTypeValue + = U8 + | U16 + | U32 + | U64 + | U128 + | I8 + | I16 + | I32 + | I64 + | I128 + | F32 + | F64 + | Boolean + | BasicString + deriving (Eq, Show) + +data ComplexTypeValue + = SliceType FieldType + | ArrayType Integer FieldType + | OptionalType FieldType + | PointerType FieldType + deriving (Eq, Show) + +data LiteralTypeValue + = LiteralString !Text + | LiteralInteger !Integer + | LiteralFloat !Float + | LiteralBoolean !Bool + deriving (Eq, Show) diff --git a/test/ParsingSpec.hs b/test/ParsingSpec.hs new file mode 100644 --- /dev/null +++ b/test/ParsingSpec.hs @@ -0,0 +1,171 @@ +module ParsingSpec where + +import qualified CodeGeneration.FSharp as FSharp +import qualified CodeGeneration.Python as Python +import qualified CodeGeneration.TypeScript as TypeScript +import Parsing +import RIO +import qualified RIO.List.Partial as PartialList +import Test.Hspec +import Types + +data TypeScriptReferenceOutput = TypeScriptReferenceOutput + { basic :: !Text, + import' :: !Text, + hasGeneric :: !Text, + generics :: !Text, + gitHub :: !Text + } + +data FSharpReferenceOutput = FSharpReferenceOutput + { basic :: !Text, + import' :: !Text, + hasGeneric :: !Text, + generics :: !Text, + gitHub :: !Text + } + +data PythonReferenceOutput = PythonReferenceOutput + { python :: !Text, + basic :: !Text + } + +typeScriptReferenceOutput :: IO TypeScriptReferenceOutput +typeScriptReferenceOutput = do + basic <- basicReferenceOutput "ts" + import' <- importReferenceOutput "ts" + hasGeneric <- hasGenericReferenceOutput "ts" + generics <- genericsReferenceOutput "ts" + gitHub <- gitHubReferenceOutput "ts" + pure TypeScriptReferenceOutput {basic, import', hasGeneric, generics, gitHub} + +fSharpReferenceOutput :: IO FSharpReferenceOutput +fSharpReferenceOutput = do + basic <- basicReferenceOutput "fs" + import' <- importReferenceOutput "fs" + hasGeneric <- hasGenericReferenceOutput "fs" + generics <- genericsReferenceOutput "fs" + gitHub <- gitHubReferenceOutput "fs" + pure FSharpReferenceOutput {basic, import', hasGeneric, generics, gitHub} + +basicReferenceOutput :: FilePath -> IO Text +basicReferenceOutput extension = readFileUtf8 $ "./test/reference-output/basic." <> extension + +importReferenceOutput :: FilePath -> IO Text +importReferenceOutput extension = + readFileUtf8 $ "./test/reference-output/importExample." <> extension + +hasGenericReferenceOutput :: FilePath -> IO Text +hasGenericReferenceOutput extension = + readFileUtf8 $ "./test/reference-output/hasGeneric." <> extension + +genericsReferenceOutput :: FilePath -> IO Text +genericsReferenceOutput extension = + readFileUtf8 $ "./test/reference-output/generics." <> extension + +gitHubReferenceOutput :: FilePath -> IO Text +gitHubReferenceOutput extension = + readFileUtf8 $ "./test/reference-output/github." <> extension + +pythonReferenceOutput :: IO PythonReferenceOutput +pythonReferenceOutput = do + python <- readFileUtf8 "./test/reference-output/python.py" + basic <- readFileUtf8 "./test/reference-output/basic.py" + pure PythonReferenceOutput {python, basic} + +spec :: TypeScriptReferenceOutput -> FSharpReferenceOutput -> PythonReferenceOutput -> Spec +spec + (TypeScriptReferenceOutput tsBasic tsImport tsHasGeneric tsGenerics tsGitHub) + (FSharpReferenceOutput fsBasic fsImport fsHasGeneric fsGenerics fsGitHub) + (PythonReferenceOutput pyPython pyBasic) = do + describe "`parseModules`" $ do + it "Parses and returns modules" $ do + modules <- getRight <$> parseModules ["examples/basic.gotyno"] + length modules `shouldBe` 1 + + modules' <- getRight <$> parseModules ["examples/basic.gotyno", "examples/importExample.gotyno"] + length modules' `shouldBe` 2 + + modules'' <- + getRight + <$> parseModules + [ "examples/basic.gotyno", + "examples/importExample.gotyno", + "examples/hasGeneric.gotyno", + "examples/generics.gotyno" + ] + length modules'' `shouldBe` 4 + + it "Allows two separate modules to declare the same type (by name)" $ do + modules <- + getRight + <$> parseModules + ["test/examples/declaration1.gotyno", "test/examples/declaration2.gotyno"] + length modules `shouldBe` 2 + + it "Gives the correct parsed output for `basic.gotyno`" $ do + Module {name, imports, definitions} <- + (getRight >>> PartialList.head) <$> parseModules ["examples/basic.gotyno"] + name `shouldBe` ModuleName "basic" + imports `shouldBe` [] + length definitions `shouldBe` 13 + + it "Mirrors reference output for `basic.gotyno`" $ do + basicModule <- (getRight >>> PartialList.head) <$> parseModules ["examples/basic.gotyno"] + let basicTypeScriptOutput = TypeScript.outputModule basicModule + basicFSharpOutput = FSharp.outputModule basicModule + basicPythonOutput = Python.outputModule basicModule + basicTypeScriptOutput `shouldBe` tsBasic + basicFSharpOutput `shouldBe` fsBasic + basicPythonOutput `shouldBe` pyBasic + + it "Mirrors reference output for `importExample.gotyno`" $ do + importModule <- + (getRight >>> PartialList.last) + <$> ( ["basic.gotyno", "importExample.gotyno"] + & fmap ("examples/" <>) + & parseModules + ) + let importTypeScriptOutput = TypeScript.outputModule importModule + importFSharpOutput = FSharp.outputModule importModule + importTypeScriptOutput `shouldBe` tsImport + importFSharpOutput `shouldBe` fsImport + + it "Mirrors reference output for `hasGeneric.gotyno`" $ do + hasGenericModule <- + (getRight >>> PartialList.head) <$> parseModules ["examples/hasGeneric.gotyno"] + let hasGenericTypeScriptOutput = TypeScript.outputModule hasGenericModule + hasGenericFSharpOutput = FSharp.outputModule hasGenericModule + hasGenericTypeScriptOutput `shouldBe` tsHasGeneric + hasGenericFSharpOutput `shouldBe` fsHasGeneric + + it "Mirrors reference output for `generics.gotyno`" $ do + genericsModule <- + (getRight >>> PartialList.last) + <$> ( ["basic.gotyno", "hasGeneric.gotyno", "generics.gotyno"] + & fmap ("examples/" <>) + & parseModules + ) + let genericsTypeScriptOutput = TypeScript.outputModule genericsModule + genericsFSharpOutput = FSharp.outputModule genericsModule + genericsTypeScriptOutput `shouldBe` tsGenerics + genericsFSharpOutput `shouldBe` fsGenerics + + it "Mirrors reference output for `github.gotyno`" $ do + gitHubModule <- + (getRight >>> PartialList.head) <$> parseModules ["./examples/github.gotyno"] + let gitHubTypeScriptOutput = TypeScript.outputModule gitHubModule + gitHubFSharpOutput = FSharp.outputModule gitHubModule + gitHubTypeScriptOutput `shouldBe` tsGitHub + gitHubFSharpOutput `shouldBe` fsGitHub + + it "Basic `python.gotyno` module is output correctly" $ do + pythonModule <- + (getRight >>> PartialList.last) + <$> parseModules ["examples/basic.gotyno", "examples/python.gotyno"] + let pythonPythonOutput = Python.outputModule pythonModule + pythonPythonOutput `shouldBe` pyPython + +getRight :: (Show l) => Either l r -> r +getRight (Right r) = r +getRight (Left e) = error $ "unpacking `Left` in `fromRight`, error: " <> show e diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,12 @@ +module Main where + +import qualified ParsingSpec +import RIO +import Test.Hspec + +main :: IO () +main = do + tsReferenceOutput <- ParsingSpec.typeScriptReferenceOutput + fsReferenceOutput <- ParsingSpec.fSharpReferenceOutput + pyReferenceOutput <- ParsingSpec.pythonReferenceOutput + hspec $ ParsingSpec.spec tsReferenceOutput fsReferenceOutput pyReferenceOutput