From bc9057a821d40743dc526ae0ee7905bbbbe3da17 Mon Sep 17 00:00:00 2001 From: Peter Brant Date: Thu, 6 Jan 2022 05:34:59 -0600 Subject: [PATCH] Code gen overhaul - Add support for generic type parameters. They are supported for PureScript encoding and decoding as well as Scala encoding. Scala decoding is not supported, but may be in the future when/if error handling is reworked. - Add support for sum types with constructor parameters. Sum types that only use zero arg constructors still generate and decode the same JSON they did before. - Separate CST and AST. The main difference is that the AST lacks position information, but includes fully resolved dependencies. This is useful for the PureScript optimizations described below. It also means that code generation does not need to deal with error conditions. - As part of the above, detect many more error conditions and centralize error handling to the CST/AST conversion phase. - Improve PureScript decoding performance. The exact performance increase depends on the template, but typical improvements are 10-20x faster. Story: S-23064 Reviewed-by: cwinebr --- .gitignore | 1 + .prettierrc | 5 + package.json | 4 +- packages.dhall | 92 ++- samples/errors/Cycle1.tmpl | 6 + samples/errors/Cycle2.tmpl | 6 + samples/errors/Cycle3.tmpl | 6 + samples/errors/Imported.tmpl | 4 + samples/errors/TypeErrors.tmpl | 21 + spago.dhall | 3 +- src/Ccap/Codegen/Annotations.purs | 20 +- src/Ccap/Codegen/Ast.purs | 150 +++++ src/Ccap/Codegen/AstBuilder.purs | 379 +++++++++++ src/Ccap/Codegen/Config.purs | 4 +- src/Ccap/Codegen/Cst.purs | 263 ++++++++ src/Ccap/Codegen/Database.purs | 114 ++-- src/Ccap/Codegen/Env.purs | 43 -- src/Ccap/Codegen/Error.purs | 83 +++ src/Ccap/Codegen/FileSystem.purs | 8 +- src/Ccap/Codegen/Imports.purs | 118 ---- src/Ccap/Codegen/Module.purs | 58 -- src/Ccap/Codegen/Parser.purs | 244 +++---- src/Ccap/Codegen/PrettyPrint.purs | 104 +-- src/Ccap/Codegen/PureScript.purs | 632 ++++++++++++++++++ src/Ccap/Codegen/PureScriptJs.purs | 188 ++++++ src/Ccap/Codegen/Purescript.purs | 372 ----------- src/Ccap/Codegen/Runtime.js | 88 +++ src/Ccap/Codegen/Runtime.purs | 183 ++++-- src/Ccap/Codegen/Scala.purs | 644 ++++++++++++------- src/Ccap/Codegen/Shared.purs | 68 +- src/Ccap/Codegen/TypeRef.purs | 124 ---- src/Ccap/Codegen/Types.purs | 163 ----- src/Ccap/Codegen/Util.purs | 8 - src/Ccap/Codegen/ValidationError.purs | 23 - src/GetSchema.purs | 6 +- src/Main.purs | 96 ++- test/Ccap/Codegen/Annotations.purs | 54 +- test/Ccap/Codegen/Exports.purs | 22 +- test/Ccap/Codegen/FastDecoding.purs | 49 ++ test/Ccap/Codegen/FastDecoding/Domains.purs | 72 +++ test/Ccap/Codegen/FastDecoding/FastTest.js | 358 +++++++++++ test/Ccap/Codegen/FastDecoding/FastTest.purs | 273 ++++++++ test/Ccap/Codegen/Imports.purs | 159 ----- test/Ccap/Codegen/Parser.purs | 35 +- test/Ccap/Codegen/Util.purs | 52 +- test/GetSchema.purs | 15 +- test/Main.purs | 6 +- test/resources/exports/Exports.tmpl | 8 +- test/resources/exports/Imports.tmpl | 2 +- test/resources/fastdecoding/Domains.tmpl | 7 + test/resources/fastdecoding/FastTest.tmpl | 68 ++ test/resources/parser/Printed.purs_ | 260 +++++++- test/resources/parser/Printed.scala | 163 ++++- test/resources/parser/Printed.tmpl | 34 + 54 files changed, 4187 insertions(+), 1781 deletions(-) create mode 100644 .prettierrc create mode 100644 samples/errors/Cycle1.tmpl create mode 100644 samples/errors/Cycle2.tmpl create mode 100644 samples/errors/Cycle3.tmpl create mode 100644 samples/errors/Imported.tmpl create mode 100644 samples/errors/TypeErrors.tmpl create mode 100644 src/Ccap/Codegen/Ast.purs create mode 100644 src/Ccap/Codegen/AstBuilder.purs create mode 100644 src/Ccap/Codegen/Cst.purs delete mode 100644 src/Ccap/Codegen/Env.purs create mode 100644 src/Ccap/Codegen/Error.purs delete mode 100644 src/Ccap/Codegen/Imports.purs delete mode 100644 src/Ccap/Codegen/Module.purs create mode 100644 src/Ccap/Codegen/PureScript.purs create mode 100644 src/Ccap/Codegen/PureScriptJs.purs delete mode 100644 src/Ccap/Codegen/Purescript.purs create mode 100644 src/Ccap/Codegen/Runtime.js delete mode 100644 src/Ccap/Codegen/TypeRef.purs delete mode 100644 src/Ccap/Codegen/Types.purs delete mode 100644 src/Ccap/Codegen/ValidationError.purs create mode 100644 test/Ccap/Codegen/FastDecoding.purs create mode 100644 test/Ccap/Codegen/FastDecoding/Domains.purs create mode 100644 test/Ccap/Codegen/FastDecoding/FastTest.js create mode 100644 test/Ccap/Codegen/FastDecoding/FastTest.purs delete mode 100644 test/Ccap/Codegen/Imports.purs create mode 100644 test/resources/fastdecoding/Domains.tmpl create mode 100644 test/resources/fastdecoding/FastTest.tmpl diff --git a/.gitignore b/.gitignore index b76dd5f..7de1b00 100644 --- a/.gitignore +++ b/.gitignore @@ -13,3 +13,4 @@ /test/generated/* package-lock.json yarn.lock +.metals diff --git a/.prettierrc b/.prettierrc new file mode 100644 index 0000000..6d14897 --- /dev/null +++ b/.prettierrc @@ -0,0 +1,5 @@ +trailingComma: es5 +bracketSpacing: true +tabWidth: 2 +singleQuote: true +insertPragma: true diff --git a/package.json b/package.json index e39326a..c7d46ee 100644 --- a/package.json +++ b/package.json @@ -17,10 +17,10 @@ "devDependencies": { "spago": "^0.13.0", "dotenv-cli": "^3.0.0", - "purescript": "^0.13.5", + "purescript": "^0.13.8", "purescript-language-server": "^0.12.7", "purescript-psa": "^0.7.3", - "purty": "^4.5.2", + "purty": "6.2.0", "rimraf": "^2.6.2" } } diff --git a/packages.dhall b/packages.dhall index 0c044dd..7c2b22e 100644 --- a/packages.dhall +++ b/packages.dhall @@ -1,54 +1,52 @@ - - let upstream = - https://github.com/purescript/package-sets/releases/download/psc-0.13.5-20191215/packages.dhall sha256:fdc5d54cd54213000100fbc13c90dce01668a73fe528d8662430558df3411bee + https://github.com/purescript/package-sets/releases/download/psc-0.13.8/packages.dhall sha256:0e95ec11604dc8afc1b129c4d405dcc17290ce56d7d0665a0ff15617e32bbf03 let overrides = {=} let additions = - { boxes = - { dependencies = - [ "profunctor" - , "prelude" - , "stringutils" - , "generics-rep" - , "strings" - ] - , repo = "https://github.com/cdepillabout/purescript-boxes.git" - , version = "v2.0.1" - } - , postgresql-client = - { dependencies = - [ "aff" - , "argonaut" - , "arrays" - , "assert" - , "bifunctors" - , "bytestrings" - , "console" - , "datetime" - , "decimals" - , "effect" - , "either" - , "exceptions" - , "foldable-traversable" - , "foreign" - , "foreign-generic" - , "foreign-object" - , "js-date" - , "lists" - , "maybe" - , "newtype" - , "nullable" - , "prelude" - , "psci-support" - , "test-unit" - , "transformers" - , "tuples" - ] - , repo = "https://github.com/pbrant/purescript-postgresql-client.git" - , version = "7188cd732eb7981910915fb5e8ab8b158abda95b" -- #update-dependencies - } - } + { boxes = + { dependencies = + [ "profunctor" + , "prelude" + , "stringutils" + , "generics-rep" + , "strings" + ] + , repo = "https://github.com/cdepillabout/purescript-boxes.git" + , version = "v2.0.1" + } + , postgresql-client = + { dependencies = + [ "aff" + , "argonaut" + , "arrays" + , "assert" + , "bifunctors" + , "bytestrings" + , "console" + , "datetime" + , "decimals" + , "effect" + , "either" + , "exceptions" + , "foldable-traversable" + , "foreign" + , "foreign-generic" + , "foreign-object" + , "js-date" + , "lists" + , "maybe" + , "newtype" + , "nullable" + , "prelude" + , "psci-support" + , "test-unit" + , "transformers" + , "tuples" + ] + , repo = "https://github.com/pbrant/purescript-postgresql-client.git" + , version = "7188cd732eb7981910915fb5e8ab8b158abda95b" + } + } in upstream // overrides // additions diff --git a/samples/errors/Cycle1.tmpl b/samples/errors/Cycle1.tmpl new file mode 100644 index 0000000..b48bf35 --- /dev/null +++ b/samples/errors/Cycle1.tmpl @@ -0,0 +1,6 @@ +scala: test.Cycle1 +purs: Test.Cycle1 + +import Cycle2 + +type X: Int diff --git a/samples/errors/Cycle2.tmpl b/samples/errors/Cycle2.tmpl new file mode 100644 index 0000000..4e18288 --- /dev/null +++ b/samples/errors/Cycle2.tmpl @@ -0,0 +1,6 @@ +scala: test.Cycle2 +purs: Test.Cycle2 + +import Cycle3 + +type X: Int diff --git a/samples/errors/Cycle3.tmpl b/samples/errors/Cycle3.tmpl new file mode 100644 index 0000000..9f154e4 --- /dev/null +++ b/samples/errors/Cycle3.tmpl @@ -0,0 +1,6 @@ +scala: test.Cycle3 +purs: Test.Cycle3 + +import Cycle1 + +type X: Int diff --git a/samples/errors/Imported.tmpl b/samples/errors/Imported.tmpl new file mode 100644 index 0000000..2774b73 --- /dev/null +++ b/samples/errors/Imported.tmpl @@ -0,0 +1,4 @@ +scala: test.Imported +purs: Test.Imported + +type X: Int diff --git a/samples/errors/TypeErrors.tmpl b/samples/errors/TypeErrors.tmpl new file mode 100644 index 0000000..3c6c26d --- /dev/null +++ b/samples/errors/TypeErrors.tmpl @@ -0,0 +1,21 @@ +scala: test.TypeErrors +purs: Test.TypeErrors + +import Imported + +type Dup1: Int +type Dup1: String + +type Rec: { + dup1: Int + dup1: String +} + +type Sum: [ + | Dup1 + | Dup1 +] + +type X: Y +type Z: Imported.Q +type Q: Bar.M diff --git a/spago.dhall b/spago.dhall index e5ce6fd..a840f3e 100644 --- a/spago.dhall +++ b/spago.dhall @@ -5,8 +5,8 @@ You can edit this file as you like. { name = "ccap-codegen" , dependencies = [ "argonaut-codecs" - , "console" , "boxes" + , "console" , "debug" , "effect" , "filterable" @@ -22,6 +22,7 @@ You can edit this file as you like. , "strings" , "transformers" , "typelevel-prelude" + , "validation" , "yargs" ] , packages = ./packages.dhall diff --git a/src/Ccap/Codegen/Annotations.purs b/src/Ccap/Codegen/Annotations.purs index 9bd7a10..8446d9d 100644 --- a/src/Ccap/Codegen/Annotations.purs +++ b/src/Ccap/Codegen/Annotations.purs @@ -8,21 +8,21 @@ module Ccap.Codegen.Annotations ) where import Prelude -import Ccap.Codegen.Types (Annotation(..), Annotations, AnnotationParam(..)) +import Ccap.Codegen.Cst as Cst import Control.Alt ((<|>)) import Data.Array as Array import Data.Maybe (Maybe) -fieldWithOptParamValue :: String -> String -> Annotations -> Maybe (Maybe String) +fieldWithOptParamValue :: String -> String -> Array Cst.Annotation -> Maybe (Maybe String) fieldWithOptParamValue annotKey paramKey annots = do - Annotation _ _ params <- Array.find (\(Annotation n _ _) -> n == annotKey) annots - AnnotationParam _ _ v <- Array.find (\(AnnotationParam n _ _) -> n == paramKey) params + Cst.Annotation _ _ params <- Array.find (\(Cst.Annotation n _ _) -> n == annotKey) annots + Cst.AnnotationParam _ _ v <- Array.find (\(Cst.AnnotationParam n _ _) -> n == paramKey) params pure v -field :: String -> String -> Annotations -> Maybe String +field :: String -> String -> Array Cst.Annotation -> Maybe String field annotKey paramKey = join <<< fieldWithOptParamValue annotKey paramKey -getWrapOpts :: String -> Annotations -> Maybe { typ :: String, decode :: String, encode :: String } +getWrapOpts :: String -> Array Cst.Annotation -> Maybe { typ :: String, decode :: String, encode :: String } getWrapOpts lang an = let f n = field lang n an @@ -33,14 +33,14 @@ getWrapOpts lang an = encode <- f "encode" <|> pure "" pure { typ, decode, encode } -getMaxLength :: Annotations -> Maybe String +getMaxLength :: Array Cst.Annotation -> Maybe String getMaxLength = field "validations" "maxLength" -getMinLength :: Annotations -> Maybe String +getMinLength :: Array Cst.Annotation -> Maybe String getMinLength = field "validations" "minLength" -getMaxSize :: Annotations -> Maybe String +getMaxSize :: Array Cst.Annotation -> Maybe String getMaxSize = field "validations" "maxSize" -getIsPositive :: Annotations -> Maybe Unit +getIsPositive :: Array Cst.Annotation -> Maybe Unit getIsPositive annots = fieldWithOptParamValue "validations" "positive" annots $> unit diff --git a/src/Ccap/Codegen/Ast.purs b/src/Ccap/Codegen/Ast.purs new file mode 100644 index 0000000..2e0e868 --- /dev/null +++ b/src/Ccap/Codegen/Ast.purs @@ -0,0 +1,150 @@ +module Ccap.Codegen.Ast + ( Constructor(..) + , Module(..) + , RecordProp(..) + , ScalaDecoderType(..) + , TRef + , TopType(..) + , Type(..) + , TypeDecl(..) + , TypeOrParam(..) + , isRecord + , noArgConstructorNames + , typeDeclName + , typeDeclTopType + ) where + +import Prelude +import Ccap.Codegen.Cst as Cst +import Data.Array.NonEmpty (NonEmptyArray) +import Data.Generic.Rep (class Generic) +import Data.Generic.Rep.Show (genericShow) +import Data.Maybe (Maybe(..)) +import Data.Traversable (traverse) +import Data.Tuple (Tuple) + +newtype Module + = Module + { types :: NonEmptyArray TypeDecl + , imports :: Array Module + , exports :: Cst.Exports + , name :: Cst.ModuleName + } + +newtype TypeDecl + = TypeDecl + { name :: String + , topType :: TopType + , annots :: Array Cst.Annotation + , isPrimary :: Boolean + , params :: Array Cst.TypeParam + , scalaDecoderType :: Maybe ScalaDecoderType + } + +data TopType + = Type Type + | Wrap Type + | Record (NonEmptyArray RecordProp) + | Sum (NonEmptyArray Constructor) + +data Type + = Primitive Cst.Primitive + | Ref TRef + | Array TypeOrParam + | Option TypeOrParam + +data TypeOrParam + = TType Type + | TParam Cst.TypeParam + +type TRef + = { decl :: Maybe (Tuple Module TypeDecl) + , typ :: String + , params :: Array TypeOrParam + , isPrimaryRef :: Boolean + } + +type RecordProp + = { name :: String + , typ :: TypeOrParam + , annots :: Array Cst.Annotation + } + +data Constructor + = NoArg Cst.ConstructorName + | WithArgs Cst.ConstructorName (NonEmptyArray TypeOrParam) + +isRecord :: TopType -> Boolean +isRecord = case _ of + Record _ -> true + _ -> false + +-- | Get the type name of a type declaration. +typeDeclName :: TypeDecl -> String +typeDeclName (TypeDecl { name }) = name + +-- | Get the top most type of a type declaration. +typeDeclTopType :: TypeDecl -> TopType +typeDeclTopType (TypeDecl { topType }) = topType + +noArgConstructorNames :: NonEmptyArray Constructor -> Maybe (NonEmptyArray String) +noArgConstructorNames = + traverse + ( case _ of + NoArg (Cst.ConstructorName n) -> Just n + WithArgs _ _ -> Nothing + ) + +data ScalaDecoderType + = Field + | Form + +-- Instances here to avoid cluttering the above +derive instance eqScalaDecoderType :: Eq ScalaDecoderType + +derive instance genericScalaDecoderType :: Generic ScalaDecoderType _ + +instance showScalaDecoderType :: Show ScalaDecoderType where + show t = genericShow t + +derive instance eqModule :: Eq Module + +derive instance genericModule :: Generic Module _ + +instance showModule :: Show Module where + show t = genericShow t + +derive instance eqTypeOrParam :: Eq TypeOrParam + +derive instance genericTypeOrParam :: Generic TypeOrParam _ + +instance showTypeOrParam :: Show TypeOrParam where + show t = genericShow t + +derive instance eqConstructor :: Eq Constructor + +derive instance genericConstructor :: Generic Constructor _ + +instance showConstructor :: Show Constructor where + show t = genericShow t + +derive instance eqType :: Eq Type + +derive instance genericType :: Generic Type _ + +instance showType :: Show Type where + show t = genericShow t + +derive instance eqTopType :: Eq TopType + +derive instance genericTopType :: Generic TopType _ + +instance showTopType :: Show TopType where + show = genericShow + +derive instance eqTypeDecl :: Eq TypeDecl + +derive instance genericTypeDecl :: Generic TypeDecl _ + +instance showTypeDecl :: Show TypeDecl where + show = genericShow diff --git a/src/Ccap/Codegen/AstBuilder.purs b/src/Ccap/Codegen/AstBuilder.purs new file mode 100644 index 0000000..6651502 --- /dev/null +++ b/src/Ccap/Codegen/AstBuilder.purs @@ -0,0 +1,379 @@ +module Ccap.Codegen.AstBuilder + ( build + , parseAll + ) where + +import Prelude +import Ccap.Codegen.Ast as Ast +import Ccap.Codegen.Cst as Cst +import Ccap.Codegen.Error as Error +import Ccap.Codegen.FileSystem as FileSystem +import Ccap.Codegen.Parser as Parser +import Ccap.Codegen.Parser.Export as Export +import Control.Monad.Except (ExceptT(..), except, runExceptT) +import Control.Monad.State (StateT) +import Control.Monad.State as S +import Control.Monad.Trans.Class as T +import Data.Array ((:)) +import Data.Array as Array +import Data.Array.NonEmpty (NonEmptyArray) +import Data.Array.NonEmpty as NonEmptyArray +import Data.Bifunctor (lmap) +import Data.Compactable (compact) +import Data.Either (Either(..), note) +import Data.Foldable (any, elem) +import Data.Generic.Rep (class Generic) +import Data.Generic.Rep.Show (genericShow) +import Data.Map (Map) +import Data.Map as Map +import Data.Maybe (Maybe(..), fromMaybe) +import Data.Set (Set) +import Data.Set as Set +import Data.String as String +import Data.Traversable (for, sequence, traverse) +import Data.Tuple (Tuple(..)) +import Data.Validation.Semigroup as Validation +import Effect (Effect) +import Node.Path (FilePath) +import Node.Path as Path +import Text.Parsing.Parser.Pos (Position) + +type BuildParams + = { files :: Array FilePath + , importPaths :: Array FilePath + } + +build :: BuildParams -> ExceptT (NonEmptyArray Error.Error) Effect (Array (Cst.Source Ast.Module)) +build params@{ files } = do + resolved <- T.lift (traverse (Path.resolve []) files) + mods <- parseAll resolved + let + importResult = runExceptT (S.evalStateT (traverse (parseImports params) mods) { visiting: Set.empty, complete: Map.empty }) + modsWithImports <- ExceptT (map (lmap NonEmptyArray.singleton) importResult) + except (S.evalStateT (traverse buildAstModule modsWithImports) Map.empty) + +buildAstModule :: ModuleWithImports -> StateT (Map FilePath (Cst.Source Ast.Module)) (Either (NonEmptyArray Error.Error)) (Cst.Source Ast.Module) +buildAstModule (ModuleWithImports { mod, imports: is }) = do + cache <- S.get + case Map.lookup mod.source cache of + Just m -> pure m + Nothing -> do + let + Cst.ModuleName modName = mod.contents.name + + scalaName = fromMaybe mod.contents.exports.scalaPkg (Array.last (Export.split mod.contents.exports.scalaPkg)) + + pursName = fromMaybe mod.contents.exports.pursPkg (Array.last (Export.split mod.contents.exports.pursPkg)) + if Array.length + ( Array.nub + [ modName + , scalaName + , pursName + ] + ) + /= 1 then + T.lift (Left (NonEmptyArray.singleton (Error.ModuleNameMismatch mod.source { moduleName: modName, scalaName, pursName }))) + else + pure unit + importedModules <- for is \m@(ModuleWithImports { mod: i }) -> map _.contents (buildAstModule m) + let + allTypeDeclNames = map Cst.typeDeclName mod.contents.types + + params = + { dups: findDups (map Cst.typeDeclName mod.contents.types) + , filePath: mod.source + , decls: Map.fromFoldable (map (\t -> Tuple (Cst.typeDeclName t) t) mod.contents.types) + , importedModules: Map.fromFoldable (map (\m@(Ast.Module { name: Cst.ModuleName n }) -> Tuple n m) importedModules) + , moduleName: mod.contents.name + } + decls <- + T.lift + ( Validation.toEither + ( traverse (Validation.V <<< lmap NonEmptyArray.singleton <<< cstTypeDeclToAstTypeDecl params) mod.contents.types + ) + ) + let + result = + { source: mod.source + , contents: + Ast.Module + { types: decls + , exports: mod.contents.exports + , imports: importedModules + , name: mod.contents.name + } + } + S.modify_ (Map.insert mod.source result) + pure result + +type BuildTypeDeclParams + = { dups :: Set String + , filePath :: FilePath + , decls :: Map String Cst.TypeDecl + , importedModules :: Map String Ast.Module + , moduleName :: Cst.ModuleName + } + +findDups :: NonEmptyArray String -> Set String +findDups ss = + Set.fromFoldable + ( compact + ( map + (\l -> if NonEmptyArray.length l > 1 then Just (NonEmptyArray.head l) else Nothing) + (Array.group (Array.sort (NonEmptyArray.toArray ss))) + ) + ) + +cstTypeDeclToAstTypeDecl :: BuildTypeDeclParams -> Cst.TypeDecl -> Either Error.Error Ast.TypeDecl +cstTypeDeclToAstTypeDecl buildParams@{ filePath, dups: typeDeclDups, importedModules, decls, moduleName } decl@(Cst.TypeDecl { position: pos, name, topType, annots, params: typeParams }) = do + if Set.member name typeDeclDups then + Left (Error.Positioned filePath pos (Error.TypeDecl Error.DuplicateType decl)) + else + Right unit + checkCycles Set.empty decl + scalaDecoderType <- scalaDecoderTypeDecl decl + case topType of + Cst.Type typ -> map (\t -> Ast.TypeDecl { name, topType: Ast.Type t, annots, isPrimary: false, params: typeParams, scalaDecoderType }) (cstTypeToAstType pos typ) + Cst.Wrap typ -> map (\t -> Ast.TypeDecl { name, topType: Ast.Wrap t, annots, isPrimary: false, params: typeParams, scalaDecoderType }) (cstTypeToAstType pos typ) + Cst.Record props -> do + let + dups = findDups (map (\{ name: n } -> n) props) + map + (\ps -> Ast.TypeDecl { name, topType: Ast.Record ps, annots, isPrimary: Cst.ModuleName name == moduleName, params: typeParams, scalaDecoderType }) + (traverse (cstRecordPropToAstRecordProp dups) props) + Cst.Sum constructors -> do + let + dups = findDups (map cstConstructorStringName constructors) + if not Set.isEmpty dups then + Left (Error.Positioned filePath pos (Error.TypeDecl (Error.DuplicateConstructorNames (map Cst.ConstructorName (Array.fromFoldable dups))) decl)) + else + map + (\cs -> Ast.TypeDecl { name, topType: Ast.Sum cs, annots, isPrimary: false, params: typeParams, scalaDecoderType }) + (traverse ((cstConstructorToAstConstructor pos) dups) constructors) + where + hasConstructorArguments :: NonEmptyArray Cst.Constructor -> Boolean + hasConstructorArguments = + any + ( case _ of + Cst.WithArgs _ _ -> true + Cst.NoArg _ -> false + ) + + checkCycles :: Set String -> Cst.TypeDecl -> Either Error.Error Unit + checkCycles visited (Cst.TypeDecl r) = do + if Set.member r.name visited then + Left (Error.Positioned filePath pos (Error.TypeDecl (Error.CircularType (Array.fromFoldable visited)) decl)) + else + Right unit + case r.topType of + Cst.Type ty -> checkCyclesType ty + Cst.Wrap ty -> Right unit + Cst.Record props -> + void + ( for props \{ typ } -> case typ of + Cst.TParam _ -> Right unit + Cst.TType t -> checkCyclesType t + ) + Cst.Sum _ -> Right unit + where + checkCyclesType :: Cst.Type -> Either Error.Error Unit + checkCyclesType = case _ of + Cst.Ref refPos ref@{ mod, params, typ } -> case mod of + Nothing -> do + d <- lookupCurrentModuleTypeDecl refPos ref + checkCycles (Set.insert r.name visited) d + Just n -> do + void (lookupImportedModuleTypeDecl refPos ref n) + Cst.Array (Cst.TType t) -> checkCyclesType t + Cst.Array (Cst.TParam _) -> Right unit + Cst.Option (Cst.TType t) -> checkCyclesType t + Cst.Option (Cst.TParam _) -> Right unit + Cst.Primitive _ -> Right unit + Cst.TypeWithParens ty -> checkCyclesType ty + + scalaDecoderTypeDecl :: Cst.TypeDecl -> Either Error.Error (Maybe Ast.ScalaDecoderType) + scalaDecoderTypeDecl (Cst.TypeDecl r) = do + if not Array.null r.params then + Right Nothing + else case r.topType of + Cst.Type ty -> scalaDecoderType ty + Cst.Wrap ty -> scalaDecoderType ty + Cst.Record _ -> Right (Just Ast.Form) + Cst.Sum cs -> + Right + ( Just + ( if hasConstructorArguments cs then + Ast.Form + else + Ast.Field + ) + ) + where + scalaDecoderType :: Cst.Type -> Either Error.Error (Maybe Ast.ScalaDecoderType) + scalaDecoderType = case _ of + Cst.Ref refPos ref@{ mod } -> case mod of + Nothing -> do + d <- lookupCurrentModuleTypeDecl refPos ref + scalaDecoderTypeDecl d + Just n -> do + Tuple _ (Ast.TypeDecl { scalaDecoderType: s }) <- lookupImportedModuleTypeDecl refPos ref n + Right s + Cst.Array (Cst.TType t) -> scalaDecoderType t + Cst.Array (Cst.TParam _) -> Right Nothing + Cst.Option (Cst.TType t) -> scalaDecoderType t + Cst.Option (Cst.TParam _) -> Right Nothing + Cst.Primitive _ -> Right (Just Ast.Field) + Cst.TypeWithParens ty -> scalaDecoderType ty + + cstTypeToAstType :: Position -> Cst.Type -> Either Error.Error Ast.Type + cstTypeToAstType typePos = case _ of + Cst.Primitive p -> Right (Ast.Primitive p) + Cst.TypeWithParens typ -> cstTypeToAstType typePos typ + Cst.Array t -> map Ast.Array (cstTypeParamToAstTypeParam typePos t) + Cst.Option t -> map Ast.Option (cstTypeParamToAstTypeParam typePos t) + Cst.Ref refPos ref@{ mod, params, typ } -> case mod of + Nothing -> do + d@(Cst.TypeDecl { params: declParams }) <- lookupCurrentModuleTypeDecl refPos ref + ps <- traverse (cstTypeParamToAstTypeParam typePos) params + if Array.length params /= Array.length declParams then + Left (Error.Positioned filePath refPos (Error.TypeRef (Error.IncorrectArity { found: Array.length params, expected: Array.length declParams }) ref)) + else + Right + ( Ast.Ref + { decl: Nothing + , typ + , params: ps + , isPrimaryRef: Cst.isRecord (Cst.typeDeclTopType d) && Cst.ModuleName typ == moduleName + } + ) + Just n -> do + Tuple m d@(Ast.TypeDecl { topType: tt, isPrimary: isPrimaryRef, params: declParams, scalaDecoderType }) <- lookupImportedModuleTypeDecl refPos ref n + ps <- traverse (cstTypeParamToAstTypeParam refPos) params + if Array.length params /= Array.length declParams then + Left (Error.Positioned filePath refPos (Error.TypeRef (Error.IncorrectArity { found: Array.length params, expected: Array.length declParams }) ref)) + else + Right (Ast.Ref { decl: Just (Tuple m d), typ, params: ps, isPrimaryRef }) + + lookupCurrentModuleTypeDecl :: Position -> Cst.TRef -> Either Error.Error Cst.TypeDecl + lookupCurrentModuleTypeDecl refPos ref = do + note + (Error.Positioned filePath refPos (Error.TypeRef Error.TypeNotFound ref)) + (Map.lookup ref.typ decls) + + lookupImportedModuleTypeDecl :: Position -> Cst.TRef -> Cst.ModuleRef -> Either Error.Error (Tuple Ast.Module Ast.TypeDecl) + lookupImportedModuleTypeDecl refPos ref (Cst.ModuleRef n) = do + m@(Ast.Module { types }) <- + note + (Error.Positioned filePath refPos (Error.TypeRef Error.NotImported ref)) + (Map.lookup n importedModules) + d@(Ast.TypeDecl _) <- + note + (Error.Positioned filePath refPos (Error.TypeRef Error.QualifiedNotDefined ref)) + (Array.find (\t -> Ast.typeDeclName t == ref.typ) types) + pure (Tuple m d) + + cstRecordPropToAstRecordProp :: Set String -> Cst.RecordProp -> Either Error.Error Ast.RecordProp + cstRecordPropToAstRecordProp dups prop@{ name: n, typ, annots: as, position } = do + if Set.member n dups then + Left (Error.Positioned filePath position (Error.TypeDecl (Error.DuplicateRecordProperty prop) decl)) + else + Right unit + map + (\t -> { name: n, typ: t, annots: as }) + (cstTypeParamToAstTypeParam position typ) + + cstConstructorStringName :: Cst.Constructor -> String + cstConstructorStringName = case _ of + Cst.NoArg (Cst.ConstructorName c) -> c + Cst.WithArgs (Cst.ConstructorName c) _ -> c + + cstConstructorToAstConstructor :: Position -> Set String -> Cst.Constructor -> Either Error.Error Ast.Constructor + cstConstructorToAstConstructor conPos dups constructor = do + case constructor of + Cst.NoArg n -> Right (Ast.NoArg n) + Cst.WithArgs n params -> map (Ast.WithArgs n) (traverse (cstTypeParamToAstTypeParam conPos) params) + + cstTypeParamToAstTypeParam :: Position -> Cst.TypeOrParam -> Either Error.Error Ast.TypeOrParam + cstTypeParamToAstTypeParam p = case _ of + Cst.TParam c -> + if not elem c typeParams then + Left (Error.Positioned filePath p (Error.TypeDecl (Error.UnknownTypeParam c) decl)) + else + Right (Ast.TParam c) + Cst.TType typ -> map Ast.TType (cstTypeToAstType p typ) + +parseAll :: Array FilePath -> ExceptT (NonEmptyArray Error.Error) Effect (Array (Cst.Source Cst.Module)) +parseAll files = + ExceptT do + result <- traverse (map ((lmap NonEmptyArray.singleton) <<< Validation.V) <<< parse) files + pure (Validation.toEither (sequence result)) + +newtype ModuleWithImports + = ModuleWithImports + { mod :: Cst.Source Cst.Module + , imports :: Array ModuleWithImports + } + +instance eqModuleWithImports :: Eq ModuleWithImports where + eq (ModuleWithImports { mod: { source: source1 } }) (ModuleWithImports { mod: { source: source2 } }) = source1 == source2 + +instance ordModuleWithImports :: Ord ModuleWithImports where + compare (ModuleWithImports { mod: { source: source1 } }) (ModuleWithImports { mod: { source: source2 } }) = compare source1 source2 + +derive instance genericModuleWithImports :: Generic ModuleWithImports _ + +instance showModuleWithImports :: Show ModuleWithImports where + show t = genericShow t + +type ImportState + = { visiting :: Set FilePath + , complete :: Map FilePath ModuleWithImports + } + +parseImports :: BuildParams -> Cst.Source Cst.Module -> StateT ImportState (ExceptT Error.Error Effect) ModuleWithImports +parseImports params mod = do + S.modify_ (\ss -> ss { visiting = Set.insert mod.source ss.visiting }) + parsedImports <- traverse (parseImport params mod) mod.contents.imports + let + result = ModuleWithImports { mod, imports: parsedImports } + S.modify_ (\ss -> ss { visiting = Set.delete mod.source ss.visiting, complete = Map.insert mod.source result ss.complete }) + pure result + +parseImport :: BuildParams -> Cst.Source Cst.Module -> Cst.Import -> StateT ImportState (ExceptT Error.Error Effect) ModuleWithImports +parseImport params mod i@(Cst.Import position ref) = do + s <- S.get + path <- T.lift (ExceptT (imports params mod i)) + if Set.member path s.visiting then + T.lift (except (Left (Error.Positioned mod.source position (Error.Import (Error.ImportCycle (Array.fromFoldable s.visiting)) i)))) + else case Map.lookup path s.complete of + Just m -> pure m + Nothing -> do + parsed <- T.lift (ExceptT (parse path)) + parseImports params parsed + +imports :: BuildParams -> Cst.Source Cst.Module -> Cst.Import -> Effect (Either Error.Error FilePath) +imports { importPaths } { source } i@(Cst.Import position ref) = do + allPossible <- possibleImportPaths + existing <- Array.filterA FileSystem.isFile allPossible + pure case Array.nub existing of + [] -> Left (Error.Positioned source position (Error.Import Error.ImportNotFound i)) + [ path ] -> Right path + paths -> Left (Error.Positioned source position (Error.Import (Error.MultipleMatches paths) i)) + where + possibleImportPaths :: Effect (Array FilePath) + possibleImportPaths = traverse (Path.resolve [] <<< resolveImport) (Path.dirname source : importPaths) + + importPath :: String + importPath = String.replaceAll (String.Pattern ".") (String.Replacement Path.sep) ref + + resolveImport :: FilePath -> FilePath + resolveImport dirPath = FileSystem.joinPaths dirPath (importPath <> ".tmpl") + +parseErrorToError :: Parser.Error -> Error.Error +parseErrorToError (Parser.Error filePath position message) = Error.Positioned filePath position (Error.Parse message) + +parse :: FilePath -> Effect (Either Error.Error (Cst.Source Cst.Module)) +parse filePath = + runExceptT do + contents <- ExceptT (map (lmap (Error.FileRead filePath)) (FileSystem.readTextFile filePath)) + except (lmap parseErrorToError (Parser.parseSource filePath contents)) diff --git a/src/Ccap/Codegen/Config.purs b/src/Ccap/Codegen/Config.purs index b85afe5..107f00d 100644 --- a/src/Ccap/Codegen/Config.purs +++ b/src/Ccap/Codegen/Config.purs @@ -14,6 +14,7 @@ import Node.Yargs.Applicative (Y, yarg) data Mode = Pretty | Purs + | PursJs | Scala | Show | Test @@ -34,13 +35,14 @@ yMode = yarg "m" alts desc def true <#> readMode where alts = [ "mode" ] - desc = Just "The output mode (must be one of pretty, purs, scala, show, or test)" + desc = Just "The output mode (must be one of pretty, purs, pursjs, scala, show, or test)" def = Right "Mode is required" readMode = case _ of "pretty" -> Right Pretty "purs" -> Right Purs + "pursjs" -> Right PursJs "scala" -> Right Scala "show" -> Right Show "test" -> Right Test diff --git a/src/Ccap/Codegen/Cst.purs b/src/Ccap/Codegen/Cst.purs new file mode 100644 index 0000000..21213bb --- /dev/null +++ b/src/Ccap/Codegen/Cst.purs @@ -0,0 +1,263 @@ +module Ccap.Codegen.Cst + ( Annotation(..) + , AnnotationParam(..) + , Constructor(..) + , ConstructorName(..) + , Exports + , Import(..) + , Module + , ModuleName(..) + , ModuleRef(..) + , Primitive(..) + , RecordProp(..) + , Source + , TRef + , TopType(..) + , Type(..) + , TypeDecl(..) + , TypeOrParam(..) + , TypeParam(..) + , isRecord + , topTypeReferences + , typeDeclName + , typeDeclTopType + ) where + +import Prelude +import Data.Array.NonEmpty (NonEmptyArray) +import Data.Array.NonEmpty as NonEmptyArray +import Data.Generic.Rep (class Generic) +import Data.Generic.Rep.Show (genericShow) +import Data.Maybe (Maybe) +import Node.Path (FilePath) +import Text.Parsing.Parser.Pos (Position) + +type Source a + = { source :: FilePath + , contents :: a + } + +newtype ModuleName + = ModuleName String + +type Module + = { types :: NonEmptyArray TypeDecl + , imports :: Array Import + , exports :: Exports + , name :: ModuleName + } + +newtype ModuleRef + = ModuleRef String + +data Import + = Import Position String + +--| package names for generating imports from a tmpl file +type Exports + = { scalaPkg :: String + , pursPkg :: String + } + +newtype TypeDecl + = TypeDecl + { position :: Position + , name :: String + , topType :: TopType + , annots :: Array Annotation + , params :: Array TypeParam + } + +data Annotation + = Annotation String Position (Array AnnotationParam) + +data AnnotationParam + = AnnotationParam String Position (Maybe String) + +newtype TypeParam + = TypeParam String + +data TopType + = Type Type + | Wrap Type + | Record (NonEmptyArray RecordProp) + | Sum (NonEmptyArray Constructor) + +data Type + = Primitive Primitive + | Ref Position TRef + | Array TypeOrParam + | Option TypeOrParam + | TypeWithParens Type + +data TypeOrParam + = TType Type + | TParam TypeParam + +type TRef + = { mod :: Maybe ModuleRef + , typ :: String + , params :: Array TypeOrParam + } + +type RecordProp + = { name :: String + , typ :: TypeOrParam + , annots :: Array Annotation + , position :: Position + } + +newtype ConstructorName + = ConstructorName String + +data Constructor + = NoArg ConstructorName + | WithArgs ConstructorName (NonEmptyArray TypeOrParam) + +data Primitive + = PBoolean + | PInt + | PDecimal + | PString + | PStringValidationHack + | PJson + +isRecord :: TopType -> Boolean +isRecord = case _ of + Record _ -> true + _ -> false + +-- | Get the type name of a type declaration. +typeDeclName :: TypeDecl -> String +typeDeclName (TypeDecl { name: typeName }) = typeName + +-- | Get the top most type of a type declaration. +typeDeclTopType :: TypeDecl -> TopType +typeDeclTopType (TypeDecl { topType }) = topType + +-- | Return all type references used in a Declared Type +topTypeReferences :: TopType -> Array TRef +topTypeReferences = case _ of + Type typ -> typeReferences typ + Wrap typ -> typeReferences typ + Record props -> + NonEmptyArray.toArray props >>= _.typ + >>> case _ of + TType typ -> typeReferences typ + TParam _ -> [] + Sum constructors -> + NonEmptyArray.toArray constructors + >>= case _ of + NoArg _ -> [] + WithArgs _ args -> + NonEmptyArray.toArray args + >>= case _ of + TType typ -> typeReferences typ + TParam _ -> [] + +-- | Return all type references in any used type. +typeReferences :: Type -> Array TRef +typeReferences = case _ of + Ref _ tRef -> [ tRef ] + Primitive _ -> [] + Array (TType typ) -> typeReferences typ + Array (TParam _) -> [] + Option (TType typ) -> typeReferences typ + Option (TParam _) -> [] + TypeWithParens typ -> typeReferences typ + +-- Instances here to avoid cluttering the above +derive instance eqModuleName :: Eq ModuleName + +derive instance genericModuleName :: Generic ModuleName _ + +instance showModuleName :: Show ModuleName where + show t = genericShow t + +derive instance eqImport :: Eq Import + +derive instance ordImport :: Ord Import + +derive instance genericImport :: Generic Import _ + +instance showImport :: Show Import where + show t = genericShow t + +derive instance eqTypeOrParam :: Eq TypeOrParam + +derive instance genericTypeOrParam :: Generic TypeOrParam _ + +instance showTypeOrParam :: Show TypeOrParam where + show t = genericShow t + +derive instance eqConstructorName :: Eq ConstructorName + +derive instance genericConstructorName :: Generic ConstructorName _ + +instance showConstructorName :: Show ConstructorName where + show t = genericShow t + +derive instance eqConstructor :: Eq Constructor + +derive instance genericConstructor :: Generic Constructor _ + +instance showConstructor :: Show Constructor where + show t = genericShow t + +derive instance eqTypeParam :: Eq TypeParam + +derive instance genericTypeParam :: Generic TypeParam _ + +instance showTypeParam :: Show TypeParam where + show t = genericShow t + +derive instance eqModuleRef :: Eq ModuleRef + +derive instance ordModuleRef :: Ord ModuleRef + +derive instance genericModuleRef :: Generic ModuleRef _ + +instance showModuleRef :: Show ModuleRef where + show t = genericShow t + +derive instance eqType :: Eq Type + +derive instance genericType :: Generic Type _ + +instance showType :: Show Type where + show t = genericShow t + +derive instance eqTopType :: Eq TopType + +derive instance genericTopType :: Generic TopType _ + +instance showTopType :: Show TopType where + show = genericShow + +derive instance eqTypeDecl :: Eq TypeDecl + +derive instance genericTypeDecl :: Generic TypeDecl _ + +instance showTypeDecl :: Show TypeDecl where + show = genericShow + +derive instance eqAnnotation :: Eq Annotation + +derive instance genericAnnotation :: Generic Annotation _ + +instance showAnnotation :: Show Annotation where + show = genericShow + +derive instance eqAnnotationParam :: Eq AnnotationParam + +derive instance genericAnnotationParam :: Generic AnnotationParam _ + +instance showAnnotationParam :: Show AnnotationParam where + show = genericShow + +derive instance eqPrimitive :: Eq Primitive + +derive instance genericPrimitive :: Generic Primitive _ + +instance showPrimitive :: Show Primitive where + show = genericShow diff --git a/src/Ccap/Codegen/Database.purs b/src/Ccap/Codegen/Database.purs index a599e6d..17c7ad0 100644 --- a/src/Ccap/Codegen/Database.purs +++ b/src/Ccap/Codegen/Database.purs @@ -4,13 +4,15 @@ module Ccap.Codegen.Database ) where import Prelude -import Ccap.Codegen.TypeRef (topTypeReferences) -import Ccap.Codegen.Types (Annotation(..), AnnotationParam(..), Import, Module, Primitive(..), RecordProp, TopType(..), Type(..), TypeDecl(..), typeDeclName, typeDeclTopType) -import Control.Monad.Except (ExceptT, withExceptT) +import Ccap.Codegen.Cst as Cst +import Control.Monad.Except (ExceptT, except, withExceptT) import Data.Array as Array +import Data.Array.NonEmpty (NonEmptyArray) +import Data.Array.NonEmpty as NonEmptyArray +import Data.Either (note) import Data.Maybe (Maybe(..), isNothing, maybe) import Data.Monoid (guard) -import Database.PostgreSQL (Connection, PGError) +import Database.PostgreSQL (Connection, PGError(..)) import Database.PostgreSQL.PG (Pool, Query(..), query, withConnection) import Database.PostgreSQL.Row (Row0(..), Row1(..), Row3(..), Row5(..)) import Effect.Aff (Aff) @@ -32,35 +34,34 @@ rowToDomain (Row3 domainName dataType charMaxLen) = , charMaxLen } -domainTypeDecl :: Domain -> TypeDecl -domainTypeDecl domain = TypeDecl domain.domainName (Wrap (dbType domain.dataType)) (annotations domain) +domainTypeDecl :: Domain -> Cst.TypeDecl +domainTypeDecl domain = Cst.TypeDecl { position: emptyPos, name: domain.domainName, topType: Cst.Wrap (dbType domain.dataType), annots: annotations domain, params: [] } -annotations :: forall r. { charMaxLen :: Maybe Int | r } -> Array Annotation +annotations :: forall r. { charMaxLen :: Maybe Int | r } -> Array Cst.Annotation annotations = Array.fromFoldable <<< map maxLengthAnnotation <<< _.charMaxLen -maxLengthAnnotation :: Int -> Annotation -maxLengthAnnotation = Annotation "validations" emptyPos <<< Array.singleton <<< param +maxLengthAnnotation :: Int -> Cst.Annotation +maxLengthAnnotation = Cst.Annotation "validations" emptyPos <<< Array.singleton <<< param where - param = AnnotationParam "maxLength" emptyPos <<< Just <<< show + param = Cst.AnnotationParam "maxLength" emptyPos <<< Just <<< show -domainModule :: Pool -> String -> String -> ExceptT String Aff Module +domainModule :: Pool -> String -> String -> ExceptT String Aff Cst.Module domainModule pool scalaPkg pursPkg = withExceptT show $ withConnection pool \conn -> do results <- query conn (Query sql) Row0 let - types = Array.sortWith typeDeclName $ domainTypeDecl <<< rowToDomain <$> results + types = Array.sortWith Cst.typeDeclName $ domainTypeDecl <<< rowToDomain <$> results + nelTypes <- except ((note (ConversionError "Expected at least one type")) (NonEmptyArray.fromArray types)) pure - $ { name: "Domains" - , types - , annots: [] - , imports: types >>= tableImports # Array.nub # Array.sort - , exports: - { scalaPkg - , pursPkg - , tmplPath: "Domains.tmpl" - } - } + { types: nelTypes + , imports: types >>= tableImports # Array.nub # Array.sort + , exports: + { scalaPkg + , pursPkg + } + , name: Cst.ModuleName "Domains" + } where sql = """ @@ -100,27 +101,32 @@ occIdColumn = , isNullable: "NO" } -tableModule :: Pool -> String -> String -> String -> ExceptT String Aff Module +tableModule :: Pool -> String -> String -> String -> ExceptT String Aff Cst.Module tableModule pool scalaPkg pursPkg tableName = withExceptT show $ withConnection pool \conn -> do columns <- queryColumns tableName conn + nelColumns <- except (note (ConversionError ("Expected at least one column. Does the \"" <> tableName <> "\" table exist?")) (NonEmptyArray.fromArray columns)) let - decl = tableType tableName (columns <> [ occIdColumn ]) + decl = tableType tableName (nelColumns `NonEmptyArray.snoc` occIdColumn) pure - { name: tableName - , types: [ decl ] - , annots: [] + { types: NonEmptyArray.singleton decl , imports: tableImports decl # Array.sort , exports: { scalaPkg , pursPkg - , tmplPath: tableName } + , name: Cst.ModuleName tableName } -tableImports :: TypeDecl -> Array Import -tableImports = typeDeclTopType >>> topTypeReferences >>> map _.mod >>> Array.catMaybes >>> Array.nub +tableImports :: Cst.TypeDecl -> Array Cst.Import +tableImports = + Cst.typeDeclTopType + >>> Cst.topTypeReferences + >>> map _.mod + >>> Array.catMaybes + >>> Array.nub + >>> map (\(Cst.ModuleRef name) -> Cst.Import emptyPos name) queryColumns :: String -> Connection -> ExceptT PGError Aff (Array DbColumn) queryColumns tableName conn = do @@ -139,38 +145,38 @@ queryColumns tableName conn = do order by ordinal_position ; """ -tableType :: String -> Array DbColumn -> TypeDecl -tableType tableName columns = TypeDecl tableName (Record $ dbRecordProp <$> columns) [] +tableType :: String -> NonEmptyArray DbColumn -> Cst.TypeDecl +tableType tableName columns = Cst.TypeDecl { position: emptyPos, name: tableName, topType: Cst.Record (dbRecordProp <$> columns), annots: [], params: [] } -dbRecordProp :: DbColumn -> RecordProp +dbRecordProp :: DbColumn -> Cst.RecordProp dbRecordProp col@{ columnName, domainName, dataType, isNullable } = let baseType = maybe (dbType dataType) domainRef domainName - optioned = if isNullable == "YES" then Option baseType else baseType + optioned = if isNullable == "YES" then Cst.Option (Cst.TType baseType) else baseType annots = guard (isNothing domainName) annotations col in - { name: columnName, typ: optioned, annots } - -domainRef :: String -> Type -domainRef "CaseNoT" = Ref emptyPos { mod: Just "CaseNoSupport", typ: "CaseNo" } + { name: columnName, typ: Cst.TType optioned, annots, position: emptyPos } -domainRef name = Ref emptyPos { mod: Just "Domains", typ: name } +domainRef :: String -> Cst.Type +domainRef = case _ of + "CaseNoT" -> Cst.Ref emptyPos { mod: Just (Cst.ModuleRef "CaseNoSupport"), typ: "CaseNo", params: [] } + name -> Cst.Ref emptyPos { mod: Just (Cst.ModuleRef "Domains"), typ: name, params: [] } -dbType :: String -> Type +dbType :: String -> Cst.Type dbType dataType = case dataType of - "numeric" -> Primitive PDecimal - "character varying" -> Primitive PString - "character" -> Primitive PString - "integer" -> Primitive PInt - "smallint" -> Primitive PInt - "text" -> Primitive PString - "boolean" -> Primitive PBoolean - "date" -> Ref emptyPos { mod: Just "DateTimeSupport", typ: "Date" } - "time without time zone" -> Ref emptyPos { mod: Just "DateTimeSupport", typ: "Time" } - "timestamp with time zone" -> Ref emptyPos { mod: Just "DateTimeSupport", typ: "Timestamp" } - "uuid" -> Ref emptyPos { mod: Just "UUIDSupport", typ: "UUID" } - "interval" -> Ref emptyPos { mod: Just "DateTimeSupport", typ: "Duration" } - "occid" -> Ref emptyPos { mod: Just "OccSupport", typ: "OccId" } - _ -> Primitive PString -- XXX + "numeric" -> Cst.Primitive Cst.PDecimal + "character varying" -> Cst.Primitive Cst.PString + "character" -> Cst.Primitive Cst.PString + "integer" -> Cst.Primitive Cst.PInt + "smallint" -> Cst.Primitive Cst.PInt + "text" -> Cst.Primitive Cst.PString + "boolean" -> Cst.Primitive Cst.PBoolean + "date" -> Cst.Ref emptyPos { mod: Just (Cst.ModuleRef "DateTimeSupport"), typ: "Date", params: [] } + "time without time zone" -> Cst.Ref emptyPos { mod: Just (Cst.ModuleRef "DateTimeSupport"), typ: "Time", params: [] } + "timestamp with time zone" -> Cst.Ref emptyPos { mod: Just (Cst.ModuleRef "DateTimeSupport"), typ: "Timestamp", params: [] } + "uuid" -> Cst.Ref emptyPos { mod: Just (Cst.ModuleRef "UUIDSupport"), typ: "UUID", params: [] } + "interval" -> Cst.Ref emptyPos { mod: Just (Cst.ModuleRef "DateTimeSupport"), typ: "Duration", params: [] } + "occid" -> Cst.Ref emptyPos { mod: Just (Cst.ModuleRef "OccSupport"), typ: "OccId", params: [] } + _ -> Cst.Primitive Cst.PString -- XXX diff --git a/src/Ccap/Codegen/Env.purs b/src/Ccap/Codegen/Env.purs deleted file mode 100644 index 213e36f..0000000 --- a/src/Ccap/Codegen/Env.purs +++ /dev/null @@ -1,43 +0,0 @@ -module Ccap.Codegen.Env - ( Env - , askModule - , askTypeDecl - , lookupModule - , lookupTypeDecl - , traverseM - , forM - ) where - -import Prelude -import Ccap.Codegen.Types (Module, ModuleName, TypeDecl, typeDeclName) -import Control.Monad.Reader (ReaderT, asks) -import Data.Foldable (find) -import Data.Maybe (Maybe) -import Data.Traversable (class Traversable, traverse) - -type Env - = { allModules :: Array Module - , currentModule :: Module - , defaultPrefix :: Maybe String - } - -askModule :: forall m. Monad m => ModuleName -> ReaderT Env m (Maybe Module) -askModule moduleName = lookupModule moduleName <$> asks _.allModules - -lookupModule :: ModuleName -> Array Module -> Maybe Module -lookupModule moduleName = find (eq moduleName <<< _.name) - -askTypeDecl :: forall m. Monad m => ModuleName -> String -> ReaderT Env m (Maybe TypeDecl) -askTypeDecl moduleName typeName = (lookupTypeDecl typeName =<< _) <$> askModule moduleName - -lookupTypeDecl :: String -> Module -> Maybe TypeDecl -lookupTypeDecl typeName = find (eq typeName <<< typeDeclName) <<< _.types - --- **Should be moved to a traverse-extra package ** --- | `traverse` followed by a monadic join inside -traverseM :: forall f g a b. Applicative g => Traversable f => Bind f => (a -> g (f b)) -> f a -> g (f b) -traverseM f = map join <<< traverse f - --- | flipped traverseM -forM :: forall f g a b. Applicative g => Traversable f => Bind f => f a -> (a -> g (f b)) -> g (f b) -forM = flip traverseM diff --git a/src/Ccap/Codegen/Error.purs b/src/Ccap/Codegen/Error.purs new file mode 100644 index 0000000..9df1789 --- /dev/null +++ b/src/Ccap/Codegen/Error.purs @@ -0,0 +1,83 @@ +module Ccap.Codegen.Error + ( Error(..) + , Detail(..) + , Import(..) + , TypeDecl(..) + , TypeRef(..) + , toString + ) where + +import Prelude +import Ccap.Codegen.Cst as Cst +import Data.Maybe (maybe) +import Data.String as String +import Node.Path (FilePath) +import Text.Parsing.Parser.Pos (Position(..)) + +data Error + = Positioned FilePath Position Detail + | FileRead FilePath String + | ModuleNameMismatch FilePath { moduleName :: String, scalaName :: String, pursName :: String } + +data Detail + = Parse String + | Import Import Cst.Import + | TypeDecl TypeDecl Cst.TypeDecl + | TypeRef TypeRef Cst.TRef + +data Import + = ImportNotFound + | ImportCycle (Array FilePath) + | MultipleMatches (Array FilePath) + +data TypeDecl + = DuplicateType + | DuplicateRecordProperty Cst.RecordProp + | DuplicateConstructorNames (Array Cst.ConstructorName) + | UnknownTypeParam Cst.TypeParam + | CircularType (Array String) + +data TypeRef + = QualifiedNotDefined + | NotImported + | TypeNotFound + | IncorrectArity { found :: Int, expected :: Int } + +toString :: Error -> String +toString = case _ of + ModuleNameMismatch path { moduleName, scalaName, pursName } -> + path + <> ": the module name (" + <> moduleName + <> "), the Scala class name (" + <> scalaName + <> "), and the PureScript module name (" + <> pursName + <> ") must all match" + FileRead path message -> path <> ": could not ready file: " <> message + Positioned path (Position { line, column }) detail -> + path <> ":" <> show line <> ":" <> show column <> ": " + <> case detail of + Parse msg -> msg + Import importError (Cst.Import _ i) -> case importError of + ImportNotFound -> "import " <> i <> " not found" + ImportCycle paths -> "import " <> i <> " is part of a cycle:\n" <> String.joinWith "\n" (map (" " <> _) paths) + MultipleMatches paths -> "import " <> i <> " is defined in multiple templates:\n" <> String.joinWith "\n" (map (" " <> _) paths) + TypeDecl typeDeclError decl -> case typeDeclError of + DuplicateType -> "type " <> Cst.typeDeclName decl <> " is defined multiple times" + DuplicateRecordProperty { name } -> "record property " <> name <> " is defined multiple times" + DuplicateConstructorNames names -> "constructor " <> String.joinWith ", " (map (\(Cst.ConstructorName name) -> name) names) <> " is defined multiple times" + UnknownTypeParam (Cst.TypeParam param) -> "Unknown type parameter " <> param + CircularType names -> + "type " + <> Cst.typeDeclName decl + <> " is involved in a cycle:\n" + <> String.joinWith "\n" (map (" " <> _) names) + TypeRef typeRefError { mod, typ } -> do + let + fullName = maybe typ (\(Cst.ModuleRef m) -> m <> "." <> typ) mod + case typeRefError of + TypeNotFound -> "type " <> typ <> " is not defined" + QualifiedNotDefined -> "type " <> typ <> " is not defined in the imported template" + NotImported -> fullName <> " does not reference an imported template" + IncorrectArity { found, expected } -> fullName <> " was given " <> show found <> " type parameters, but should have been given " <> show expected diff --git a/src/Ccap/Codegen/FileSystem.purs b/src/Ccap/Codegen/FileSystem.purs index 844292d..84fccab 100644 --- a/src/Ccap/Codegen/FileSystem.purs +++ b/src/Ccap/Codegen/FileSystem.purs @@ -7,8 +7,8 @@ module Ccap.Codegen.FileSystem ) where import Prelude -import Ccap.Codegen.Parser (errorMessage, parseSource) -import Ccap.Codegen.Types (Source, Module) +import Ccap.Codegen.Cst as Cst +import Ccap.Codegen.Parser as Parser import Ccap.Codegen.Util (liftEffectSafely) import Control.Monad.Error.Class (try) import Control.Monad.Except (ExceptT(..), except, runExceptT) @@ -53,8 +53,8 @@ readTextFile :: FilePath -> Effect (Either String String) readTextFile = map (lmap Error.message) <<< try <<< Sync.readTextFile UTF8 -- | Read and parse a tmpl file -sourceFile :: FilePath -> Effect (Either String (Source Module)) +sourceFile :: FilePath -> Effect (Either String (Cst.Source Cst.Module)) sourceFile filePath = runExceptT do contents <- ExceptT $ readTextFile filePath - except $ lmap (errorMessage filePath) $ parseSource filePath contents + except $ lmap Parser.errorMessage $ Parser.parseSource filePath contents diff --git a/src/Ccap/Codegen/Imports.purs b/src/Ccap/Codegen/Imports.purs deleted file mode 100644 index c85f4cc..0000000 --- a/src/Ccap/Codegen/Imports.purs +++ /dev/null @@ -1,118 +0,0 @@ -module Ccap.Codegen.Imports - ( ImportError - , Imported - , Includes - , importInScope - , importPath - , importsInScope - , importsInScopes - , parseImports - , possibleImportPaths - , resolveImport - , validateImports - ) where - -import Prelude -import Ccap.Codegen.FileSystem as FS -import Ccap.Codegen.Types (Import, Module, Source) -import Ccap.Codegen.ValidationError (class ValidationError, toValidation) -import Control.Monad.Except (ExceptT(..), runExceptT) -import Data.Array ((:)) -import Data.Array as Array -import Data.Bifunctor (bimap, rmap) -import Data.Either (Either, note) -import Data.String (Pattern(..), Replacement(..)) -import Data.String as String -import Data.Traversable (sequence, traverse) -import Effect (Effect) -import Node.Path (FilePath) -import Node.Path as Path - -type Includes - = Array FilePath - -type FoundImport - = { imprt :: Import, filePath :: FilePath } - -type Imported - = Source { imprt :: Import, mod :: Module } - -data ImportError - = NotFound Module Import - -- | MultipleFound Module Import - | ParseError Import String - -instance importValidationError :: ValidationError ImportError where - printError = case _ of - NotFound mod imprt -> - mod.name - <> " tried to import module: " - <> imprt - <> " but it does not exist, or was not included." - ParseError imprt message -> - "Parsing imported module, " - <> imprt - <> ", failed with error: " - <> message - -importPath :: Import -> FilePath -importPath = String.replaceAll (Pattern ".") (Replacement Path.sep) - -resolveImport :: FilePath -> Import -> FilePath -resolveImport filePath = FS.joinPaths filePath <<< flip append ".tmpl" <<< importPath - -possibleImportPaths :: Includes -> FilePath -> Import -> Array FilePath -possibleImportPaths includes source imprt = - (Path.dirname source : includes) - <#> (flip resolveImport $ importPath imprt) - -importInScope :: Includes -> Source Module -> Import -> Effect (Either ImportError FoundImport) -importInScope included { source, contents } imprt = - let - options = possibleImportPaths included source imprt - - existing = Array.filterA FS.isFile options - in -- TODO error if multiple found - existing <#> Array.head >>> map { imprt, filePath: _ } >>> note (NotFound contents imprt) - --- | Get the file paths for all imports or _an_ error message for _all_ imports that cannot be --- | found. This is done over a batch of modules to avoid parsing the same file twice. -importsInScope :: - Includes -> - Source Module -> - Effect (Either (Array ImportError) (Array FoundImport)) -importsInScope includes source = - traverse (importInScope includes source) source.contents.imports - <#> toValidation - -importsInScopes :: - Includes -> - Array (Source Module) -> - Effect (Either (Array ImportError) (Array FoundImport)) -importsInScopes includes sources = - let - validations :: Effect (Array (Either (Array ImportError) (Array FoundImport))) - validations = traverse (importsInScope includes) sources - in - validations <#> sequence <#> rmap (join >>> Array.nub) - --- | Really is just parsing an array of files right now but the Import type might get more --- | complicated later. -parseImports :: Array FoundImport -> Effect (Either (Array ImportError) (Array Imported)) -parseImports imports = traverse parse imports <#> toValidation - where - parse { imprt, filePath } = - bimap (ParseError imprt) - (\source -> { source: filePath, contents: { imprt, mod: source.contents } }) - <$> FS.sourceFile filePath - --- | Validate that the imports of the given modules exist and parse the imported modules --- | Note: Does not validate the contents of the imported files. -validateImports :: - Includes -> - Array (Source Module) -> - Effect (Either (Array ImportError) (Array Imported)) -validateImports includes sources = - runExceptT do - imports <- ExceptT $ importsInScopes includes sources - ExceptT $ parseImports imports diff --git a/src/Ccap/Codegen/Module.purs b/src/Ccap/Codegen/Module.purs deleted file mode 100644 index d8af825..0000000 --- a/src/Ccap/Codegen/Module.purs +++ /dev/null @@ -1,58 +0,0 @@ -module Ccap.Codegen.Module - ( validateModules - , importsForModule - ) where - -import Prelude -import Ccap.Codegen.Imports (Imported, Includes, possibleImportPaths, validateImports) -import Ccap.Codegen.TypeRef (validateAllTypeRefs) -import Ccap.Codegen.Types (Module, Source, ValidatedModule) -import Ccap.Codegen.ValidationError (printError) -import Control.Monad.Except (ExceptT(..), except, runExceptT, withExceptT) -import Data.Array as Array -import Data.Bifunctor (lmap) -import Data.Either (Either) -import Data.Foldable (any) -import Data.Traversable (for) -import Effect (Effect) - --- | Validate imports and type references against the compile scope. -validateModules :: - Includes -> - Array (Source Module) -> - Effect (Either (Array String) (Array (Source ValidatedModule))) -validateModules includes sources = - runExceptT do - allImports <- withExceptT (map printError) $ ExceptT $ validateImports includes sources - except $ for sources $ validateModule includes allImports - -validateModule :: - Includes -> - Array Imported -> - Source Module -> - Either (Array String) (Source ValidatedModule) -validateModule includes allImports source = - let - imports = importsForModule includes source allImports - - validatedSource = source { contents = source.contents { imports = imports } } - - validations = lmap (map printError) $ validateAllTypeRefs source.contents imports - in - validations *> pure validatedSource - -importsForModule :: Includes -> Source Module -> Array Imported -> Array Module -importsForModule includes source = - map _.contents.mod - <<< Array.filter (isImportedBy includes source) - --- This was already done by validateImports, we should adjust the return type of that so we don't --- have to do this again. -isImportedBy :: Includes -> Source Module -> Imported -> Boolean -isImportedBy includes source imported = - let - { source: modulePath, contents: { imports } } = source - - { source: importPath, contents: { imprt, mod: { name } } } = imported - in -- TODO: this is almost identical to importInScope - any (eq importPath) $ possibleImportPaths includes modulePath =<< imports diff --git a/src/Ccap/Codegen/Parser.purs b/src/Ccap/Codegen/Parser.purs index e411e28..f438c70 100644 --- a/src/Ccap/Codegen/Parser.purs +++ b/src/Ccap/Codegen/Parser.purs @@ -1,16 +1,19 @@ module Ccap.Codegen.Parser - ( errorMessage + ( Error(..) + , errorMessage + , parseSource , roundTrip , wholeFile - , parseSource ) where import Prelude -import Ccap.Codegen.PrettyPrint (prettyPrint) as PrettyPrinter -import Ccap.Codegen.Shared (invalidate) -import Ccap.Codegen.Types (Annotation(..), AnnotationParam(..), Exports, Import, Module, Primitive(..), RecordProp, TRef, TopType(..), Type(..), TypeDecl(..), ValidatedModule, Source) +import Ccap.Codegen.Cst as Cst +import Ccap.Codegen.PrettyPrint as PrettyPrint import Control.Alt ((<|>)) -import Data.Array (fromFoldable, many) as Array +import Data.Array as Array +import Data.Array.NonEmpty (NonEmptyArray) +import Data.Array.NonEmpty as NonEmptyArray +import Data.Bifunctor (lmap) import Data.Char.Unicode (isLower) import Data.Either (Either) import Data.Foldable (intercalate) @@ -19,13 +22,14 @@ import Data.List (List(..)) import Data.List as List import Data.List.NonEmpty (NonEmptyList(..)) import Data.List.NonEmpty as NonEmpty -import Data.Maybe (Maybe(..)) +import Data.Maybe (Maybe(..), maybe) import Data.NonEmpty ((:|)) import Data.String.CodeUnits (fromCharArray, singleton) as SCU import Node.Path (FilePath) import Node.Path as Path -import Text.Parsing.Parser (ParseError, ParserT, parseErrorMessage, parseErrorPosition, position, runParser) -import Text.Parsing.Parser.Combinators (option, sepBy1, ()) +import Text.Parsing.Parser (Parser, ParserT, position, runParser) +import Text.Parsing.Parser as Parser +import Text.Parsing.Parser.Combinators (option, optional, try, ()) import Text.Parsing.Parser.Language (javaStyle) import Text.Parsing.Parser.Pos (Position(..)) import Text.Parsing.Parser.String (char, satisfy) @@ -38,94 +42,123 @@ tokenParser = (unGenLanguageDef javaStyle) { identStart = lower , identLetter = alphaNum + , reservedNames = + [ "scala" + , "purs" + , "Boolean" + , "Int" + , "Decimal" + , "String" + , "StringValidationHack" + , "Array" + , "Maybe" + , "wrap" + , "import" + , "type" + ] } -stringLiteral :: ParserT String Identity String +stringLiteral :: Parser String String stringLiteral = tokenParser.stringLiteral -reserved :: String -> ParserT String Identity Unit +reserved :: String -> Parser String Unit reserved = tokenParser.reserved -commaSep1 :: forall a. ParserT String Identity a -> ParserT String Identity (Array a) +commaSep1 :: forall a. Parser String a -> Parser String (Array a) commaSep1 inner = tokenParser.commaSep1 inner <#> Array.fromFoldable -braces :: forall a. ParserT String Identity a -> ParserT String Identity a +braces :: forall a. Parser String a -> Parser String a braces = tokenParser.braces -brackets :: forall a. ParserT String Identity a -> ParserT String Identity a +brackets :: forall a. Parser String a -> Parser String a brackets = tokenParser.brackets -- | Parse phrases prefixed by a separator, requiring at least one match. -startBy1 :: forall m s a sep. Monad m => ParserT s m a -> ParserT s m sep -> ParserT s m (List a) -startBy1 p sep = sep *> sepBy1 p sep +startBy1 :: forall m s a sep. Monad m => ParserT s m a -> ParserT s m sep -> ParserT s m (NonEmptyList a) +startBy1 p sep = sep *> sepBy1Nel p sep -pipeSep1 :: forall a. ParserT String Identity a -> ParserT String Identity (Array a) -pipeSep1 a = (a `startBy1` (lexeme $ char '|')) <#> Array.fromFoldable +pipeSep1 :: forall a. Parser String a -> Parser String (NonEmptyArray a) +pipeSep1 a = (a `startBy1` (lexeme $ char '|')) <#> NonEmptyArray.fromFoldable1 -whiteSpace :: ParserT String Identity Unit +whiteSpace :: Parser String Unit whiteSpace = tokenParser.whiteSpace -lower :: ParserT String Identity Char +lower :: Parser String Char lower = satisfy isLower "lowercase letter" -identifier :: ParserT String Identity String +identifier :: Parser String String identifier = tokenParser.identifier -lexeme :: forall a. ParserT String Identity a -> ParserT String Identity a +lexeme :: forall a. Parser String a -> Parser String a lexeme = tokenParser.lexeme -importOrTypeName :: ParserT String Identity String +importOrTypeName :: Parser String String importOrTypeName = lexeme $ mkImportOrTypeName <$> upper <*> Array.many alphaNum where mkImportOrTypeName :: Char -> Array Char -> String mkImportOrTypeName c s = SCU.singleton c <> SCU.fromCharArray s -packageName :: ParserT String Identity String +packageName :: Parser String String packageName = lexeme $ Array.many (alphaNum <|> char '.') <#> SCU.fromCharArray -tRef :: ParserT String Identity TRef -tRef = ado +typeOrParam :: Unit -> Parser String Cst.TypeOrParam +typeOrParam _ = map Cst.TType (tyTypeWithParens unit) <|> map (Cst.TParam <<< Cst.TypeParam) identifier + +tRef :: Unit -> Parser String Cst.TRef +tRef _ = do parts <- importOrTypeName `sepBy1Nel` char '.' + params <- Array.many (typeOrParam unit) let { init, last: typ } = NonEmpty.unsnoc parts - let + mod = if init == Nil then Nothing else Just $ intercalate "." init - in { mod, typ } + pure { mod: map Cst.ModuleRef mod, typ, params } -primitive :: String -> Primitive -> ParserT String Identity Type -primitive s decl = reserved s <#> const (Primitive decl) +primitive :: String -> Cst.Primitive -> Parser String Cst.Type +primitive s decl = reserved s <#> const (Cst.Primitive decl) -anyPrimitiveExceptJson :: ParserT String Identity Type +anyPrimitiveExceptJson :: Parser String Cst.Type anyPrimitiveExceptJson = - primitive "Boolean" PBoolean - <|> primitive "Int" PInt - <|> primitive "Decimal" PDecimal - <|> primitive "String" PString - <|> primitive "StringValidationHack" PStringValidationHack + primitive "Boolean" Cst.PBoolean + <|> primitive "Int" Cst.PInt + <|> primitive "Decimal" Cst.PDecimal + <|> primitive "String" Cst.PString + <|> primitive "StringValidationHack" Cst.PStringValidationHack + +tyTypeWithParens :: Unit -> Parser String Cst.Type +tyTypeWithParens _ = lexeme (char '(') *> map Cst.TypeWithParens (tyType unit) <* lexeme (char ')') <|> tyType unit -tyType :: Unit -> ParserT String Identity Type +tyType :: Unit -> Parser String Cst.Type tyType _ = anyPrimitiveExceptJson - <|> (reserved "Array" >>= tyType <#> Array) - <|> (reserved "Maybe" >>= tyType <#> Option) - <|> (Ref <$> position <*> tRef) - -topType :: ParserT String Identity TopType -topType = - (tyType unit <#> Type) - <|> (braces $ Array.many recordProp <#> Record) - <|> (brackets $ pipeSep1 importOrTypeName <#> Sum) - <|> (reserved "wrap" >>= (\_ -> primitive "Json" PJson <|> tyType unit) <#> Wrap) - -recordProp :: ParserT String Identity RecordProp + <|> (reserved "Array" >>= typeOrParam <#> Cst.Array) + <|> (reserved "Maybe" >>= typeOrParam <#> Cst.Option) + <|> (Cst.Ref <$> position <*> tRef unit) + +topType :: Unit -> Parser String Cst.TopType +topType _ = + (tyTypeWithParens unit <#> Cst.Type) + <|> (braces $ many1 recordProp <#> Cst.Record) + <|> (brackets $ pipeSep1 (constructor unit) <#> Cst.Sum) + <|> (reserved "wrap" >>= (\_ -> primitive "Json" Cst.PJson <|> tyTypeWithParens unit) <#> Cst.Wrap) + +constructor :: Unit -> Parser String Cst.Constructor +constructor _ = ado + name <- map Cst.ConstructorName importOrTypeName + params <- Array.many (typeOrParam unit) + in maybe (Cst.NoArg name) (Cst.WithArgs name) (NonEmptyArray.fromArray params) + +recordProp :: Parser String Cst.RecordProp recordProp = ado + p <- position name <- identifier lexeme $ char ':' - typ <- tyType unit + typ <- typeOrParam unit annots <- Array.many annotation - in { name, typ, annots } + try (optional (lexeme (char ','))) + in { name, typ, annots, position: p } -exports :: ParserT String Identity Exports +exports :: Parser String Cst.Exports exports = ado reserved "scala" lexeme $ char ':' @@ -133,95 +166,90 @@ exports = ado reserved "purs" lexeme $ char ':' pursPkg <- lexeme $ packageName - in { scalaPkg, pursPkg, tmplPath: "" } + in { scalaPkg, pursPkg } -imports :: ParserT String Identity (Array Import) --not yet battle-tested +imports :: Parser String (Array Cst.Import) imports = Array.many do + p <- position reserved "import" - packageName + n <- packageName + pure (Cst.Import p n) -oneModule :: ParserT String Identity Module -oneModule = ado +oneModule :: Cst.ModuleName -> Parser String Cst.Module +oneModule name = ado expts <- exports imprts <- imports - annots <- Array.many annotation --we can probably remove this - types <- Array.many typeDecl - in { name: "", types, annots, imports: imprts, exports: expts } + types <- many1 typeDecl + in { types, imports: imprts, exports: expts, name } -typeDecl :: ParserT String Identity TypeDecl -typeDecl = ado +typeDecl :: Parser String Cst.TypeDecl +typeDecl = do reserved "type" + p <- position name <- importOrTypeName - lexeme $ char ':' - ty <- topType + params <- map (map Cst.TypeParam) (Array.many identifier) + _ <- lexeme $ char ':' + ty <- topType unit annots <- Array.many annotation - in TypeDecl name ty annots + pure (Cst.TypeDecl { position: p, name, topType: ty, annots, params }) -annotation :: ParserT String Identity Annotation +annotation :: Parser String Cst.Annotation annotation = ado pos <- position lexeme $ char '<' - name <- identifier + name <- (reserved "scala" *> pure "scala") <|> (reserved "purs" *> pure "purs") <|> identifier params <- Array.many annotationParam lexeme $ char '>' - in Annotation name pos params + in Cst.Annotation name pos params -annotationParam :: ParserT String Identity AnnotationParam +annotationParam :: Parser String Cst.AnnotationParam annotationParam = ado pos <- position name <- identifier value <- option Nothing (lexeme (char '=') *> stringLiteral <#> Just) - in AnnotationParam name pos value + in Cst.AnnotationParam name pos value -wholeFile :: ParserT String Identity Module -wholeFile = whiteSpace *> oneModule +wholeFile :: Cst.ModuleName -> Parser String Cst.Module +wholeFile name = whiteSpace *> oneModule name -parseSource :: FilePath -> String -> Either ParseError (Source Module) -parseSource filePath contents = - let - moduleName = Path.basenameWithoutExt filePath ".tmpl" - in - runParser contents wholeFile - <#> \mod -> - { source: filePath - , contents: - mod - { name = moduleName - , exports = - mod.exports - { tmplPath = moduleName - } - } - } +data Error + = Error FilePath Position String -errorMessage :: String -> ParseError -> String -errorMessage fileName err = +parseSource :: FilePath -> String -> Either Error (Cst.Source Cst.Module) +parseSource filePath contents = do let - Position pos = parseErrorPosition err - in - "Could not parse " - <> fileName - <> ": line " - <> show pos.line - <> ", column " - <> show pos.column - <> ": " - <> parseErrorMessage err - -roundTrip :: ValidatedModule -> Either ParseError Boolean -roundTrip module1 = do + name = Path.basenameWithoutExt filePath ".tmpl" + lmap + (parseErrorToError filePath) + ( runParser contents (wholeFile (Cst.ModuleName name)) + <#> \mod -> + { source: filePath + , contents: mod + } + ) + +parseErrorToError :: FilePath -> Parser.ParseError -> Error +parseErrorToError filePath e = Error filePath (Parser.parseErrorPosition e) (Parser.parseErrorMessage e) + +errorMessage :: Error -> String +errorMessage (Error filePath (Position pos) message) = filePath <> ":" <> show pos.line <> ":" <> show pos.column <> " " <> message + +roundTrip :: Cst.Source Cst.Module -> Either Error Boolean +roundTrip { source: filePath, contents: module1 } = do let - prettyPrinted1 = PrettyPrinter.prettyPrint $ invalidate module1 - module2 <- runParser prettyPrinted1 wholeFile + prettyPrinted1 = PrettyPrint.prettyPrint module1 + module2 <- lmap (parseErrorToError filePath) (runParser prettyPrinted1 (wholeFile module1.name)) let - prettyPrinted2 = PrettyPrinter.prettyPrint $ invalidate $ module2 { imports = module1.imports } + prettyPrinted2 = PrettyPrint.prettyPrint module2 { imports = module1.imports } pure $ prettyPrinted1 == prettyPrinted2 --- TODO: Push this upstream to purescript-parsing? -- | Parse phrases delimited by a separator, requiring at least one match. sepBy1Nel :: forall m s a sep. Monad m => ParserT s m a -> ParserT s m sep -> ParserT s m (NonEmptyList a) sepBy1Nel p sep = do a <- p as <- List.many $ sep *> p pure $ NonEmptyList (a :| as) + +many1 :: forall m s a. Monad m => ParserT s m a -> ParserT s m (NonEmptyArray a) +many1 p = NonEmptyArray.cons' <$> p <*> Array.many p diff --git a/src/Ccap/Codegen/PrettyPrint.purs b/src/Ccap/Codegen/PrettyPrint.purs index 22f9516..00e48bf 100644 --- a/src/Ccap/Codegen/PrettyPrint.purs +++ b/src/Ccap/Codegen/PrettyPrint.purs @@ -1,91 +1,105 @@ module Ccap.Codegen.PrettyPrint - ( outputSpec - , prettyPrint + ( prettyPrint ) where import Prelude -import Ccap.Codegen.Shared (OutputSpec, invalidate) -import Ccap.Codegen.Types (Annotation(..), AnnotationParam(..), Primitive(..), RecordProp, TopType(..), Type(..), TypeDecl(..), Module) +import Ccap.Codegen.Cst as Cst import Data.Array as Array +import Data.Foldable (class Foldable) import Data.Maybe (Maybe(..), maybe) import Text.PrettyPrint.Boxes (Box, char, emptyBox, hsep, render, text, vcat, (//), (<<+>>), (<<>>)) import Text.PrettyPrint.Boxes (left, top) as Boxes -prettyPrint :: Module -> String +prettyPrint :: Cst.Module -> String prettyPrint = render <<< oneModule -outputSpec :: OutputSpec -outputSpec = - { render: render <<< oneModule <<< invalidate - , filePath: \mod -> mod.name <> ".tmpl" - } - -oneModule :: Module -> Box +oneModule :: Cst.Module -> Box oneModule mod = text ("scala: " <> mod.exports.scalaPkg) // text ("purs: " <> mod.exports.pursPkg) - // (vcat Boxes.left $ mod.imports <#> append "import " >>> text) + // (vcat Boxes.left $ mod.imports <#> \(Cst.Import _ t) -> text ("import " <> t)) // (vcat Boxes.left $ mod.types <#> typeDecl) -trailingSpace :: Array Box -> Box -trailingSpace boxes = - hsep 1 Boxes.top boxes - <<>> if Array.length boxes > 0 then char ' ' else emptyBox 0 0 +leadingSpace :: Array Box -> Box +leadingSpace boxes = + ( if Array.length boxes > 0 then + char ' ' + else + emptyBox 0 0 + ) + <<>> hsep 1 Boxes.top boxes -primitive :: Primitive -> Box +primitive :: Cst.Primitive -> Box primitive p = text case p of - PBoolean -> "Boolean" - PInt -> "Int" - PDecimal -> "Decimal" - PString -> "String" - PStringValidationHack -> "StringValidationHack" - PJson -> "Json" + Cst.PBoolean -> "Boolean" + Cst.PInt -> "Int" + Cst.PDecimal -> "Decimal" + Cst.PString -> "String" + Cst.PStringValidationHack -> "StringValidationHack" + Cst.PJson -> "Json" indented :: Box -> Box indented b = emptyBox 0 2 <<>> b -indentedList :: Array Box -> Box +indentedList :: forall f. Foldable f => f Box -> Box indentedList = indented <<< vcat Boxes.left -typeDecl :: TypeDecl -> Box -typeDecl (TypeDecl name tt annots) = +typeDecl :: Cst.TypeDecl -> Box +typeDecl (Cst.TypeDecl { name, topType: tt, annots, params }) = let - dec = text "type" <<+>> text name <<>> char ':' + dec :: Box + dec = text "type" <<+>> text name <<>> ps params <<>> char ':' + + ps :: Array Cst.TypeParam -> Box + ps = leadingSpace <<< map (\(Cst.TypeParam s) -> text s) ty = case tt of - Type t -> dec <<+>> tyType t - Wrap t -> dec <<+>> text "wrap" <<+>> tyType t - Record props -> + Cst.Type t -> dec <<+>> tyType t + Cst.Wrap t -> dec <<+>> text "wrap" <<+>> tyType t + Cst.Record props -> dec <<+>> char '{' // indentedList (props <#> recordProp) // text "}" - Sum vs -> + Cst.Sum vs -> dec <<+>> char '[' - // indented (vcat Boxes.left (vs <#> (\x -> char '|' <<+>> text x))) + // indented (vcat Boxes.left (vs <#> (\x -> char '|' <<+>> constructor x))) // char ']' in ty // indentedList (annots <#> annotation) -annotation :: Annotation -> Box -annotation (Annotation name _ params) = +constructor :: Cst.Constructor -> Box +constructor = case _ of + Cst.NoArg (Cst.ConstructorName c) -> text c + Cst.WithArgs (Cst.ConstructorName c) params -> text c <<+>> hsep 1 Boxes.top (map typeOrParam params) + +annotation :: Cst.Annotation -> Box +annotation (Cst.Annotation name _ params) = let op = if Array.length params == 0 then (<<>>) else (<<+>>) in char '<' <<>> text name `op` (hsep 1 Boxes.top (params <#> annotationParam)) <<>> char '>' -annotationParam :: AnnotationParam -> Box -annotationParam (AnnotationParam name _ value) = text name <<>> maybe (emptyBox 0 0) ((char '=' <<>> _) <<< text <<< show) value +annotationParam :: Cst.AnnotationParam -> Box +annotationParam (Cst.AnnotationParam name _ value) = text name <<>> maybe (emptyBox 0 0) ((char '=' <<>> _) <<< text <<< show) value -recordProp :: RecordProp -> Box +recordProp :: Cst.RecordProp -> Box recordProp { name, typ, annots } = - text name <<>> char ':' <<+>> tyType typ + text name <<>> char ':' <<+>> typeOrParam typ <<>> (if Array.null annots then char ',' else emptyBox 0 0) // indentedList (annotation <$> annots) -tyType :: Type -> Box +typeOrParam :: Cst.TypeOrParam -> Box +typeOrParam = case _ of + Cst.TType t -> tyType t + Cst.TParam (Cst.TypeParam t) -> text t + +tyType :: Cst.Type -> Box tyType = case _ of - Primitive p -> primitive p - Ref _ { mod: Nothing, typ } -> text typ - Ref _ { mod: Just m, typ } -> text (m <> "." <> typ) - Array t -> text "Array" <<+>> tyType t - Option t -> text "Maybe" <<+>> tyType t + Cst.Primitive p -> primitive p + Cst.Ref _ { mod: Nothing, typ, params: [] } -> text typ + Cst.Ref _ { mod: Just (Cst.ModuleRef m), typ, params: [] } -> text (m <> "." <> typ) + Cst.Ref _ { mod: Nothing, typ, params } -> text typ <<+>> hsep 1 Boxes.top (map typeOrParam params) + Cst.Ref _ { mod: Just (Cst.ModuleRef m), typ, params } -> text (m <> "." <> typ) <<+>> hsep 1 Boxes.top (map typeOrParam params) + Cst.Array t -> text "Array" <<+>> typeOrParam t + Cst.Option t -> text "Maybe" <<+>> typeOrParam t + Cst.TypeWithParens t -> char '(' <<>> tyType t <<>> char ')' diff --git a/src/Ccap/Codegen/PureScript.purs b/src/Ccap/Codegen/PureScript.purs new file mode 100644 index 0000000..03f8be3 --- /dev/null +++ b/src/Ccap/Codegen/PureScript.purs @@ -0,0 +1,632 @@ +module Ccap.Codegen.PureScript + ( outputSpec + ) where + +import Prelude +import Ccap.Codegen.Annotations as Annotations +import Ccap.Codegen.Ast as Ast +import Ccap.Codegen.Cst as Cst +import Ccap.Codegen.Parser.Export as Export +import Ccap.Codegen.Shared (DelimitedLiteralDir(..), OutputSpec, delimitedLiteral, fastPathDecoderType, indented) +import Control.Monad.Writer (class MonadTell, Writer, runWriter, tell) +import Data.Array ((:)) +import Data.Array as Array +import Data.Array.NonEmpty (NonEmptyArray) +import Data.Array.NonEmpty as NonEmptyArray +import Data.Compactable (compact) +import Data.Foldable (fold, intercalate) +import Data.Function (on) +import Data.Maybe (Maybe(..), fromMaybe, isJust, maybe) +import Data.String (Pattern(..)) +import Data.String as String +import Data.Traversable (for, traverse) +import Data.TraversableWithIndex (forWithIndex) +import Data.Tuple (Tuple(..), fst) +import Node.Path (FilePath) +import Text.PrettyPrint.Boxes (Box, char, emptyBox, hsep, punctuateH, render, text, vcat, vsep, (//), (<<+>>), (<<>>)) +import Text.PrettyPrint.Boxes as Boxes + +type PsImport + = { mod :: String + , typ :: Maybe String + , alias :: Maybe String + } + +type Codegen + = Writer (Array PsImport) + +runCodegen :: forall a. Codegen a -> Tuple a (Array PsImport) +runCodegen c = runWriter c + +emit :: forall m a. MonadTell (Array PsImport) m => PsImport -> a -> m a +emit imp a = map (const a) (tell [ imp ]) + +oneModule :: Ast.Module -> Box +oneModule (Ast.Module mod) = + vsep 1 Boxes.left + let + Tuple body imports = runCodegen (traverse typeDecl mod.types) + + allImports = imports <> (mod.imports <#> importModule) + in + text "-- This file is automatically generated. Do not edit." + : text ("module " <> mod.exports.pursPkg <> " where") + : vcat Boxes.left + ((renderImports <<< mergeImports $ allImports) <#> append "import " >>> text) + : NonEmptyArray.toArray body + +renderImports :: Array PsImport -> Array String +renderImports = + map \{ mod, typ, alias } -> + mod + <> (fromMaybe "" (typ <#> (\t -> " (" <> t <> ")"))) + <> (fromMaybe "" (alias <#> (" as " <> _))) + +mergeImports :: Array PsImport -> Array PsImport +mergeImports imps = + let + sorted = Array.sortBy ((compare `on` _.mod) <> (compare `on` _.alias)) imps + + grouped = Array.groupBy (\a b -> a.mod == b.mod && a.alias == b.alias) sorted + in + grouped + <#> \group -> + (NonEmptyArray.head group) + { typ = + traverse _.typ group <#> NonEmptyArray.toArray + >>> Array.sort + >>> Array.nub + >>> intercalate ", " + } + +outputSpec :: OutputSpec +outputSpec = + { render: Just <<< render <<< oneModule + , filePath: modulePath + } + +modulePath :: Ast.Module -> FilePath +modulePath (Ast.Module mod) = Export.toPath mod.exports.pursPkg <> ".purs" + +primitive :: Cst.Primitive -> Codegen Box +primitive = case _ of + Cst.PBoolean -> pure (text "Boolean") + Cst.PInt -> pure (text "Int") + Cst.PDecimal -> emit { mod: "Data.Decimal", typ: Just "Decimal", alias: Nothing } (text "Decimal") + Cst.PString -> pure (text "String") + Cst.PStringValidationHack -> pure (text "String") + Cst.PJson -> emit { mod: "Data.Argonaut.Core", typ: Nothing, alias: Just "A" } (text "A.Json") + +type Extern + = { prefix :: String, t :: String } + +externalType :: Extern -> Codegen Box +externalType { prefix, t } = emit { mod: prefix, typ: Just t, alias: Just prefix } $ text (prefix <> "." <> t) + +moduleName :: Ast.Module -> String +moduleName (Ast.Module { exports: { pursPkg } }) = fromMaybe pursPkg $ Array.last $ Export.split pursPkg + +importModule :: Ast.Module -> PsImport +importModule mod@(Ast.Module m) = + { mod: m.exports.pursPkg + , typ: Nothing + , alias: Just $ moduleName mod + } + +splitType :: String -> Maybe Extern +splitType s = do + i <- String.lastIndexOf (Pattern ".") s + let + prefix = String.take i s + let + t = String.drop (i + 1) s + pure $ { prefix, t } + +typeDecl :: Ast.TypeDecl -> Codegen Box +typeDecl (Ast.TypeDecl { name, topType: tt, annots, params: typeParams }) = + let + pp = + if Array.null typeParams then + "" + else + " " <> intercalate " " (map (\(Cst.TypeParam p) -> p) typeParams) + + dec kw = text kw <<+>> text (name <> pp) <<+>> char '=' + in + case tt of + Ast.Type t -> do + ty <- tyType t false + j <- jsonCodec t false + pure $ (dec "type" <<+>> ty) + // defJsonCodec name typeParams j + Ast.Wrap t -> case Annotations.getWrapOpts "purs" annots of + Nothing -> do + other <- otherInstances name typeParams + ty <- tyType t false + j <- newtypeJsonCodec name t + newtype_ <- newtypeInstances name + pure + $ dec "newtype" + <<+>> text name + <<+>> ty + // newtype_ + // other + // defJsonCodec name typeParams j + Just { typ, decode, encode } -> do + ty <- externalRef typ + j <- externalJsonCodec name t decode encode + pure + $ dec "type" + <<+>> ty + // defJsonCodec name typeParams j + Ast.Record props -> do + recordDecl <- record props <#> \p -> dec "type" // indented p + recordDecoderApiTypeDecl <- recordDecoderApi props <#> \p -> text ("type DecoderApi_" <> name <> pp <> " =") // indented p + recordDecoderApiTypeDeclDecl <- recordDecoderApiDecl props <#> \p -> text ("decoderApi_" <> name <> defParams typeParams <> " =") // indented p + codec <- recordJsonCodec name typeParams props + pure + $ recordDecl + // recordDecoderApiTypeDecl + // text ("decoderApi_" <> name <> " ::" <> declParamTypes typeParams <> "DecoderApi_" <> name <> pp) + // recordDecoderApiTypeDeclDecl + // text + ( "foreign import decode_" + <> name + <> " ::" + <> declForAll typeParams + <> " DecoderApi_" + <> name + <> pp + <> " -> A.Json -> E.Either String " + <> if Array.null typeParams then + name + else + "(" <> name <> pp <> ")" + ) + // defJsonCodec name typeParams codec + Ast.Sum constructors -> + maybe + ( do + other <- otherInstances name typeParams + cs <- + for constructors case _ of + Ast.NoArg (Cst.ConstructorName n) -> pure (text n) + Ast.WithArgs (Cst.ConstructorName n) args -> do + params <- tyTypeOrParams (NonEmptyArray.toArray args) + pure (text n <<+>> hsep 1 Boxes.top params) + codec <- sumJsonCodec name constructors + pure + $ dec "data" + // indented (hsep 1 Boxes.bottom $ vcat Boxes.left <$> [ NonEmptyArray.drop 1 cs <#> \_ -> char '|', NonEmptyArray.toArray cs ]) + // other + // defJsonCodec name typeParams codec + ) + ( \vs -> do + other <- otherInstances name typeParams + codec <- noArgSumJsonCodec name vs + pure + $ dec "data" + // indented (hsep 1 Boxes.bottom $ vcat Boxes.left <$> [ NonEmptyArray.drop 1 vs <#> \_ -> char '|', NonEmptyArray.toArray (vs <#> text) ]) + // other + // defJsonCodec name typeParams codec + ) + (Ast.noArgConstructorNames constructors) + +noArgSumJsonCodec :: String -> NonEmptyArray String -> Codegen Box +noArgSumJsonCodec name vs = do + tell + [ { mod: "Data.Either", typ: Just "Either(..)", alias: Nothing } + ] + let + encode = + text "encode: case _ of" + // indented (branches encodeBranch) + + decode = + text "decode: case _ of" + // indented (branches decodeBranch // fallthrough) + emitRuntime $ text "R.composeCodec" + // indented (delimitedLiteral Vert '{' '}' [ decode, encode ] // text "R.jsonCodec_string") + where + branches branch = vcat Boxes.left (vs <#> branch) + + encodeBranch v = text v <<+>> text "->" <<+>> text (show v) + + decodeBranch v = text (show v) <<+>> text "-> Right" <<+>> text v + + fallthrough = text $ "s -> Left $ \"Invalid value \" <> show s <> \" for " <> name <> "\"" + +sumJsonCodec :: String -> NonEmptyArray Ast.Constructor -> Codegen Box +sumJsonCodec name cs = do + tell + [ { mod: "Data.Either", typ: Nothing, alias: Just "E" } + , { mod: "Data.Tuple", typ: Nothing, alias: Just "T" } + , { mod: "Data.Array", typ: Nothing, alias: Just "Array" } + ] + encodeBranches <- traverse encodeBranch cs + decodeBranches <- traverse decodeBranch cs + let + encode = + text "encode: case _ of" + // indented (vcat Boxes.left encodeBranches) + + decode = + text "decode: case _ of" + // indented (vcat Boxes.left (decodeBranches `NonEmptyArray.snoc` fallThrough)) + emitRuntime $ text "R.composeCodec" + // indented (delimitedLiteral Vert '{' '}' [ decode, encode ] // text "R.jsonCodec_constructor") + where + encodeBranch :: Ast.Constructor -> Codegen Box + encodeBranch = case _ of + Ast.NoArg (Cst.ConstructorName n) -> pure (text n <<+>> text ("-> T.Tuple " <> show n <> " []")) + Ast.WithArgs (Cst.ConstructorName n) params -> do + encodeParams <- + forWithIndex params \i typ -> do + x <- case typ of + Ast.TType t -> jsonCodec t true + Ast.TParam (Cst.TypeParam p) -> pure (text ("jsonCodec_param_" <> p)) + pure (x <<>> text (".encode param_" <> show i)) + pure + ( text + ( n + <> " " + <> intercalate " " (map (\i -> "param_" <> show i) (Array.range 0 (NonEmptyArray.length params - 1))) + <> " -> T.Tuple " + <> show n + <> " [" + ) + <<>> punctuateH Boxes.top (text ", ") encodeParams + <<>> text "]" + ) + + decodeBranch :: Ast.Constructor -> Codegen Box + decodeBranch = case _ of + Ast.NoArg (Cst.ConstructorName n) -> pure (text ("T.Tuple " <> show n <> " [] -> E.Right " <> n)) + Ast.WithArgs (Cst.ConstructorName n) params -> do + decodeParams <- + forWithIndex params \i typ -> do + x <- case typ of + Ast.TType t -> jsonCodec t true + Ast.TParam (Cst.TypeParam p) -> pure (text ("jsonCodec_param_" <> p)) + pure (text ("param_" <> show i <> " <- ") <<>> x <<>> text (".decode jsonParam_" <> show i)) + pure + ( text + ( "T.Tuple " + <> show n + <> " [" + <> intercalate ", " (map (\i -> "jsonParam_" <> show i) (Array.range 0 (NonEmptyArray.length params - 1))) + <> "] -> do" + ) + // indented + ( vcat Boxes.left + ( NonEmptyArray.toArray decodeParams + <> [ text + ( "E.Right (" + <> n + <> " " + <> intercalate " " (map (\i -> "param_" <> show i) (Array.range 0 (NonEmptyArray.length params - 1))) + <> ")" + ) + ] + ) + ) + ) + + fallThrough = text $ "T.Tuple cn params -> E.Left $ \"Pattern match failed for \" <> show cn <> \" with \" <> show (Array.length params) <> \" parameters\"" + +needsParens :: Ast.Type -> Boolean +needsParens = case _ of + Ast.Primitive _ -> false + Ast.Ref { params } -> not Array.null params + Ast.Array _ -> true + Ast.Option _ -> true + +newtypeInstances :: String -> Codegen Box +newtypeInstances name = do + tell + [ { mod: "Data.Newtype", typ: Just "class Newtype", alias: Nothing } + , { mod: "Data.Argonaut.Decode", typ: Just "class DecodeJson", alias: Nothing } + , { mod: "Data.Argonaut.Encode", typ: Just "class EncodeJson", alias: Nothing } + ] + pure + $ text ("derive instance newtype" <> name <> " :: Newtype " <> name <> " _") + // text ("instance encodeJson" <> name <> " :: EncodeJson " <> name <> " where ") + // indented (text $ "encodeJson a = jsonCodec_" <> name <> ".encode a") + // text ("instance decodeJson" <> name <> " :: DecodeJson " <> name <> " where ") + // indented (text $ "decodeJson a = jsonCodec_" <> name <> ".decode a") + +otherInstances :: String -> Array Cst.TypeParam -> Codegen Box +otherInstances name params = do + tell + [ { mod: "Prelude", typ: Nothing, alias: Nothing } + , { mod: "Data.Generic.Rep", typ: Just "class Generic", alias: Nothing } + , { mod: "Data.Generic.Rep.Show", typ: Just "genericShow", alias: Nothing } + ] + let + nameWithParams = + if Array.null params then + name + else + "(" <> name <> " " <> intercalate " " (map (\(Cst.TypeParam p) -> p) params) <> ")" + + depends :: String -> String + depends which = case params of + [] -> "" + [ Cst.TypeParam p ] -> which <> " " <> p <> " => " + _ -> "(" <> intercalate ", " (map (\(Cst.TypeParam p) -> which <> " " <> p) params) <> ") => " + pure + $ text ("derive instance eq" <> name <> " :: " <> depends "Eq" <> "Eq " <> nameWithParams) + // text ("derive instance ord" <> name <> " :: " <> depends "Ord" <> "Ord " <> nameWithParams) + // text ("derive instance generic" <> name <> " :: Generic " <> nameWithParams <> " _") + // text ("instance show" <> name <> " :: " <> depends "Show" <> "Show " <> nameWithParams <> " where") + // indented (text "show a = genericShow a") + +tyType :: Ast.Type -> Boolean -> Codegen Box +tyType tt includeParensIfNeeded = + let + wrap tycon t = tyType t true <#> \ty -> text tycon <<+>> ty + in + do + result <- case tt of + Ast.Primitive p -> primitive p + Ast.Ref { decl, typ, params } -> internalTypeRef decl params typ + Ast.Array (Ast.TType t) -> wrap "Array" t + Ast.Array (Ast.TParam (Cst.TypeParam t)) -> pure (text ("Array " <> t)) + Ast.Option (Ast.TType t) -> tell (pure { mod: "Data.Maybe", typ: Just "Maybe", alias: Nothing }) >>= const (wrap "Maybe" t) + Ast.Option (Ast.TParam (Cst.TypeParam t)) -> pure (text ("Maybe " <> t)) + pure + ( if includeParensIfNeeded && needsParens tt then + parens result + else + result + ) + +tyTypeOrParams :: Array Ast.TypeOrParam -> Codegen (Array Box) +tyTypeOrParams typeOrParams = + for typeOrParams case _ of + Ast.TType ttt -> tyType ttt true + Ast.TParam (Cst.TypeParam c) -> pure (text c) + +internalRef :: Maybe (Tuple Ast.Module Ast.TypeDecl) -> String -> Array Box -> Box +internalRef decl typ paramsBoxes = do + let + path = map (moduleName <<< fst) decl + + paramsBox = + if Array.null paramsBoxes then + emptyBox 0 0 + else + text " " <<>> hsep 1 Boxes.top paramsBoxes + text (qualify path typ) <<>> paramsBox + +internalTypeRef :: Maybe (Tuple Ast.Module Ast.TypeDecl) -> Array Ast.TypeOrParam -> String -> Codegen Box +internalTypeRef decl params typ = do + pp <- tyTypeOrParams params + pure (internalRef decl typ pp) + +internalCodecRef :: Maybe (Tuple Ast.Module Ast.TypeDecl) -> Array Ast.TypeOrParam -> String -> Codegen Box +internalCodecRef decl params typ = do + pp <- + for params case _ of + Ast.TParam (Cst.TypeParam p) -> pure (text ("jsonCodec_param_" <> p)) + Ast.TType tt -> jsonCodec tt true + pure (internalRef decl ("jsonCodec_" <> typ) pp) + +qualify :: Maybe String -> String -> String +qualify path name = maybe name (_ <> "." <> name) path + +externalRef :: String -> Codegen Box +externalRef s = fromMaybe (text s # pure) (splitType s <#> externalType) + +emitRuntime :: Box -> Codegen Box +emitRuntime b = emit { mod: "Ccap.Codegen.Runtime", typ: Nothing, alias: Just "R" } b + +newtypeJsonCodec :: String -> Ast.Type -> Codegen Box +newtypeJsonCodec name t = do + i <- jsonCodec t true + emitRuntime $ text "R.codec_newtype" <<+>> i + +externalJsonCodec :: String -> Ast.Type -> String -> String -> Codegen Box +externalJsonCodec name t decode encode = do + i <- jsonCodec t true + decode_ <- externalRef decode + encode_ <- externalRef encode + emitRuntime $ text "R.codec_custom" <<+>> decode_ <<+>> encode_ <<+>> i + +codecName :: Maybe String -> String -> String +codecName mod t = qualify mod $ "jsonCodec_" <> t + +jsonCodec :: Ast.Type -> Boolean -> Codegen Box +jsonCodec ty includeParensIfNeeded = do + let + tycon :: String -> Box -> Box + tycon which ref = do + text (codecName (Just "R") which <> " ") <<>> ref + result <- case ty of + Ast.Primitive p -> + pure + ( text + $ codecName (Just "R") + ( case p of + Cst.PBoolean -> "boolean" + Cst.PInt -> "int" + Cst.PDecimal -> "decimal" + Cst.PString -> "string" + Cst.PStringValidationHack -> "string" + Cst.PJson -> "json" + ) + ) + Ast.Array (Ast.TType t) -> do + ref <- jsonCodec t true + pure (tycon "array" ref) + Ast.Array (Ast.TParam (Cst.TypeParam p)) -> pure (tycon "array" (text ("jsonCodec_param_" <> p))) + Ast.Option (Ast.TType t) -> do + ref <- jsonCodec t true + pure (tycon "maybe" ref) + Ast.Option (Ast.TParam (Cst.TypeParam p)) -> pure (tycon "maybe" (text ("jsonCodec_param_" <> p))) + Ast.Ref { decl, typ, params } -> internalCodecRef decl params typ + pure + ( if includeParensIfNeeded && needsParens ty then + parens result + else + result + ) + +parens :: Box -> Box +parens b = char '(' <<>> b <<>> char ')' + +declForAll :: Array Cst.TypeParam -> String +declForAll typeParams = + if Array.null typeParams then + "" + else + " forall " <> intercalate " " (map (\(Cst.TypeParam p) -> p) typeParams) <> "." + +declParamTypes :: Array Cst.TypeParam -> String +declParamTypes typeParams = do + declForAll typeParams <> " " <> fold (map (\(Cst.TypeParam p) -> "R.JsonCodec " <> p <> " -> ") typeParams) + +declParams :: String -> Array Cst.TypeParam -> String +declParams name typeParams = + if Array.null typeParams then + name + else + "(" <> name <> " " <> intercalate " " (map (\(Cst.TypeParam p) -> p) typeParams) <> ")" + +defParams :: Array Cst.TypeParam -> String +defParams typeParams = + if Array.null typeParams then + "" + else + " " <> intercalate " " (map (\(Cst.TypeParam p) -> "jsonCodec_param_" <> p) typeParams) + +defJsonCodec :: String -> Array Cst.TypeParam -> Box -> Box +defJsonCodec name typeParams def = + let + cname = codecName Nothing name + in + text cname <<+>> text ("::" <> declParamTypes typeParams <> "R.JsonCodec") <<+>> text (declParams name typeParams) + // (text (cname <> defParams typeParams) <<+>> char '=') + // indented def + +record :: NonEmptyArray Ast.RecordProp -> Codegen Box +record props = do + tell [ { mod: "Data.Tuple", typ: Nothing, alias: Just "T" } ] + types <- + for props $ _.typ + >>> case _ of + Ast.TParam (Cst.TypeParam p) -> pure (text p) + Ast.TType t -> tyType t false + let + labels = props <#> \{ name } -> text name <<+>> text "::" + pure $ delimitedLiteral Vert '{' '}' (NonEmptyArray.toArray (NonEmptyArray.zip labels types <#> \(Tuple l t) -> l <<+>> t)) + +recordDecoderApi :: NonEmptyArray Ast.RecordProp -> Codegen Box +recordDecoderApi props = do + labelsAndTypes <- + map (compact <<< NonEmptyArray.toArray) + ( for props \{ name, typ } -> case typ of + Ast.TParam (Cst.TypeParam p) -> pure (Just (text ("jsonCodec_" <> name <> " :: R.JsonCodec " <> p))) + Ast.TType t -> + if hasDecoderFastPath t then + pure Nothing + else do + tt <- tyType t true + pure (Just (text ("jsonCodec_" <> name) <<+>> text "::" <<+>> text "R.JsonCodec" <<+>> tt)) + ) + if Array.null labelsAndTypes then do + tell + [ { mod: "Data.Either", typ: Nothing, alias: Just "E" } + ] + pure (text "R.StandardDecoderApi") + else do + tell + [ { mod: "Prelude", typ: Nothing, alias: Nothing } + , { mod: "Data.Either", typ: Nothing, alias: Just "E" } + , { mod: "Data.Maybe", typ: Nothing, alias: Just "M" } + , { mod: "Data.Bifunctor", typ: Nothing, alias: Just "B" } + , { mod: "Ccap.Codegen.Runtime", typ: Nothing, alias: Just "R" } + , { mod: "Data.Decimal", typ: Just "Decimal", alias: Nothing } + ] + pure (delimitedLiteral Vert '{' '}' (standard <> labelsAndTypes)) + where + standard :: Array Box + standard = + map text + [ "nothing :: forall a. M.Maybe a" + , "just :: forall a. a -> M.Maybe a" + , "isLeft :: forall a b. E.Either a b -> Boolean" + , "fromRight :: forall a b. Partial => E.Either a b -> b" + , "right :: forall a b. b -> E.Either a b" + , "left :: forall a b. a -> E.Either a b" + , "addErrorPrefix :: forall a. String -> E.Either String a -> E.Either String a" + , "jsonCodec_primitive_decimal :: R.JsonCodec Decimal" + ] + +recordDecoderApiDecl :: NonEmptyArray Ast.RecordProp -> Codegen Box +recordDecoderApiDecl props = do + labelsAndValues <- + map (compact <<< NonEmptyArray.toArray) + ( for props \{ name, typ } -> case typ of + Ast.TParam (Cst.TypeParam p) -> pure (Just (text ("jsonCodec_" <> name) <<>> text (": jsonCodec_param_" <> p))) + Ast.TType t -> + if hasDecoderFastPath t then + pure Nothing + else do + x <- jsonCodec t false + pure (Just (text ("jsonCodec_" <> name) <<>> text ":" <<+>> x)) + ) + pure + ( if Array.null labelsAndValues then + text "R.standardDecoderApi" + else + delimitedLiteral Vert '{' '}' (standard <> labelsAndValues) + ) + where + standard :: Array Box + standard = + map text + [ "nothing: M.Nothing" + , "just: M.Just" + , "isLeft: E.isLeft" + , "fromRight: E.fromRight" + , "right: E.Right" + , "left: E.Left" + , "addErrorPrefix: \\s -> B.lmap (s <> _)" + , "jsonCodec_primitive_decimal: R.jsonCodec_decimal" + ] + +hasDecoderFastPath :: Ast.Type -> Boolean +hasDecoderFastPath = isJust <<< fastPathDecoderType + +recordJsonCodec :: String -> Array Cst.TypeParam -> NonEmptyArray Ast.RecordProp -> Codegen Box +recordJsonCodec name typeParams props = do + tell + [ { mod: "Data.Argonaut.Core", typ: Nothing, alias: Just "A" } + , { mod: "Ccap.Codegen.Runtime", typ: Nothing, alias: Just "R" } + , { mod: "Foreign.Object", typ: Nothing, alias: Just "FO" } + , { mod: "Prelude", typ: Nothing, alias: Nothing } + ] + encodeProps <- recordWriteProps props + let + encode = + text "encode: \\p -> A.fromObject $" + // indented + ( text "FO.fromFoldable" + // indented encodeProps + ) + + names = props <#> _.name >>> text + + decode = text ("decode: decode_" <> name <> " (decoderApi_" <> name <> defParams typeParams <> ")") + pure $ delimitedLiteral Vert '{' '}' [ decode, encode ] + +recordWriteProps :: NonEmptyArray Ast.RecordProp -> Codegen Box +recordWriteProps props = do + types <- + for props \{ name, typ } -> do + x <- case typ of + Ast.TType t -> jsonCodec t true + Ast.TParam (Cst.TypeParam p) -> pure (text ("jsonCodec_param_" <> p)) + pure $ text "T.Tuple" <<+>> text (show name) <<+>> parens (x <<>> text ".encode p." <<>> text name) + pure $ delimitedLiteral Vert '[' ']' (NonEmptyArray.toArray types) diff --git a/src/Ccap/Codegen/PureScriptJs.purs b/src/Ccap/Codegen/PureScriptJs.purs new file mode 100644 index 0000000..3965679 --- /dev/null +++ b/src/Ccap/Codegen/PureScriptJs.purs @@ -0,0 +1,188 @@ +module Ccap.Codegen.PureScriptJs + ( outputSpec + ) where + +import Prelude +import Ccap.Codegen.Ast as Ast +import Ccap.Codegen.Cst as Cst +import Ccap.Codegen.Parser.Export as Export +import Ccap.Codegen.Shared (DelimitedLiteralDir(..), FastPathDecoderType(..), OutputSpec, delimitedLiteral, fastPathDecoderType, indented) +import Data.Array as Array +import Data.Array.NonEmpty (NonEmptyArray) +import Data.Array.NonEmpty as NonEmptyArray +import Data.Maybe (Maybe(..)) +import Data.Tuple (Tuple(..)) +import Node.Path (FilePath) +import Text.PrettyPrint.Boxes (Box, render, text, vsep, (//)) +import Text.PrettyPrint.Boxes as Boxes + +outputSpec :: OutputSpec +outputSpec = + { render: map render <<< oneModule + , filePath: modulePath + } + +modulePath :: Ast.Module -> FilePath +modulePath (Ast.Module mod) = Export.toPath mod.exports.pursPkg <> ".js" + +records :: Ast.Module -> Array (Tuple String (NonEmptyArray Ast.RecordProp)) +records (Ast.Module mod) = + Array.mapMaybe + ( case _ of + Ast.TypeDecl { name, topType: Ast.Record props } -> Just (Tuple name props) + _ -> Nothing + ) + (Array.fromFoldable mod.types) + +oneModule :: Ast.Module -> Maybe Box +oneModule m@(Ast.Module mod) = do + let + recs = records m + if Array.null recs then + Nothing + else + Just + ( text "// This file is automatically generated. Do not edit." + // vsep 1 Boxes.left (map (\(Tuple name props) -> oneRecord name props) recs) + ) + +oneRecord :: String -> NonEmptyArray Ast.RecordProp -> Box +oneRecord name props = + text ("exports.decode_" <> name <> " = function (api) {") + // indented + ( text "return function(json) {" + // indented + ( text "if (! (typeof json === 'object' && !Array.isArray(json) && json !== null)) {" + // indented (text "return api.left('This value must be an object');") + // text "}" + // text "" + // vsep 1 Boxes.left (map decodeProp props) + // returnAll props + ) + // text "};" + ) + // text "};" + +returnAll :: NonEmptyArray Ast.RecordProp -> Box +returnAll props = + text "return api.right(" + // indented (delimitedLiteral Vert '{' '}' (NonEmptyArray.toArray (map (\{ name } -> text (name <> ": " <> name)) props))) + // text ");" + +decodeProp :: Ast.RecordProp -> Box +decodeProp { name, typ } = + text ("let " <> name <> ";") + // text ("if (! ('" <> name <> "' in json)) {") + // indented (text ("return api.left(" <> show ("Property '" <> name <> "' does not exist") <> ");")) + // text "}" + // case typ of + Ast.TParam (Cst.TypeParam p) -> + decodeCustom + { name + , decoder: "api.jsonCodec_" <> name + } + Ast.TType t -> case fastPathDecoderType t of + Just FBoolean -> + decodeFastStandard + { name + , negTest: "typeof json." <> name <> " !== 'boolean'" + , descr: "boolean" + } + Just FString -> + decodeFastStandard + { name + , negTest: "typeof json." <> name <> " !== 'string'" + , descr: "string" + } + Just FInt -> do + let + ref = "json." <> name + decodeFastStandard + { name + , negTest: "typeof " <> ref <> " !== 'number' && (" <> ref <> " | 0) === " <> ref + , descr: "integer" + } + Just FOptionBoolean -> + decodeFastOptionStandard + { name + , negTest: "typeof json." <> name <> " !== 'boolean'" + , descr: "boolean" + } + Just FOptionString -> + decodeFastOptionStandard + { name + , negTest: "typeof json." <> name <> " !== 'string'" + , descr: "string" + } + Just FOptionInt -> do + let + ref = "json." <> name + decodeFastOptionStandard + { name + , negTest: "typeof " <> ref <> " !== 'number' && (" <> ref <> " | 0) === " <> ref + , descr: "integer" + } + Just FJson -> text (name <> " = json." <> name <> ";") + Just FOptionJson -> + text ("if (json." <> name <> " === null) {") + // indented (text (name <> " = api.nothing;")) + // text "} else {" + // indented (text (name <> " = api.just(json." <> name <> ");")) + // text "}" + Just FDecimal -> + decodeCustom + { name + , decoder: "api.jsonCodec_primitive_decimal" + } + Just FOptionDecimal -> + decodeOptionCustom + { name + , decoder: "api.jsonCodec_primitive_decimal" + } + Nothing -> + decodeCustom + { name + , decoder: "api.jsonCodec_" <> name + } + +decodeFastStandard :: { name :: String, negTest :: String, descr :: String } -> Box +decodeFastStandard { name, negTest, descr } = + text ("if (" <> negTest <> ") {") + // indented (text ("return api.left(" <> (show ("Property '" <> name <> "' must be a(n) " <> descr)) <> ");")) + // text "}" + // text (name <> " = json." <> name <> ";") + +decodeFastOptionStandard :: { name :: String, negTest :: String, descr :: String } -> Box +decodeFastOptionStandard { name, negTest, descr } = + text ("if (json." <> name <> " === null) {") + // indented (text (name <> " = api.nothing;")) + // text "} else {" + // indented + ( text ("if (" <> negTest <> ") {") + // indented (text ("return api.left(" <> (show ("Property '" <> name <> "' must be a(n) " <> descr)) <> ");")) + // text "}" + // text (name <> " = api.just(json." <> name <> ");") + ) + // text "}" + +decodeCustom :: { name :: String, decoder :: String } -> Box +decodeCustom { name, decoder } = + text (name <> " = " <> decoder <> ".decode(json." <> name <> ");") + // text ("if (api.isLeft(" <> name <> ")) {") + // indented (text ("return api.addErrorPrefix(" <> show ("Property '" <> name <> "': ") <> ")(" <> name <> ");")) + // text "}" + // text (name <> " = api.fromRight()(" <> name <> ");") + +decodeOptionCustom :: { name :: String, decoder :: String } -> Box +decodeOptionCustom { name, decoder } = + text ("if (json." <> name <> " === null) {") + // indented (text (name <> " = api.nothing;")) + // text "} else {" + // indented + ( text (name <> " = " <> decoder <> ".decode(json." <> name <> ");") + // text ("if (api.isLeft(" <> name <> ")) {") + // indented (text ("return " <> name <> ";")) + // text "}" + // text (name <> " = api.just(api.fromRight()(" <> name <> "));") + ) + // text "}" diff --git a/src/Ccap/Codegen/Purescript.purs b/src/Ccap/Codegen/Purescript.purs deleted file mode 100644 index 7951902..0000000 --- a/src/Ccap/Codegen/Purescript.purs +++ /dev/null @@ -1,372 +0,0 @@ -module Ccap.Codegen.Purescript - ( outputSpec - ) where - -import Prelude -import Ccap.Codegen.Annotations (field) as Annotations -import Ccap.Codegen.Annotations (getWrapOpts) -import Ccap.Codegen.Env (Env, askModule, forM) -import Ccap.Codegen.Parser.Export as Export -import Ccap.Codegen.Shared (DelimitedLiteralDir(..), OutputSpec, delimitedLiteral, indented, modulesInScope) -import Ccap.Codegen.Types (Module, Primitive(..), RecordProp, TopType(..), Type(..), TypeDecl(..), ValidatedModule, ModuleName) -import Control.Alt ((<|>)) -import Control.Monad.Reader (ReaderT, ask, asks, runReaderT) -import Control.Monad.Writer (class MonadTell, Writer, runWriter, tell) -import Data.Array ((:)) -import Data.Array as Array -import Data.Array.NonEmpty as NonEmptyArray -import Data.Foldable (intercalate) -import Data.Function (on) -import Data.Maybe (Maybe(..), fromMaybe, maybe) -import Data.String (Pattern(..)) -import Data.String as String -import Data.Traversable (for, traverse) -import Data.Tuple (Tuple(..)) -import Node.Path (FilePath) -import Text.PrettyPrint.Boxes (Box, char, hsep, render, text, vcat, vsep, (//), (<<+>>), (<<>>)) -import Text.PrettyPrint.Boxes (bottom, left) as Boxes - -type PsImport - = { mod :: String - , typ :: Maybe String - , alias :: Maybe String - } - -type Codegen - = ReaderT Env (Writer (Array PsImport)) - -runCodegen :: forall a. Env -> Codegen a -> Tuple a (Array PsImport) -runCodegen env c = runWriter (runReaderT c env) - -emit :: forall m a. MonadTell (Array PsImport) m => PsImport -> a -> m a -emit imp a = map (const a) (tell [ imp ]) - ---refactor module names -oneModule :: ValidatedModule -> Box -oneModule mod = - vsep 1 Boxes.left - let - env = - { defaultPrefix: Nothing - , currentModule: - mod - { imports = mod.imports <#> _.exports.pursPkg - } - , allModules: modulesInScope mod - } - - Tuple body imports = runCodegen env (traverse typeDecl mod.types) - - allImports = imports <> (mod.imports <#> importModule) - in - text "-- This file is automatically generated. Do not edit." - : text ("module " <> mod.exports.pursPkg <> " where") - : vcat Boxes.left - ((renderImports <<< mergeImports $ allImports) <#> append "import " >>> text) - : body - -renderImports :: Array PsImport -> Array String -renderImports = - map \{ mod, typ, alias } -> - mod - <> (fromMaybe "" (typ <#> (\t -> " (" <> t <> ")"))) - <> (fromMaybe "" (alias <#> (" as " <> _))) - -mergeImports :: Array PsImport -> Array PsImport -mergeImports imps = - let - sorted = Array.sortBy ((compare `on` _.mod) <> (compare `on` _.alias)) imps - - grouped = Array.groupBy (\a b -> a.mod == b.mod && a.alias == b.alias) sorted - in - grouped - <#> \group -> - (NonEmptyArray.head group) - { typ = - traverse _.typ group <#> NonEmptyArray.toArray - >>> Array.sort - >>> Array.nub - >>> intercalate ", " - } - -outputSpec :: OutputSpec -outputSpec = - { render: render <<< oneModule - , filePath: modulePath - } - -modulePath :: ValidatedModule -> FilePath -modulePath mod = (Export.toPath mod.exports.pursPkg) <> ".purs" - -primitive :: Primitive -> Codegen Box -primitive = case _ of - PBoolean -> pure (text "Boolean") - PInt -> pure (text "Int") - PDecimal -> emit { mod: "Data.Decimal", typ: Just "Decimal", alias: Nothing } (text "Decimal") - PString -> pure (text "String") - PStringValidationHack -> pure (text "String") - PJson -> emit { mod: "Data.Argonaut.Core", typ: Nothing, alias: Just "A" } (text "A.Json") - -type Extern - = { prefix :: String, t :: String } - -externalType :: Extern -> Codegen Box -externalType { prefix, t } = emit { mod: prefix, typ: Just t, alias: Just prefix } $ text (prefix <> "." <> t) - -moduleName :: Module -> String -moduleName { exports: { pursPkg } } = fromMaybe pursPkg $ Array.last $ Export.split pursPkg - -importModule :: Module -> PsImport -importModule mod = - { mod: mod.exports.pursPkg - , typ: Nothing - , alias: Just $ moduleName mod - } - -splitType :: String -> Maybe Extern -splitType s = do - i <- String.lastIndexOf (Pattern ".") s - let - prefix = String.take i s - let - t = String.drop (i + 1) s - pure $ { prefix, t } - -typeDecl :: TypeDecl -> Codegen Box -typeDecl (TypeDecl name tt annots) = - let - dec kw = text kw <<+>> text name <<+>> char '=' - in - case tt of - Type t -> do - ty <- tyType t - j <- jsonCodec t - pure $ (dec "type" <<+>> ty) - // defJsonCodec name j - Wrap t -> case getWrapOpts "purs" annots of - Nothing -> do - other <- otherInstances name - ty <- tyType t - j <- newtypeJsonCodec name t - newtype_ <- newtypeInstances name - pure - $ dec "newtype" - <<+>> text name - <<+>> ty - // newtype_ - // other - // defJsonCodec name j - Just { typ, decode, encode } -> do - ty <- externalRef typ - j <- externalJsonCodec name t decode encode - pure - $ dec "type" - <<+>> ty - // defJsonCodec name j - Record props -> do - recordDecl <- record props <#> \p -> dec "type" // indented p - codec <- recordJsonCodec props - pure - $ recordDecl - // defJsonCodec name codec - Sum vs -> do - other <- otherInstances name - codec <- sumJsonCodec name vs - pure - $ dec "data" - // indented (hsep 1 Boxes.bottom $ vcat Boxes.left <$> [ Array.drop 1 vs <#> \_ -> char '|', vs <#> text ]) - // other - // defJsonCodec name codec - -sumJsonCodec :: String -> Array String -> Codegen Box -sumJsonCodec name vs = do - tell - [ { mod: "Data.Either", typ: Just "Either(..)", alias: Nothing } - ] - let - encode = - text "encode: case _ of" - // indented (branches encodeBranch) - - decode = - text "decode: case _ of" - // indented (branches decodeBranch // fallthrough) - emitRuntime $ text "R.composeCodec" - // indented (delimitedLiteral Vert '{' '}' [ decode, encode ] // text "R.jsonCodec_string") - where - branches branch = vcat Boxes.left (vs <#> branch) - - encodeBranch v = text v <<+>> text "->" <<+>> text (show v) - - decodeBranch v = text (show v) <<+>> text "-> Right" <<+>> text v - - fallthrough = text $ "s -> Left $ \"Invalid value \" <> show s <> \" for " <> name <> "\"" - -newtypeInstances :: String -> Codegen Box -newtypeInstances name = do - tell - [ { mod: "Data.Newtype", typ: Just "class Newtype", alias: Nothing } - , { mod: "Data.Argonaut.Decode", typ: Just "class DecodeJson", alias: Nothing } - , { mod: "Data.Argonaut.Encode", typ: Just "class EncodeJson", alias: Nothing } - ] - pure - $ text ("derive instance newtype" <> name <> " :: Newtype " <> name <> " _") - // text ("instance encodeJson" <> name <> " :: EncodeJson " <> name <> " where ") - // indented (text $ "encodeJson a = jsonCodec_" <> name <> ".encode a") - // text ("instance decodeJson" <> name <> " :: DecodeJson " <> name <> " where ") - // indented (text $ "decodeJson a = jsonCodec_" <> name <> ".decode a") - -otherInstances :: String -> Codegen Box -otherInstances name = do - tell - [ { mod: "Prelude", typ: Nothing, alias: Nothing } - , { mod: "Data.Generic.Rep", typ: Just "class Generic", alias: Nothing } - , { mod: "Data.Generic.Rep.Show", typ: Just "genericShow", alias: Nothing } - ] - pure - $ text ("derive instance eq" <> name <> " :: Eq " <> name) - // text ("derive instance ord" <> name <> " :: Ord " <> name) - // text ("derive instance generic" <> name <> " :: Generic " <> name <> " _") - // text ("instance show" <> name <> " :: Show " <> name <> " where") - // indented (text "show a = genericShow a") - -tyType :: Type -> Codegen Box -tyType = - let - wrap tycon t = tyType t <#> \ty -> text tycon <<+>> parens ty - in - case _ of - Primitive p -> primitive p - Ref _ { mod, typ } -> internalRef mod typ - Array t -> wrap "Array" t - Option t -> tell (pure { mod: "Data.Maybe", typ: Just "Maybe", alias: Nothing }) >>= const (wrap "Maybe" t) - -internalRef :: Maybe ModuleName -> String -> Codegen Box -internalRef modName typ = do - allMods <- asks _.allModules - mod <- forM modName askModule - path <- for mod \m -> modulePrefix m <#> flip moduleRef m - pure $ text $ maybe typ (flip qualify typ) path - -qualify :: Array String -> String -> String -qualify path = intercalate "." <<< Array.snoc path - -packageAnnotation :: Module -> Maybe String -packageAnnotation = Annotations.field "purs" "modulePrefix" <<< _.annots - -modulePrefix :: Module -> Codegen (Maybe String) -modulePrefix mod = do - { defaultPrefix } <- ask - pure $ packageAnnotation mod <|> defaultPrefix - -moduleRef :: Maybe String -> Module -> Array String -moduleRef prefix mod = Array.fromFoldable prefix `Array.snoc` (moduleName mod) - -externalRef :: String -> Codegen Box -externalRef s = fromMaybe (text s # pure) (splitType s <#> externalType) - -emitRuntime :: Box -> Codegen Box -emitRuntime b = emit { mod: "Ccap.Codegen.Runtime", typ: Nothing, alias: Just "R" } b - -newtypeJsonCodec :: String -> Type -> Codegen Box -newtypeJsonCodec name t = do - i <- jsonCodec t - emitRuntime $ text "R.codec_newtype" <<+>> parens i - -externalJsonCodec :: String -> Type -> String -> String -> Codegen Box -externalJsonCodec name t decode encode = do - i <- jsonCodec t - decode_ <- externalRef decode - encode_ <- externalRef encode - emitRuntime $ text "R.codec_custom" <<+>> decode_ <<+>> encode_ <<+>> parens i - -codecName :: Maybe String -> String -> String -codecName mod t = qualify (Array.fromFoldable mod) $ "jsonCodec_" <> t - -jsonCodec :: Type -> Codegen Box -jsonCodec ty = case ty of - Primitive p -> - pure - ( text - $ codecName (Just "R") - ( case p of - PBoolean -> "boolean" - PInt -> "int" - PDecimal -> "decimal" - PString -> "string" - PStringValidationHack -> "string" - PJson -> "json" - ) - ) - Array t -> tycon "array" t - Option t -> tycon "maybe" t - Ref _ { mod, typ } -> internalRef mod ("jsonCodec_" <> typ) - where - tycon which t = do - ref <- jsonCodec t - pure $ text ("(" <> codecName (Just "R") which <> " ") <<>> ref <<>> text ")" - -parens :: Box -> Box -parens b = char '(' <<>> b <<>> char ')' - -defJsonCodec :: String -> Box -> Box -defJsonCodec name def = - let - cname = codecName Nothing name - in - text cname <<+>> text ":: R.JsonCodec" <<+>> text name - // (text cname <<+>> char '=') - // indented def - -record :: Array RecordProp -> Codegen Box -record props = do - tell [ { mod: "Data.Tuple", typ: Just "Tuple(..)", alias: Nothing } ] - types <- for props $ _.typ >>> tyType - let - labels = props <#> \{ name } -> text name <<+>> text "::" - pure $ delimitedLiteral Vert '{' '}' (Array.zip labels types <#> \(Tuple l t) -> l <<+>> t) - -recordJsonCodec :: Array RecordProp -> Codegen Box -recordJsonCodec props = do - tell - [ { mod: "Data.Argonaut.Core", typ: Nothing, alias: Just "A" } - , { mod: "Ccap.Codegen.Runtime", typ: Nothing, alias: Just "R" } - , { mod: "Foreign.Object", typ: Nothing, alias: Just "FO" } - , { mod: "Prelude", typ: Nothing, alias: Nothing } - ] - encodeProps <- recordWriteProps props - decodeProps <- recordReadProps props - let - encode = - text "encode: \\p -> A.fromObject $" - // indented - ( text "FO.fromFoldable" - // indented encodeProps - ) - - names = props <#> _.name >>> text - - decode = - text "decode: \\j -> do" - // indented - ( text "o <- R.obj j" - // decodeProps - // (text "pure" <<+>> delimitedLiteral Horiz '{' '}' names) - ) - pure $ delimitedLiteral Vert '{' '}' [ decode, encode ] - -recordWriteProps :: Array RecordProp -> Codegen Box -recordWriteProps props = do - types <- - for props \{ name, typ } -> do - x <- jsonCodec typ - pure $ text "Tuple" <<+>> text (show name) <<+>> parens (x <<>> text ".encode p." <<>> text name) - pure $ delimitedLiteral Vert '[' ']' types - -recordReadProps :: Array RecordProp -> Codegen Box -recordReadProps props = do - lines <- - for props \{ name, typ } -> do - x <- jsonCodec typ - pure $ text name <<+>> text "<- R.decodeProperty" <<+>> text (show name) <<+>> x <<+>> text "o" - pure $ vcat Boxes.left lines diff --git a/src/Ccap/Codegen/Runtime.js b/src/Ccap/Codegen/Runtime.js new file mode 100644 index 0000000..8779f53 --- /dev/null +++ b/src/Ccap/Codegen/Runtime.js @@ -0,0 +1,88 @@ +/** @format */ + +exports.decodeArray_ = function(api) { + return function(decode) { + return function(ary) { + if (Object.prototype.toString.call(ary) === '[object Array]') { + const result = ary.slice(); + for (let i = 0; i < ary.length; i++) { + const e = decode(ary[i]); + if (api.isLeft(e)) { + return e; + } else { + result[i] = api.fromRight()(e); + } + } + return api.right(result); + } else { + return api.left('This value must be an array'); + } + }; + }; +}; + +exports.decodeString_ = function(api) { + return function(json) { + if (typeof json === 'string') { + return api.right(json); + } else { + return api.left('This value must be a string'); + } + }; +}; + +exports.decodeBoolean_ = function(api) { + return function(json) { + if (typeof json === 'boolean') { + return api.right(json); + } else { + return api.left('This value must be a boolean'); + } + }; +}; + +exports.decodeNumber_ = function(api) { + return function(json) { + if (typeof json === 'number') { + return api.right(json); + } else { + return api.left('This value must be a number'); + } + }; +}; + +exports.decodeInt_ = function(api) { + return function(json) { + if (typeof json === 'number' && (json | 0) === json) { + return api.right(json); + } else { + return api.left('This value must be an integer'); + } + }; +}; + +exports.decodeObject_ = function(api) { + return function(json) { + if (typeof json === 'object' && !Array.isArray(json) && json !== null) { + return api.right(json); + } else { + return api.left('This value must be an object'); + } + }; +}; + +exports.lookup_ = function(api) { + return function(prop) { + return function(obj) { + if (prop in obj) { + return api.right(obj[prop]); + } else { + return api.left('Property ' + prop + ' does not exist'); + } + }; + }; +}; + +exports.isNull_ = function(json) { + return json === null; +}; diff --git a/src/Ccap/Codegen/Runtime.purs b/src/Ccap/Codegen/Runtime.purs index e740549..43d0b8c 100644 --- a/src/Ccap/Codegen/Runtime.purs +++ b/src/Ccap/Codegen/Runtime.purs @@ -1,4 +1,23 @@ -module Ccap.Codegen.Runtime where +module Ccap.Codegen.Runtime + ( Codec + , JsonCodec + , StandardDecoderApi + , codec_custom + , codec_newtype + , composeCodec + , decodeProperty + , jsonCodec_array + , jsonCodec_boolean + , jsonCodec_constructor + , jsonCodec_decimal + , jsonCodec_int + , jsonCodec_json + , jsonCodec_maybe + , jsonCodec_number + , jsonCodec_string + , obj + , standardDecoderApi + ) where import Prelude import Data.Argonaut.Core (Json) @@ -6,14 +25,15 @@ import Data.Argonaut.Core as Argonaut import Data.Bifunctor (lmap) import Data.Decimal (Decimal) import Data.Decimal as Decimal -import Data.Either (Either(..)) +import Data.Either (Either(..), note) +import Data.Either as Either import Data.Int as Int import Data.Maybe (Maybe(..), maybe) -import Data.Newtype (class Newtype, unwrap, wrap) -import Data.Traversable (traverse) +import Data.Newtype (class Newtype) +import Data.Tuple (Tuple(..)) import Foreign.Object (Object) -import Foreign.Object (Object) as FO -import Foreign.Object (lookup) as Object +import Foreign.Object as Object +import Unsafe.Coerce as Unsafe type Codec a b = { decode :: a -> Either String b @@ -29,43 +49,123 @@ jsonCodec_json = , encode: identity } +type Api + = { isLeft :: forall a b. Either a b -> Boolean + , fromRight :: forall a b. Partial => Either a b -> b + , right :: forall a b. b -> Either a b + , left :: forall a b. a -> Either a b + } + +type StandardDecoderApi + = { nothing :: forall a. Maybe a + , just :: forall a. a -> Maybe a + , isLeft :: forall a b. Either a b -> Boolean + , fromRight :: forall a b. Partial => Either a b -> b + , right :: forall a b. b -> Either a b + , left :: forall a b. a -> Either a b + , addErrorPrefix :: forall a. String -> Either String a -> Either String a + , jsonCodec_primitive_decimal :: JsonCodec Decimal + } + +standardDecoderApi :: StandardDecoderApi +standardDecoderApi = + { nothing: Nothing + , just: Just + , isLeft: Either.isLeft + , fromRight: Either.fromRight + , right: Right + , left: Left + , addErrorPrefix: \s -> lmap (s <> _) + , jsonCodec_primitive_decimal: jsonCodec_decimal + } + +api :: Api +api = + { isLeft: Either.isLeft + , fromRight: Either.fromRight + , right: Right + , left: Left + } + +foreign import decodeArray_ :: + forall a. + Api -> + (Json -> Either String a) -> + Json -> + Either String (Array a) + +foreign import decodeString_ :: + Api -> + Json -> + Either String String + +foreign import decodeBoolean_ :: + Api -> + Json -> + Either String Boolean + +foreign import decodeNumber_ :: + Api -> + Json -> + Either String Number + +foreign import decodeInt_ :: + Api -> + Json -> + Either String Int + +foreign import decodeObject_ :: + Api -> + Json -> + Either String (Object Json) + +foreign import lookup_ :: + Api -> + String -> + Object Json -> + Either String Json + +foreign import isNull_ :: + Json -> + Boolean + jsonCodec_string :: JsonCodec String jsonCodec_string = - { decode: maybe (Left "This value must be a string") Right <<< Argonaut.toString + { decode: decodeString_ api , encode: Argonaut.fromString } jsonCodec_decimal :: JsonCodec Decimal jsonCodec_decimal = - composeCodec - { decode: maybe (Left "This value must be a decimal") Right <<< Decimal.fromString - , encode: Decimal.toString - } - jsonCodec_string + { decode: + \j -> decodeString_ api j >>= (Decimal.fromString >>> note "This value must be a decimal") + , encode: Argonaut.fromString <<< Decimal.toString + } jsonCodec_number :: JsonCodec Number jsonCodec_number = - { decode: maybe (Left "This value must be a number") Right <<< Argonaut.toNumber + { decode: decodeNumber_ api , encode: Argonaut.fromNumber } jsonCodec_int :: JsonCodec Int jsonCodec_int = - composeCodec - { decode: maybe (Left "This value must be an integer") Right <<< Int.fromNumber - , encode: Int.toNumber - } - jsonCodec_number + { decode: decodeInt_ api + , encode: Argonaut.fromNumber <<< Int.toNumber + } jsonCodec_boolean :: JsonCodec Boolean jsonCodec_boolean = - { decode: maybe (Left "This value must be a boolean") Right <<< Argonaut.toBoolean + { decode: decodeBoolean_ api , encode: Argonaut.fromBoolean } +nothingResult :: forall a b. Either a (Maybe b) +nothingResult = Right Nothing + jsonCodec_maybe :: forall a. JsonCodec a -> JsonCodec (Maybe a) jsonCodec_maybe w = - { decode: \j -> if Argonaut.isNull j then Right Nothing else map Just (w.decode j) + { decode: \j -> if isNull_ j then nothingResult else map Just (w.decode j) , encode: \a -> maybe Argonaut.jsonNull w.encode a } @@ -74,17 +174,13 @@ jsonCodec_array :: JsonCodec a -> JsonCodec (Array a) jsonCodec_array inner = - { decode: maybe (Left "This value must be an array") (traverse inner.decode) <<< Argonaut.toArray - , encode: Argonaut.fromArray <<< (map inner.encode) + { decode: decodeArray_ api inner.decode + , encode: Argonaut.fromArray <<< map inner.encode } -decodeProperty :: forall a. String -> JsonCodec a -> FO.Object Json -> Either String a +decodeProperty :: forall a. String -> JsonCodec a -> Object Json -> Either String a decodeProperty prop codec o = do - v <- - maybe - (Left $ "Property " <> prop <> " does not exist") - Right - (Object.lookup prop o) + v <- lookup_ api prop o lmap (\s -> "Property " <> prop <> ": " <> s) (codec.decode v) composeCodec :: @@ -93,12 +189,12 @@ composeCodec :: Codec a b -> Codec a c composeCodec codec1 codec2 = - { decode: map (flip bind codec1.decode) codec2.decode + { decode: \j -> codec2.decode j >>= codec1.decode , encode: codec1.encode >>> codec2.encode } obj :: Json -> Either String (Object Json) -obj = maybe (Left "This value must be an object") Right <<< Argonaut.toObject +obj = decodeObject_ api codec_custom :: forall t a b. @@ -108,16 +204,27 @@ codec_custom :: Codec a t codec_custom decode encode = composeCodec { decode, encode } -decodeNewtype :: forall t a. Newtype t a => a -> Either String t -decodeNewtype a = Right $ wrap a - codec_newtype :: forall t a b. Newtype t b => Codec a b -> Codec a t -codec_newtype = - composeCodec - { decode: decodeNewtype - , encode: unwrap - } +codec_newtype = Unsafe.unsafeCoerce + +jsonCodec_constructor :: JsonCodec (Tuple String (Array Json)) +jsonCodec_constructor = + { encode: + \(Tuple name params) -> + Argonaut.fromObject + ( Object.fromFoldable + [ Tuple "c" (Argonaut.fromString name) + , Tuple "p" (Argonaut.fromArray params) + ] + ) + , decode: + \j -> do + o <- obj j + c <- decodeProperty "c" jsonCodec_string o + p <- decodeProperty "p" (jsonCodec_array jsonCodec_json) o + pure (Tuple c p) + } diff --git a/src/Ccap/Codegen/Scala.purs b/src/Ccap/Codegen/Scala.purs index d872cbd..ed66de3 100644 --- a/src/Ccap/Codegen/Scala.purs +++ b/src/Ccap/Codegen/Scala.purs @@ -4,26 +4,31 @@ module Ccap.Codegen.Scala import Prelude import Ccap.Codegen.Annotations as Annotations -import Ccap.Codegen.Env (Env, askModule, lookupTypeDecl) +import Ccap.Codegen.Ast as Ast +import Ccap.Codegen.Cst as Cst import Ccap.Codegen.Parser.Export as Export -import Ccap.Codegen.Shared (DelimitedLiteralDir(..), OutputSpec, delimitedLiteral, indented, modulesInScope) -import Ccap.Codegen.Types (Annotations, Exports, Module, ModuleName, Primitive(..), RecordProp, TRef, TopType(..), Type(..), TypeDecl(..), ValidatedModule, isRecord, typeDeclName, typeDeclTopType) -import Ccap.Codegen.Util (fromMaybeT, maybeT) -import Control.Alt (alt) -import Control.Monad.Maybe.Trans (MaybeT(..), runMaybeT) -import Control.Monad.Reader (Reader, ask, asks, runReader) +import Ccap.Codegen.Shared (DelimitedLiteralDir(..), OutputSpec, delimitedLiteral, indented) +import Control.Monad.Reader (Reader, asks, runReader) import Data.Array (foldl, (:)) import Data.Array as Array +import Data.Array.NonEmpty (NonEmptyArray) +import Data.Array.NonEmpty as NonEmptyArray import Data.Compactable (compact) -import Data.Foldable (intercalate) -import Data.Maybe (Maybe(..), fromMaybe, maybe) +import Data.Foldable (class Foldable, intercalate) +import Data.Maybe (Maybe(..), fromMaybe, maybe, maybe') import Data.Monoid (guard) import Data.String as String -import Data.Traversable (traverse) +import Data.Traversable (for, traverse) +import Data.TraversableWithIndex (forWithIndex) +import Data.Tuple (Tuple(..)) import Node.Path (FilePath) -import Text.PrettyPrint.Boxes (Box, char, emptyBox, hcat, nullBox, render, text, vcat, vsep, (//), (<<+>>), (<<>>)) +import Text.PrettyPrint.Boxes (Box, char, emptyBox, hcat, nullBox, punctuateH, render, text, vcat, vsep, (//), (<<+>>), (<<>>)) import Text.PrettyPrint.Boxes (left, top) as Boxes +type Env + = { currentModule :: Ast.Module + } + type Codegen = Reader Env @@ -32,35 +37,30 @@ runCodegen = flip runReader outputSpec :: OutputSpec outputSpec = - { render: render <<< oneModule + { render: Just <<< render <<< oneModule , filePath: modulePath } -modulePath :: ValidatedModule -> FilePath -modulePath mod = (Export.toPath mod.exports.scalaPkg) <> ".scala" +modulePath :: Ast.Module -> FilePath +modulePath (Ast.Module mod) = Export.toPath mod.exports.scalaPkg <> ".scala" -oneModule :: ValidatedModule -> Box -oneModule mod = do +oneModule :: Ast.Module -> Box +oneModule mod@(Ast.Module { types }) = do let modDecl = primaryClass mod env = - { defaultPrefix: Nothing - , currentModule: - mod - { imports = mod.imports <#> _.exports.scalaPkg - } - , allModules: modulesInScope mod + { currentModule: mod } body = runCodegen env do modDeclOutput <- traverse (typeDecl TopLevelCaseClass) modDecl - declsOutput <- traverse (typeDecl CompanionObject) mod.types + declsOutput <- traverse (typeDecl CompanionObject) types pure $ Array.fromFoldable modDeclOutput - <> [ text ("object " <> (objectName mod) <> " {") ] - <> (declsOutput <#> indented) + <> [ text ("object " <> objectName mod <> " {") ] + <> (NonEmptyArray.toArray declsOutput <#> indented) <> [ char '}' ] vsep 1 Boxes.left do [ text "// This file is automatically generated. Do not edit." @@ -69,22 +69,28 @@ oneModule mod = do ] <> body -objectName :: forall r. { exports :: Exports | r } -> String -objectName { exports: { scalaPkg } } = fromMaybe scalaPkg $ Array.last $ Export.split scalaPkg +typeParams :: Array Cst.TypeParam -> String +typeParams params = + if Array.null params then + "" + else + "[" <> intercalate ", " (map (\(Cst.TypeParam p) -> initialUpper p) params) <> "]" -classPackage :: forall r. { exports :: Exports | r } -> String -classPackage { exports: { scalaPkg } } = maybe scalaPkg Export.join $ Array.init $ Export.split scalaPkg +objectName :: Ast.Module -> String +objectName (Ast.Module { exports: { scalaPkg } }) = fromMaybe scalaPkg $ Array.last $ Export.split scalaPkg -curly :: Box -> Array Box -> Box -curly pref inner = vcat Boxes.left (pref <<+>> char '{' : (indented <$> inner) `Array.snoc` char '}') +classPackage :: Ast.Module -> String +classPackage (Ast.Module { exports: { scalaPkg } }) = maybe scalaPkg Export.join $ Array.init $ Export.split scalaPkg -paren :: Box -> Array Box -> Box -paren pref inner = vcat Boxes.left (pref <<>> char '(' : (indented <$> inner) `Array.snoc` char ')') +curly :: forall f. Foldable f => Functor f => Box -> f Box -> Box +curly pref inner = vcat Boxes.left (pref <<+>> char '{' : (Array.fromFoldable (indented <$> inner)) `Array.snoc` char '}') -paren_ :: Box -> Array Box -> Box -> Box -paren_ pref inner suffix = vcat Boxes.left (pref <<>> char '(' : (indented <$> inner) `Array.snoc` (char ')' <<>> suffix)) +paren :: forall f. Foldable f => Functor f => Box -> f Box -> Box +paren pref inner = vcat Boxes.left (pref <<>> char '(' : (Array.fromFoldable (indented <$> inner)) `Array.snoc` char ')') + +paren_ :: forall f. Foldable f => Functor f => Box -> f Box -> Box -> Box +paren_ pref inner suffix = vcat Boxes.left (pref <<>> char '(' : (Array.fromFoldable (indented <$> inner)) `Array.snoc` (char ')' <<>> suffix)) --- TODO: Clean up when we switch to a proper pretty printer. -- Like `paren`, but outputs on a sigle line. paren1 :: Box -> Array Box -> Box paren1 pref inner = hcat Boxes.top (pref <<>> char '(' : inner `Array.snoc` char ')') @@ -96,47 +102,57 @@ standardImports = , "scalaz.Monad" ] -imports :: ValidatedModule -> Box -imports mod = +imports :: Ast.Module -> Box +imports mod@(Ast.Module m) = let pkg = classPackage mod samePkg impt = classPackage impt == pkg - impts = _.exports.scalaPkg <$> Array.filter (not <<< samePkg) mod.imports + impts = (\(Ast.Module r) -> r.exports.scalaPkg) <$> Array.filter (not <<< samePkg) m.imports all = impts <> standardImports # Array.sort >>> Array.nub in vcat Boxes.left (all <#> \s -> text ("import " <> s)) -defEncoder :: Boolean -> String -> Box -> Box -defEncoder includeName name enc = +defEncoder :: Boolean -> String -> Array Cst.TypeParam -> Box -> Box +defEncoder includeName name pp enc = let includedName = if includeName then name else "" + + typeParamParameters :: String + typeParamParameters = + if Array.null pp then + "" + else + "(" + <> intercalate ", " + ( map (\(Cst.TypeParam p) -> "jsonEncoder_param_" <> initialUpper p <> ": Encoder[" <> initialUpper p <> ", argonaut.Json]") pp + ) + <> ")" in - text ("lazy val jsonEncoder" <> includedName <> ": Encoder[" <> name <> ", argonaut.Json] =") + text ("def jsonEncoder" <> includedName <> typeParams pp <> typeParamParameters <> ": Encoder[" <> name <> typeParams pp <> ", argonaut.Json] =") // indented enc -defDecoder :: Boolean -> String -> String -> Box -> Box +defDecoder :: Boolean -> String -> Ast.ScalaDecoderType -> Box -> Box defDecoder includeName name dType dec = let includedName = if includeName then name else "" in - text ("def jsonDecoder" <> includedName <> "[M[_]: Monad]: Decoder." <> dType <> "[M, " <> name <> "] =") + text ("def jsonDecoder" <> includedName <> typeParams ([ Cst.TypeParam "M[_]: Monad" ]) <> ": Decoder." <> decoderType dType <> "[M, " <> name <> "] =") // indented dec -wrapEncoder :: String -> Type -> Box -> Codegen Box -wrapEncoder name t enc = do +wrapEncoder :: String -> Array Cst.TypeParam -> Ast.Type -> Box -> Codegen Box +wrapEncoder name pp t enc = do e <- encoder t - pure $ defEncoder true name ((e <<>> text ".compose") `paren` [ enc ]) + pure $ defEncoder true name pp ((e <<>> text ".compose") `paren` [ enc ]) -wrapDecoder :: Annotations -> String -> Type -> Box -> Codegen Box -wrapDecoder annots name t dec = do - d <- decoderType t +wrapDecoder :: Array Cst.Annotation -> String -> Ast.ScalaDecoderType -> Ast.Type -> Box -> Codegen Box +wrapDecoder annots name dType t dec = do topDec <- decoder annots t let body = (topDec <<>> text ".disjunction.andThen") `paren` [ dec ] // text ".validation" - pure $ defDecoder true name d body + pure $ defDecoder true name dType body data TypeDeclOutputMode = TopLevelCaseClass @@ -144,27 +160,37 @@ data TypeDeclOutputMode derive instance eqTypeDeclOutputMode :: Eq TypeDeclOutputMode -typeDecl :: TypeDeclOutputMode -> TypeDecl -> Codegen Box -typeDecl outputMode (TypeDecl name tt an) = case tt of - Type t -> do - dTy <- decoderType t +noGenericParameters :: Box +noGenericParameters = text "// Scala decoders that involve parameterized types are not supported" + +typeDecl :: TypeDeclOutputMode -> Ast.TypeDecl -> Codegen Box +typeDecl outputMode (Ast.TypeDecl { name, topType: tt, annots: an, params: pp, scalaDecoderType }) = case tt of + Ast.Type t -> do ty <- typeDef outputMode t e <- encoder t - d <- decoder an t + d <- + maybe' + (\_ -> pure noGenericParameters) + (\dType -> map (defDecoder true name dType) (decoder an t)) + scalaDecoderType pure $ text "type" <<+>> text name + <<>> text (typeParams pp) <<+>> char '=' <<+>> ty - // defEncoder true name e - // defDecoder true name dTy d - Wrap t -> do + // defEncoder true name pp e + // d + Ast.Wrap t -> do case Annotations.getWrapOpts "scala" an of Nothing -> do - dTy <- decoderType t ty <- typeDef outputMode t e <- encoder t - d <- decoder an t + d <- + maybe' + (\_ -> pure noGenericParameters) + (\dType -> map (\b -> defDecoder true name dType (b <<>> text ".tagged")) (decoder an t)) + scalaDecoderType let tagname = text (name <> "T") @@ -178,12 +204,16 @@ typeDecl outputMode (TypeDecl name tt an) = case tt of <<>> text "] = scalaz.Tag.of[" <<>> tagname <<>> char ']' - , defEncoder true name (e <<>> text ".tagged") - , defDecoder true name dTy (d <<>> text ".tagged") + , defEncoder true name pp (e <<>> text ".tagged") + , d ] Just { typ, decode, encode } -> do - wrappedEncoder <- wrapEncoder name t (text encode) - wrappedDecoder <- wrapDecoder an name t (text decode <<>> text ".disjunction") + wrappedEncoder <- wrapEncoder name pp t (text encode) + wrappedDecoder <- + maybe' + (\_ -> pure noGenericParameters) + (\dType -> wrapDecoder an name dType t (text decode <<>> text ".disjunction")) + scalaDecoderType pure $ text "type" <<+>> text name @@ -191,24 +221,32 @@ typeDecl outputMode (TypeDecl name tt an) = case tt of <<+>> text typ // wrappedEncoder // wrappedDecoder - Record props -> do + Ast.Record props -> do mod <- asks _.currentModule recordFieldTypes <- traverse (recordFieldType outputMode) props recordFieldEncoders <- traverse recordFieldEncoder props let - cls = (text "final case class" <<+>> text name) `paren` recordFieldTypes - - enc = defEncoder (mod.name /= name) name (text "x => argonaut.Json.obj" `paren` recordFieldEncoders) - decBody <- case Array.length props of - 1 -> maybe (pure (emptyBox 0 0)) (singletonRecordDecoder name) (Array.head props) - x - | x <= 12 -> smallRecordDecoder name props - x -> largeRecordDecoder name props - let - dec = defDecoder (mod.name /= name) name "Form" decBody + modName = objectName mod + cls = (text "final case class" <<+>> text (name <> typeParams pp)) `paren` recordFieldTypes + + enc = defEncoder (modName /= name) name pp (text "x => argonaut.Json.obj" `paren` recordFieldEncoders) + dec <- + maybe' + (\_ -> pure noGenericParameters) + ( \dType -> + map (defDecoder (modName /= name) name dType) + ( case NonEmptyArray.length props of + 1 -> singletonRecordDecoder name (NonEmptyArray.head props) + x + | x <= 12 -> smallRecordDecoder name props + x -> largeRecordDecoder name props + ) + ) + scalaDecoderType + let fieldNamesTarget = - if mod.name == name then + if modName == name then Nothing else Just name @@ -216,63 +254,218 @@ typeDecl outputMode (TypeDecl name tt an) = case tt of names = fieldNames fieldNamesTarget (props <#> _.name) output - | mod.name == name && outputMode == TopLevelCaseClass = cls + | modName == name && outputMode == TopLevelCaseClass = cls output - | mod.name == name && outputMode == CompanionObject = enc // dec // names + | modName == name && outputMode == CompanionObject = enc // dec // names output | otherwise = cls // enc // dec // names pure output - Sum vs -> do - let - trait = (text "sealed trait" <<+>> text name) `curly` [ text "def tag: String" ] - - variants = - vs - <#> \v -> - text ("case object " <> v <> " extends " <> name) - `curly` - [ text ("override def tag: String = " <> show v) ] - - assocs = - vs - <#> \v -> - paren1 (emptyBox 0 0) [ text (show v), text ", ", text name <<>> char '.' <<>> text v ] <<>> char ',' - - params = text (show name) <<>> char ',' : assocs - enc <- wrapEncoder name (Primitive PString) (text "_.tag") - dec <- - wrapDecoder - an - name - (Primitive PString) - (((text ("Decoder.enum[M, " <> name) <<>> char ']') `paren` params) // text ".disjunction") - pure $ trait // ((text "object" <<+>> text name) `curly` variants) // enc // dec - -fieldNames :: Maybe String -> Array String -> Box + Ast.Sum constructors -> + maybe + ( do + let + trait = + if NonEmptyArray.length constructors > 1 then + text "sealed trait" <<+>> text (name <> typeParams pp) + else + text "" + cs <- + if NonEmptyArray.length constructors == 1 then + dataConstructor outputMode name pp false (NonEmptyArray.head constructors) + else do + ccc <- traverse (dataConstructor outputMode name pp true) constructors + pure (text ("object " <> name) `curly` ccc) + e <- sumTypeEncoder name pp constructors + d <- + maybe' + (\_ -> pure noGenericParameters) + (\dType -> map (defDecoder true name dType) (sumTypeDecoder name constructors)) + scalaDecoderType + pure + ( trait + // cs + // defEncoder true name pp e + // d + ) + ) + ( \vs -> do + let + trait = (text "sealed trait" <<+>> text name) `curly` [ text "def tag: String" ] + + variants = + vs + <#> \v -> + text ("case object " <> v <> " extends " <> name) + `curly` + [ text ("override def tag: String = " <> show v) ] + + assocs = + vs + <#> \v -> + paren1 (emptyBox 0 0) [ text (show v), text ", ", text name <<>> char '.' <<>> text v ] <<>> char ',' + + params = text (show name) <<>> char ',' NonEmptyArray.: assocs + enc <- wrapEncoder name pp (Ast.Primitive Cst.PString) (text "_.tag") + dec <- + wrapDecoder + an + name + Ast.Field + (Ast.Primitive Cst.PString) + (((text ("Decoder.enum[M, " <> name) <<>> char ']') `paren` params) // text ".disjunction") + pure $ trait // ((text "object" <<+>> text name) `curly` variants) // enc // dec + ) + (Ast.noArgConstructorNames constructors) + +sumTypeEncoder :: String -> Array Cst.TypeParam -> NonEmptyArray Ast.Constructor -> Codegen Box +sumTypeEncoder name pp constructors = do + let + withName :: String -> String + withName s = + if NonEmptyArray.length constructors == 1 then + s + else + name <> "." <> s + branches <- + for constructors case _ of + Ast.NoArg (Cst.ConstructorName n) -> + pure + ( if Array.null pp then + text ("case " <> withName n <> " => Encoder.constructor(" <> show n <> ", Nil)") + else + text ("case " <> withName n <> "() => Encoder.constructor(" <> show n <> ", Nil)") + ) + Ast.WithArgs (Cst.ConstructorName n) args -> do + parts <- + forWithIndex args \i c -> case c of + Ast.TParam (Cst.TypeParam p) -> pure (text ("jsonEncoder_param_" <> initialUpper p <> ".encode(param_" <> show i <> ")")) + Ast.TType t -> do + enc <- encoder t + pure (enc <<>> text (".encode(param_" <> show i <> ")")) + pure + ( text + ( "case " + <> withName n + <> "(" + <> intercalate ", " (map (\r -> "param_" <> show r) (Array.range 0 (NonEmptyArray.length args - 1))) + <> ") => Encoder.constructor(" + <> show n + <> ", List(" + ) + <<>> punctuateH Boxes.top (text ", ") parts + <<>> text "))" + ) + pure + ( text "_ match " `curly` branches + ) + +sumTypeDecoder :: String -> NonEmptyArray Ast.Constructor -> Codegen Box +sumTypeDecoder name constructors = do + let + withName :: String -> String + withName s = + if NonEmptyArray.length constructors == 1 then + s + else + name <> "." <> s + + curly0 :: Box -> Array Box -> Box + curly0 pref inner = vcat Boxes.left (pref <<+>> char '{' : (indented <$> inner) `Array.snoc` text "}.validation") + branches <- + for constructors case _ of + Ast.NoArg (Cst.ConstructorName n) -> pure (text ("case (" <> show n <> ", Nil) => Decoder.construct0(" <> withName n <> ")")) + Ast.WithArgs (Cst.ConstructorName n) args -> do + parts <- + forWithIndex args \i c -> case c of + Ast.TParam (Cst.TypeParam p) -> pure (text "(not implemented)") + Ast.TType t -> do + dec <- decoder [] t + pure (dec <<>> text (".param(" <> show i <> ", param_" <> show i <> ")")) + let + all = + indented + ( text ("Decoder.construct" <> show (NonEmptyArray.length args) <> "(") + // indented (punctuateH Boxes.top (text ", ") (text (show n) NonEmptyArray.: parts)) + // text (")(" <> withName n <> ".apply" <> ")") + ) + pure + ( text + ( "case (" + <> show n + <> ", List(" + <> intercalate ", " (map (\r -> "param_" <> show r) (Array.range 0 (NonEmptyArray.length args - 1))) + <> ")) => " + ) + // all + ) + let + -- XXX Awful, but there doesn't seem to be a better option besides a big boom + failureBranch = text ("case (n, l) => sys.error(s\"Match error on type " <> name <> " for constructor $n with ${l.length} parameters\")") + + func = + text "val d: Decoder.Form[M, Blarg] =" + // indented (text "p match" `curly` (branches `NonEmptyArray.snoc` failureBranch)) + // text "d.disjunction" + pure + ( text "Decoder.constructor.disjunction.flatMap { p =>" + // indented func + // text "}.validation" + ) + +dataConstructor :: TypeDeclOutputMode -> String -> Array Cst.TypeParam -> Boolean -> Ast.Constructor -> Codegen Box +dataConstructor outputMode name pp includeExtends = case _ of + Ast.NoArg (Cst.ConstructorName n) -> + pure + ( if Array.null pp then + text ("case object " <> n <> " extends " <> name) + else + text ("final case class " <> n <> typeParams pp <> "() extends " <> name <> typeParams pp) + ) + Ast.WithArgs (Cst.ConstructorName n) args -> do + params <- + forWithIndex args \i c -> do + ty <- case c of + Ast.TParam (Cst.TypeParam p) -> pure (text (initialUpper p)) + Ast.TType ttt -> typeDef outputMode ttt + pure (text ("param_" <> show i <> ": ") <<>> ty) + pure + ( text + ( "final case class " + <> n + <> typeParams pp + <> "(" + ) + <<>> punctuateH Boxes.top (text ", ") params + <<>> text ")" + <<>> if includeExtends then text (" extends " <> name <> typeParams pp) else text "" + ) + +fieldNames :: Maybe String -> NonEmptyArray String -> Box fieldNames mod names = maybe body (\m -> curly (text "object" <<+>> text m) [ body ]) mod where body = curly (text "object" <<+>> text "FieldNames") (names <#> fieldNameConst) - fieldNameConst s = text "val" <<+>> text (valName s) <<>> text ": String" <<+>> text "=" <<+>> text (show s) + fieldNameConst s = text "val" <<+>> text (initialUpper s) <<>> text ": String" <<+>> text "=" <<+>> text (show s) - valName s = - let - { before, after } = String.splitAt 1 s - in - String.toUpper before <> after +initialUpper :: String -> String +initialUpper s = + let + { before, after } = String.splitAt 1 s + in + String.toUpper before <> after -primitive :: Primitive -> Box +primitive :: Cst.Primitive -> Box primitive = text <<< case _ of - PBoolean -> "Boolean" - PInt -> "Int" - PDecimal -> "BigDecimal" - PString -> "String" - PStringValidationHack -> "String" - PJson -> "argonaut.Json" + Cst.PBoolean -> "Boolean" + Cst.PInt -> "Int" + Cst.PDecimal -> "BigDecimal" + Cst.PString -> "String" + Cst.PStringValidationHack -> "String" + Cst.PJson -> "argonaut.Json" generic :: String -> Box -> Box generic typeName param = text typeName <<>> char '[' <<>> param <<>> char ']' @@ -283,97 +476,101 @@ list = generic "List" option :: Box -> Box option = generic "Option" -typeDef :: TypeDeclOutputMode -> Type -> Codegen Box +typeDef :: TypeDeclOutputMode -> Ast.Type -> Codegen Box typeDef mode = case _ of - Ref _ tRef -> typeRef mode tRef - Array t -> list <$> typeDef mode t - Option t -> option <$> typeDef mode t - Primitive p -> pure $ primitive p - -typeRef :: TypeDeclOutputMode -> TRef -> Codegen Box -typeRef mode { mod, typ: typeName } = do + Ast.Ref tRef -> typeRef mode tRef + Ast.Array (Ast.TType t) -> list <$> typeDef mode t + Ast.Array (Ast.TParam (Cst.TypeParam p)) -> pure (list (text (initialUpper p))) + Ast.Option (Ast.TType t) -> option <$> typeDef mode t + Ast.Option (Ast.TParam (Cst.TypeParam p)) -> pure (option (text (initialUpper p))) + Ast.Primitive p -> pure $ primitive p + +typeRef :: TypeDeclOutputMode -> Ast.TRef -> Codegen Box +typeRef mode { decl, typ: typeName, params } = do currentModule <- asks _.currentModule - fromMaybeT (internalTypeRef mode currentModule typeName) do - importedModuleName <- maybeT mod - importedModule <- MaybeT $ askModule importedModuleName - importedType <- maybeT $ lookupTypeDecl typeName importedModule - pure $ externalTypeRef importedModule importedType + refParams <- + for params case _ of + Ast.TParam (Cst.TypeParam p) -> pure (text (initialUpper p)) + Ast.TType t -> typeDef mode t + let + paramContent = + if Array.null params then + text "" + else + char '[' <<>> punctuateH Boxes.top (text ", ") refParams <<>> char ']' + pure (maybe (internalTypeRef mode currentModule typeName) externalTypeRef decl <<>> paramContent) -internalTypeRef :: TypeDeclOutputMode -> Module -> String -> Box +internalTypeRef :: TypeDeclOutputMode -> Ast.Module -> String -> Box internalTypeRef mode currentModule = case mode of TopLevelCaseClass -> text <<< prefix [ objectName currentModule ] CompanionObject -> text -externalTypeRef :: Module -> TypeDecl -> Box -externalTypeRef importedModule importedType = +externalTypeRef :: Tuple Ast.Module Ast.TypeDecl -> Box +externalTypeRef (Tuple importedModule importedType) = let scalaName = objectName importedModule - pkg = packageAnnotation importedModule - - path = Array.snoc (Array.fromFoldable pkg) scalaName - - typeName = typeDeclName importedType + typeName = Ast.typeDeclName importedType in text if needsQualifier scalaName importedType then - prefix path $ typeName + prefix [ scalaName ] typeName else typeName -primaryClass :: forall r. { name :: ModuleName, types :: Array TypeDecl | r } -> Maybe TypeDecl -primaryClass { name, types } = Array.find (isPrimaryClass name) types +primaryClass :: Ast.Module -> Maybe Ast.TypeDecl +primaryClass mod@(Ast.Module { types }) = Array.find (\(Ast.TypeDecl { isPrimary }) -> isPrimary) types -isPrimaryClass :: ModuleName -> TypeDecl -> Boolean -isPrimaryClass modName typeD = modName == typeDeclName typeD && (isRecord $ typeDeclTopType typeD) +isPrimaryClass :: String -> Ast.TypeDecl -> Boolean +isPrimaryClass modName typeD = modName == Ast.typeDeclName typeD && Ast.isRecord (Ast.typeDeclTopType typeD) -needsQualifier :: ModuleName -> TypeDecl -> Boolean +needsQualifier :: String -> Ast.TypeDecl -> Boolean needsQualifier modName = not <<< isPrimaryClass modName -packageAnnotation :: Module -> Maybe String -packageAnnotation = Annotations.field "scala" "package" <<< _.annots - prefix :: Array String -> String -> String prefix names = intercalate "." <<< Array.snoc names -encoder :: Type -> Codegen Box +encoder :: Ast.Type -> Codegen Box encoder = case _ of - Ref _ tRef -> text <$> jsonTypeRef "Encoder" tRef - Array t -> encoder t <#> jsonList - Option t -> encoder t <#> jsonOption - Primitive p -> pure $ text $ "Encoder" <> jsonPrimitive p - -decoder :: Annotations -> Type -> Codegen Box + Ast.Ref tRef@{ params } -> do + refParams <- + for params case _ of + Ast.TParam (Cst.TypeParam p) -> pure (text ("jsonEncoder_param_" <> initialUpper p)) + Ast.TType t -> encoder t + jsonTypeRef "Encoder" refParams tRef + Ast.Array (Ast.TType t) -> encoder t <#> jsonList + Ast.Array (Ast.TParam (Cst.TypeParam e)) -> pure (jsonList (text ("jsonEncoder_param_" <> initialUpper e))) + Ast.Option (Ast.TType t) -> encoder t <#> jsonOption + Ast.Option (Ast.TParam (Cst.TypeParam e)) -> pure (jsonOption (text ("jsonEncoder_param_" <> initialUpper e))) + Ast.Primitive p -> pure $ text $ "Encoder" <> jsonPrimitive p + +decoder :: Array Cst.Annotation -> Ast.Type -> Codegen Box decoder annots = case _ of - Ref _ tRef -> text <$> jsonTypeRef "Decoder" tRef - Array t -> decoder annots t <#> jsonList - Option t -> decoder annots t <#> jsonOption - Primitive p -> pure $ (text $ "Decoder" <> jsonPrimitive p) <<>> decoderValidations annots + Ast.Ref tRef -> jsonTypeRef "Decoder" [] tRef + Ast.Array (Ast.TType t) -> decoder annots t <#> jsonList + Ast.Array (Ast.TParam (Cst.TypeParam e)) -> pure (jsonList (text ("jsonDecoder_param_" <> initialUpper e))) + Ast.Option (Ast.TType t) -> decoder annots t <#> jsonOption + Ast.Option (Ast.TParam (Cst.TypeParam e)) -> pure (jsonOption (text ("jsonDecoder_param_" <> initialUpper e))) + Ast.Primitive p -> pure $ (text $ "Decoder" <> jsonPrimitive p) <<>> decoderValidations annots jsonRef :: String -> String -> String jsonRef which typ = "json" <> which <> typ -- should be blank if it is the primary class -jsonTypeRef :: String -> TRef -> Codegen String -jsonTypeRef which { mod, typ } = - let - externalJson = - runMaybeT do - modName <- maybeT mod - extMod <- MaybeT $ askModule modName - extTypeDecl <- maybeT $ lookupTypeDecl typ extMod - let - path = Array.snoc (Array.fromFoldable $ packageAnnotation extMod) modName - pure $ prefix path $ jsonRef which $ guard (needsQualifier modName extTypeDecl) typ - - internalJson = - runMaybeT do - thisMod <- MaybeT $ Just <$> asks _.currentModule - decl <- maybeT $ lookupTypeDecl typ thisMod - pure $ jsonRef which $ guard (needsQualifier thisMod.name decl) typ - - default = jsonRef which typ - in - alt <$> internalJson <*> externalJson <#> fromMaybe default +jsonTypeRef :: String -> Array Box -> Ast.TRef -> Codegen Box +jsonTypeRef which params { decl, typ, isPrimaryRef } = do + thisMod <- asks _.currentModule + pure + ( text + ( maybe + (jsonRef which (guard (not isPrimaryRef) typ)) + (\(Tuple m _) -> prefix [ objectName m ] (jsonRef which (guard (not isPrimaryRef) typ))) + decl + ) + <<>> if Array.null params then + text "" + else + char '(' <<>> punctuateH Boxes.top (text ", ") params <<>> char ')' + ) jsonList :: Box -> Box jsonList json = json <<>> text ".list" @@ -381,16 +578,16 @@ jsonList json = json <<>> text ".list" jsonOption :: Box -> Box jsonOption json = json <<>> text ".option" -jsonPrimitive :: Primitive -> String +jsonPrimitive :: Cst.Primitive -> String jsonPrimitive = case _ of - PBoolean -> ".boolean" - PInt -> ".int" - PDecimal -> ".decimal" - PString -> ".string" - PStringValidationHack -> ".stringValidationHack" - PJson -> ".json" - -decoderValidations :: Annotations -> Box + Cst.PBoolean -> ".boolean" + Cst.PInt -> ".int" + Cst.PDecimal -> ".decimal" + Cst.PString -> ".string" + Cst.PStringValidationHack -> ".stringValidationHack" + Cst.PJson -> ".json" + +decoderValidations :: Array Cst.Annotation -> Box decoderValidations annots = foldl (<<>>) nullBox validations where validations = @@ -413,69 +610,62 @@ maxSizeValidation max = text $ ".maxSize(" <> max <> ")" positiveValidation :: Unit -> Box positiveValidation _ = text $ ".positive" -decoderType :: Type -> Codegen String -decoderType ty = case ty of - Ref _ { mod, typ } -> do - { currentModule, allModules } <- ask - let - external = mod >>= (\m -> Array.find (\n -> n.name == m) allModules) - - myMod = fromMaybe currentModule external - - tt = - Array.find (\(TypeDecl n _ _) -> n == typ) myMod.types - <#> (\(TypeDecl _ t _) -> t) - maybe (pure "MISSING") decoderTopType tt - Array t -> decoderType t - Option t -> decoderType t - Primitive _ -> pure "Field" - -decoderTopType :: TopType -> Codegen String -decoderTopType = case _ of - Type ty -> decoderType ty - Wrap ty -> decoderType ty - Record _ -> pure "Form" - Sum _ -> pure "Field" - -encodeType :: Type -> Box -> Codegen Box +decoderType :: Ast.ScalaDecoderType -> String +decoderType = case _ of + Ast.Field -> "Field" + Ast.Form -> "Form" + +encodeType :: Ast.Type -> Box -> Codegen Box encodeType t e = encoder t <#> (_ <<>> text ".encode" `paren1` [ e ]) -recordFieldType :: TypeDeclOutputMode -> RecordProp -> Codegen Box +encodeTypeParam :: Cst.TypeParam -> Box -> Box +encodeTypeParam (Cst.TypeParam t) e = text ("jsonEncoder_param_" <> initialUpper t <> ".encode(") <<>> e <<>> char ')' + +recordFieldType :: TypeDeclOutputMode -> Ast.RecordProp -> Codegen Box recordFieldType mode { name, typ } = do - ty <- typeDef mode typ + ty <- case typ of + Ast.TType t -> typeDef mode t + Ast.TParam (Cst.TypeParam c) -> pure (text (initialUpper c)) pure $ text name <<>> char ':' <<+>> ty <<>> char ',' -recordFieldEncoder :: RecordProp -> Codegen Box +recordFieldEncoder :: Ast.RecordProp -> Codegen Box recordFieldEncoder { name, typ } = do - ty <- encodeType typ (text ("x." <> name)) + ty <- case typ of + Ast.TType t -> encodeType t (text ("x." <> name)) + Ast.TParam t -> pure (encodeTypeParam t (text ("x." <> name))) pure $ text (show name <> " ->") <<+>> ty <<>> char ',' -recordFieldDecoder :: RecordProp -> Codegen Box -recordFieldDecoder { name, typ, annots } = decoder annots typ <#> (_ <<>> recordFieldProperty name) +recordFieldDecoder :: Ast.RecordProp -> Codegen Box +recordFieldDecoder { name, typ, annots } = case typ of + Ast.TType t -> decoder annots t <#> (_ <<>> recordFieldProperty name) + Ast.TParam _ -> pure (text "(not implemented)") recordFieldProperty :: String -> Box recordFieldProperty name = text ".property(" <<>> text (show name) <<>> char ')' -singletonRecordDecoder :: String -> RecordProp -> Codegen Box +singletonRecordDecoder :: String -> Ast.RecordProp -> Codegen Box singletonRecordDecoder name prop = recordFieldDecoder prop <#> (_ <<>> text (".map(" <> name <> ".apply)")) -smallRecordDecoder :: String -> Array RecordProp -> Codegen Box +smallRecordDecoder :: String -> NonEmptyArray Ast.RecordProp -> Codegen Box smallRecordDecoder name props = do ps <- traverse (\r -> recordFieldDecoder r <#> (_ <<>> char ',')) props pure $ paren_ - (text ("scalaz.Apply[Decoder.Form[M, *]].apply" <> show (Array.length props))) + (text ("scalaz.Apply[Decoder.Form[M, *]].apply" <> show (NonEmptyArray.length props))) ps (text ("(" <> name <> ".apply)")) -- | tree type for bulding scalaz Apply statements data TupleApplyStatement - = Final (Array RecordProp) + = Final (Array Ast.RecordProp) | Intermediate (Array TupleApplyStatement) -largeRecordDecoder :: String -> Array RecordProp -> Codegen Box -largeRecordDecoder name props = buildApplyStatement tupleStatements +largeRecordDecoder :: String -> NonEmptyArray Ast.RecordProp -> Codegen Box +largeRecordDecoder name nelProps = buildApplyStatement tupleStatements where + -- XXX A compromise considering the late hour + props = NonEmptyArray.toArray nelProps + -- | collects all the props into a tree that can be parsed into scalaz.Apply statements tupleStatements :: Array TupleApplyStatement tupleStatements = go (Final <$> chunksOf 5 props) diff --git a/src/Ccap/Codegen/Shared.purs b/src/Ccap/Codegen/Shared.purs index 633968f..44b7cb1 100644 --- a/src/Ccap/Codegen/Shared.purs +++ b/src/Ccap/Codegen/Shared.purs @@ -1,23 +1,25 @@ module Ccap.Codegen.Shared ( DelimitedLiteralDir(..) + , FastPathDecoderType(..) , OutputSpec , delimitedLiteral + , fastPathDecoderType , indented - , invalidate - , modulesInScope ) where import Prelude -import Ccap.Codegen.Types (Module, ValidatedModule) -import Data.Array ((:)) +import Ccap.Codegen.Annotations as Annotations +import Ccap.Codegen.Ast as Ast +import Ccap.Codegen.Cst as Cst import Data.Array as Array -import Record (merge) +import Data.Maybe (Maybe(..), isNothing) +import Data.Tuple (Tuple(..)) import Text.PrettyPrint.Boxes (Box, char, emptyBox, hcat, vcat, (<<+>>), (<<>>)) import Text.PrettyPrint.Boxes (left, top) as Boxes type OutputSpec - = { render :: ValidatedModule -> String - , filePath :: ValidatedModule -> String + = { render :: Ast.Module -> Maybe String + , filePath :: Ast.Module -> String } indent :: Box @@ -26,12 +28,6 @@ indent = emptyBox 0 2 indented :: Box -> Box indented = (<<>>) indent -invalidate :: ValidatedModule -> Module -invalidate vmod = merge { imports: (vmod.imports <#> _.name) } vmod - -modulesInScope :: ValidatedModule -> Array Module -modulesInScope vmod = invalidate vmod : vmod.imports - data DelimitedLiteralDir = Vert | Horiz @@ -51,3 +47,49 @@ delimitedLiteral dir l r boxes = case dir of Vert -> vcat Boxes.left (all <> [ char r ]) Horiz -> hcat Boxes.top (all <> [ char ' ' <<>> char r ]) + +data FastPathDecoderType + = FBoolean + | FInt + | FDecimal + | FString + | FJson + | FOptionBoolean + | FOptionInt + | FOptionDecimal + | FOptionString + | FOptionJson + +fastPathDecoderType :: Ast.Type -> Maybe FastPathDecoderType +fastPathDecoderType = case _ of + Ast.Primitive p -> Just (cstPrimitiveToDecoderType p) + Ast.Ref { decl: Just (Tuple _ (Ast.TypeDecl { topType: Ast.Wrap tt, annots })) } + | isNothing (Annotations.getWrapOpts "purs" annots) -> fastPathDecoderType tt + Ast.Option (Ast.TType (Ast.Primitive p)) -> Just (cstPrimitiveToOptionDecoderType p) + Ast.Option (Ast.TType (Ast.Ref { decl: Just (Tuple _ (Ast.TypeDecl { topType: Ast.Wrap tt, annots: annots })) })) + | isNothing (Annotations.getWrapOpts "purs" annots) -> case fastPathDecoderType tt of + Just FBoolean -> Just FOptionBoolean + Just FInt -> Just FOptionInt + Just FDecimal -> Just FOptionDecimal + Just FString -> Just FOptionString + Just FJson -> Just FOptionJson + _ -> Nothing + _ -> Nothing + where + cstPrimitiveToDecoderType :: Cst.Primitive -> FastPathDecoderType + cstPrimitiveToDecoderType = case _ of + Cst.PBoolean -> FBoolean + Cst.PInt -> FInt + Cst.PDecimal -> FDecimal + Cst.PString -> FString + Cst.PStringValidationHack -> FString + Cst.PJson -> FJson + + cstPrimitiveToOptionDecoderType :: Cst.Primitive -> FastPathDecoderType + cstPrimitiveToOptionDecoderType = case _ of + Cst.PBoolean -> FOptionBoolean + Cst.PInt -> FOptionInt + Cst.PDecimal -> FOptionDecimal + Cst.PString -> FOptionString + Cst.PStringValidationHack -> FOptionString + Cst.PJson -> FOptionJson diff --git a/src/Ccap/Codegen/TypeRef.purs b/src/Ccap/Codegen/TypeRef.purs deleted file mode 100644 index 4ba3645..0000000 --- a/src/Ccap/Codegen/TypeRef.purs +++ /dev/null @@ -1,124 +0,0 @@ -module Ccap.Codegen.TypeRef - ( TypeRefError - , topTypeReferences - , validateAllTypeRefs - ) where - -import Prelude -import Ccap.Codegen.Types (Import, Module, ModuleName, TRef, TopType(..), Type(..), TypeDecl, typeDeclTopType, typeDeclName) -import Ccap.Codegen.ValidationError (class ValidationError, toValidation) -import Data.Array ((:)) -import Data.Array as Array -import Data.Either (Either(..), note) -import Data.Foldable (intercalate) -import Data.List (List(..)) -import Data.List as List -import Data.List.NonEmpty (NonEmptyList) -import Data.List.NonEmpty as NonEmptyList -import Data.Maybe (Maybe(..)) -import Data.Tuple (Tuple(..), fst, snd) - -type TypeName - = String - -type QTRef - = { moduleName :: ModuleName - , typeName :: TypeName - } - -data TypeRef - = Qualified QTRef - | Unqualified TypeName - -data TypeRefError - = QualifiedNotDefined Module QTRef - | QualifiedNotImported Module QTRef - | UnqualifiedNotDefined Module TypeName - | UnqualifiedMultipleDefinitions Module TypeName (NonEmptyList Import) - -instance typeRefValidationError :: ValidationError TypeRefError where - printError = case _ of - QualifiedNotDefined mod { moduleName, typeName } -> mod.name <> ": qualified reference of " <> typeName <> " is not defined in " <> moduleName - QualifiedNotImported mod { moduleName, typeName } -> - mod.name <> ": does not import module " <> moduleName - <> " but uses it in qualified reference of " - <> typeName - UnqualifiedNotDefined mod typeName -> mod.name <> ": unqualified reference, " <> typeName <> ", is not defined." - UnqualifiedMultipleDefinitions mod typeName imports -> - mod.name <> ": unqualified reference, " <> typeName - <> ", defined multiple times: " - <> (intercalate ", " imports) - --- | Return all type references in a module -moduleTypeReferences :: Module -> Array TRef -moduleTypeReferences = _.types >=> typeDeclTopType >>> topTypeReferences - --- | Return all type references used in a Declared Type -topTypeReferences :: TopType -> Array TRef -topTypeReferences = case _ of - Type typ -> typeReferences typ - Wrap typ -> typeReferences typ - Record props -> props >>= _.typ >>> typeReferences - Sum variants -> mempty - --- | Return all type references in any used type. -typeReferences :: Type -> Array TRef -typeReferences = case _ of - Ref _ tRef -> pure tRef - Primitive _ -> mempty - Array typ -> typeReferences typ - Option typ -> typeReferences typ - --- | Interpert a TypeRef as either a Qualified or Unqualified type reference. -fromTRef :: TRef -> TypeRef -fromTRef = case _ of - { mod: Just moduleName, typ: typeName } -> Qualified { moduleName, typeName } - { mod: Nothing, typ: typeName } -> Unqualified typeName - --- | Find a type declaration in a module. -findDeclaration :: TypeName -> Module -> Maybe TypeDecl -findDeclaration typeName = Array.find (eq typeName <<< typeDeclName) <<< _.types - --- | Find a module by name -findModule :: ModuleName -> Array Module -> Maybe Module -findModule moduleName = Array.find $ eq moduleName <<< _.name - --- | Validate all type references in a module by finding their type declarations in the module and --- | it's imports. -validateAllTypeRefs :: Module -> Array Module -> Either (Array TypeRefError) (Array TypeDecl) -validateAllTypeRefs mod imports = moduleTypeReferences mod <#> fromTRef >>> validate # toValidation - where - validate typeRef = validateTypeRef typeRef mod imports - --- | Validate a type reference by finding its declaration. -validateTypeRef :: TypeRef -> Module -> Array Module -> Either TypeRefError TypeDecl -validateTypeRef = case _ of - Qualified qtRef -> validateQtRef qtRef - Unqualified typeName -> validateUnQRef typeName - --- | Validate a qualified reference against the imported modules. -validateQtRef :: QTRef -> Module -> Array Module -> Either TypeRefError TypeDecl -validateQtRef qtRef mod imports = do - importedModule <- - note (QualifiedNotImported mod qtRef) - $ findModule qtRef.moduleName imports - note (QualifiedNotDefined mod qtRef) - $ findDeclaration qtRef.typeName importedModule - --- | Validate a unqualified reference against the current module and all imported modules. -validateUnQRef :: TypeName -> Module -> Array Module -> Either TypeRefError TypeDecl -validateUnQRef typeName mod imports = - let - findDecl imprt = findDeclaration typeName imprt <#> Tuple imprt - - matches = List.fromFoldable $ Array.catMaybes $ findDecl <$> (mod : imports) - in - case matches of - Cons match maybeMore -> case NonEmptyList.fromList maybeMore of - Nothing -> Right $ snd match - Just moreMatches -> - let - multipleMatches = NonEmptyList.cons match moreMatches <#> fst >>> _.name - in - Left $ UnqualifiedMultipleDefinitions mod typeName multipleMatches - Nil -> Left $ UnqualifiedNotDefined mod typeName diff --git a/src/Ccap/Codegen/Types.purs b/src/Ccap/Codegen/Types.purs deleted file mode 100644 index 01af886..0000000 --- a/src/Ccap/Codegen/Types.purs +++ /dev/null @@ -1,163 +0,0 @@ -module Ccap.Codegen.Types - ( Annotation(..) - , Annotations - , AnnotationParam(..) - , Exports - , Import - , Module - , ModuleName - , Primitive(..) - , Type(..) - , TRef - , RecordProp(..) - , Source - , TopType(..) - , TypeDecl(..) - , ValidatedModule - , Variant - , isRecord - , typeDeclName - , typeDeclTopType - ) where - -import Data.Generic.Rep (class Generic) -import Data.Generic.Rep.Show (genericShow) -import Data.Maybe (Maybe) -import Node.Path (FilePath) -import Prelude (class Eq, class Show) -import Text.Parsing.Parser.Pos (Position) - -type Source a - = { source :: FilePath - , contents :: a - } - -type Module - = { name :: ModuleName - , types :: Array TypeDecl - , annots :: Annotations - , imports :: Array Import - , exports :: Exports - } - -type ValidatedModule - = { name :: ModuleName - , types :: Array TypeDecl - , annots :: Annotations - , imports :: Array Module - , exports :: Exports - } - -type ModuleName - = String - --- TODO: newtype Import (to distinguish between the import statement and the actual file) -type Import - = String - ---| package names for generating imports from a tmpl file -type Exports - = { scalaPkg :: String - , pursPkg :: String - , tmplPath :: String -- What is the purpose of this? - } - -data TypeDecl - = TypeDecl String TopType Annotations - -type Annotations - = Array Annotation -- TODO: Consider using a Map? - -data Annotation - = Annotation String Position (Array AnnotationParam) - -data AnnotationParam - = AnnotationParam String Position (Maybe String) - -data TopType - = Type Type - | Wrap Type - | Record (Array RecordProp) - | Sum (Array Variant) - -isRecord :: TopType -> Boolean -isRecord (Record _) = true - -isRecord _ = false - -data Type - = Primitive Primitive - | Ref Position TRef - | Array Type - | Option Type - -type TRef - = { mod :: Maybe ModuleName, typ :: String } - -type RecordProp - = { name :: String - , typ :: Type - , annots :: Annotations - } - -type Variant - = String - -data Primitive - = PBoolean - | PInt - | PDecimal - | PString - | PStringValidationHack - | PJson - --- Instances here to avoid cluttering the above -derive instance eqType :: Eq Type - -derive instance genericType :: Generic Type _ - -instance showType :: Show Type where - show t = genericShow t - -derive instance eqTopType :: Eq TopType - -derive instance genericTopType :: Generic TopType _ - -instance showTopType :: Show TopType where - show = genericShow - -derive instance eqTypeDecl :: Eq TypeDecl - -derive instance genericTypeDecl :: Generic TypeDecl _ - -instance showTypeDecl :: Show TypeDecl where - show = genericShow - -derive instance eqAnnotation :: Eq Annotation - -derive instance genericAnnotation :: Generic Annotation _ - -instance showAnnotation :: Show Annotation where - show = genericShow - -derive instance eqAnnotationParam :: Eq AnnotationParam - -derive instance genericAnnotationParam :: Generic AnnotationParam _ - -instance showAnnotationParam :: Show AnnotationParam where - show = genericShow - -derive instance eqPrimitive :: Eq Primitive - -derive instance genericPrimitive :: Generic Primitive _ - -instance showPrimitive :: Show Primitive where - show = genericShow - --- | Get the type name of a type declaration. -typeDeclName :: TypeDecl -> String -typeDeclName (TypeDecl typeName _ _) = typeName - --- | Get the top most type of a type declaration. -typeDeclTopType :: TypeDecl -> TopType -typeDeclTopType (TypeDecl _ topType _) = topType diff --git a/src/Ccap/Codegen/Util.purs b/src/Ccap/Codegen/Util.purs index 7214295..ffb718b 100644 --- a/src/Ccap/Codegen/Util.purs +++ b/src/Ccap/Codegen/Util.purs @@ -3,10 +3,8 @@ module Ccap.Codegen.Util where import Prelude import Control.Monad.Error.Class (try) import Control.Monad.Except (ExceptT(..), runExceptT) -import Control.Monad.Maybe.Trans (MaybeT(..), runMaybeT) import Data.Bifunctor (lmap) import Data.Either (either) -import Data.Maybe (Maybe, fromMaybe) import Data.String.Regex (regex) import Data.String.Regex (replace) as Regex import Data.String.Regex.Flags (global, multiline) as Regex.Flags @@ -45,9 +43,3 @@ scrubEolSpaces i = --| Ensure newline ensureNewline :: String -> String ensureNewline s = if String.endsWith "\n" s then s else s <> "\n" - -maybeT :: forall f a. Applicative f => Maybe a -> MaybeT f a -maybeT = MaybeT <<< pure - -fromMaybeT :: forall f a. Functor f => a -> MaybeT f a -> f a -fromMaybeT a = map (fromMaybe a) <<< runMaybeT diff --git a/src/Ccap/Codegen/ValidationError.purs b/src/Ccap/Codegen/ValidationError.purs deleted file mode 100644 index b21db00..0000000 --- a/src/Ccap/Codegen/ValidationError.purs +++ /dev/null @@ -1,23 +0,0 @@ -module Ccap.Codegen.ValidationError - ( class ValidationError - , joinErrors - , printError - , toValidation - ) where - -import Prelude -import Data.Array as Array -import Data.Bifunctor (lmap) -import Data.Either (Either) -import Data.Foldable (class Foldable, intercalate) -import Data.Traversable (traverse) - -class ValidationError a where - printError :: a -> String - --- | Map over an array of checks and collect either all errors or all results -toValidation :: forall a b. Array (Either a b) -> Either (Array a) (Array b) -toValidation = traverse $ lmap Array.singleton - -joinErrors :: forall f a. Foldable f => Either (f String) a -> Either String a -joinErrors = lmap $ intercalate "\n" diff --git a/src/GetSchema.purs b/src/GetSchema.purs index 6da87f8..533f0dc 100644 --- a/src/GetSchema.purs +++ b/src/GetSchema.purs @@ -3,9 +3,9 @@ module GetSchema ) where import Prelude +import Ccap.Codegen.Cst as Cst import Ccap.Codegen.Database as Database import Ccap.Codegen.PrettyPrint as PrettyPrint -import Ccap.Codegen.Types (Module) import Ccap.Codegen.Util (liftEffectSafely, processResult, scrubEolSpaces) import Control.Monad.Except (ExceptT, except) import Data.Either (Either(..), note) @@ -70,7 +70,7 @@ app domains dbConfig tableParam scalaPkg pursPkg = portFromString = note "Database port must be an integer" <<< Int.fromString -dbModules :: Config -> ExceptT String Aff (Maybe Module) +dbModules :: Config -> ExceptT String Aff (Maybe Cst.Module) dbModules config = do pool <- liftEffect $ newPool config.poolConfig if config.domains then @@ -89,7 +89,7 @@ type Config prependNotice :: String -> String prependNotice = ("// This file is automatically generated from DB schema. Do not edit.\n" <> _) -writeModule :: Module -> ExceptT String Aff Unit +writeModule :: Cst.Module -> ExceptT String Aff Unit writeModule = liftEffectSafely <<< print where print = Console.info <<< prependNotice <<< scrubEolSpaces <<< PrettyPrint.prettyPrint diff --git a/src/Main.purs b/src/Main.purs index f24afb6..ed54a13 100644 --- a/src/Main.purs +++ b/src/Main.purs @@ -3,21 +3,27 @@ module Main ) where import Prelude +import Ccap.Codegen.Ast as Ast +import Ccap.Codegen.AstBuilder as AstBuilder import Ccap.Codegen.Config (Config, Mode(..), config) -import Ccap.Codegen.FileSystem (mkDirP, sourceFile) -import Ccap.Codegen.Module (validateModules) -import Ccap.Codegen.Parser (errorMessage, roundTrip) +import Ccap.Codegen.Cst as Cst +import Ccap.Codegen.Error as Error +import Ccap.Codegen.FileSystem (mkDirP) +import Ccap.Codegen.Parser as Parser import Ccap.Codegen.PrettyPrint as PrettyPrint -import Ccap.Codegen.Purescript as Purescript +import Ccap.Codegen.PureScript as PureScript +import Ccap.Codegen.PureScriptJs as PureScriptJs import Ccap.Codegen.Scala as Scala import Ccap.Codegen.Shared (OutputSpec) -import Ccap.Codegen.Types (ValidatedModule, Source) import Ccap.Codegen.Util (ensureNewline, liftEffectSafely, processResult, scrubEolSpaces) -import Ccap.Codegen.ValidationError (joinErrors, toValidation) -import Control.Monad.Except (ExceptT(..), except, runExcept) +import Control.Monad.Except (ExceptT(..), except, runExcept, runExceptT) +import Data.Array.NonEmpty (NonEmptyArray) +import Data.Array.NonEmpty as NonEmptyArray import Data.Bifunctor (lmap) import Data.Either (Either(..)) -import Data.Maybe (maybe) +import Data.Foldable (for_) +import Data.Maybe (fromMaybe, maybe) +import Data.String as String import Data.Traversable (traverse, traverse_) import Effect (Effect) import Effect.Aff (Aff, launchAff_) @@ -38,44 +44,70 @@ app eConfig fs = $ processResult do config <- except eConfig files <- except $ readFiles fs - sources <- ExceptT $ liftEffect $ traverse sourceFile files <#> toValidation >>> joinErrors - validated <- ExceptT $ liftEffect $ validateModules config.includes sources <#> joinErrors - traverse_ (writeModule config) validated + writeModules config files readFiles :: Array Foreign -> Either String (Array FilePath) readFiles = lmap show <<< runExcept <<< traverse readString -writeModule :: Config -> Source ValidatedModule -> ExceptT String Aff Unit -writeModule config { source: fileName, contents: mod } = case config.mode of - Pretty -> writeOutput config mod PrettyPrint.outputSpec - Purs -> writeOutput config mod Purescript.outputSpec - Scala -> writeOutput config mod Scala.outputSpec - Show -> Console.info $ show mod - Test -> - ifM (except $ lmap (errorMessage fileName) (roundTrip mod)) - (Console.info "Round-trip passed") - (except $ Left "Round-trip failed") +writeModules :: Config -> Array FilePath -> ExceptT String Aff Unit +writeModules config files = case config.mode of + Pretty -> do + modules <- convertBuilderResult (AstBuilder.parseAll files) + traverse_ (Console.info <<< scrubEolSpaces <<< PrettyPrint.prettyPrint <<< _.contents) modules + Purs -> do + modules <- convertBuilderResult (AstBuilder.build { files, importPaths: config.includes }) + traverse_ (writeOutput config PureScript.outputSpec) modules + PursJs -> do + modules <- convertBuilderResult (AstBuilder.build { files, importPaths: config.includes }) + traverse_ (writeOutput config PureScriptJs.outputSpec) modules + Scala -> do + modules <- convertBuilderResult (AstBuilder.build { files, importPaths: config.includes }) + traverse_ (writeOutput config Scala.outputSpec) modules + Show -> do + modules <- convertBuilderResult (AstBuilder.build { files, importPaths: config.includes }) + traverse_ (Console.info <<< show) modules + Test -> do + modules <- convertBuilderResult (AstBuilder.parseAll files) + for_ modules \mod -> + ifM (except (lmap Parser.errorMessage (Parser.roundTrip mod))) + (Console.info "Round-trip passed") + (except $ Left "Round-trip failed") -writeOutput :: Config -> ValidatedModule -> OutputSpec -> ExceptT String Aff Unit -writeOutput config mod outputSpec = do +convertBuilderResult :: ExceptT (NonEmptyArray Error.Error) Effect ~> ExceptT String Aff +convertBuilderResult e = ExceptT (liftEffect (map (lmap errorToOutputString) (runExceptT e))) + where + errorToOutputString :: NonEmptyArray Error.Error -> String + errorToOutputString es = + Error.toString (NonEmptyArray.head es) <> "\n" + <> String.joinWith "\n" (map (\ee -> "ERROR: " <> (Error.toString ee)) (NonEmptyArray.tail es)) + +writeOutput :: Config -> OutputSpec -> Cst.Source Ast.Module -> ExceptT String Aff Unit +writeOutput config outputSpec mod = do config.outputDirectory # maybe - (Console.info <<< scrubEolSpaces <<< outputSpec.render $ mod) + (Console.info <<< scrubEolSpaces <<< fromMaybe "" <<< outputSpec.render $ mod.contents) writeOutput_ where writeOutput_ :: String -> ExceptT String Aff Unit writeOutput_ dir = do let - filePath = [ dir, (outputSpec.filePath mod) ] + filePath = [ dir, (outputSpec.filePath mod.contents) ] outputFile = Path.concat filePath - Console.info $ "Writing " <> outputFile - mkDirP (Path.dirname outputFile) - liftEffectSafely - $ Sync.writeTextFile - UTF8 - outputFile - (ensureNewline <<< scrubEolSpaces <<< outputSpec.render $ mod) + + contents = outputSpec.render mod.contents + maybe + (Console.info ("Skipping " <> outputFile)) + ( \c -> do + Console.info $ "Writing " <> outputFile + mkDirP (Path.dirname outputFile) + liftEffectSafely + $ Sync.writeTextFile + UTF8 + outputFile + (ensureNewline <<< scrubEolSpaces $ c) + ) + contents main :: Effect Unit main = diff --git a/test/Ccap/Codegen/Annotations.purs b/test/Ccap/Codegen/Annotations.purs index 03cfc25..2832337 100644 --- a/test/Ccap/Codegen/Annotations.purs +++ b/test/Ccap/Codegen/Annotations.purs @@ -3,18 +3,19 @@ module Test.Ccap.Codegen.Annotations ) where import Prelude +import Ccap.Codegen.Cst as Cst import Ccap.Codegen.PrettyPrint (prettyPrint) -import Ccap.Codegen.Shared (invalidate) -import Ccap.Codegen.Types (Annotation(..), AnnotationParam(..), RecordProp, TopType(..), TypeDecl(..), typeDeclName) import Ccap.Codegen.Util (scrubEolSpaces) import Control.Monad.Except (except) +import Data.Array.NonEmpty (NonEmptyArray) +import Data.Array.NonEmpty as NonEmptyArray import Data.Either (Either) import Data.Foldable (find) import Data.Maybe (Maybe(..), fromMaybe, maybe) import Effect (Effect) import Effect.Aff (Aff) import Node.Path (FilePath) -import Test.Ccap.Codegen.Util (exceptAffT, parse, runOrFail, sourceTmpl, validateModule) +import Test.Ccap.Codegen.Util (exceptAffT, parse, runOrFail, sourceCstTmpl) import Test.Spec (Spec, describe, it) import Test.Spec.Assertions (shouldEqual) @@ -30,27 +31,27 @@ type Annot maxLen5 :: Annot maxLen5 = { name: "validations", params: [ { name: "maxLength", value: Just "5" } ] } -deposAnnot :: Annotation -> Annot -deposAnnot (Annotation name _ params) = { name, params: deposeAnnotParam <$> params } +deposAnnot :: Cst.Annotation -> Annot +deposAnnot (Cst.Annotation name _ params) = { name, params: deposeAnnotParam <$> params } -deposeAnnotParam :: AnnotationParam -> AnnotParam -deposeAnnotParam (AnnotationParam name _ value) = { name, value } +deposeAnnotParam :: Cst.AnnotationParam -> AnnotParam +deposeAnnotParam (Cst.AnnotationParam name _ value) = { name, value } -findTypeDecl :: String -> Array TypeDecl -> Maybe TypeDecl -findTypeDecl typeName = find $ eq typeName <<< typeDeclName +findTypeDecl :: String -> NonEmptyArray Cst.TypeDecl -> Maybe Cst.TypeDecl +findTypeDecl typeName = find $ eq typeName <<< Cst.typeDeclName -typeDeclAnnots :: TypeDecl -> Array Annot -typeDeclAnnots (TypeDecl _ _ annots) = annots <#> deposAnnot +typeDeclAnnots :: Cst.TypeDecl -> Array Annot +typeDeclAnnots (Cst.TypeDecl { annots }) = annots <#> deposAnnot -typeDeclRecordProps :: TypeDecl -> Array RecordProp -typeDeclRecordProps (TypeDecl _ (Record props) _) = props +typeDeclRecordProps :: Cst.TypeDecl -> Array Cst.RecordProp +typeDeclRecordProps = case _ of + Cst.TypeDecl { topType: Cst.Record props } -> NonEmptyArray.toArray props + _ -> [] -typeDeclRecordProps _ = [] - -findRecordProp :: String -> TypeDecl -> Maybe RecordProp +findRecordProp :: String -> Cst.TypeDecl -> Maybe Cst.RecordProp findRecordProp propName = find (eq propName <<< _.name) <<< typeDeclRecordProps -recordPropAnnots :: RecordProp -> Array Annot +recordPropAnnots :: Cst.RecordProp -> Array Annot recordPropAnnots { annots } = deposAnnot <$> annots specs :: Spec Unit @@ -81,17 +82,17 @@ specs = $ checkPrint tmplFile $ fieldShouldHaveAnnotation "Record" "nextLine" maxLen5 -readTypes :: FilePath -> Effect (Either String (Array TypeDecl)) -readTypes = map (map _.contents.types) <<< sourceTmpl +readTypes :: FilePath -> Effect (Either String (NonEmptyArray Cst.TypeDecl)) +readTypes = map (map _.contents.types) <<< sourceCstTmpl -typeShouldHaveAnnotation :: String -> Annot -> Array TypeDecl -> Aff Unit +typeShouldHaveAnnotation :: String -> Annot -> NonEmptyArray Cst.TypeDecl -> Aff Unit typeShouldHaveAnnotation typeName annot types = let annots = maybe [] typeDeclAnnots $ findTypeDecl typeName types in annots `shouldEqual` [ annot ] -fieldShouldHaveAnnotation :: String -> String -> Annot -> Array TypeDecl -> Aff Unit +fieldShouldHaveAnnotation :: String -> String -> Annot -> NonEmptyArray Cst.TypeDecl -> Aff Unit fieldShouldHaveAnnotation typeName propName annot types = let annots = @@ -102,7 +103,7 @@ fieldShouldHaveAnnotation typeName propName annot types = in annots `shouldEqual` [ annot ] -checkTypes :: (Array TypeDecl -> Aff Unit) -> Aff Unit +checkTypes :: (NonEmptyArray Cst.TypeDecl -> Aff Unit) -> Aff Unit checkTypes check = runOrFail $ check <$> (exceptAffT $ readTypes tmplFile) typeShouldHaveAnnotation_ :: String -> Annot -> Aff Unit @@ -111,12 +112,11 @@ typeShouldHaveAnnotation_ typeName annot = checkTypes $ typeShouldHaveAnnotation fieldShouldHaveAnnotation_ :: String -> String -> Annot -> Aff Unit fieldShouldHaveAnnotation_ typeName propName annot = checkTypes $ fieldShouldHaveAnnotation typeName propName annot -checkPrint :: FilePath -> (Array TypeDecl -> Aff Unit) -> Aff Unit +checkPrint :: FilePath -> (NonEmptyArray Cst.TypeDecl -> Aff Unit) -> Aff Unit checkPrint filePath check = runOrFail do - source <- exceptAffT $ sourceTmpl filePath + source <- exceptAffT $ sourceCstTmpl filePath let - printed = scrubEolSpaces $ prettyPrint (invalidate source.contents) + printed = scrubEolSpaces $ prettyPrint source.contents resourced <- except $ parse filePath printed - revalidated <- exceptAffT $ validateModule resourced - pure $ check revalidated.contents.types + pure $ check resourced.contents.types diff --git a/test/Ccap/Codegen/Exports.purs b/test/Ccap/Codegen/Exports.purs index e63de2b..89c2b77 100644 --- a/test/Ccap/Codegen/Exports.purs +++ b/test/Ccap/Codegen/Exports.purs @@ -3,12 +3,12 @@ module Test.Ccap.Codegen.Exports ) where import Prelude -import Ccap.Codegen.Purescript as Purescript +import Ccap.Codegen.PureScript as PureScript import Ccap.Codegen.Scala as Scala import Ccap.Codegen.Shared (OutputSpec) import Effect.Aff (Aff) import Node.Path (FilePath) -import Test.Ccap.Codegen.Util (exceptAffT, matchKeyLine, runOrFail, sourceTmpl) +import Test.Ccap.Codegen.Util (exceptAffT, matchKeyLine, runOrFail, sourceAstTmpl) import Test.Spec (Spec, describe, it) import Test.Spec.Assertions (shouldEqual) @@ -23,34 +23,34 @@ specs = describe "Exports" do describe "Scala exports" do it "only uses exports.scalaPkg for file path" - $ matchOutputPath Scala.outputSpec "test/ScalaExport.scala" + $ matchOutputPath Scala.outputSpec "test/Exports.scala" it "uses the parent directory as the package" $ matchKeyLine_ "package" Scala.outputSpec "package test" it "uses the last name as the main object name" - $ matchKeyLine_ "object" Scala.outputSpec "object ScalaExport {" + $ matchKeyLine_ "object" Scala.outputSpec "object Exports {" describe "Purescript exports" do it "only uses exports.pursPkg for file path" - $ matchOutputPath Purescript.outputSpec "Test/PurescriptExport.purs" + $ matchOutputPath PureScript.outputSpec "Test/Exports.purs" it "uses the pursPkg for the module path" - $ matchKeyLine_ "module" Purescript.outputSpec "module Test.PurescriptExport where" + $ matchKeyLine_ "module" PureScript.outputSpec "module Test.Exports where" describe "Imports of custom Exports" do let check = matchKeyLine importFile "ImportedType" describe "Scala imports" do it "References type with it's scala object name" - $ check Scala.outputSpec " type ImportedType = ScalaExport.ExportedType" + $ check Scala.outputSpec " type ImportedType = Exports.ExportedType" it "Uses the imported module qualifier when defining record fields" - $ matchKeyLine importFile "field" Scala.outputSpec " field: ScalaExport.ExportedType," + $ matchKeyLine importFile "field" Scala.outputSpec " field: Exports.ExportedType," it "Won't prefix if it's the imported file's class" - $ matchKeyLine importFile "ImportedRec" Scala.outputSpec " type ImportedRec = ScalaExport" + $ matchKeyLine importFile "ImportedRec" Scala.outputSpec " type ImportedRec = Exports" describe "Purescript imports" do it "References with it's purescript module name" - $ check Purescript.outputSpec "type ImportedType = PurescriptExport.ExportedType" + $ check PureScript.outputSpec "type ImportedType = Exports.ExportedType" matchOutputPath :: OutputSpec -> FilePath -> Aff Unit matchOutputPath outSpec outPath = runOrFail do - source <- exceptAffT $ sourceTmpl tmplFile + source <- exceptAffT $ sourceAstTmpl tmplFile let path = outSpec.filePath source.contents pure $ path `shouldEqual` outPath diff --git a/test/Ccap/Codegen/FastDecoding.purs b/test/Ccap/Codegen/FastDecoding.purs new file mode 100644 index 0000000..9ba273f --- /dev/null +++ b/test/Ccap/Codegen/FastDecoding.purs @@ -0,0 +1,49 @@ +module Test.Ccap.Codegen.FastDecoding + ( specs + ) where + +import Prelude +import Data.Either (either) +import Data.Maybe (Maybe(..)) +import Test.Ccap.Codegen.FastDecoding.Domains as Domains +import Test.Ccap.Codegen.FastDecoding.FastTest as FastTest +import Test.Spec (Spec, describe, it) +import Test.Spec.Assertions (fail, shouldEqual) + +specs :: Spec Unit +specs = + describe "The fast decoding code" do + it "Can round trip a sample" do + let + sample :: FastTest.Basic + sample = + { stringTest: "a" + , intTest: 1 + , booleanTest: true + , decimalTest: zero + , stringOpt: Just "b" + , intOpt: Nothing + , booleanOpt: Just true + , decimalOpt: Just zero + , stringT: Domains.StringT "c" + , intT: Domains.IntT 3 + , booleanT: Domains.BooleanT true + , decimalT: Domains.DecimalT zero + , stringOptT: Just (Domains.StringT "d") + , intOptT: Just (Domains.IntT 5) + , booleanOptT: Just (Domains.BooleanT true) + , decimalOptT: Just (Domains.DecimalT zero) + , ref: { intTest: 6, somethingA: [ false, true, false ] } + , refOpt: Just { intTest: 7, somethingA: zero } + , anotherRef: { intTest: 8, somethingA: 8 } + , yetAnotherRef: Just { intTest: 9, somethingA: "z" } + , arrayOfB: [ 10, 11, 12 ] + , aC: [ true, true, true ] + , xx: FastTest.Cons "a" (FastTest.Cons "b" (FastTest.Cons "c" FastTest.Nil)) + , yy: FastTest.MyTuple "one" 1 + } + + json = FastTest.jsonCodec_Basic.encode sample + + back = FastTest.jsonCodec_Basic.decode json + either fail (_ `shouldEqual` sample) back diff --git a/test/Ccap/Codegen/FastDecoding/Domains.purs b/test/Ccap/Codegen/FastDecoding/Domains.purs new file mode 100644 index 0000000..4d6fd5f --- /dev/null +++ b/test/Ccap/Codegen/FastDecoding/Domains.purs @@ -0,0 +1,72 @@ +-- This file is automatically generated. Do not edit. + +module Test.Ccap.Codegen.FastDecoding.Domains where + +import Ccap.Codegen.Runtime as R +import Data.Argonaut.Decode (class DecodeJson) +import Data.Argonaut.Encode (class EncodeJson) +import Data.Decimal (Decimal) +import Data.Generic.Rep (class Generic) +import Data.Generic.Rep.Show (genericShow) +import Data.Newtype (class Newtype) +import Prelude + +newtype StringT = StringT String +derive instance newtypeStringT :: Newtype StringT _ +instance encodeJsonStringT :: EncodeJson StringT where + encodeJson a = jsonCodec_StringT.encode a +instance decodeJsonStringT :: DecodeJson StringT where + decodeJson a = jsonCodec_StringT.decode a +derive instance eqStringT :: Eq StringT +derive instance ordStringT :: Ord StringT +derive instance genericStringT :: Generic StringT _ +instance showStringT :: Show StringT where + show a = genericShow a +jsonCodec_StringT :: R.JsonCodec StringT +jsonCodec_StringT = + R.codec_newtype (R.jsonCodec_string) + +newtype BooleanT = BooleanT Boolean +derive instance newtypeBooleanT :: Newtype BooleanT _ +instance encodeJsonBooleanT :: EncodeJson BooleanT where + encodeJson a = jsonCodec_BooleanT.encode a +instance decodeJsonBooleanT :: DecodeJson BooleanT where + decodeJson a = jsonCodec_BooleanT.decode a +derive instance eqBooleanT :: Eq BooleanT +derive instance ordBooleanT :: Ord BooleanT +derive instance genericBooleanT :: Generic BooleanT _ +instance showBooleanT :: Show BooleanT where + show a = genericShow a +jsonCodec_BooleanT :: R.JsonCodec BooleanT +jsonCodec_BooleanT = + R.codec_newtype (R.jsonCodec_boolean) + +newtype IntT = IntT Int +derive instance newtypeIntT :: Newtype IntT _ +instance encodeJsonIntT :: EncodeJson IntT where + encodeJson a = jsonCodec_IntT.encode a +instance decodeJsonIntT :: DecodeJson IntT where + decodeJson a = jsonCodec_IntT.decode a +derive instance eqIntT :: Eq IntT +derive instance ordIntT :: Ord IntT +derive instance genericIntT :: Generic IntT _ +instance showIntT :: Show IntT where + show a = genericShow a +jsonCodec_IntT :: R.JsonCodec IntT +jsonCodec_IntT = + R.codec_newtype (R.jsonCodec_int) + +newtype DecimalT = DecimalT Decimal +derive instance newtypeDecimalT :: Newtype DecimalT _ +instance encodeJsonDecimalT :: EncodeJson DecimalT where + encodeJson a = jsonCodec_DecimalT.encode a +instance decodeJsonDecimalT :: DecodeJson DecimalT where + decodeJson a = jsonCodec_DecimalT.decode a +derive instance eqDecimalT :: Eq DecimalT +derive instance ordDecimalT :: Ord DecimalT +derive instance genericDecimalT :: Generic DecimalT _ +instance showDecimalT :: Show DecimalT where + show a = genericShow a +jsonCodec_DecimalT :: R.JsonCodec DecimalT +jsonCodec_DecimalT = + R.codec_newtype (R.jsonCodec_decimal) diff --git a/test/Ccap/Codegen/FastDecoding/FastTest.js b/test/Ccap/Codegen/FastDecoding/FastTest.js new file mode 100644 index 0000000..85ba588 --- /dev/null +++ b/test/Ccap/Codegen/FastDecoding/FastTest.js @@ -0,0 +1,358 @@ +// This file is automatically generated. Do not edit. +exports.decode_WithParams = function (api) { + return function(json) { + if (! (typeof json === 'object' && !Array.isArray(json) && json !== null)) { + return api.left('This value must be an object'); + } + + let stringTest; + if (! ('stringTest' in json)) { + return api.left("Property 'stringTest' does not exist"); + } + if (typeof json.stringTest !== 'string') { + return api.left("Property 'stringTest' must be a(n) string"); + } + stringTest = json.stringTest; + + let intTest; + if (! ('intTest' in json)) { + return api.left("Property 'intTest' does not exist"); + } + if (typeof json.intTest !== 'number' && (json.intTest | 0) === json.intTest) { + return api.left("Property 'intTest' must be a(n) integer"); + } + intTest = json.intTest; + + let booleanTest; + if (! ('booleanTest' in json)) { + return api.left("Property 'booleanTest' does not exist"); + } + if (typeof json.booleanTest !== 'boolean') { + return api.left("Property 'booleanTest' must be a(n) boolean"); + } + booleanTest = json.booleanTest; + + let decimalTest; + if (! ('decimalTest' in json)) { + return api.left("Property 'decimalTest' does not exist"); + } + decimalTest = api.jsonCodec_primitive_decimal.decode(json.decimalTest); + if (api.isLeft(decimalTest)) { + return api.addErrorPrefix("Property 'decimalTest': ")(decimalTest); + } + decimalTest = api.fromRight()(decimalTest); + + let stringOpt; + if (! ('stringOpt' in json)) { + return api.left("Property 'stringOpt' does not exist"); + } + if (json.stringOpt === null) { + stringOpt = api.nothing; + } else { + if (typeof json.stringOpt !== 'string') { + return api.left("Property 'stringOpt' must be a(n) string"); + } + stringOpt = api.just(json.stringOpt); + } + + let intOpt; + if (! ('intOpt' in json)) { + return api.left("Property 'intOpt' does not exist"); + } + if (json.intOpt === null) { + intOpt = api.nothing; + } else { + if (typeof json.intOpt !== 'number' && (json.intOpt | 0) === json.intOpt) { + return api.left("Property 'intOpt' must be a(n) integer"); + } + intOpt = api.just(json.intOpt); + } + + let booleanOpt; + if (! ('booleanOpt' in json)) { + return api.left("Property 'booleanOpt' does not exist"); + } + if (json.booleanOpt === null) { + booleanOpt = api.nothing; + } else { + if (typeof json.booleanOpt !== 'boolean') { + return api.left("Property 'booleanOpt' must be a(n) boolean"); + } + booleanOpt = api.just(json.booleanOpt); + } + + let decimalOpt; + if (! ('decimalOpt' in json)) { + return api.left("Property 'decimalOpt' does not exist"); + } + if (json.decimalOpt === null) { + decimalOpt = api.nothing; + } else { + decimalOpt = api.jsonCodec_primitive_decimal.decode(json.decimalOpt); + if (api.isLeft(decimalOpt)) { + return decimalOpt; + } + decimalOpt = api.just(api.fromRight()(decimalOpt)); + } + + let stringT; + if (! ('stringT' in json)) { + return api.left("Property 'stringT' does not exist"); + } + if (typeof json.stringT !== 'string') { + return api.left("Property 'stringT' must be a(n) string"); + } + stringT = json.stringT; + + let intT; + if (! ('intT' in json)) { + return api.left("Property 'intT' does not exist"); + } + if (typeof json.intT !== 'number' && (json.intT | 0) === json.intT) { + return api.left("Property 'intT' must be a(n) integer"); + } + intT = json.intT; + + let booleanT; + if (! ('booleanT' in json)) { + return api.left("Property 'booleanT' does not exist"); + } + if (typeof json.booleanT !== 'boolean') { + return api.left("Property 'booleanT' must be a(n) boolean"); + } + booleanT = json.booleanT; + + let decimalT; + if (! ('decimalT' in json)) { + return api.left("Property 'decimalT' does not exist"); + } + decimalT = api.jsonCodec_primitive_decimal.decode(json.decimalT); + if (api.isLeft(decimalT)) { + return api.addErrorPrefix("Property 'decimalT': ")(decimalT); + } + decimalT = api.fromRight()(decimalT); + + let stringOptT; + if (! ('stringOptT' in json)) { + return api.left("Property 'stringOptT' does not exist"); + } + if (json.stringOptT === null) { + stringOptT = api.nothing; + } else { + if (typeof json.stringOptT !== 'string') { + return api.left("Property 'stringOptT' must be a(n) string"); + } + stringOptT = api.just(json.stringOptT); + } + + let intOptT; + if (! ('intOptT' in json)) { + return api.left("Property 'intOptT' does not exist"); + } + if (json.intOptT === null) { + intOptT = api.nothing; + } else { + if (typeof json.intOptT !== 'number' && (json.intOptT | 0) === json.intOptT) { + return api.left("Property 'intOptT' must be a(n) integer"); + } + intOptT = api.just(json.intOptT); + } + + let booleanOptT; + if (! ('booleanOptT' in json)) { + return api.left("Property 'booleanOptT' does not exist"); + } + if (json.booleanOptT === null) { + booleanOptT = api.nothing; + } else { + if (typeof json.booleanOptT !== 'boolean') { + return api.left("Property 'booleanOptT' must be a(n) boolean"); + } + booleanOptT = api.just(json.booleanOptT); + } + + let decimalOptT; + if (! ('decimalOptT' in json)) { + return api.left("Property 'decimalOptT' does not exist"); + } + if (json.decimalOptT === null) { + decimalOptT = api.nothing; + } else { + decimalOptT = api.jsonCodec_primitive_decimal.decode(json.decimalOptT); + if (api.isLeft(decimalOptT)) { + return decimalOptT; + } + decimalOptT = api.just(api.fromRight()(decimalOptT)); + } + + let ref; + if (! ('ref' in json)) { + return api.left("Property 'ref' does not exist"); + } + ref = api.jsonCodec_ref.decode(json.ref); + if (api.isLeft(ref)) { + return api.addErrorPrefix("Property 'ref': ")(ref); + } + ref = api.fromRight()(ref); + + let refOpt; + if (! ('refOpt' in json)) { + return api.left("Property 'refOpt' does not exist"); + } + refOpt = api.jsonCodec_refOpt.decode(json.refOpt); + if (api.isLeft(refOpt)) { + return api.addErrorPrefix("Property 'refOpt': ")(refOpt); + } + refOpt = api.fromRight()(refOpt); + + let anotherRef; + if (! ('anotherRef' in json)) { + return api.left("Property 'anotherRef' does not exist"); + } + anotherRef = api.jsonCodec_anotherRef.decode(json.anotherRef); + if (api.isLeft(anotherRef)) { + return api.addErrorPrefix("Property 'anotherRef': ")(anotherRef); + } + anotherRef = api.fromRight()(anotherRef); + + let yetAnotherRef; + if (! ('yetAnotherRef' in json)) { + return api.left("Property 'yetAnotherRef' does not exist"); + } + yetAnotherRef = api.jsonCodec_yetAnotherRef.decode(json.yetAnotherRef); + if (api.isLeft(yetAnotherRef)) { + return api.addErrorPrefix("Property 'yetAnotherRef': ")(yetAnotherRef); + } + yetAnotherRef = api.fromRight()(yetAnotherRef); + + let arrayOfB; + if (! ('arrayOfB' in json)) { + return api.left("Property 'arrayOfB' does not exist"); + } + arrayOfB = api.jsonCodec_arrayOfB.decode(json.arrayOfB); + if (api.isLeft(arrayOfB)) { + return api.addErrorPrefix("Property 'arrayOfB': ")(arrayOfB); + } + arrayOfB = api.fromRight()(arrayOfB); + + let aC; + if (! ('aC' in json)) { + return api.left("Property 'aC' does not exist"); + } + aC = api.jsonCodec_aC.decode(json.aC); + if (api.isLeft(aC)) { + return api.addErrorPrefix("Property 'aC': ")(aC); + } + aC = api.fromRight()(aC); + + let xx; + if (! ('xx' in json)) { + return api.left("Property 'xx' does not exist"); + } + xx = api.jsonCodec_xx.decode(json.xx); + if (api.isLeft(xx)) { + return api.addErrorPrefix("Property 'xx': ")(xx); + } + xx = api.fromRight()(xx); + + let yy; + if (! ('yy' in json)) { + return api.left("Property 'yy' does not exist"); + } + yy = api.jsonCodec_yy.decode(json.yy); + if (api.isLeft(yy)) { + return api.addErrorPrefix("Property 'yy': ")(yy); + } + yy = api.fromRight()(yy); + return api.right( + { stringTest: stringTest + , intTest: intTest + , booleanTest: booleanTest + , decimalTest: decimalTest + , stringOpt: stringOpt + , intOpt: intOpt + , booleanOpt: booleanOpt + , decimalOpt: decimalOpt + , stringT: stringT + , intT: intT + , booleanT: booleanT + , decimalT: decimalT + , stringOptT: stringOptT + , intOptT: intOptT + , booleanOptT: booleanOptT + , decimalOptT: decimalOptT + , ref: ref + , refOpt: refOpt + , anotherRef: anotherRef + , yetAnotherRef: yetAnotherRef + , arrayOfB: arrayOfB + , aC: aC + , xx: xx + , yy: yy + } + ); + }; +}; + +exports.decode_Ref = function (api) { + return function(json) { + if (! (typeof json === 'object' && !Array.isArray(json) && json !== null)) { + return api.left('This value must be an object'); + } + + let intTest; + if (! ('intTest' in json)) { + return api.left("Property 'intTest' does not exist"); + } + if (typeof json.intTest !== 'number' && (json.intTest | 0) === json.intTest) { + return api.left("Property 'intTest' must be a(n) integer"); + } + intTest = json.intTest; + + let somethingA; + if (! ('somethingA' in json)) { + return api.left("Property 'somethingA' does not exist"); + } + somethingA = api.jsonCodec_somethingA.decode(json.somethingA); + if (api.isLeft(somethingA)) { + return api.addErrorPrefix("Property 'somethingA': ")(somethingA); + } + somethingA = api.fromRight()(somethingA); + return api.right( + { intTest: intTest + , somethingA: somethingA + } + ); + }; +}; + +exports.decode_RecordOfOther = function (api) { + return function(json) { + if (! (typeof json === 'object' && !Array.isArray(json) && json !== null)) { + return api.left('This value must be an object'); + } + + let x; + if (! ('x' in json)) { + return api.left("Property 'x' does not exist"); + } + if (typeof json.x !== 'number' && (json.x | 0) === json.x) { + return api.left("Property 'x' must be a(n) integer"); + } + x = json.x; + + let y; + if (! ('y' in json)) { + return api.left("Property 'y' does not exist"); + } + if (typeof json.y !== 'number' && (json.y | 0) === json.y) { + return api.left("Property 'y' must be a(n) integer"); + } + y = json.y; + return api.right( + { x: x + , y: y + } + ); + }; +}; diff --git a/test/Ccap/Codegen/FastDecoding/FastTest.purs b/test/Ccap/Codegen/FastDecoding/FastTest.purs new file mode 100644 index 0000000..5f0f4d3 --- /dev/null +++ b/test/Ccap/Codegen/FastDecoding/FastTest.purs @@ -0,0 +1,273 @@ +-- This file is automatically generated. Do not edit. + +module Test.Ccap.Codegen.FastDecoding.FastTest where + +import Ccap.Codegen.Runtime as R +import Data.Argonaut.Core as A +import Data.Argonaut.Decode (class DecodeJson) +import Data.Argonaut.Encode (class EncodeJson) +import Data.Array as Array +import Data.Bifunctor as B +import Data.Decimal (Decimal) +import Data.Either as E +import Data.Generic.Rep (class Generic) +import Data.Generic.Rep.Show (genericShow) +import Data.Maybe (Maybe) +import Data.Maybe as M +import Data.Newtype (class Newtype) +import Data.Tuple as T +import Foreign.Object as FO +import Prelude +import Test.Ccap.Codegen.FastDecoding.Domains as Domains + +type Basic = WithParams (Ref Decimal) Int (Array Boolean) +jsonCodec_Basic :: R.JsonCodec Basic +jsonCodec_Basic = + jsonCodec_WithParams (jsonCodec_Ref R.jsonCodec_decimal) R.jsonCodec_int (R.jsonCodec_array R.jsonCodec_boolean) + +type WithParams a b c = + { stringTest :: String + , intTest :: Int + , booleanTest :: Boolean + , decimalTest :: Decimal + , stringOpt :: Maybe String + , intOpt :: Maybe Int + , booleanOpt :: Maybe Boolean + , decimalOpt :: Maybe Decimal + , stringT :: Domains.StringT + , intT :: Domains.IntT + , booleanT :: Domains.BooleanT + , decimalT :: Domains.DecimalT + , stringOptT :: Maybe Domains.StringT + , intOptT :: Maybe Domains.IntT + , booleanOptT :: Maybe Domains.BooleanT + , decimalOptT :: Maybe Domains.DecimalT + , ref :: Ref c + , refOpt :: Maybe (Ref a) + , anotherRef :: Ref Int + , yetAnotherRef :: Maybe (Ref String) + , arrayOfB :: Array b + , aC :: c + , xx :: MyList String + , yy :: MyTuple String Int + } +type DecoderApi_WithParams a b c = + { nothing :: forall a. M.Maybe a + , just :: forall a. a -> M.Maybe a + , isLeft :: forall a b. E.Either a b -> Boolean + , fromRight :: forall a b. Partial => E.Either a b -> b + , right :: forall a b. b -> E.Either a b + , left :: forall a b. a -> E.Either a b + , addErrorPrefix :: forall a. String -> E.Either String a -> E.Either String a + , jsonCodec_primitive_decimal :: R.JsonCodec Decimal + , jsonCodec_ref :: R.JsonCodec (Ref c) + , jsonCodec_refOpt :: R.JsonCodec (Maybe (Ref a)) + , jsonCodec_anotherRef :: R.JsonCodec (Ref Int) + , jsonCodec_yetAnotherRef :: R.JsonCodec (Maybe (Ref String)) + , jsonCodec_arrayOfB :: R.JsonCodec (Array b) + , jsonCodec_aC :: R.JsonCodec c + , jsonCodec_xx :: R.JsonCodec (MyList String) + , jsonCodec_yy :: R.JsonCodec (MyTuple String Int) + } +decoderApi_WithParams :: forall a b c. R.JsonCodec a -> R.JsonCodec b -> R.JsonCodec c -> DecoderApi_WithParams a b c +decoderApi_WithParams jsonCodec_param_a jsonCodec_param_b jsonCodec_param_c = + { nothing: M.Nothing + , just: M.Just + , isLeft: E.isLeft + , fromRight: E.fromRight + , right: E.Right + , left: E.Left + , addErrorPrefix: \s -> B.lmap (s <> _) + , jsonCodec_primitive_decimal: R.jsonCodec_decimal + , jsonCodec_ref: jsonCodec_Ref jsonCodec_param_c + , jsonCodec_refOpt: R.jsonCodec_maybe (jsonCodec_Ref jsonCodec_param_a) + , jsonCodec_anotherRef: jsonCodec_Ref R.jsonCodec_int + , jsonCodec_yetAnotherRef: R.jsonCodec_maybe (jsonCodec_Ref R.jsonCodec_string) + , jsonCodec_arrayOfB: R.jsonCodec_array jsonCodec_param_b + , jsonCodec_aC: jsonCodec_param_c + , jsonCodec_xx: jsonCodec_MyList R.jsonCodec_string + , jsonCodec_yy: jsonCodec_MyTuple R.jsonCodec_string R.jsonCodec_int + } +foreign import decode_WithParams :: forall a b c. DecoderApi_WithParams a b c -> A.Json -> E.Either String (WithParams a b c) +jsonCodec_WithParams :: forall a b c. R.JsonCodec a -> R.JsonCodec b -> R.JsonCodec c -> R.JsonCodec (WithParams a b c) +jsonCodec_WithParams jsonCodec_param_a jsonCodec_param_b jsonCodec_param_c = + { decode: decode_WithParams (decoderApi_WithParams jsonCodec_param_a jsonCodec_param_b jsonCodec_param_c) + , encode: \p -> A.fromObject $ + FO.fromFoldable + [ T.Tuple "stringTest" (R.jsonCodec_string.encode p.stringTest) + , T.Tuple "intTest" (R.jsonCodec_int.encode p.intTest) + , T.Tuple "booleanTest" (R.jsonCodec_boolean.encode p.booleanTest) + , T.Tuple "decimalTest" (R.jsonCodec_decimal.encode p.decimalTest) + , T.Tuple "stringOpt" ((R.jsonCodec_maybe R.jsonCodec_string).encode p.stringOpt) + , T.Tuple "intOpt" ((R.jsonCodec_maybe R.jsonCodec_int).encode p.intOpt) + , T.Tuple "booleanOpt" ((R.jsonCodec_maybe R.jsonCodec_boolean).encode p.booleanOpt) + , T.Tuple "decimalOpt" ((R.jsonCodec_maybe R.jsonCodec_decimal).encode p.decimalOpt) + , T.Tuple "stringT" (Domains.jsonCodec_StringT.encode p.stringT) + , T.Tuple "intT" (Domains.jsonCodec_IntT.encode p.intT) + , T.Tuple "booleanT" (Domains.jsonCodec_BooleanT.encode p.booleanT) + , T.Tuple "decimalT" (Domains.jsonCodec_DecimalT.encode p.decimalT) + , T.Tuple "stringOptT" ((R.jsonCodec_maybe Domains.jsonCodec_StringT).encode p.stringOptT) + , T.Tuple "intOptT" ((R.jsonCodec_maybe Domains.jsonCodec_IntT).encode p.intOptT) + , T.Tuple "booleanOptT" ((R.jsonCodec_maybe Domains.jsonCodec_BooleanT).encode p.booleanOptT) + , T.Tuple "decimalOptT" ((R.jsonCodec_maybe Domains.jsonCodec_DecimalT).encode p.decimalOptT) + , T.Tuple "ref" ((jsonCodec_Ref jsonCodec_param_c).encode p.ref) + , T.Tuple "refOpt" ((R.jsonCodec_maybe (jsonCodec_Ref jsonCodec_param_a)).encode p.refOpt) + , T.Tuple "anotherRef" ((jsonCodec_Ref R.jsonCodec_int).encode p.anotherRef) + , T.Tuple "yetAnotherRef" ((R.jsonCodec_maybe (jsonCodec_Ref R.jsonCodec_string)).encode p.yetAnotherRef) + , T.Tuple "arrayOfB" ((R.jsonCodec_array jsonCodec_param_b).encode p.arrayOfB) + , T.Tuple "aC" (jsonCodec_param_c.encode p.aC) + , T.Tuple "xx" ((jsonCodec_MyList R.jsonCodec_string).encode p.xx) + , T.Tuple "yy" ((jsonCodec_MyTuple R.jsonCodec_string R.jsonCodec_int).encode p.yy) + ] + } + +type Ref a = + { intTest :: Int + , somethingA :: a + } +type DecoderApi_Ref a = + { nothing :: forall a. M.Maybe a + , just :: forall a. a -> M.Maybe a + , isLeft :: forall a b. E.Either a b -> Boolean + , fromRight :: forall a b. Partial => E.Either a b -> b + , right :: forall a b. b -> E.Either a b + , left :: forall a b. a -> E.Either a b + , addErrorPrefix :: forall a. String -> E.Either String a -> E.Either String a + , jsonCodec_primitive_decimal :: R.JsonCodec Decimal + , jsonCodec_somethingA :: R.JsonCodec a + } +decoderApi_Ref :: forall a. R.JsonCodec a -> DecoderApi_Ref a +decoderApi_Ref jsonCodec_param_a = + { nothing: M.Nothing + , just: M.Just + , isLeft: E.isLeft + , fromRight: E.fromRight + , right: E.Right + , left: E.Left + , addErrorPrefix: \s -> B.lmap (s <> _) + , jsonCodec_primitive_decimal: R.jsonCodec_decimal + , jsonCodec_somethingA: jsonCodec_param_a + } +foreign import decode_Ref :: forall a. DecoderApi_Ref a -> A.Json -> E.Either String (Ref a) +jsonCodec_Ref :: forall a. R.JsonCodec a -> R.JsonCodec (Ref a) +jsonCodec_Ref jsonCodec_param_a = + { decode: decode_Ref (decoderApi_Ref jsonCodec_param_a) + , encode: \p -> A.fromObject $ + FO.fromFoldable + [ T.Tuple "intTest" (R.jsonCodec_int.encode p.intTest) + , T.Tuple "somethingA" (jsonCodec_param_a.encode p.somethingA) + ] + } + +type ArrayOfSomething a = Array a +jsonCodec_ArrayOfSomething :: forall a. R.JsonCodec a -> R.JsonCodec (ArrayOfSomething a) +jsonCodec_ArrayOfSomething jsonCodec_param_a = + R.jsonCodec_array jsonCodec_param_a + +type Foo = Array String +jsonCodec_Foo :: R.JsonCodec Foo +jsonCodec_Foo = + R.jsonCodec_array R.jsonCodec_string + +type RecordOfOther = + { x :: Int + , y :: Int + } +type DecoderApi_RecordOfOther = + R.StandardDecoderApi +decoderApi_RecordOfOther :: DecoderApi_RecordOfOther +decoderApi_RecordOfOther = + R.standardDecoderApi +foreign import decode_RecordOfOther :: DecoderApi_RecordOfOther -> A.Json -> E.Either String RecordOfOther +jsonCodec_RecordOfOther :: R.JsonCodec RecordOfOther +jsonCodec_RecordOfOther = + { decode: decode_RecordOfOther (decoderApi_RecordOfOther) + , encode: \p -> A.fromObject $ + FO.fromFoldable + [ T.Tuple "x" (R.jsonCodec_int.encode p.x) + , T.Tuple "y" (R.jsonCodec_int.encode p.y) + ] + } + +data MyList a = + Nil + | Cons a (MyList a) +derive instance eqMyList :: Eq a => Eq (MyList a) +derive instance ordMyList :: Ord a => Ord (MyList a) +derive instance genericMyList :: Generic (MyList a) _ +instance showMyList :: Show a => Show (MyList a) where + show a = genericShow a +jsonCodec_MyList :: forall a. R.JsonCodec a -> R.JsonCodec (MyList a) +jsonCodec_MyList jsonCodec_param_a = + R.composeCodec + { decode: case _ of + T.Tuple "Nil" [] -> E.Right Nil + T.Tuple "Cons" [jsonParam_0, jsonParam_1] -> do + param_0 <- jsonCodec_param_a.decode jsonParam_0 + param_1 <- (jsonCodec_MyList jsonCodec_param_a).decode jsonParam_1 + E.Right (Cons param_0 param_1) + T.Tuple cn params -> E.Left $ "Pattern match failed for " <> show cn <> " with " <> show (Array.length params) <> " parameters" + , encode: case _ of + Nil -> T.Tuple "Nil" [] + Cons param_0 param_1 -> T.Tuple "Cons" [jsonCodec_param_a.encode param_0, (jsonCodec_MyList jsonCodec_param_a).encode param_1] + } + R.jsonCodec_constructor + +data MyTuple a b = + MyTuple a b +derive instance eqMyTuple :: (Eq a, Eq b) => Eq (MyTuple a b) +derive instance ordMyTuple :: (Ord a, Ord b) => Ord (MyTuple a b) +derive instance genericMyTuple :: Generic (MyTuple a b) _ +instance showMyTuple :: (Show a, Show b) => Show (MyTuple a b) where + show a = genericShow a +jsonCodec_MyTuple :: forall a b. R.JsonCodec a -> R.JsonCodec b -> R.JsonCodec (MyTuple a b) +jsonCodec_MyTuple jsonCodec_param_a jsonCodec_param_b = + R.composeCodec + { decode: case _ of + T.Tuple "MyTuple" [jsonParam_0, jsonParam_1] -> do + param_0 <- jsonCodec_param_a.decode jsonParam_0 + param_1 <- jsonCodec_param_b.decode jsonParam_1 + E.Right (MyTuple param_0 param_1) + T.Tuple cn params -> E.Left $ "Pattern match failed for " <> show cn <> " with " <> show (Array.length params) <> " parameters" + , encode: case _ of + MyTuple param_0 param_1 -> T.Tuple "MyTuple" [jsonCodec_param_a.encode param_0, jsonCodec_param_b.encode param_1] + } + R.jsonCodec_constructor + +data Blarg = + Blue String + | Red +derive instance eqBlarg :: Eq Blarg +derive instance ordBlarg :: Ord Blarg +derive instance genericBlarg :: Generic Blarg _ +instance showBlarg :: Show Blarg where + show a = genericShow a +jsonCodec_Blarg :: R.JsonCodec Blarg +jsonCodec_Blarg = + R.composeCodec + { decode: case _ of + T.Tuple "Blue" [jsonParam_0] -> do + param_0 <- R.jsonCodec_string.decode jsonParam_0 + E.Right (Blue param_0) + T.Tuple "Red" [] -> E.Right Red + T.Tuple cn params -> E.Left $ "Pattern match failed for " <> show cn <> " with " <> show (Array.length params) <> " parameters" + , encode: case _ of + Blue param_0 -> T.Tuple "Blue" [R.jsonCodec_string.encode param_0] + Red -> T.Tuple "Red" [] + } + R.jsonCodec_constructor + +newtype X = X String +derive instance newtypeX :: Newtype X _ +instance encodeJsonX :: EncodeJson X where + encodeJson a = jsonCodec_X.encode a +instance decodeJsonX :: DecodeJson X where + decodeJson a = jsonCodec_X.decode a +derive instance eqX :: Eq X +derive instance ordX :: Ord X +derive instance genericX :: Generic X _ +instance showX :: Show X where + show a = genericShow a +jsonCodec_X :: R.JsonCodec X +jsonCodec_X = + R.codec_newtype R.jsonCodec_string diff --git a/test/Ccap/Codegen/Imports.purs b/test/Ccap/Codegen/Imports.purs deleted file mode 100644 index cf8bf2c..0000000 --- a/test/Ccap/Codegen/Imports.purs +++ /dev/null @@ -1,159 +0,0 @@ -module Test.Ccap.Codegen.Imports - ( specs - ) where - -import Prelude -import Ccap.Codegen.FileSystem as FS -import Ccap.Codegen.Imports (importsInScope, validateImports) -import Ccap.Codegen.Module (validateModules) -import Ccap.Codegen.TypeRef (validateAllTypeRefs) -import Ccap.Codegen.ValidationError (class ValidationError, printError) -import Control.Monad.Except (ExceptT(..), except, runExceptT, withExceptT) -import Data.Either (either) -import Data.Foldable (fold) -import Data.Traversable (intercalate, sequence, traverse) -import Effect.Class (liftEffect) -import Node.Path (FilePath) -import Node.Path as Path -import Test.Ccap.Codegen.Util (eqElems, shouldBeLeft, shouldBeRight) -import Test.Spec (Spec, describe, it) -import Test.Spec.Assertions (shouldSatisfy) - -resources :: FilePath -resources = "./test/resources/" - -imports_ :: FilePath -imports_ = Path.concat [ resources, "imports" ] - -includes_ :: FilePath -includes_ = Path.concat [ resources, "includes" ] - -internal_ :: FilePath -internal_ = Path.concat [ includes_, "internal" ] - -external_ :: FilePath -external_ = Path.concat [ includes_, "external" ] - -internal :: FilePath -> FilePath -internal fileName = Path.concat [ internal_, fileName ] - -plainSource :: FilePath -plainSource = internal "SourcePlain.tmpl" - -internalSource :: FilePath -internalSource = internal "SourceInternal.tmpl" - -submoduleSource :: FilePath -submoduleSource = internal "SourceSubmodule.tmpl" - -externalSource :: FilePath -externalSource = internal "SourceExternal.tmpl" - -externalSubmoduleSource :: FilePath -externalSubmoduleSource = internal "SourceExternalSubmodule.tmpl" - -app1 :: FilePath -app1 = Path.concat [ imports_, "app1", "Main.tmpl" ] - -app2 :: FilePath -app2 = Path.concat [ imports_, "app2", "Main.tmpl" ] - -withPrintErrors ∷ ∀ e m a. ValidationError e ⇒ Monad m ⇒ ExceptT (Array e) m a → ExceptT String m a -withPrintErrors = withExceptT $ fold <<< map printError - -specs :: Spec Unit -specs = - let - itCanBeParsed = - it "can be parsed with no errors" - <<< (shouldBeRight <=< liftEffect <<< FS.sourceFile) - - itHasImports filePath imports = - it "parsed the imports as expected" do - sourceImports <- FS.sourceFile filePath <#> (map _.contents.imports) # liftEffect - shouldSatisfy sourceImports $ either (const false) (eqElems imports) - - itCanFindImports filePath includes = - it "Has imports that exist" do - imports <- - liftEffect - $ runExceptT do - source <- ExceptT $ FS.sourceFile filePath - withPrintErrors $ ExceptT $ importsInScope includes source - shouldBeRight imports - - itCanValidateImports filePath includes = - it "Can validate it's imports" do - imports <- - liftEffect - $ runExceptT do - source <- ExceptT $ FS.sourceFile filePath - withPrintErrors $ ExceptT $ validateImports includes [ source ] - shouldBeRight imports - - itCanValidateAllModules filePaths includes = - it "Can validate all modules" do - modules <- - liftEffect - $ runExceptT do - sources <- ExceptT $ map sequence $ traverse FS.sourceFile filePaths - withExceptT (intercalate "|") $ ExceptT $ validateModules includes sources - shouldBeRight modules - - itFailsWithoutIncludes filePath = - it "Fails validation without including the external folder" do - let - includes = [] - imports <- - liftEffect - $ runExceptT do - source <- ExceptT $ FS.sourceFile filePath - withPrintErrors $ ExceptT $ validateImports includes [ source ] - shouldBeLeft imports - - itHasValidTypeReferences filePath includes = - it "Has valid type references to imported types" do - typeDecls <- - liftEffect - $ runExceptT do - source <- ExceptT $ FS.sourceFile filePath - imports <- withPrintErrors $ ExceptT $ validateImports includes [ source ] - withPrintErrors $ except $ validateAllTypeRefs source.contents (imports <#> _.contents.mod) - shouldBeRight typeDecls - in - describe "template include syntax" do - describe "a plain file with no references" do - itCanBeParsed plainSource - itHasImports plainSource [] - itHasValidTypeReferences plainSource [] - describe "a file with an neighboring reference" do - itCanBeParsed internalSource - itHasImports internalSource [ "Internal" ] - itCanFindImports internalSource [] - itCanValidateImports internalSource [] - itHasValidTypeReferences internalSource [] - describe "a file with an submodule reference" do - itCanBeParsed submoduleSource - itHasImports submoduleSource [ "submodule.Submodule" ] - itCanFindImports submoduleSource [] - itCanValidateImports submoduleSource [] - itHasValidTypeReferences submoduleSource [] - itCanValidateAllModules [ submoduleSource ] [] - describe "a file with an external reference" do - itCanBeParsed externalSource - itHasImports externalSource [ "External" ] - itCanFindImports externalSource [ external_ ] - itCanValidateImports externalSource [ external_ ] - itFailsWithoutIncludes externalSource - itHasValidTypeReferences externalSource [ external_ ] - itCanValidateAllModules [ externalSource ] [ external_ ] - describe "a file with an external reference to a submodule" do - itCanBeParsed externalSubmoduleSource - itHasImports externalSubmoduleSource [ "submodule.ExternalSubmodule" ] - itCanFindImports externalSubmoduleSource [ external_ ] - itCanValidateImports externalSubmoduleSource [ external_ ] - itFailsWithoutIncludes externalSubmoduleSource - itHasValidTypeReferences externalSubmoduleSource [ external_ ] - itCanValidateAllModules [ externalSubmoduleSource ] [ external_ ] - describe "two files with identical relative imports" - $ itCanValidateAllModules [ app1, app2 ] [] diff --git a/test/Ccap/Codegen/Parser.purs b/test/Ccap/Codegen/Parser.purs index 6f6beca..eaa8e5d 100644 --- a/test/Ccap/Codegen/Parser.purs +++ b/test/Ccap/Codegen/Parser.purs @@ -3,23 +3,21 @@ module Test.Ccap.Codegen.Parser ) where import Prelude +import Ccap.Codegen.Cst as Cst import Ccap.Codegen.FileSystem (joinPaths, readTextFile) -import Ccap.Codegen.PrettyPrint (prettyPrint) -import Ccap.Codegen.Purescript as Purescript +import Ccap.Codegen.PrettyPrint as PrettyPrint +import Ccap.Codegen.PureScript as PureScript import Ccap.Codegen.Scala as Scala -import Ccap.Codegen.Shared (invalidate) -import Ccap.Codegen.Types (Source, ValidatedModule) import Ccap.Codegen.Util (scrubEolSpaces) -import Control.Monad.Except (ExceptT(..), runExceptT) -import Control.Monad.Except.Trans (except) -import Data.Array as Array +import Control.Monad.Except (ExceptT(..), except, runExceptT) +import Data.Array.NonEmpty as NonEmptyArray import Data.Either (either) import Data.Foldable (traverse_) import Data.Tuple (Tuple(..), uncurry) import Effect.Aff (Aff) import Effect.Class (liftEffect) import Node.Path (FilePath) -import Test.Ccap.Codegen.Util (diffByLine, parse, print, sourceTmpl, validateModule) +import Test.Ccap.Codegen.Util (diffByLine, parse, print, sourceAstTmpl, sourceCstTmpl) import Test.Spec (Spec, describe, it) import Test.Spec.Assertions (fail, shouldEqual) @@ -48,18 +46,17 @@ specs = results <- liftEffect $ runExceptT do - validated <- ExceptT $ sourceTmpl tmplFile + input <- ExceptT $ sourceCstTmpl tmplFile let - printed = scrubEolSpaces $ prettyPrint (invalidate validated.contents) + printed = scrubEolSpaces (PrettyPrint.prettyPrint input.contents) resourced <- except $ parse tmplFile printed - revalidated <- ExceptT $ validateModule resourced - pure $ Tuple validated revalidated + pure $ Tuple input resourced either fail (uncurry compareModules) results it "Prints a scala a file as expected" do results <- liftEffect $ runExceptT do - validated <- ExceptT $ sourceTmpl tmplFile + validated <- ExceptT $ sourceAstTmpl tmplFile let printed = print Scala.outputSpec validated scala <- ExceptT $ readTextFile scalaFile @@ -69,21 +66,19 @@ specs = results <- liftEffect $ runExceptT do - validated <- ExceptT $ sourceTmpl tmplFile + validated <- ExceptT $ sourceAstTmpl tmplFile let - printed = print Purescript.outputSpec validated + printed = print PureScript.outputSpec validated purs <- ExceptT $ readTextFile pursFile pure $ Tuple printed purs either fail (uncurry diffByLine) results -compareModules :: Source ValidatedModule -> Source ValidatedModule -> Aff Unit +compareModules :: Cst.Source Cst.Module -> Cst.Source Cst.Module -> Aff Unit compareModules x y = do x.source `shouldEqual` y.source - x.contents.name `shouldEqual` y.contents.name - x.contents.annots `shouldEqual` y.contents.annots x.contents.imports `shouldEqual` y.contents.imports x.contents.exports `shouldEqual` y.contents.exports - (Array.length x.contents.types) `shouldEqual` (Array.length y.contents.types) + (NonEmptyArray.length x.contents.types) `shouldEqual` (NonEmptyArray.length y.contents.types) let - types = Array.zip x.contents.types y.contents.types + types = NonEmptyArray.zip x.contents.types y.contents.types traverse_ (uncurry shouldEqual) types diff --git a/test/Ccap/Codegen/Util.purs b/test/Ccap/Codegen/Util.purs index ad83fa6..9eff4ff 100644 --- a/test/Ccap/Codegen/Util.purs +++ b/test/Ccap/Codegen/Util.purs @@ -10,33 +10,34 @@ module Test.Ccap.Codegen.Util , runOrFail , shouldBeLeft , shouldBeRight - , sourceTmpl + , sourceAstTmpl + , sourceCstTmpl , splitLines - -- , traceFile - , validateModule ) where import Prelude +import Ccap.Codegen.Ast as Ast +import Ccap.Codegen.AstBuilder as AstBuilder +import Ccap.Codegen.Cst as Cst +import Ccap.Codegen.Error as Error import Ccap.Codegen.FileSystem (readTextFile) -import Ccap.Codegen.Module as Module -import Ccap.Codegen.Parser (errorMessage, parseSource) +import Ccap.Codegen.Parser as Parser2 import Ccap.Codegen.Shared (OutputSpec) -import Ccap.Codegen.Types (Module, Source, ValidatedModule) import Ccap.Codegen.Util (ensureNewline, scrubEolSpaces) -import Ccap.Codegen.ValidationError (joinErrors) import Control.Monad.Error.Class (class MonadThrow) import Control.Monad.Except (ExceptT(..), except, runExceptT) import Data.Array (sort) import Data.Array as Array +import Data.Array.NonEmpty as NonEmptyArray import Data.Bifunctor (lmap) -import Data.Either (Either(..), either, isLeft, isRight) +import Data.Either (Either(..), either, isLeft, isRight, note) import Data.Foldable (traverse_) import Data.List (List(..)) import Data.List as List import Data.List.Lazy (find) import Data.Maybe (Maybe, fromMaybe) import Data.String (Pattern(..)) -import Data.String (split) as String +import Data.String (joinWith, split) as String import Data.String.Utils (includes) as String import Data.Tuple (uncurry) import Effect (Effect) @@ -52,9 +53,6 @@ exceptAffT = ExceptT <<< liftEffect runOrFail :: ExceptT String Aff (Aff Unit) -> Aff Unit runOrFail = either fail identity <=< runExceptT -validateModule :: Source Module -> Effect (Either String (Source ValidatedModule)) -validateModule = Array.singleton >>> Module.validateModules [] >>> map (joinErrors >=> onlyOne) - onlyOne :: forall a. Array a -> Either String a onlyOne = List.fromFoldable @@ -72,11 +70,11 @@ shouldBeLeft = flip shouldSatisfy isLeft eqElems :: forall a. Ord a => Eq a => Array a -> Array a -> Boolean eqElems xs ys = sort xs == sort ys -parse :: FilePath -> String -> Either String (Source Module) -parse filePath = lmap (errorMessage filePath) <<< parseSource filePath +parse :: FilePath -> String -> Either String (Cst.Source Cst.Module) +parse filePath = lmap Parser2.errorMessage <<< Parser2.parseSource filePath -print :: OutputSpec -> Source ValidatedModule -> String -print { render } { contents } = ensureNewline $ scrubEolSpaces $ render contents +print :: OutputSpec -> Cst.Source Ast.Module -> String +print { render } { contents } = ensureNewline $ scrubEolSpaces $ fromMaybe "" $ render contents splitLines :: String -> Array String splitLines = String.split (Pattern "\n") @@ -95,19 +93,27 @@ diffByLine x y = do findLine :: (String -> Boolean) -> String -> Maybe String findLine pred = find pred <<< splitLines ---traceFile :: forall m. Monad m => String -> m Unit ---traceFile = traverse_ traceM <<< splitLines -sourceTmpl :: FilePath -> Effect (Either String (Source ValidatedModule)) -sourceTmpl filePath = +sourceCstTmpl :: FilePath -> Effect (Either String (Cst.Source Cst.Module)) +sourceCstTmpl filePath = runExceptT do text <- ExceptT $ readTextFile filePath - sourced <- except $ parse filePath text - ExceptT $ validateModule sourced + except $ parse filePath text + +sourceAstTmpl :: FilePath -> Effect (Either String (Cst.Source Ast.Module)) +sourceAstTmpl filePath = + runExceptT do + result <- + ExceptT + ( map + (lmap (String.joinWith "\n" <<< NonEmptyArray.toArray <<< map (\e -> "ERROR: " <> Error.toString e))) + (runExceptT (AstBuilder.build { files: [ filePath ], importPaths: [] })) + ) + except (note "Expected result" (Array.head result)) matchKeyLine :: FilePath -> String -> OutputSpec -> String -> Aff Unit matchKeyLine file keyWord outSpec line = runOrFail do - source <- exceptAffT $ sourceTmpl file + source <- exceptAffT $ sourceAstTmpl file let printed = print outSpec source diff --git a/test/GetSchema.purs b/test/GetSchema.purs index fbbe66f..35582b0 100644 --- a/test/GetSchema.purs +++ b/test/GetSchema.purs @@ -1,10 +1,9 @@ module Test.GetSchema where import Prelude +import Ccap.Codegen.Cst as Cst import Ccap.Codegen.Database (tableModule) import Ccap.Codegen.PrettyPrint (prettyPrint) -import Ccap.Codegen.Shared (invalidate) -import Ccap.Codegen.Types (Source, ValidatedModule, Module) import Ccap.Codegen.Util (scrubEolSpaces) import Control.Monad.Except (ExceptT(..), runExceptT) import Data.Either (either) @@ -17,7 +16,7 @@ import Effect.Aff (Aff, launchAff_) import Effect.Class (liftEffect) import Node.Path (FilePath) import Node.Process (lookupEnv) -import Test.Ccap.Codegen.Util (diffByLine, sourceTmpl) +import Test.Ccap.Codegen.Util (diffByLine, sourceCstTmpl) import Test.Spec (Spec, describe, it) import Test.Spec.Assertions (fail) import Test.Spec.Reporter (consoleReporter) @@ -44,7 +43,7 @@ poolConfig = do , password = password } -stripImports :: Source ValidatedModule -> Source ValidatedModule +stripImports :: Cst.Source Cst.Module -> Cst.Source Cst.Module stripImports source = source { contents = source.contents { imports = [] } } specs :: Spec Unit @@ -53,15 +52,15 @@ specs = it "fetches the case data correctly" do results <- runExceptT do - fileSource <- ExceptT <<< liftEffect $ sourceTmpl caseTmplFile + fileSource <- ExceptT <<< liftEffect $ sourceCstTmpl caseTmplFile let { scalaPkg, pursPkg } = fileSource.contents.exports pool <- ExceptT <<< liftEffect <<< map pure $ poolConfig >>= newPool - dbModule <- tableModule pool scalaPkg pursPkg fileSource.contents.name - pure $ Tuple (invalidate fileSource.contents) dbModule + dbModule <- tableModule pool scalaPkg pursPkg "Case" + pure $ Tuple fileSource.contents dbModule either fail (uncurry printAndDiff) results -printAndDiff :: Module -> Module -> Aff Unit +printAndDiff :: Cst.Module -> Cst.Module -> Aff Unit printAndDiff x y = (print x) `diffByLine` (print y) where print = scrubEolSpaces <<< prettyPrint diff --git a/test/Main.purs b/test/Main.purs index 0604b39..ff10740 100644 --- a/test/Main.purs +++ b/test/Main.purs @@ -6,18 +6,18 @@ import Effect.Aff (launchAff_) import Test.Ccap.Codegen.Annotations (specs) as Annotations import Test.Ccap.Codegen.Exports (specs) as Exports import Test.Ccap.Codegen.FileSystem (specs) as FileSystem -import Test.Ccap.Codegen.Imports (specs) as Imports +import Test.Ccap.Codegen.FastDecoding (specs) as FastDecoding import Test.Ccap.Codegen.Parser (specs) as Parser import Test.Ccap.Codegen.Prefix (specs) as Prefix import Test.Spec.Reporter.Console (consoleReporter) import Test.Spec.Runner (runSpec) main :: Effect Unit -main = +main = do launchAff_ $ runSpec [ consoleReporter ] do + FastDecoding.specs FileSystem.specs - Imports.specs Parser.specs Exports.specs Annotations.specs diff --git a/test/resources/exports/Exports.tmpl b/test/resources/exports/Exports.tmpl index debd36a..40a78a6 100644 --- a/test/resources/exports/Exports.tmpl +++ b/test/resources/exports/Exports.tmpl @@ -1,8 +1,12 @@ -scala: test.ScalaExport -purs: Test.PurescriptExport +scala: test.Exports +purs: Test.Exports type ExportedType: Int type ScalaExport: { field: String } + +type Exports: { + field: String +} diff --git a/test/resources/exports/Imports.tmpl b/test/resources/exports/Imports.tmpl index eec0799..c9a989e 100644 --- a/test/resources/exports/Imports.tmpl +++ b/test/resources/exports/Imports.tmpl @@ -5,7 +5,7 @@ import Exports type ImportedType: Exports.ExportedType -type ImportedRec: Exports.ScalaExport +type ImportedRec: Exports.Exports type Imports: { field: Exports.ExportedType diff --git a/test/resources/fastdecoding/Domains.tmpl b/test/resources/fastdecoding/Domains.tmpl new file mode 100644 index 0000000..5466cbe --- /dev/null +++ b/test/resources/fastdecoding/Domains.tmpl @@ -0,0 +1,7 @@ +scala: gov.wicourts.codegen.test.fastdecoding.Domains +purs: Test.Ccap.Codegen.FastDecoding.Domains + +type StringT: wrap String +type BooleanT: wrap Boolean +type IntT: wrap Int +type DecimalT: wrap Decimal diff --git a/test/resources/fastdecoding/FastTest.tmpl b/test/resources/fastdecoding/FastTest.tmpl new file mode 100644 index 0000000..4e133f0 --- /dev/null +++ b/test/resources/fastdecoding/FastTest.tmpl @@ -0,0 +1,68 @@ +scala: gov.wicourts.codegen.test.fastdecoding.FastTest +purs: Test.Ccap.Codegen.FastDecoding.FastTest + +import Domains + +type Basic: WithParams (Ref Decimal) Int (Array Boolean) + +type WithParams a b c: { + stringTest: String, + intTest: Int, + booleanTest: Boolean, + decimalTest: Decimal, + stringOpt: Maybe String, + intOpt: Maybe Int, + booleanOpt: Maybe Boolean, + decimalOpt: Maybe Decimal, + + stringT: Domains.StringT, + intT: Domains.IntT, + booleanT: Domains.BooleanT, + decimalT: Domains.DecimalT, + stringOptT: Maybe Domains.StringT, + intOptT: Maybe Domains.IntT, + booleanOptT: Maybe Domains.BooleanT, + decimalOptT: Maybe Domains.DecimalT, + + ref: Ref c, + refOpt: Maybe (Ref a), + anotherRef: Ref Int, + yetAnotherRef: Maybe (Ref String) + + arrayOfB: Array b, + aC: c, + + xx: MyList String, + yy: MyTuple String Int +} + +type Ref a: { + intTest: Int, + somethingA: a, +} + +type ArrayOfSomething a: Array a + +type Foo: Array String + +type RecordOfOther: { + x: Int, + y: Int, +} + +type MyList a: [ + | Nil + | Cons a (MyList a) + ] + +type MyTuple a b: [ + | MyTuple a b + ] + +type Blarg: [ + | Blue String + | Green Int Int + | Red + ] + +type X: wrap String diff --git a/test/resources/parser/Printed.purs_ b/test/resources/parser/Printed.purs_ index 845d29e..13244bf 100644 --- a/test/resources/parser/Printed.purs_ +++ b/test/resources/parser/Printed.purs_ @@ -3,15 +3,22 @@ module Test.Printed where import Ccap.Codegen.Runtime as R +import Ccap.Common.Either (fromCodegenEither, toCodegenEither) as Ccap.Common.Either +import Data (Either) as Data import Data.Argonaut.Core as A import Data.Argonaut.Decode (class DecodeJson) import Data.Argonaut.Encode (class EncodeJson) +import Data.Array as Array +import Data.Bifunctor as B import Data.Decimal (Decimal) +import Data.Either (Either(..)) +import Data.Either as E import Data.Generic.Rep (class Generic) import Data.Generic.Rep.Show (genericShow) import Data.Maybe (Maybe) +import Data.Maybe as M import Data.Newtype (class Newtype) -import Data.Tuple (Tuple(..)) +import Data.Tuple as T import Foreign.Object as FO import Prelude import Test.Imported as Imported @@ -49,33 +56,35 @@ instance showTagType :: Show TagType where show a = genericShow a jsonCodec_TagType :: R.JsonCodec TagType jsonCodec_TagType = - R.codec_newtype (R.jsonCodec_int) + R.codec_newtype R.jsonCodec_int -type Optional = Maybe (Int) +type Optional = Maybe Int jsonCodec_Optional :: R.JsonCodec Optional jsonCodec_Optional = - (R.jsonCodec_maybe R.jsonCodec_int) + R.jsonCodec_maybe R.jsonCodec_int -type Collection = Array (Int) +type Collection = Array Int jsonCodec_Collection :: R.JsonCodec Collection jsonCodec_Collection = - (R.jsonCodec_array R.jsonCodec_int) + R.jsonCodec_array R.jsonCodec_int type Point = { x :: Int , y :: Int } +type DecoderApi_Point = + R.StandardDecoderApi +decoderApi_Point :: DecoderApi_Point +decoderApi_Point = + R.standardDecoderApi +foreign import decode_Point :: DecoderApi_Point -> A.Json -> E.Either String Point jsonCodec_Point :: R.JsonCodec Point jsonCodec_Point = - { decode: \j -> do - o <- R.obj j - x <- R.decodeProperty "x" R.jsonCodec_int o - y <- R.decodeProperty "y" R.jsonCodec_int o - pure { x, y } + { decode: decode_Point (decoderApi_Point) , encode: \p -> A.fromObject $ FO.fromFoldable - [ Tuple "x" (R.jsonCodec_int.encode p.x) - , Tuple "y" (R.jsonCodec_int.encode p.y) + [ T.Tuple "x" (R.jsonCodec_int.encode p.x) + , T.Tuple "y" (R.jsonCodec_int.encode p.y) ] } @@ -94,22 +103,233 @@ jsonCodec_Validated :: R.JsonCodec Validated jsonCodec_Validated = R.jsonCodec_string -type ValidatedMaybe = Maybe (String) +type ValidatedMaybe = Maybe String jsonCodec_ValidatedMaybe :: R.JsonCodec ValidatedMaybe jsonCodec_ValidatedMaybe = - (R.jsonCodec_maybe R.jsonCodec_string) + R.jsonCodec_maybe R.jsonCodec_string type ValidatedRec = { name :: String } +type DecoderApi_ValidatedRec = + R.StandardDecoderApi +decoderApi_ValidatedRec :: DecoderApi_ValidatedRec +decoderApi_ValidatedRec = + R.standardDecoderApi +foreign import decode_ValidatedRec :: DecoderApi_ValidatedRec -> A.Json -> E.Either String ValidatedRec jsonCodec_ValidatedRec :: R.JsonCodec ValidatedRec jsonCodec_ValidatedRec = - { decode: \j -> do - o <- R.obj j - name <- R.decodeProperty "name" R.jsonCodec_string o - pure { name } + { decode: decode_ValidatedRec (decoderApi_ValidatedRec) , encode: \p -> A.fromObject $ FO.fromFoldable - [ Tuple "name" (R.jsonCodec_string.encode p.name) + [ T.Tuple "name" (R.jsonCodec_string.encode p.name) ] } + +type ArrayOfArrayOfArrayString = Array (Array (Array String)) +jsonCodec_ArrayOfArrayOfArrayString :: R.JsonCodec ArrayOfArrayOfArrayString +jsonCodec_ArrayOfArrayOfArrayString = + R.jsonCodec_array (R.jsonCodec_array (R.jsonCodec_array R.jsonCodec_string)) + +type ArrayOfSomething a = Array a +jsonCodec_ArrayOfSomething :: forall a. R.JsonCodec a -> R.JsonCodec (ArrayOfSomething a) +jsonCodec_ArrayOfSomething jsonCodec_param_a = + R.jsonCodec_array jsonCodec_param_a + +data Either a b = + Left a + | Right b +derive instance eqEither :: (Eq a, Eq b) => Eq (Either a b) +derive instance ordEither :: (Ord a, Ord b) => Ord (Either a b) +derive instance genericEither :: Generic (Either a b) _ +instance showEither :: (Show a, Show b) => Show (Either a b) where + show a = genericShow a +jsonCodec_Either :: forall a b. R.JsonCodec a -> R.JsonCodec b -> R.JsonCodec (Either a b) +jsonCodec_Either jsonCodec_param_a jsonCodec_param_b = + R.composeCodec + { decode: case _ of + T.Tuple "Left" [jsonParam_0] -> do + param_0 <- jsonCodec_param_a.decode jsonParam_0 + E.Right (Left param_0) + T.Tuple "Right" [jsonParam_0] -> do + param_0 <- jsonCodec_param_b.decode jsonParam_0 + E.Right (Right param_0) + T.Tuple cn params -> E.Left $ "Pattern match failed for " <> show cn <> " with " <> show (Array.length params) <> " parameters" + , encode: case _ of + Left param_0 -> T.Tuple "Left" [jsonCodec_param_a.encode param_0] + Right param_0 -> T.Tuple "Right" [jsonCodec_param_b.encode param_0] + } + R.jsonCodec_constructor + +type EitherWithStringError a = Either String a +jsonCodec_EitherWithStringError :: forall a. R.JsonCodec a -> R.JsonCodec (EitherWithStringError a) +jsonCodec_EitherWithStringError jsonCodec_param_a = + jsonCodec_Either R.jsonCodec_string jsonCodec_param_a + +data List a = + Nil + | Cons a (List a) +derive instance eqList :: Eq a => Eq (List a) +derive instance ordList :: Ord a => Ord (List a) +derive instance genericList :: Generic (List a) _ +instance showList :: Show a => Show (List a) where + show a = genericShow a +jsonCodec_List :: forall a. R.JsonCodec a -> R.JsonCodec (List a) +jsonCodec_List jsonCodec_param_a = + R.composeCodec + { decode: case _ of + T.Tuple "Nil" [] -> E.Right Nil + T.Tuple "Cons" [jsonParam_0, jsonParam_1] -> do + param_0 <- jsonCodec_param_a.decode jsonParam_0 + param_1 <- (jsonCodec_List jsonCodec_param_a).decode jsonParam_1 + E.Right (Cons param_0 param_1) + T.Tuple cn params -> E.Left $ "Pattern match failed for " <> show cn <> " with " <> show (Array.length params) <> " parameters" + , encode: case _ of + Nil -> T.Tuple "Nil" [] + Cons param_0 param_1 -> T.Tuple "Cons" [jsonCodec_param_a.encode param_0, (jsonCodec_List jsonCodec_param_a).encode param_1] + } + R.jsonCodec_constructor + +data Tuple a b = + Tuple a b +derive instance eqTuple :: (Eq a, Eq b) => Eq (Tuple a b) +derive instance ordTuple :: (Ord a, Ord b) => Ord (Tuple a b) +derive instance genericTuple :: Generic (Tuple a b) _ +instance showTuple :: (Show a, Show b) => Show (Tuple a b) where + show a = genericShow a +jsonCodec_Tuple :: forall a b. R.JsonCodec a -> R.JsonCodec b -> R.JsonCodec (Tuple a b) +jsonCodec_Tuple jsonCodec_param_a jsonCodec_param_b = + R.composeCodec + { decode: case _ of + T.Tuple "Tuple" [jsonParam_0, jsonParam_1] -> do + param_0 <- jsonCodec_param_a.decode jsonParam_0 + param_1 <- jsonCodec_param_b.decode jsonParam_1 + E.Right (Tuple param_0 param_1) + T.Tuple cn params -> E.Left $ "Pattern match failed for " <> show cn <> " with " <> show (Array.length params) <> " parameters" + , encode: case _ of + Tuple param_0 param_1 -> T.Tuple "Tuple" [jsonCodec_param_a.encode param_0, jsonCodec_param_b.encode param_1] + } + R.jsonCodec_constructor + +type NonEmptyList a = Tuple a (List a) +jsonCodec_NonEmptyList :: forall a. R.JsonCodec a -> R.JsonCodec (NonEmptyList a) +jsonCodec_NonEmptyList jsonCodec_param_a = + jsonCodec_Tuple jsonCodec_param_a (jsonCodec_List jsonCodec_param_a) + +type AnotherNonEmptyList a = + { head :: a + , tail :: List a + } +type DecoderApi_AnotherNonEmptyList a = + { nothing :: forall a. M.Maybe a + , just :: forall a. a -> M.Maybe a + , isLeft :: forall a b. E.Either a b -> Boolean + , fromRight :: forall a b. Partial => E.Either a b -> b + , right :: forall a b. b -> E.Either a b + , left :: forall a b. a -> E.Either a b + , addErrorPrefix :: forall a. String -> E.Either String a -> E.Either String a + , jsonCodec_primitive_decimal :: R.JsonCodec Decimal + , jsonCodec_head :: R.JsonCodec a + , jsonCodec_tail :: R.JsonCodec (List a) + } +decoderApi_AnotherNonEmptyList :: forall a. R.JsonCodec a -> DecoderApi_AnotherNonEmptyList a +decoderApi_AnotherNonEmptyList jsonCodec_param_a = + { nothing: M.Nothing + , just: M.Just + , isLeft: E.isLeft + , fromRight: E.fromRight + , right: E.Right + , left: E.Left + , addErrorPrefix: \s -> B.lmap (s <> _) + , jsonCodec_primitive_decimal: R.jsonCodec_decimal + , jsonCodec_head: jsonCodec_param_a + , jsonCodec_tail: jsonCodec_List jsonCodec_param_a + } +foreign import decode_AnotherNonEmptyList :: forall a. DecoderApi_AnotherNonEmptyList a -> A.Json -> E.Either String (AnotherNonEmptyList a) +jsonCodec_AnotherNonEmptyList :: forall a. R.JsonCodec a -> R.JsonCodec (AnotherNonEmptyList a) +jsonCodec_AnotherNonEmptyList jsonCodec_param_a = + { decode: decode_AnotherNonEmptyList (decoderApi_AnotherNonEmptyList jsonCodec_param_a) + , encode: \p -> A.fromObject $ + FO.fromFoldable + [ T.Tuple "head" (jsonCodec_param_a.encode p.head) + , T.Tuple "tail" ((jsonCodec_List jsonCodec_param_a).encode p.tail) + ] + } + +type NonEmptyArray a = Tuple a (Array a) +jsonCodec_NonEmptyArray :: forall a. R.JsonCodec a -> R.JsonCodec (NonEmptyArray a) +jsonCodec_NonEmptyArray jsonCodec_param_a = + jsonCodec_Tuple jsonCodec_param_a (R.jsonCodec_array jsonCodec_param_a) + +data Enum = + Red + | Green + | Blue +derive instance eqEnum :: Eq Enum +derive instance ordEnum :: Ord Enum +derive instance genericEnum :: Generic Enum _ +instance showEnum :: Show Enum where + show a = genericShow a +jsonCodec_Enum :: R.JsonCodec Enum +jsonCodec_Enum = + R.composeCodec + { decode: case _ of + "Red" -> Right Red + "Green" -> Right Green + "Blue" -> Right Blue + s -> Left $ "Invalid value " <> show s <> " for Enum" + , encode: case _ of + Red -> "Red" + Green -> "Green" + Blue -> "Blue" + } + R.jsonCodec_string + +type RecordOfStrings = + { a :: List String + , b :: List String + , c :: List String + } +type DecoderApi_RecordOfStrings = + { nothing :: forall a. M.Maybe a + , just :: forall a. a -> M.Maybe a + , isLeft :: forall a b. E.Either a b -> Boolean + , fromRight :: forall a b. Partial => E.Either a b -> b + , right :: forall a b. b -> E.Either a b + , left :: forall a b. a -> E.Either a b + , addErrorPrefix :: forall a. String -> E.Either String a -> E.Either String a + , jsonCodec_primitive_decimal :: R.JsonCodec Decimal + , jsonCodec_a :: R.JsonCodec (List String) + , jsonCodec_b :: R.JsonCodec (List String) + , jsonCodec_c :: R.JsonCodec (List String) + } +decoderApi_RecordOfStrings :: DecoderApi_RecordOfStrings +decoderApi_RecordOfStrings = + { nothing: M.Nothing + , just: M.Just + , isLeft: E.isLeft + , fromRight: E.fromRight + , right: E.Right + , left: E.Left + , addErrorPrefix: \s -> B.lmap (s <> _) + , jsonCodec_primitive_decimal: R.jsonCodec_decimal + , jsonCodec_a: jsonCodec_List R.jsonCodec_string + , jsonCodec_b: jsonCodec_List R.jsonCodec_string + , jsonCodec_c: jsonCodec_List R.jsonCodec_string + } +foreign import decode_RecordOfStrings :: DecoderApi_RecordOfStrings -> A.Json -> E.Either String RecordOfStrings +jsonCodec_RecordOfStrings :: R.JsonCodec RecordOfStrings +jsonCodec_RecordOfStrings = + { decode: decode_RecordOfStrings (decoderApi_RecordOfStrings) + , encode: \p -> A.fromObject $ + FO.fromFoldable + [ T.Tuple "a" ((jsonCodec_List R.jsonCodec_string).encode p.a) + , T.Tuple "b" ((jsonCodec_List R.jsonCodec_string).encode p.b) + , T.Tuple "c" ((jsonCodec_List R.jsonCodec_string).encode p.c) + ] + } + +type NativeEither a b = Data.Either +jsonCodec_NativeEither :: forall a b. R.JsonCodec a -> R.JsonCodec b -> R.JsonCodec (NativeEither a b) +jsonCodec_NativeEither jsonCodec_param_a jsonCodec_param_b = + R.codec_custom Ccap.Common.Either.fromCodegenEither Ccap.Common.Either.toCodegenEither (jsonCodec_Either jsonCodec_param_a jsonCodec_param_b) diff --git a/test/resources/parser/Printed.scala b/test/resources/parser/Printed.scala index 7eac26c..6e5086d 100644 --- a/test/resources/parser/Printed.scala +++ b/test/resources/parser/Printed.scala @@ -9,25 +9,25 @@ import scalaz.Monad object Printed { type YesNo = Boolean - lazy val jsonEncoderYesNo: Encoder[YesNo, argonaut.Json] = + def jsonEncoderYesNo: Encoder[YesNo, argonaut.Json] = Encoder.boolean def jsonDecoderYesNo[M[_]: Monad]: Decoder.Field[M, YesNo] = Decoder.boolean type Number = BigDecimal - lazy val jsonEncoderNumber: Encoder[Number, argonaut.Json] = + def jsonEncoderNumber: Encoder[Number, argonaut.Json] = Encoder.decimal def jsonDecoderNumber[M[_]: Monad]: Decoder.Field[M, Number] = Decoder.decimal type Text = String - lazy val jsonEncoderText: Encoder[Text, argonaut.Json] = + def jsonEncoderText: Encoder[Text, argonaut.Json] = Encoder.string def jsonDecoderText[M[_]: Monad]: Decoder.Field[M, Text] = Decoder.string type Integer = Int - lazy val jsonEncoderInteger: Encoder[Integer, argonaut.Json] = + def jsonEncoderInteger: Encoder[Integer, argonaut.Json] = Encoder.int def jsonDecoderInteger[M[_]: Monad]: Decoder.Field[M, Integer] = Decoder.int @@ -35,19 +35,19 @@ object Printed { final abstract class TagTypeT type TagType = scalaz.@@[Int, TagTypeT] val TagType: scalaz.Tag.TagOf[TagTypeT] = scalaz.Tag.of[TagTypeT] - lazy val jsonEncoderTagType: Encoder[TagType, argonaut.Json] = + def jsonEncoderTagType: Encoder[TagType, argonaut.Json] = Encoder.int.tagged def jsonDecoderTagType[M[_]: Monad]: Decoder.Field[M, TagType] = Decoder.int.tagged type Optional = Option[Int] - lazy val jsonEncoderOptional: Encoder[Optional, argonaut.Json] = + def jsonEncoderOptional: Encoder[Optional, argonaut.Json] = Encoder.int.option def jsonDecoderOptional[M[_]: Monad]: Decoder.Field[M, Optional] = Decoder.int.option type Collection = List[Int] - lazy val jsonEncoderCollection: Encoder[Collection, argonaut.Json] = + def jsonEncoderCollection: Encoder[Collection, argonaut.Json] = Encoder.int.list def jsonDecoderCollection[M[_]: Monad]: Decoder.Field[M, Collection] = Decoder.int.list @@ -56,7 +56,7 @@ object Printed { x: Int, y: Int, ) - lazy val jsonEncoderPoint: Encoder[Point, argonaut.Json] = + def jsonEncoderPoint: Encoder[Point, argonaut.Json] = x => argonaut.Json.obj( "x" -> Encoder.int.encode(x.x), "y" -> Encoder.int.encode(x.y), @@ -74,25 +74,25 @@ object Printed { } type InternalRef = Integer - lazy val jsonEncoderInternalRef: Encoder[InternalRef, argonaut.Json] = + def jsonEncoderInternalRef: Encoder[InternalRef, argonaut.Json] = jsonEncoderInteger def jsonDecoderInternalRef[M[_]: Monad]: Decoder.Field[M, InternalRef] = jsonDecoderInteger type ExternalRef = Imported.ImportedType - lazy val jsonEncoderExternalRef: Encoder[ExternalRef, argonaut.Json] = + def jsonEncoderExternalRef: Encoder[ExternalRef, argonaut.Json] = Imported.jsonEncoderImportedType def jsonDecoderExternalRef[M[_]: Monad]: Decoder.Field[M, ExternalRef] = Imported.jsonDecoderImportedType type Validated = String - lazy val jsonEncoderValidated: Encoder[Validated, argonaut.Json] = + def jsonEncoderValidated: Encoder[Validated, argonaut.Json] = Encoder.string def jsonDecoderValidated[M[_]: Monad]: Decoder.Field[M, Validated] = Decoder.string.maxLength(5) type ValidatedMaybe = Option[String] - lazy val jsonEncoderValidatedMaybe: Encoder[ValidatedMaybe, argonaut.Json] = + def jsonEncoderValidatedMaybe: Encoder[ValidatedMaybe, argonaut.Json] = Encoder.string.option def jsonDecoderValidatedMaybe[M[_]: Monad]: Decoder.Field[M, ValidatedMaybe] = Decoder.string.maxLength(5).option @@ -100,7 +100,7 @@ object Printed { final case class ValidatedRec( name: String, ) - lazy val jsonEncoderValidatedRec: Encoder[ValidatedRec, argonaut.Json] = + def jsonEncoderValidatedRec: Encoder[ValidatedRec, argonaut.Json] = x => argonaut.Json.obj( "name" -> Encoder.string.encode(x.name), ) @@ -112,4 +112,141 @@ object Printed { } } + type ArrayOfArrayOfArrayString = List[List[List[String]]] + def jsonEncoderArrayOfArrayOfArrayString: Encoder[ArrayOfArrayOfArrayString, argonaut.Json] = + Encoder.string.list.list.list + def jsonDecoderArrayOfArrayOfArrayString[M[_]: Monad]: Decoder.Field[M, ArrayOfArrayOfArrayString] = + Decoder.string.list.list.list + + type ArrayOfSomething[A] = List[A] + def jsonEncoderArrayOfSomething[A](jsonEncoder_param_A: Encoder[A, argonaut.Json]): Encoder[ArrayOfSomething[A], argonaut.Json] = + jsonEncoder_param_A.list + // Scala decoders that involve parameterized types are not supported + + sealed trait Either[A, B] + object Either { + final case class Left[A, B](param_0: A) extends Either[A, B] + final case class Right[A, B](param_0: B) extends Either[A, B] + } + def jsonEncoderEither[A, B](jsonEncoder_param_A: Encoder[A, argonaut.Json], jsonEncoder_param_B: Encoder[B, argonaut.Json]): Encoder[Either[A, B], argonaut.Json] = + _ match { + case Either.Left(param_0) => Encoder.constructor("Left", List(jsonEncoder_param_A.encode(param_0))) + case Either.Right(param_0) => Encoder.constructor("Right", List(jsonEncoder_param_B.encode(param_0))) + } + // Scala decoders that involve parameterized types are not supported + + type EitherWithStringError[A] = Either[String, A] + def jsonEncoderEitherWithStringError[A](jsonEncoder_param_A: Encoder[A, argonaut.Json]): Encoder[EitherWithStringError[A], argonaut.Json] = + jsonEncoderEither(Encoder.string, jsonEncoder_param_A) + // Scala decoders that involve parameterized types are not supported + + sealed trait List[A] + object List { + final case class Nil[A]() extends List[A] + final case class Cons[A](param_0: A, param_1: List[A]) extends List[A] + } + def jsonEncoderList[A](jsonEncoder_param_A: Encoder[A, argonaut.Json]): Encoder[List[A], argonaut.Json] = + _ match { + case List.Nil() => Encoder.constructor("Nil", Nil) + case List.Cons(param_0, param_1) => Encoder.constructor("Cons", List(jsonEncoder_param_A.encode(param_0), jsonEncoderList(jsonEncoder_param_A).encode(param_1))) + } + // Scala decoders that involve parameterized types are not supported + + + final case class Tuple[A, B](param_0: A, param_1: B) + def jsonEncoderTuple[A, B](jsonEncoder_param_A: Encoder[A, argonaut.Json], jsonEncoder_param_B: Encoder[B, argonaut.Json]): Encoder[Tuple[A, B], argonaut.Json] = + _ match { + case Tuple(param_0, param_1) => Encoder.constructor("Tuple", List(jsonEncoder_param_A.encode(param_0), jsonEncoder_param_B.encode(param_1))) + } + // Scala decoders that involve parameterized types are not supported + + type NonEmptyList[A] = Tuple[A, List[A]] + def jsonEncoderNonEmptyList[A](jsonEncoder_param_A: Encoder[A, argonaut.Json]): Encoder[NonEmptyList[A], argonaut.Json] = + jsonEncoderTuple(jsonEncoder_param_A, jsonEncoderList(jsonEncoder_param_A)) + // Scala decoders that involve parameterized types are not supported + + final case class AnotherNonEmptyList[A]( + head: A, + tail: List[A], + ) + def jsonEncoderAnotherNonEmptyList[A](jsonEncoder_param_A: Encoder[A, argonaut.Json]): Encoder[AnotherNonEmptyList[A], argonaut.Json] = + x => argonaut.Json.obj( + "head" -> jsonEncoder_param_A.encode(x.head), + "tail" -> jsonEncoderList(jsonEncoder_param_A).encode(x.tail), + ) + // Scala decoders that involve parameterized types are not supported + object AnotherNonEmptyList { + object FieldNames { + val Head: String = "head" + val Tail: String = "tail" + } + } + + type NonEmptyArray[A] = Tuple[A, List[A]] + def jsonEncoderNonEmptyArray[A](jsonEncoder_param_A: Encoder[A, argonaut.Json]): Encoder[NonEmptyArray[A], argonaut.Json] = + jsonEncoderTuple(jsonEncoder_param_A, jsonEncoder_param_A.list) + // Scala decoders that involve parameterized types are not supported + + sealed trait Enum { + def tag: String + } + object Enum { + case object Red extends Enum { + override def tag: String = "Red" + } + case object Green extends Enum { + override def tag: String = "Green" + } + case object Blue extends Enum { + override def tag: String = "Blue" + } + } + def jsonEncoderEnum: Encoder[Enum, argonaut.Json] = + Encoder.string.compose( + _.tag + ) + def jsonDecoderEnum[M[_]: Monad]: Decoder.Field[M, Enum] = + Decoder.string.disjunction.andThen( + Decoder.enum[M, Enum]( + "Enum", + ("Red", Enum.Red), + ("Green", Enum.Green), + ("Blue", Enum.Blue), + ) + .disjunction + ) + .validation + + final case class RecordOfStrings( + a: List[String], + b: List[String], + c: List[String], + ) + def jsonEncoderRecordOfStrings: Encoder[RecordOfStrings, argonaut.Json] = + x => argonaut.Json.obj( + "a" -> jsonEncoderList(Encoder.string).encode(x.a), + "b" -> jsonEncoderList(Encoder.string).encode(x.b), + "c" -> jsonEncoderList(Encoder.string).encode(x.c), + ) + def jsonDecoderRecordOfStrings[M[_]: Monad]: Decoder.Form[M, RecordOfStrings] = + scalaz.Apply[Decoder.Form[M, *]].apply3( + jsonDecoderList.property("a"), + jsonDecoderList.property("b"), + jsonDecoderList.property("c"), + )(RecordOfStrings.apply) + object RecordOfStrings { + object FieldNames { + val A: String = "a" + val B: String = "b" + val C: String = "c" + } + } + + type NativeEither = scala.Either + def jsonEncoderNativeEither[A, B](jsonEncoder_param_A: Encoder[A, argonaut.Json], jsonEncoder_param_B: Encoder[B, argonaut.Json]): Encoder[NativeEither[A, B], argonaut.Json] = + jsonEncoderEither(jsonEncoder_param_A, jsonEncoder_param_B).compose( + Encoder.either + ) + // Scala decoders that involve parameterized types are not supported + } diff --git a/test/resources/parser/Printed.tmpl b/test/resources/parser/Printed.tmpl index 92597bd..4459267 100644 --- a/test/resources/parser/Printed.tmpl +++ b/test/resources/parser/Printed.tmpl @@ -22,3 +22,37 @@ type ValidatedRec: { name: String } +type ArrayOfArrayOfArrayString: Array (Array (Array String)) +type ArrayOfSomething a: Array a +type Either a b: [ + | Left a + | Right b + ] +type EitherWithStringError a: Either String a +type List a: [ + | Nil + | Cons a (List a) + ] +type Tuple a b: [ + | Tuple a b + ] +type NonEmptyList a: Tuple a (List a) +type AnotherNonEmptyList a: { + head: a + tail: List a +} +type NonEmptyArray a: Tuple a (Array a) +type Enum: [ + | Red + | Green + | Blue +] +type RecordOfStrings: { + a: List String, + b: List String + + c: List String +} +type NativeEither a b: wrap (Either a b) + +