gotyno-hs 1.0.2 → 1.1.0
raw patch · 20 files changed
+1413/−206 lines, 20 filesdep +aesonPVP ok
version bump matches the API change (PVP)
Dependencies added: aeson
API changes (from Hackage documentation)
- Parsing: AppState :: !IORef [Module] -> !IORef [Import] -> !IORef (Set ModuleName) -> !IORef [TypeDefinition] -> !IORef (Maybe DefinitionName) -> AppState
- Parsing: [$sel:currentDeclarationNamesReference:AppState] :: AppState -> !IORef (Set ModuleName)
- Parsing: [$sel:currentDefinitionNameReference:AppState] :: AppState -> !IORef (Maybe DefinitionName)
- Parsing: [$sel:currentDefinitionsReference:AppState] :: AppState -> !IORef [TypeDefinition]
- Parsing: [$sel:currentImportsReference:AppState] :: AppState -> !IORef [Import]
- Parsing: [$sel:modulesReference:AppState] :: AppState -> !IORef [Module]
- Parsing: addDeclarationName :: ModuleName -> Parser ()
- Parsing: addDefinition :: TypeDefinition -> Parser ()
- Parsing: addImports :: [Import] -> Parser ()
- Parsing: addModule :: Module -> IORef [Module] -> IO ()
- Parsing: arrayTypeP :: [TypeVariable] -> Parser ComplexTypeValue
- Parsing: basicStringP :: Parser BasicTypeValue
- Parsing: basicTypeValueP :: Parser BasicTypeValue
- Parsing: booleanP :: Parser BasicTypeValue
- Parsing: clearDeclarationNames :: Parser ()
- Parsing: clearDefinitions :: Parser ()
- Parsing: complexTypeP :: [TypeVariable] -> Parser ComplexTypeValue
- Parsing: constructorNameP :: Parser Text
- Parsing: constructorP :: [TypeVariable] -> Parser Constructor
- Parsing: constructorsP :: [TypeVariable] -> Parser [Constructor]
- Parsing: data AppState
- Parsing: declarationP :: Parser TypeDefinition
- Parsing: definitionNameP :: Parser DefinitionName
- Parsing: definitionReferenceP :: [TypeVariable] -> Parser DefinitionReference
- Parsing: embeddedConstructorNameP :: Parser Text
- Parsing: embeddedUnionP :: FieldName -> Parser TypeDefinition
- Parsing: embeddedUnionStructConstructorP :: [TypeVariable] -> Parser EmbeddedConstructor
- Parsing: embeddedUnionStructConstructorsP :: [TypeVariable] -> Parser [EmbeddedConstructor]
- Parsing: enumerationP :: Parser TypeDefinition
- Parsing: enumerationValueP :: Parser EnumerationValue
- Parsing: enumerationValuesP :: Parser [EnumerationValue]
- Parsing: falseP :: Parser Bool
- Parsing: fieldNameP :: Parser FieldName
- Parsing: fieldP :: [TypeVariable] -> Parser StructField
- Parsing: fieldTypeP :: [TypeVariable] -> Parser FieldType
- Parsing: fieldsP :: [TypeVariable] -> Parser [StructField]
- Parsing: floatP :: Parser BasicTypeValue
- Parsing: genericStructP :: DefinitionName -> [TypeVariable] -> Parser TypeDefinition
- Parsing: genericUnionP :: FieldName -> DefinitionName -> [TypeVariable] -> Parser TypeDefinition
- Parsing: getDeclarationNames :: Parser (Set ModuleName)
- Parsing: getDefinition :: DefinitionName -> Parser (Maybe TypeDefinition)
- Parsing: getDefinitions :: Parser [TypeDefinition]
- Parsing: getImport :: Text -> Parser (Maybe Import)
- Parsing: getImports :: Parser [Import]
- Parsing: getModule :: String -> Parser (Maybe Module)
- Parsing: hasDefinition :: TypeDefinition -> [TypeDefinition] -> Bool
- Parsing: importP :: Parser Import
- Parsing: importedReferenceP :: [TypeVariable] -> Parser DefinitionReference
- Parsing: intP :: Parser BasicTypeValue
- Parsing: integerSizes :: [Int]
- Parsing: integerTypeParsers :: Text -> [Parser Text]
- Parsing: literalBooleanP :: Parser LiteralTypeValue
- Parsing: literalFloatP :: Parser LiteralTypeValue
- Parsing: literalIntegerP :: Parser LiteralTypeValue
- Parsing: literalP :: Parser LiteralTypeValue
- Parsing: literalStringP :: Parser LiteralTypeValue
- Parsing: moduleP :: ModuleName -> FilePath -> Parser Module
- Parsing: optionalTypeP :: [TypeVariable] -> Parser ComplexTypeValue
- Parsing: partialFromLeft :: Either l r -> l
- Parsing: partialFromRight :: Either l r -> r
- Parsing: pascalWordP :: Parser Text
- Parsing: plainStructP :: DefinitionName -> Parser TypeDefinition
- Parsing: plainUnionP :: FieldName -> DefinitionName -> Parser TypeDefinition
- Parsing: pointerTypeP :: [TypeVariable] -> Parser ComplexTypeValue
- Parsing: precededBy :: Parser ignored -> Parser a -> Parser a
- Parsing: readCurrentDefinitionName :: Parser DefinitionName
- Parsing: recursiveReferenceP :: Parser DefinitionName
- Parsing: reportError :: String -> Parser a
- Parsing: run :: AppState -> Text -> Parser a -> IO (Either (ParseErrorBundle Text Void) a)
- Parsing: setCurrentDefinitionName :: DefinitionName -> Parser ()
- Parsing: sliceTypeP :: [TypeVariable] -> Parser ComplexTypeValue
- Parsing: stringCharacterP :: Parser Char
- Parsing: structP :: Parser TypeDefinition
- Parsing: structReferenceP :: [TypeVariable] -> Parser DefinitionReference
- Parsing: tagTypeP :: Parser TagType
- Parsing: trueP :: Parser Bool
- Parsing: type Parser = ParsecT Void Text (RIO AppState)
- Parsing: typeDefinitionP :: Parser TypeDefinition
- Parsing: typeVariableReferenceP :: [TypeVariable] -> Parser TypeVariable
- Parsing: typeVariablesP :: Parser [Text]
- Parsing: uintP :: Parser BasicTypeValue
- Parsing: unionP :: FieldName -> Parser TypeDefinition
- Parsing: untaggedUnionCaseP :: Parser FieldType
- Parsing: untaggedUnionCasesP :: Parser [FieldType]
- Parsing: untaggedUnionP :: Parser TypeDefinition
+ Basic: Recruiter :: !String -> !String -> ![Maybe String] -> !Maybe Recruiter -> !Integer -> Recruiter
+ Basic: [$sel:recruiterCreated:Recruiter] :: Recruiter -> !Integer
+ Basic: [$sel:recruiterEmails:Recruiter] :: Recruiter -> ![Maybe String]
+ Basic: [$sel:recruiterName:Recruiter] :: Recruiter -> !String
+ Basic: [$sel:recruiterRecruiter:Recruiter] :: Recruiter -> !Maybe Recruiter
+ Basic: [$sel:recruiterType:Recruiter] :: Recruiter -> !String
+ Basic: data Recruiter
+ Basic: instance Data.Aeson.Types.FromJSON.FromJSON Basic.Recruiter
+ Basic: instance Data.Aeson.Types.ToJSON.ToJSON Basic.Recruiter
+ Basic: instance GHC.Classes.Eq Basic.Recruiter
+ Basic: instance GHC.Generics.Generic Basic.Recruiter
+ Basic: instance GHC.Show.Show Basic.Recruiter
+ CodeGeneration.Haskell: outputModule :: Module -> Text
+ CodeGeneration.Utilities: typeVariablesFrom :: FieldType -> Maybe [TypeVariable]
+ CodeGeneration.Utilities: typeVariablesFromDefinition :: TypeDefinition -> Maybe [TypeVariable]
+ CodeGeneration.Utilities: typeVariablesFromReference :: DefinitionReference -> Maybe [TypeVariable]
+ Gotyno.Helpers: LiteralString :: Text -> LiteralString
+ Gotyno.Helpers: StringEncodedInteger :: Integer -> StringEncodedInteger
+ Gotyno.Helpers: checkEqualTo :: (Eq a, Show a) => a -> a -> Parser a
+ Gotyno.Helpers: instance Data.Aeson.Types.FromJSON.FromJSON Gotyno.Helpers.StringEncodedInteger
+ Gotyno.Helpers: instance Data.Aeson.Types.ToJSON.ToJSON Gotyno.Helpers.LiteralString
+ Gotyno.Helpers: instance Data.Aeson.Types.ToJSON.ToJSON Gotyno.Helpers.StringEncodedInteger
+ Gotyno.Helpers: instance GHC.Classes.Eq Gotyno.Helpers.LiteralString
+ Gotyno.Helpers: instance GHC.Classes.Eq Gotyno.Helpers.StringEncodedInteger
+ Gotyno.Helpers: instance GHC.Show.Show Gotyno.Helpers.LiteralString
+ Gotyno.Helpers: instance GHC.Show.Show Gotyno.Helpers.StringEncodedInteger
+ Gotyno.Helpers: newtype LiteralString
+ Gotyno.Helpers: newtype StringEncodedInteger
+ Types: [$sel:unDefinitionName:DefinitionName] :: DefinitionName -> Text
Files
- CHANGELOG.md +31/−0
- gotyno-hs.cabal +19/−4
- src/Basic.hs +50/−0
- src/CodeGeneration/FSharp.hs +1/−52
- src/CodeGeneration/Haskell.hs +937/−0
- src/CodeGeneration/Python.hs +1/−52
- src/CodeGeneration/TypeScript.hs +1/−52
- src/CodeGeneration/Utilities.hs +52/−0
- src/Gotyno/Helpers.hs +32/−0
- src/Parsing.hs +91/−43
- src/Types.hs +1/−1
- test/ParsingSpec.hs +135/−2
- test/examples/applyingNonGeneric.gotyno +7/−0
- test/examples/declaredGenerics1.gotyno +5/−0
- test/examples/declaredGenerics2.gotyno +5/−0
- test/examples/declaredGenerics3.gotyno +5/−0
- test/examples/declaredGenerics4.gotyno +5/−0
- test/examples/declaredGenerics5.gotyno +5/−0
- test/examples/notApplyingEnoughGenericTypes.gotyno +8/−0
- test/examples/relaxedWhiteSpace.gotyno +22/−0
+ CHANGELOG.md view
@@ -0,0 +1,31 @@+# Changelog++## 1.1.0++### General++- Made the parser much less strict, allowing extra whitespace in many places.+ This is experimental for now, but should allow people to have just a bit more+ of their own style.++### Features++### Fixes++- Added checks for whether or not the user is applying enough/too many type+ parameters to the usage of a given definition/declaration. This was previously+ punted to the output language but if we are to output to languages with very+ poor static checks themselves, this safeguard is good to have.++## 1.0.2++### General++- Uploaded package to Stackage++### Features++### Fixes++- Clearing definitions & declarations on module parsing success *and* failure+- Using debouncing to handle duplicate file events when using `--watch`
gotyno-hs.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: gotyno-hs-version: 1.0.2+version: 1.1.0 synopsis: A type definition compiler supporting multiple output languages. description: Compiles type definitions into F#, TypeScript and Python, with validators, decoders and encoders. category: Compiler@@ -15,6 +15,7 @@ build-type: Simple extra-source-files: README.md+ CHANGELOG.md examples/basic.gotyno examples/generics.gotyno examples/github.gotyno@@ -39,15 +40,26 @@ test/reference-output/hasGeneric.py test/reference-output/importExample.py test/reference-output/python.py+ test/examples/applyingNonGeneric.gotyno test/examples/declaration1.gotyno test/examples/declaration2.gotyno+ test/examples/declaredGenerics1.gotyno+ test/examples/declaredGenerics2.gotyno+ test/examples/declaredGenerics3.gotyno+ test/examples/declaredGenerics4.gotyno+ test/examples/declaredGenerics5.gotyno+ test/examples/notApplyingEnoughGenericTypes.gotyno+ test/examples/relaxedWhiteSpace.gotyno library exposed-modules:+ Basic CodeGeneration.FSharp+ CodeGeneration.Haskell CodeGeneration.Python CodeGeneration.TypeScript CodeGeneration.Utilities+ Gotyno.Helpers Library Parsing Types@@ -101,7 +113,8 @@ TypeApplications ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints build-depends:- base >=4.9.1.0 && <5+ aeson+ , base >=4.9.1.0 && <5 , fsnotify , megaparsec , pretty-show@@ -161,7 +174,8 @@ 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+ aeson+ , base >=4.9.1.0 && <5 , fsnotify , gotyno-hs , megaparsec@@ -225,7 +239,8 @@ 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+ aeson+ , base >=4.9.1.0 && <5 , fsnotify , gotyno-hs , hspec >=2.0.0
+ src/Basic.hs view
@@ -0,0 +1,50 @@+module Basic where++import Data.Aeson (FromJSON (..), ToJSON (..), (.:), (.:?), (.=))+import qualified Data.Aeson as JSON+import GHC.Generics (Generic)+import qualified Gotyno.Helpers as Helpers+import Prelude++data Recruiter = Recruiter+ { recruiterType :: !String,+ recruiterName :: !String,+ recruiterEmails :: ![Maybe String],+ recruiterRecruiter :: !(Maybe Recruiter),+ recruiterCreated :: !Integer+ }+ deriving (Eq, Show, Generic)++instance FromJSON Recruiter where+ parseJSON = JSON.withObject "Recruiter" $ \o -> do+ recruiterType <- o .: "type" >>= Helpers.checkEqualTo "Recruiter"+ recruiterName <- o .: "Name"+ recruiterEmails <- o .: "emails"+ recruiterRecruiter <- o .:? "recruiter"+ Helpers.StringEncodedInteger recruiterCreated <- o .: "created"+ pure $+ Recruiter+ { recruiterType,+ recruiterName,+ recruiterEmails,+ recruiterRecruiter,+ recruiterCreated+ }++instance ToJSON Recruiter where+ toJSON value =+ JSON.object+ [ "type" .= Helpers.LiteralString "Recruiter",+ "name" .= recruiterName value,+ "emails" .= recruiterEmails value,+ "recruiter" .= recruiterRecruiter value,+ "created" .= Helpers.StringEncodedInteger (recruiterCreated value)+ ]++-- struct Recruiter {+-- type: "Recruiter"+-- Name: String+-- emails: [3]?String+-- recruiter: ?*Recruiter+-- created: U64+-- }
src/CodeGeneration/FSharp.hs view
@@ -1,6 +1,6 @@ module CodeGeneration.FSharp (outputModule) where -import CodeGeneration.Utilities (upperCaseFirstCharacter)+import CodeGeneration.Utilities (typeVariablesFrom, upperCaseFirstCharacter) import RIO import qualified RIO.List.Partial as PartialList import qualified RIO.Text as Text@@ -710,57 +710,6 @@ [ 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) =
+ src/CodeGeneration/Haskell.hs view
@@ -0,0 +1,937 @@+module CodeGeneration.Haskell (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, declarationNames} =+ let definitionOutput = definitions & mapMaybe outputDefinition & Text.intercalate "\n\n"+ importsOutput = imports & fmap outputImport & mconcat+ outputImport (Import Module {name = ModuleName importName}) =+ mconcat ["import qualified ", importName, " as ", importName, "\n\n"]+ declarationImportsOutput =+ declarationNames+ & fmap+ ( \(ModuleName declarationModuleName) ->+ mconcat+ [ "import qualified ",+ haskellifyModuleName declarationModuleName,+ " as ",+ haskellifyModuleName declarationModuleName+ ]+ )+ & Text.intercalate "\n"+ in mconcat+ [ modulePrelude (haskellifyModuleName name),+ "\n\n",+ importsOutput,+ "\n\n",+ declarationImportsOutput,+ "\n\n",+ definitionOutput+ ]++haskellifyModuleName :: Text -> Text+haskellifyModuleName = upperCaseFirstCharacter++modulePrelude :: Text -> Text+modulePrelude name =+ mconcat+ [ mconcat ["module ", name, " where\n\n"],+ "import Data.Aeson (FromJSON(..), ToJSON(..))\n",+ "import qualified Data.Aeson as JSON\n",+ "import GHC.Generics (Generic)\n",+ "import qualified Gotyno.Helpers as Helpers\n",+ "import qualified Prelude"+ ]++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 [haskellifyModuleName 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 ["(", haskellifyModuleName moduleName, ".", name, ".Decoder ", appliedDecoders, ")"]+decoderForDefinitionReference+ ( GenericDeclarationReference+ (ModuleName moduleName)+ (DefinitionName name)+ (AppliedTypes appliedTypes)+ ) =+ let appliedDecoders = appliedTypes & fmap decoderForFieldType & Text.intercalate " "+ in mconcat ["(", haskellifyModuleName moduleName, ".", name, ".Decoder ", appliedDecoders, ")"]+decoderForDefinitionReference+ (DeclarationReference (ModuleName moduleName) (DefinitionName name)) =+ mconcat [haskellifyModuleName 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 [haskellifyModuleName 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 ["(", haskellifyModuleName moduleName, ".", name, ".Encoder ", appliedEncoders, ")"]+encoderForDefinitionReference+ ( GenericDeclarationReference+ (ModuleName moduleName)+ (DefinitionName name)+ (AppliedTypes appliedTypes)+ ) =+ let appliedEncoders = appliedTypes & fmap (encoderForFieldType ("", "")) & Text.intercalate " "+ in mconcat ["(", haskellifyModuleName moduleName, ".", name, ".Encoder ", appliedEncoders, ")"]+encoderForDefinitionReference+ (DeclarationReference (ModuleName moduleName) (DefinitionName name)) =+ mconcat [haskellifyModuleName 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 [haskellifyModuleName 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 [haskellifyModuleName 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 [haskellifyModuleName moduleName, ".", name, maybeAppliedOutput]+outputDefinitionReference (DeclarationReference (ModuleName moduleName) (DefinitionName name)) =+ mconcat [haskellifyModuleName 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
@@ -1,6 +1,6 @@ module CodeGeneration.Python (outputModule) where -import CodeGeneration.Utilities (upperCaseFirstCharacter)+import CodeGeneration.Utilities (typeVariablesFrom, upperCaseFirstCharacter) import RIO import qualified RIO.Text as Text import Types@@ -1058,57 +1058,6 @@ 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) =
src/CodeGeneration/TypeScript.hs view
@@ -1,6 +1,6 @@ module CodeGeneration.TypeScript (outputModule) where -import CodeGeneration.Utilities (upperCaseFirstCharacter)+import CodeGeneration.Utilities (typeVariablesFrom, upperCaseFirstCharacter) import RIO import qualified RIO.Text as Text import Types@@ -1011,57 +1011,6 @@ & 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 =
src/CodeGeneration/Utilities.hs view
@@ -3,9 +3,61 @@ import RIO import qualified RIO.Char as Char import qualified RIO.Text as Text+import Types upperCaseFirstCharacter :: Text -> Text upperCaseFirstCharacter t = case Text.uncons t of Just (c, rest) -> Text.cons (Char.toUpper c) rest Nothing -> t++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++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++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
+ src/Gotyno/Helpers.hs view
@@ -0,0 +1,32 @@+module Gotyno.Helpers where++import Data.Aeson (FromJSON (..), ToJSON (..))+import qualified Data.Aeson as JSON+import Data.Aeson.Types (Parser)+import RIO+import qualified RIO.Text as Text++-- | Used for a more explicit style in `toJSON` instances. It also means we don't have to add type+-- annotations after the value.+newtype LiteralString = LiteralString Text+ deriving (Eq, Show, ToJSON)++-- | Used to encode `Integer` ({I,U}{64,128}) values, because there are ecosystems where these+-- cannot be decoded properly without having them come in as strings in transit.+newtype StringEncodedInteger = StringEncodedInteger Integer+ deriving (Eq, Show)++instance FromJSON StringEncodedInteger where+ parseJSON = JSON.withText "StringEncodedInteger" $ \text ->+ case text & Text.unpack & readMaybe of+ Just i -> pure $ StringEncodedInteger i+ Nothing -> fail $ mconcat ["Expected value readable as bigint, got: ", show text]++instance ToJSON StringEncodedInteger where+ toJSON (StringEncodedInteger i) = JSON.String $ tshow i++-- | Checks that a value matches an expectation, used to check literals.+checkEqualTo :: (Eq a, Show a) => a -> a -> Parser a+checkEqualTo expected actual+ | expected == actual = pure actual+ | otherwise = fail $ "Expected: " <> show expected <> " but got: " <> show actual
src/Parsing.hs view
@@ -1,5 +1,6 @@-module Parsing where+module Parsing (parseModules, test) where +import qualified CodeGeneration.Utilities as Utilities import RIO ( Bool (..), Char,@@ -23,6 +24,7 @@ for, fromMaybe, isLeft,+ length, maybe, mconcat, mempty,@@ -40,6 +42,7 @@ (&), (*>), (.),+ (/=), (<$), (<$>), (<*),@@ -55,7 +58,8 @@ import System.IO (putStrLn) import Text.Megaparsec import Text.Megaparsec.Char-import Text.Megaparsec.Char.Lexer+import Text.Megaparsec.Char.Lexer hiding (lexeme, symbol)+import qualified Text.Megaparsec.Char.Lexer as Lexer import Text.Show.Pretty (pPrint) import Types @@ -88,6 +92,8 @@ let moduleName = f & FilePath.takeBaseName & pack & ModuleName fileContents <- readFileUtf8 f maybeModule <- run state fileContents $ moduleP moduleName f+ writeIORef currentDefinitionsReference mempty+ writeIORef currentDeclarationNamesReference mempty case maybeModule of Right module' -> do addModule module' modulesReference@@ -116,10 +122,8 @@ moduleP name sourceFile = do imports <- fromMaybe [] <$> optional (sepEndBy1 importP newline <* newline) addImports imports- definitions <- sepBy1 typeDefinitionP (newline <* newline) <* eof+ definitions <- sepEndBy1 typeDefinitionP (some newline) <* eof declarationNames <- Set.toList <$> getDeclarationNames- clearDeclarationNames- clearDefinitions pure Module {name, imports, definitions, sourceFile, declarationNames} addImports :: [Import] -> Parser ()@@ -137,14 +141,9 @@ AppState {currentDeclarationNamesReference} <- ask readIORef currentDeclarationNamesReference -clearDeclarationNames :: Parser ()-clearDeclarationNames = do- AppState {currentDeclarationNamesReference} <- ask- writeIORef currentDeclarationNamesReference Set.empty- importP :: Parser Import importP = do- string "import "+ symbol "import " importName <- some (alphaNumChar <|> char '_') maybeModule <- getModule importName case maybeModule of@@ -168,23 +167,23 @@ keyword <- choice $ List.map string ["struct", "untagged union", "union", "enum", "declare"] definition <- case keyword of "struct" ->- char ' ' *> structP+ some (char ' ') *> structP "union" -> do maybeTagType <- optional $ do- _ <- char '('+ _ <- symbol "(" tagTypeP <* char ')' let tagType = fromMaybe (StandardTypeTag $ FieldName "type") maybeTagType- char ' ' *> case tagType of+ some (char ' ') *> case tagType of StandardTypeTag fieldName -> unionP fieldName EmbeddedTypeTag fieldName -> embeddedUnionP fieldName "untagged union" ->- char ' ' *> untaggedUnionP+ some (char ' ') *> untaggedUnionP "enum" ->- char ' ' *> enumerationP+ some (char ' ') *> enumerationP "declare" ->- char ' ' *> declarationP+ some (char ' ') *> declarationP other -> reportError $ "Unknown type definition keyword: " <> unpack other addDefinition definition@@ -231,7 +230,7 @@ structP :: Parser TypeDefinition structP = do- name <- readCurrentDefinitionName <* char ' '+ name <- lexeme readCurrentDefinitionName maybeTypeVariables <- optional $ between (char '<') (char '>') typeVariablesP string "{\n" case maybeTypeVariables of@@ -251,17 +250,16 @@ pure $ TypeDefinition name $ Struct $ PlainStruct fields constructorsP :: [TypeVariable] -> Parser [Constructor]-constructorsP = some . constructorP+constructorsP typeVariables = some $ some (char ' ') *> constructorP typeVariables constructorP :: [TypeVariable] -> Parser Constructor constructorP typeVariables = do- string " " name <- constructorNameP- maybeColon <- optional $ string ": "+ maybeColon <- optional $ symbol ": " payload <- case maybeColon of Just _ -> Just <$> fieldTypeP typeVariables Nothing -> pure Nothing- newline+ many (char ' ') *> newline pure $ Constructor (ConstructorName name) payload constructorNameP :: Parser Text@@ -272,7 +270,7 @@ unionP :: FieldName -> Parser TypeDefinition unionP typeTag = do- name <- readCurrentDefinitionName <* char ' '+ name <- lexeme readCurrentDefinitionName maybeTypeVariables <- optional $ between (char '<') (char '>') typeVariablesP string "{\n" case maybeTypeVariables of@@ -281,7 +279,7 @@ embeddedUnionP :: FieldName -> Parser TypeDefinition embeddedUnionP typeTag = do- name <- readCurrentDefinitionName <* string " {\n"+ name <- lexeme readCurrentDefinitionName <* string "{\n" constructors <- embeddedUnionStructConstructorsP [] _ <- char '}' pure $ TypeDefinition name (EmbeddedUnion typeTag constructors)@@ -300,11 +298,11 @@ embeddedUnionStructConstructorP :: [TypeVariable] -> Parser EmbeddedConstructor embeddedUnionStructConstructorP typeVariables = do- constructorName <- string " " *> embeddedConstructorNameP+ constructorName <- some (char ' ') *> embeddedConstructorNameP maybeDefinition <- choice- [ Nothing <$ newline,- Just <$> (string ": " *> structReferenceP typeVariables <* newline)+ [ Nothing <$ many (char ' ') <* newline,+ Just <$> (symbol ": " *> structReferenceP typeVariables <* many (char ' ') <* newline) ] pure $ EmbeddedConstructor (ConstructorName constructorName) maybeDefinition @@ -330,9 +328,7 @@ enumerationP :: Parser TypeDefinition enumerationP = do- name <- definitionNameP- setCurrentDefinitionName name- string " {\n"+ name <- lexeme readCurrentDefinitionName <* "{\n" values <- enumerationValuesP char '}' pure $ TypeDefinition name $ Enumeration values@@ -342,9 +338,9 @@ enumerationValueP :: Parser EnumerationValue enumerationValueP = do- string " "- identifier <- (pack >>> EnumerationIdentifier) <$> someTill alphaNumChar (string " = ")- value <- literalP <* newline+ some (char ' ')+ identifier <- (pack >>> EnumerationIdentifier) <$> someTill alphaNumChar (symbol " = ")+ value <- literalP <* many (char ' ') <* newline pure $ EnumerationValue identifier value plainUnionP :: FieldName -> DefinitionName -> Parser TypeDefinition@@ -366,9 +362,9 @@ fieldP :: [TypeVariable] -> Parser StructField fieldP typeVariables = do- string " "+ _ <- some $ char ' ' name <- fieldNameP- string ": "+ symbol ": " fieldType <- fieldTypeP typeVariables newline pure $ StructField name fieldType@@ -410,21 +406,65 @@ maybeDefinition <- getDefinition soughtName maybeTypeVariables <- optional $ between (char '<') (char '>') $ sepBy1 (fieldTypeP typeVariables) (string ", ")+ ensureMatchingGenericity maybeDefinition maybeTypeVariables case maybeDefinition of- Just (TypeDefinition name' (DeclaredType moduleName _typeVariables)) ->+ Just definition@(TypeDefinition name' (DeclaredType moduleName _typeVariables)) -> case maybeTypeVariables of Nothing -> pure $ DeclarationReference moduleName name' Just appliedTypes ->- pure $ GenericDeclarationReference moduleName name' (AppliedTypes appliedTypes)+ if isGenericType definition+ then pure $ GenericDeclarationReference moduleName name' (AppliedTypes appliedTypes)+ else+ reportError $+ mconcat ["Trying to apply type as generic, but ", unpack n, " is not generic"] Just definition -> do case maybeTypeVariables of Just appliedTypeVariables ->- pure $ AppliedGenericReference appliedTypeVariables definition+ if isGenericType definition+ then pure $ AppliedGenericReference appliedTypeVariables definition+ else+ reportError $+ mconcat ["Trying to apply type as generic, but ", unpack n, " is not generic"] Nothing -> pure $ DefinitionReference definition Nothing -> reportError $ mconcat ["Unknown type reference: ", unpack n] +ensureMatchingGenericity :: Maybe TypeDefinition -> Maybe [FieldType] -> Parser ()+ensureMatchingGenericity Nothing _maybeTypeParameters = pure ()+ensureMatchingGenericity (Just definition) maybeTypeParameters = do+ let expectedTypeParameters =+ definition+ & Utilities.typeVariablesFromDefinition+ & fromMaybe []+ & length+ name = definition & typeDefinitionName & unDefinitionName & unpack+ appliedTypeParameters = maybeTypeParameters & fromMaybe [] & length+ if expectedTypeParameters /= appliedTypeParameters+ then+ reportError $+ mconcat+ [ "Type ",+ name,+ " expects ",+ show expectedTypeParameters,+ " type parameters, ",+ show appliedTypeParameters,+ " applied"+ ]+ else pure ()++isGenericType :: TypeDefinition -> Bool+isGenericType (TypeDefinition _name (Struct (GenericStruct _typeVariables _fields))) = True+isGenericType (TypeDefinition _name (Union _tag (GenericUnion _typeVariables _constructors))) = True+isGenericType (TypeDefinition _name (Struct (PlainStruct _fields))) = False+isGenericType (TypeDefinition _name (Union _tag (PlainUnion _constructors))) = False+isGenericType (TypeDefinition _name (DeclaredType _moduleName typeVariables)) =+ not $ List.null typeVariables+isGenericType (TypeDefinition _name (EmbeddedUnion _tag _constructors)) = False+isGenericType (TypeDefinition _name (UntaggedUnion _cases)) = False+isGenericType (TypeDefinition _name (Enumeration _values)) = False+ getDefinitions :: Parser [TypeDefinition] getDefinitions = do AppState {currentDefinitionsReference} <- ask@@ -445,11 +485,6 @@ 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')@@ -465,6 +500,7 @@ DefinitionReferenceType <$> importedReferenceP typeVariables, RecursiveReferenceType <$> recursiveReferenceP ]+ <* many (char ' ') typeVariableReferenceP :: [TypeVariable] -> Parser TypeVariable typeVariableReferenceP typeVariables =@@ -620,3 +656,15 @@ partialFromLeft :: Either l r -> l partialFromLeft (Left l) = l partialFromLeft (Right _r) = error "Unable to get `Left` from `Right`"++typeDefinitionName :: TypeDefinition -> DefinitionName+typeDefinitionName (TypeDefinition name _) = name++lexeme :: Parser a -> Parser a+lexeme = Lexer.lexeme spaceConsumer++symbol :: Text -> Parser Text+symbol = Lexer.symbol spaceConsumer++spaceConsumer :: Parser ()+spaceConsumer = Lexer.space space1 (Lexer.skipLineComment "# ") empty
src/Types.hs view
@@ -17,7 +17,7 @@ newtype Import = Import Module deriving (Eq, Show) -newtype DefinitionName = DefinitionName Text+newtype DefinitionName = DefinitionName {unDefinitionName :: Text} deriving (Eq, Show) data TypeDefinition = TypeDefinition !DefinitionName !TypeData
test/ParsingSpec.hs view
@@ -103,6 +103,135 @@ ["test/examples/declaration1.gotyno", "test/examples/declaration2.gotyno"] length modules `shouldBe` 2 + describe "Handles applied type parameters properly" $ do+ it "Errors out when trying to apply a non-generic type" $ do+ result <- parseModules ["test/examples/applyingNonGeneric.gotyno"]+ isLeft result `shouldBe` True+ case result of+ Left e ->+ PartialList.head e `shouldContain` "Type NotGeneric expects 0 type parameters"+ Right _ ->+ error "We should not hit `Right` when expecting error"++ it "Errors out when not applying enough type parameters" $ do+ result <- parseModules ["test/examples/notApplyingEnoughGenericTypes.gotyno"]+ isLeft result `shouldBe` True+ case result of+ Left e ->+ PartialList.head e+ `shouldContain` "Type GenericUnion expects 2 type parameters, 1 applied"+ Right _ ->+ error "We should not hit `Right` when expecting error"+ it "Handles one missing argument out of 2" $ do+ result <- parseModules ["test/examples/declaredGenerics1.gotyno"]+ isLeft result `shouldBe` True+ case result of+ Left e ->+ PartialList.head e+ `shouldContain` "Type GenericUnion expects 2 type parameters, 1 applied"+ Right _ ->+ error "We should not hit `Right` when expecting error"+ it "Handles two missing arguments out of 2" $ do+ result <- parseModules ["test/examples/declaredGenerics2.gotyno"]+ isLeft result `shouldBe` True+ case result of+ Left e ->+ PartialList.head e+ `shouldContain` "Type GenericUnion expects 2 type parameters, 0 applied"+ Right _ ->+ error "We should not hit `Right` when expecting error"+ it "Handles one missing arguments out of 1" $ do+ result <- parseModules ["test/examples/declaredGenerics3.gotyno"]+ isLeft result `shouldBe` True+ case result of+ Left e ->+ PartialList.head e+ `shouldContain` "Type GenericUnion expects 1 type parameters, 0 applied"+ Right _ ->+ error "We should not hit `Right` when expecting error"+ it "Errors out when trying to apply a non-generic declared type" $ do+ result <- parseModules ["test/examples/declaredGenerics5.gotyno"]+ isLeft result `shouldBe` True+ case result of+ Left e ->+ PartialList.head e+ `shouldContain` "Type GenericUnion expects 0 type parameters, 1 applied"+ Right _ ->+ error "We should not hit `Right` when expecting error"+ it "Gives correct result when all are applied" $ do+ result <- parseModules ["test/examples/declaredGenerics4.gotyno"]+ isRight result `shouldBe` True++ describe "Parser is less rigid about syntax than reference implementation" $ do+ it "Does not error out when extra whitespace is used in many places" $ do+ result <- parseModules ["test/examples/relaxedWhiteSpace.gotyno"]+ let expectedModule =+ Module+ { name = ModuleName "relaxedWhiteSpace",+ imports = [],+ declarationNames = [],+ sourceFile = "test/examples/relaxedWhiteSpace.gotyno",+ definitions = expectedDefinitions+ }+ expectedDefinitions =+ [ TypeDefinition+ ( DefinitionName+ "UsingExtraSpaces"+ )+ ( Struct+ ( PlainStruct [StructField (FieldName "field") (BasicType BasicString)]+ )+ ),+ TypeDefinition+ (DefinitionName "DefinitionWithoutManyNewlines")+ (Struct (PlainStruct [StructField (FieldName "field2") (BasicType U32)])),+ TypeDefinition+ (DefinitionName "SomeUnionName")+ ( Union+ (FieldName "type")+ ( PlainUnion+ [ Constructor (ConstructorName "One") (Just (BasicType U32)),+ Constructor (ConstructorName "Two") Nothing+ ]+ )+ ),+ TypeDefinition+ (DefinitionName "Name")+ ( EmbeddedUnion+ (FieldName "kind")+ [ EmbeddedConstructor (ConstructorName "NoPayload") Nothing,+ EmbeddedConstructor+ (ConstructorName "WithPayload")+ ( Just+ ( DefinitionReference+ ( TypeDefinition+ (DefinitionName "UsingExtraSpaces")+ ( Struct+ ( PlainStruct+ [ StructField+ (FieldName "field")+ (BasicType BasicString)+ ]+ )+ )+ )+ )+ )+ ]+ ),+ TypeDefinition+ (DefinitionName "EnumName")+ ( Enumeration+ [ EnumerationValue+ (EnumerationIdentifier "value1")+ (LiteralString "value1"),+ EnumerationValue (EnumerationIdentifier "value2") (LiteralString "value1")+ ]+ )+ ]+ result `shouldBe` Right [expectedModule]++ describe "Reference output" $ do it "Gives the correct parsed output for `basic.gotyno`" $ do Module {name, imports, definitions} <- (getRight >>> PartialList.head) <$> parseModules ["examples/basic.gotyno"]@@ -166,6 +295,10 @@ let pythonPythonOutput = Python.outputModule pythonModule pythonPythonOutput `shouldBe` pyPython -getRight :: (Show l) => Either l r -> r+getRight :: Either [String] r -> r getRight (Right r) = r-getRight (Left e) = error $ "unpacking `Left` in `fromRight`, error: " <> show e+getRight (Left e) = error $ mconcat e++shouldBeRight :: Either [String] r -> Expectation+shouldBeRight (Right _r) = pure ()+shouldBeRight (Left e) = error $ mconcat e
+ test/examples/applyingNonGeneric.gotyno view
@@ -0,0 +1,7 @@+struct NotGeneric {+ field: String+}++struct UsingNotGeneric {+ field: NotGeneric<String>+}
+ test/examples/declaredGenerics1.gotyno view
@@ -0,0 +1,5 @@+declare someModule.GenericUnion<T, U>++struct UsingGeneric {+ field: GenericUnion<String>+}
+ test/examples/declaredGenerics2.gotyno view
@@ -0,0 +1,5 @@+declare someModule.GenericUnion<T, U>++struct UsingGeneric {+ field: GenericUnion+}
+ test/examples/declaredGenerics3.gotyno view
@@ -0,0 +1,5 @@+declare someModule.GenericUnion<T>++struct UsingGeneric {+ field: GenericUnion+}
+ test/examples/declaredGenerics4.gotyno view
@@ -0,0 +1,5 @@+declare someModule.GenericUnion<T>++struct UsingGeneric {+ field: GenericUnion<String>+}
+ test/examples/declaredGenerics5.gotyno view
@@ -0,0 +1,5 @@+declare someModule.GenericUnion++struct UsingGeneric {+ field: GenericUnion<String>+}
+ test/examples/notApplyingEnoughGenericTypes.gotyno view
@@ -0,0 +1,8 @@+union GenericUnion <T, U>{+ One: T+ Two: U+}++struct UsingGeneric {+ field: GenericUnion<String>+}
+ test/examples/relaxedWhiteSpace.gotyno view
@@ -0,0 +1,22 @@+struct UsingExtraSpaces {+ field: String +}+struct DefinitionWithoutManyNewlines {+ field2: U32+}+++union SomeUnionName {+ One: U32+ Two +}++union(tag = kind, embedded) Name {+ NoPayload + WithPayload: UsingExtraSpaces +}++enum EnumName {+ value1 = "value1" + value2 = "value1" +}