gotyno-hs (empty) → 1.0.0
raw patch · 12 files changed
+4772/−0 lines, 12 filesdep +basedep +fsnotifydep +gotyno-hs
Dependencies added: base, fsnotify, gotyno-hs, hspec, megaparsec, optparse-applicative, pretty-show, rio, text
Files
- LICENSE.txt +22/−0
- app/Main.hs +60/−0
- gotyno-hs.cabal +208/−0
- src/CodeGeneration/FSharp.hs +913/−0
- src/CodeGeneration/Python.hs +1264/−0
- src/CodeGeneration/TypeScript.hs +1227/−0
- src/CodeGeneration/Utilities.hs +11/−0
- src/Library.hs +125/−0
- src/Parsing.hs +622/−0
- src/Types.hs +137/−0
- test/ParsingSpec.hs +171/−0
- test/Spec.hs +12/−0
+ LICENSE.txt view
@@ -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.
+ app/Main.hs view
@@ -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
+ gotyno-hs.cabal view
@@ -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 <gonz@severnatazvezda.com>+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
+ src/CodeGeneration/FSharp.hs view
@@ -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 <> ">")
+ src/CodeGeneration/Python.hs view
@@ -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
+ src/CodeGeneration/TypeScript.hs view
@@ -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 <> ">")
+ src/CodeGeneration/Utilities.hs view
@@ -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
+ src/Library.hs view
@@ -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
+ src/Parsing.hs view
@@ -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`"
+ src/Types.hs view
@@ -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)
+ test/ParsingSpec.hs view
@@ -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
+ test/Spec.hs view
@@ -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