diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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` diff --git a/gotyno-hs.cabal b/gotyno-hs.cabal --- a/gotyno-hs.cabal +++ b/gotyno-hs.cabal @@ -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 diff --git a/src/Basic.hs b/src/Basic.hs new file mode 100644 --- /dev/null +++ b/src/Basic.hs @@ -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 +-- } diff --git a/src/CodeGeneration/FSharp.hs b/src/CodeGeneration/FSharp.hs --- a/src/CodeGeneration/FSharp.hs +++ b/src/CodeGeneration/FSharp.hs @@ -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) = diff --git a/src/CodeGeneration/Haskell.hs b/src/CodeGeneration/Haskell.hs new file mode 100644 --- /dev/null +++ b/src/CodeGeneration/Haskell.hs @@ -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 <> ">") diff --git a/src/CodeGeneration/Python.hs b/src/CodeGeneration/Python.hs --- a/src/CodeGeneration/Python.hs +++ b/src/CodeGeneration/Python.hs @@ -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) = diff --git a/src/CodeGeneration/TypeScript.hs b/src/CodeGeneration/TypeScript.hs --- a/src/CodeGeneration/TypeScript.hs +++ b/src/CodeGeneration/TypeScript.hs @@ -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 = diff --git a/src/CodeGeneration/Utilities.hs b/src/CodeGeneration/Utilities.hs --- a/src/CodeGeneration/Utilities.hs +++ b/src/CodeGeneration/Utilities.hs @@ -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 diff --git a/src/Gotyno/Helpers.hs b/src/Gotyno/Helpers.hs new file mode 100644 --- /dev/null +++ b/src/Gotyno/Helpers.hs @@ -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 diff --git a/src/Parsing.hs b/src/Parsing.hs --- a/src/Parsing.hs +++ b/src/Parsing.hs @@ -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 diff --git a/src/Types.hs b/src/Types.hs --- a/src/Types.hs +++ b/src/Types.hs @@ -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 diff --git a/test/ParsingSpec.hs b/test/ParsingSpec.hs --- a/test/ParsingSpec.hs +++ b/test/ParsingSpec.hs @@ -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 diff --git a/test/examples/applyingNonGeneric.gotyno b/test/examples/applyingNonGeneric.gotyno new file mode 100644 --- /dev/null +++ b/test/examples/applyingNonGeneric.gotyno @@ -0,0 +1,7 @@ +struct NotGeneric { + field: String +} + +struct UsingNotGeneric { + field: NotGeneric +} diff --git a/test/examples/declaredGenerics1.gotyno b/test/examples/declaredGenerics1.gotyno new file mode 100644 --- /dev/null +++ b/test/examples/declaredGenerics1.gotyno @@ -0,0 +1,5 @@ +declare someModule.GenericUnion + +struct UsingGeneric { + field: GenericUnion +} diff --git a/test/examples/declaredGenerics2.gotyno b/test/examples/declaredGenerics2.gotyno new file mode 100644 --- /dev/null +++ b/test/examples/declaredGenerics2.gotyno @@ -0,0 +1,5 @@ +declare someModule.GenericUnion + +struct UsingGeneric { + field: GenericUnion +} diff --git a/test/examples/declaredGenerics3.gotyno b/test/examples/declaredGenerics3.gotyno new file mode 100644 --- /dev/null +++ b/test/examples/declaredGenerics3.gotyno @@ -0,0 +1,5 @@ +declare someModule.GenericUnion + +struct UsingGeneric { + field: GenericUnion +} diff --git a/test/examples/declaredGenerics4.gotyno b/test/examples/declaredGenerics4.gotyno new file mode 100644 --- /dev/null +++ b/test/examples/declaredGenerics4.gotyno @@ -0,0 +1,5 @@ +declare someModule.GenericUnion + +struct UsingGeneric { + field: GenericUnion +} diff --git a/test/examples/declaredGenerics5.gotyno b/test/examples/declaredGenerics5.gotyno new file mode 100644 --- /dev/null +++ b/test/examples/declaredGenerics5.gotyno @@ -0,0 +1,5 @@ +declare someModule.GenericUnion + +struct UsingGeneric { + field: GenericUnion +} diff --git a/test/examples/notApplyingEnoughGenericTypes.gotyno b/test/examples/notApplyingEnoughGenericTypes.gotyno new file mode 100644 --- /dev/null +++ b/test/examples/notApplyingEnoughGenericTypes.gotyno @@ -0,0 +1,8 @@ +union GenericUnion { + One: T + Two: U +} + +struct UsingGeneric { + field: GenericUnion +} diff --git a/test/examples/relaxedWhiteSpace.gotyno b/test/examples/relaxedWhiteSpace.gotyno new file mode 100644 --- /dev/null +++ b/test/examples/relaxedWhiteSpace.gotyno @@ -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" +}