nirum 0.1.0 → 0.2.0
raw patch · 36 files changed
+1740/−933 lines, 36 filesdep +mtl
Dependencies added: mtl
Files
- README.md +45/−16
- nirum.cabal +22/−6
- src/Nirum/Cli.hs +1/−2
- src/Nirum/CodeGen.hs +42/−0
- src/Nirum/Constructs/Annotation.hs +46/−30
- src/Nirum/Constructs/Annotation/Internal.hs +49/−0
- src/Nirum/Constructs/Declaration.hs +8/−39
- src/Nirum/Constructs/Docs.hs +45/−0
- src/Nirum/Constructs/Identifier.hs +3/−3
- src/Nirum/Constructs/Module.hs +22/−18
- src/Nirum/Constructs/ModulePath.hs +1/−1
- src/Nirum/Constructs/Name.hs +0/−1
- src/Nirum/Constructs/Service.hs +25/−21
- src/Nirum/Constructs/TypeDeclaration.hs +73/−60
- src/Nirum/Constructs/TypeExpression.hs +13/−2
- src/Nirum/Package.hs +2/−2
- src/Nirum/Parser.hs +110/−35
- src/Nirum/Targets/Python.hs +217/−162
- test/Nirum/CliSpec.hs +1/−1
- test/Nirum/CodeGenSpec.hs +39/−0
- test/Nirum/Constructs/AnnotationSpec.hs +59/−10
- test/Nirum/Constructs/DeclarationSetSpec.hs +8/−6
- test/Nirum/Constructs/DeclarationSpec.hs +0/−33
- test/Nirum/Constructs/DocsSpec.hs +32/−0
- test/Nirum/Constructs/IdentifierSpec.hs +0/−1
- test/Nirum/Constructs/ModulePathSpec.hs +1/−1
- test/Nirum/Constructs/ModuleSpec.hs +12/−12
- test/Nirum/Constructs/NameSpec.hs +0/−1
- test/Nirum/Constructs/ServiceSpec.hs +232/−0
- test/Nirum/Constructs/TypeDeclarationSpec.hs +46/−54
- test/Nirum/Constructs/TypeExpressionSpec.hs +0/−1
- test/Nirum/PackageSpec.hs +28/−25
- test/Nirum/ParserSpec.hs +329/−143
- test/Nirum/Targets/PythonSpec.hs +221/−245
- test/Nirum/VersionSpec.hs +1/−2
- test/Util.hs +7/−0
README.md view
@@ -1,6 +1,20 @@ Nirum ===== +[![Build Status (Travis CI)][ci-svg]][ci]+[![Build Status (AppVeyor)][ciw-svg]][ciw]+[![Docker Automated Build][docker-svg]][docker]+[![Gitter][chat-svg]][chat]++[ci-svg]: https://travis-ci.org/spoqa/nirum.svg+[ci]: https://travis-ci.org/spoqa/nirum+[ciw-svg]: https://ci.appveyor.com/api/projects/status/jf9bsrnalcb1xrp0?svg=true+[ciw]: https://ci.appveyor.com/project/dahlia/nirum-k5n5y+[docker]: https://hub.docker.com/r/spoqa/nirum/+[docker-svg]: https://img.shields.io/docker/automated/spoqa/nirum.svg+[chat-svg]: https://badges.gitter.im/spoqa/nirum.svg+[chat]: https://gitter.im/spoqa/nirum?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge+ Nirum is an [IDL][1] compiler and [RPC][2]/[distributed object][3] framework for [microservices][4], built on top of the modern Web server technologies such as RESTful HTTP and JSON.@@ -17,26 +31,20 @@ [4]: https://en.wikipedia.org/wiki/Microservices -Installation---------------If you already installed [Haskell Platform][5] or [Haskell Stack][6],-you can build the project in the same way other Haskell projects are built:-- $ cabal sandbox init- $ cabal install --only-dependencies- $ cabal configure- $ cabal build--or:+Nightly builds+-------------- - $ stack build+The easiest way to give a try to use Nirum is downloading a nightly build.+We currently provides the prebuilt binaries of the following platforms: -[5]: https://www.haskell.org/platform/-[6]: https://www.haskellstack.org/+- [Linux (x86_64)](https://nightly-builds.nirum.org/travis-builds/nirum-linux-x86_64)+- [Mac (x86_64)](https://nightly-builds.nirum.org/travis-builds/nirum-darwin-x86_64)+- [Windows (x64)](https://ci.appveyor.com/api/projects/dahlia/nirum-k5n5y/artifacts/nirum-win-x64.exe?job=Platform%3A%20x64&branch=master)+- [Windows (x86)](https://ci.appveyor.com/api/projects/dahlia/nirum-k5n5y/artifacts/nirum-win-x86.exe?job=Platform%3A%20x86&branch=master)+- [Docker (`spoqa/nirum:latest`)][docker] -Getting Started+Getting started --------------- In order to compile a Nirum package (`examples/`) to a Python package:@@ -56,6 +64,27 @@ -? --help Display help message -V --version Print version information --numeric-version Print just the version number+++Building+--------++If you already installed [Haskell Platform][5] or [Haskell Stack][6],+you can build the project in the same way to build other Haskell projects.++Using Stack:++ $ stack build++Using vanilla Cabal:++ $ cabal sandbox init+ $ cabal install --only-dependencies+ $ cabal configure+ $ cabal build++[5]: https://www.haskell.org/platform/+[6]: https://www.haskellstack.org/ Etymology
nirum.cabal view
@@ -1,9 +1,15 @@ name: nirum-version: 0.1.0-synopsis: Distributed object framework built on top of- REST HTTP and JSON-description: Distributed object framework for microservices,- built on top of RESTful HTTP and JSON+version: 0.2.0+synopsis: IDL compiler and RPC/distributed object framework for+ microservices+description: Nirum is an IDL compiler and RPC/distributed object+ framework for microservices, built on top of the modern+ Web server technologies such as RESTful HTTP and JSON.+ .+ You can find how its IDL looks like from source codes in+ the examples/ directory.+ .+ See also README.md for more details. homepage: https://github.com/spoqa/nirum bug-reports: https://github.com/spoqa/nirum/issues license: GPL-3@@ -19,10 +25,13 @@ library exposed-modules: Nirum.Cli+ , Nirum.CodeGen , Nirum.Constructs , Nirum.Constructs.Annotation+ , Nirum.Constructs.Annotation.Internal , Nirum.Constructs.Declaration , Nirum.Constructs.DeclarationSet+ , Nirum.Constructs.Docs , Nirum.Constructs.Identifier , Nirum.Constructs.Module , Nirum.Constructs.ModulePath@@ -41,10 +50,12 @@ , filepath >=1.4 && <1.5 , interpolatedstring-perl6 >=1.0.0 && <1.1.0 , megaparsec >=5 && <5.1+ , mtl >=2.2.1 && <3 , semver >=0.3.0 && <1.0 , text >=0.9.1.0 && <1.3 hs-source-dirs: src default-language: Haskell2010+ default-extensions: OverloadedStrings ghc-options: -fwarn-incomplete-uni-patterns executable nirum@@ -69,20 +80,24 @@ hs-source-dirs: test main-is: Spec.hs other-modules: Nirum.CliSpec+ , Nirum.CodeGenSpec , Nirum.Constructs.AnnotationSpec- , Nirum.Constructs.DeclarationSpec+ , Nirum.Constructs.DocsSpec , Nirum.Constructs.DeclarationSetSpec , Nirum.Constructs.IdentifierSpec , Nirum.Constructs.ModuleSpec , Nirum.Constructs.ModulePathSpec , Nirum.Constructs.NameSpec+ , Nirum.Constructs.ServiceSpec , Nirum.Constructs.TypeDeclarationSpec , Nirum.Constructs.TypeExpressionSpec , Nirum.PackageSpec , Nirum.ParserSpec , Nirum.Targets.PythonSpec , Nirum.VersionSpec+ , Util default-language: Haskell2010+ default-extensions: OverloadedStrings build-depends: base >=4.7 && <5 , containers >=0.5.6.2 && <0.6 , directory@@ -92,6 +107,7 @@ , hspec-meta , interpolatedstring-perl6 >=1.0.0 && <1.1.0 , megaparsec >=5 && <5.1+ , mtl >=2.2.1 && <3 , nirum , process >=1.1 && <2 , semigroups
src/Nirum/Cli.hs view
@@ -1,5 +1,4 @@-{-# LANGUAGE ExtendedDefaultRules, OverloadedStrings, QuasiQuotes,- DeriveDataTypeable #-}+{-# LANGUAGE ExtendedDefaultRules, QuasiQuotes, DeriveDataTypeable #-} module Nirum.Cli (main, writeFiles) where import Control.Monad (forM_)
+ src/Nirum/CodeGen.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}+module Nirum.CodeGen ( CodeGen+ , Failure+ , fromString+ , runCodeGen+ ) where++import Control.Applicative (Applicative)+import Control.Monad (Monad)+import Control.Monad.Except (MonadError, ExceptT(ExceptT), mapExceptT, runExceptT)+import Control.Monad.State (MonadState, State, mapState, runState)+import Data.Functor (Functor)+++newtype CodeGen s e a = CodeGen (ExceptT e (State s) a)+ deriving ( Applicative+ , Functor+ , MonadError e+ , MonadState s+ )++class Failure s a where+ fromString :: MonadState s m => String -> m a++instance (Failure s e) => Monad (CodeGen s e) where+ return a = CodeGen $ ExceptT $ return (Right a)+ {-# INLINE return #-}+ (CodeGen m) >>= k = CodeGen $ ExceptT $ do+ a <- runExceptT m+ case a of+ Left e -> return (Left e)+ Right x -> let CodeGen n = k x in runExceptT n+ {-# INLINE (>>=) #-}+ fail str = CodeGen $ mapExceptT mutate (fromString str)+ where+ mutate = mapState (\(a, s) -> case a of+ Left _ -> undefined+ Right e -> (Left e, s))+ {-# INLINE fail #-}++runCodeGen :: CodeGen s e a -> s -> (Either e a, s)+runCodeGen (CodeGen a) = runState (runExceptT a)
src/Nirum/Constructs/Annotation.hs view
@@ -1,45 +1,33 @@-{-# LANGUAGE OverloadedStrings, QuasiQuotes #-} module Nirum.Constructs.Annotation ( Annotation(Annotation)- , AnnotationSet(AnnotationSet)+ , AnnotationSet , Metadata , NameDuplication(AnnotationNameDuplication) , annotations+ , docs , empty , fromList+ , insertDocs+ , lookup+ , lookupDocs+ , singleton , toCode , toList+ , union ) where +import Prelude hiding (lookup)+ import qualified Data.Map.Strict as M import qualified Data.Set as S-import qualified Data.Text as T-import Text.InterpolatedString.Perl6 (qq) import Nirum.Constructs (Construct (toCode))+import Nirum.Constructs.Annotation.Internal+import Nirum.Constructs.Docs (Docs (Docs), annotationDocsName, toText) import Nirum.Constructs.Identifier (Identifier) -type Metadata = T.Text---- | Annotation for 'Declaration'.-data Annotation = Annotation { name :: Identifier- , metadata :: Maybe Metadata- } deriving (Eq, Ord, Show)--instance Construct Annotation where- toCode Annotation {name = n, metadata = Just m} =- let m' = T.replace "\"" "\\\"" m in [qq|@{toCode n}("$m'")|]- toCode Annotation {name = n, metadata = Nothing} = [qq|@{toCode n}|]--data AnnotationSet- -- | The set of 'Annotation' values.- -- Every annotation name has to be unique in the set.- = AnnotationSet { annotations :: M.Map Identifier Annotation }- deriving (Eq, Ord, Show)--instance Construct AnnotationSet where- toCode AnnotationSet {annotations = annotations'} =- T.concat [s | e <- M.elems annotations', s <- [toCode e, "\n"]]+docs :: Docs -> Annotation+docs (Docs d) = Annotation { name = annotationDocsName, metadata = Just d } data NameDuplication = AnnotationNameDuplication Identifier deriving (Eq, Ord, Show)@@ -47,14 +35,18 @@ empty :: AnnotationSet empty = AnnotationSet { annotations = M.empty } +singleton :: Annotation -> AnnotationSet+singleton Annotation { name = name', metadata = metadata' } =+ AnnotationSet { annotations = M.singleton name' metadata' }+ fromList :: [Annotation] -> Either NameDuplication AnnotationSet fromList annotations' = case findDup names S.empty of Just duplication -> Left (AnnotationNameDuplication duplication)- _ -> Right AnnotationSet { annotations = M.fromList [ (name a, a)- | a <- annotations'- ]- }+ _ -> Right $ AnnotationSet ( M.fromList [ (name a, metadata a)+ | a <- annotations'+ ]+ ) where names :: [Identifier] names = [name a | a <- annotations']@@ -67,4 +59,28 @@ _ -> Nothing toList :: AnnotationSet -> [Annotation]-toList AnnotationSet { annotations = annotations' } = M.elems annotations'+toList AnnotationSet { annotations = annotations' } =+ map fromTuple $ M.assocs annotations'++union :: AnnotationSet -> AnnotationSet -> AnnotationSet+union (AnnotationSet a) (AnnotationSet b) = AnnotationSet $ M.union a b++lookup :: Identifier -> AnnotationSet -> Maybe Annotation+lookup id' (AnnotationSet anno) = do+ metadata' <- M.lookup id' anno+ return Annotation { name = id', metadata = metadata' }++lookupDocs :: AnnotationSet -> Maybe Docs+lookupDocs annotationSet = do+ Annotation _ m <- lookup annotationDocsName annotationSet+ data' <- m+ return $ Docs data'++insertDocs :: (Monad m) => Docs -> AnnotationSet -> m AnnotationSet+insertDocs docs' (AnnotationSet anno) =+ case insertLookup annotationDocsName (Just $ toText docs') anno of+ (Just _ , _ ) -> fail "<duplicated>"+ (Nothing, anno') -> return $ AnnotationSet anno'+ where+ insertLookup :: Ord k => k -> a -> M.Map k a -> (Maybe a, M.Map k a)+ insertLookup = M.insertLookupWithKey (\_ a _ -> a)
+ src/Nirum/Constructs/Annotation/Internal.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE QuasiQuotes #-}+module Nirum.Constructs.Annotation.Internal ( Annotation(..)+ , AnnotationSet(..)+ , Metadata+ , fromTuple+ ) where++import qualified Data.Char as C+import qualified Data.Map.Strict as M+import qualified Data.Text as T+import Text.InterpolatedString.Perl6 (qq)++import Nirum.Constructs (Construct (toCode))+import Nirum.Constructs.Docs (annotationDocsName)+import Nirum.Constructs.Identifier (Identifier)+++type Metadata = T.Text++-- | Annotation for 'Declaration'.+data Annotation = Annotation { name :: Identifier+ , metadata :: Maybe Metadata+ } deriving (Eq, Ord, Show)++instance Construct Annotation where+ toCode Annotation {name = n, metadata = Just m} = [qq|@{toCode n}("$m'")|]+ where+ m' = (showLitString $ T.unpack m) ""+ showLitString :: String -> ShowS+ showLitString = foldr ((.) . showLitChar') id+ showLitChar' :: Char -> ShowS+ showLitChar' '"' = showString "\\\""+ showLitChar' c = C.showLitChar c+ toCode Annotation {name = n, metadata = Nothing} = [qq|@{toCode n}|]++fromTuple :: (Identifier, Maybe Metadata) -> Annotation+fromTuple (name', meta') = Annotation { name = name', metadata = meta' }++data AnnotationSet+ -- | The set of 'Annotation' values.+ -- Every annotation name has to be unique in the set.+ = AnnotationSet { annotations :: M.Map Identifier (Maybe Metadata) }+ deriving (Eq, Ord, Show)++instance Construct AnnotationSet where+ toCode AnnotationSet {annotations = annotations'} =+ T.concat [s | e <- M.assocs annotations'+ , fst e /= annotationDocsName+ , s <- [toCode $ fromTuple e, "\n"]]
src/Nirum/Constructs/Declaration.hs view
@@ -1,49 +1,18 @@-{-# LANGUAGE OverloadedStrings #-} module Nirum.Constructs.Declaration ( Declaration- , Docs(Docs)+ , annotations , docs , name- , toCode- , toCodeWithPrefix- , toText ) where -import Data.String (IsString(fromString))--import qualified Data.Text as T--import Nirum.Constructs (Construct(toCode))+import Nirum.Constructs (Construct)+import Nirum.Constructs.Annotation (AnnotationSet, lookupDocs)+import Nirum.Constructs.Docs (Docs) import Nirum.Constructs.Name (Name) -- 'Construct' which has its own unique 'name' and can has its 'docs'. class Construct a => Declaration a where- name :: a -> Name- docs :: a -> Maybe Docs---- | Docstring for constructs.-data Docs = Docs T.Text deriving (Eq, Ord, Show)---- | Convert the docs to text.-toText :: Docs -> T.Text-toText (Docs docs') = docs'---- | Similar to 'toCode' except it takes 'Maybe Docs' instead of 'Docs'.--- If the given docs is 'Nothing' it simply returns an empty string.--- Otherwise it returns a code string with the prefix.-toCodeWithPrefix :: T.Text -- | The prefix to be prepended if not empty.- -> Maybe Docs -- | The docs to convert to code.- -> T.Text-toCodeWithPrefix _ Nothing = ""-toCodeWithPrefix prefix (Just docs') = T.append prefix $ toCode docs'--instance Construct Docs where- toCode (Docs docs') = let d = if "\n" `T.isSuffixOf` docs'- then T.dropEnd 1 docs'- else docs'- in T.append "# " $ T.replace "\n" "\n# " d+ name :: a -> Name+ annotations :: a -> AnnotationSet -instance IsString Docs where- fromString s = let t = T.pack s- in Docs (if "\n" `T.isSuffixOf` t- then t- else t `T.snoc` '\n')+docs :: Declaration a => a -> Maybe Docs+docs = lookupDocs . annotations
+ src/Nirum/Constructs/Docs.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE OverloadedStrings #-}+module Nirum.Constructs.Docs ( Docs(Docs)+ , annotationDocsName+ , toCode+ , toCodeWithPrefix+ , toText+ ) where++import Data.String (IsString(fromString))++import qualified Data.Text as T++import Nirum.Constructs (Construct(toCode))+import Nirum.Constructs.Identifier (Identifier)++annotationDocsName :: Identifier+annotationDocsName = "docs"++-- | Docstring for constructs.+data Docs = Docs T.Text deriving (Eq, Ord, Show)++-- | Convert the docs to text.+toText :: Docs -> T.Text+toText (Docs docs') = docs'++-- | Similar to 'toCode' except it takes 'Maybe Docs' instead of 'Docs'.+-- If the given docs is 'Nothing' it simply returns an empty string.+-- Otherwise it returns a code string with the prefix.+toCodeWithPrefix :: T.Text -- | The prefix to be prepended if not empty.+ -> Maybe Docs -- | The docs to convert to code.+ -> T.Text+toCodeWithPrefix _ Nothing = ""+toCodeWithPrefix prefix (Just docs') = T.append prefix $ toCode docs'++instance Construct Docs where+ toCode (Docs docs') = let d = if "\n" `T.isSuffixOf` docs'+ then T.dropEnd 1 docs'+ else docs'+ in T.append "# " $ T.replace "\n" "\n# " d++instance IsString Docs where+ fromString s = let t = T.pack s+ in Docs (if "\n" `T.isSuffixOf` t+ then t+ else t `T.snoc` '\n')
src/Nirum/Constructs/Identifier.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedLists, OverloadedStrings #-}+{-# LANGUAGE OverloadedLists #-} module Nirum.Constructs.Identifier ( Identifier , fromString , fromText@@ -52,12 +52,12 @@ data Identifier = Identifier T.Text deriving (Show) reservedKeywords :: S.Set Identifier-reservedKeywords = [ "boxed"- , "enum"+reservedKeywords = [ "enum" , "record" , "service" , "throws" , "type"+ , "unboxed" , "union" ]
src/Nirum/Constructs/Module.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedLists, OverloadedStrings, QuasiQuotes #-}+{-# LANGUAGE OverloadedLists, QuasiQuotes #-} module Nirum.Constructs.Module ( Module(Module, docs, types) , coreModule , coreModulePath@@ -13,7 +13,7 @@ import Nirum.Constructs (Construct(toCode)) import Nirum.Constructs.Annotation (empty)-import Nirum.Constructs.Declaration (Docs)+import Nirum.Constructs.Docs (Docs) import qualified Nirum.Constructs.DeclarationSet as DS import Nirum.Constructs.Identifier (Identifier) import Nirum.Constructs.ModulePath (ModulePath)@@ -56,7 +56,7 @@ imports :: Module -> M.Map ModulePath (S.Set Identifier) imports (Module decls _) =- M.fromListWith S.union [(p, [i]) | Import p i <- DS.toList decls]+ M.fromListWith S.union [(p, [i]) | Import p i _ <- DS.toList decls] coreModulePath :: ModulePath coreModulePath = ["core"]@@ -67,25 +67,29 @@ coreTypes :: DS.DeclarationSet TypeDeclaration coreTypes = -- number types- [ TypeDeclaration "bigint" (PrimitiveType Bigint String) Nothing empty- , TypeDeclaration "decimal" (PrimitiveType Decimal String) Nothing empty- , TypeDeclaration "int32" (PrimitiveType Int32 Number) Nothing empty- , TypeDeclaration "int64" (PrimitiveType Int64 Number) Nothing empty- , TypeDeclaration "float32" (PrimitiveType Float32 Number) Nothing empty- , TypeDeclaration "float64" (PrimitiveType Float64 Number) Nothing empty+ [ decl' "bigint" Bigint String+ , decl' "decimal" Decimal String+ , decl' "int32" Int32 Number+ , decl' "int64" Int64 Number+ , decl' "float32" Float32 Number+ , decl' "float64" Float64 Number -- string types- , TypeDeclaration "text" (PrimitiveType Text String) Nothing empty- , TypeDeclaration "binary" (PrimitiveType Binary String) Nothing empty+ , decl' "text" Text String+ , decl' "binary" Binary String -- time types- , TypeDeclaration- "date" (PrimitiveType Date String) Nothing empty- , TypeDeclaration- "datetime" (PrimitiveType Datetime String) Nothing empty+ , decl' "date" Date String+ , decl' "datetime" Datetime String -- et cetera- , TypeDeclaration "bool" (PrimitiveType Bool Boolean) Nothing empty- , TypeDeclaration "uuid" (PrimitiveType Uuid String) Nothing empty- , TypeDeclaration "uri" (PrimitiveType Uri String) Nothing empty+ , decl' "bool" Bool Boolean+ , decl' "uuid" Uuid String+ , decl' "uri" Uri String ]+ where+ decl' name prim json =+ TypeDeclaration { typename = name+ , type' = PrimitiveType prim json+ , typeAnnotations = empty+ } coreDocs :: Docs coreDocs = [q|
src/Nirum/Constructs/ModulePath.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings, TypeFamilies #-}+{-# LANGUAGE TypeFamilies #-} module Nirum.Constructs.ModulePath ( ModulePath( ModuleName , ModulePath , moduleName
src/Nirum/Constructs/Name.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE OverloadedStrings #-} module Nirum.Constructs.Name ( Name(Name) , behindName , facialName
src/Nirum/Constructs/Service.hs view
@@ -1,57 +1,55 @@-{-# LANGUAGE OverloadedStrings #-} module Nirum.Constructs.Service ( Method ( Method , methodAnnotations- , methodDocs , methodName , parameters , returnType ) , Parameter(Parameter) , Service(Service, methods)+ , methodDocs ) where import qualified Data.Text as T import Nirum.Constructs (Construct(toCode))-import Nirum.Constructs.Annotation (AnnotationSet)-import Nirum.Constructs.Declaration ( Declaration(name, docs)- , Docs- , toCodeWithPrefix- )+import Nirum.Constructs.Annotation (AnnotationSet, empty, lookupDocs)+import Nirum.Constructs.Declaration (Declaration(annotations, name), docs)+import Nirum.Constructs.Docs (Docs, toCodeWithPrefix) import Nirum.Constructs.DeclarationSet (DeclarationSet, toList) import Nirum.Constructs.Name (Name) import Nirum.Constructs.TypeExpression (TypeExpression) -- | 'Method' parameter.-data Parameter = Parameter Name TypeExpression (Maybe Docs)+data Parameter = Parameter Name TypeExpression AnnotationSet deriving (Eq, Ord, Show) instance Construct Parameter where- toCode (Parameter name' typeExpr docs') =+ toCode p@(Parameter name' typeExpr _) = T.concat [ toCode typeExpr , " " , toCode name' , ","- , toCodeWithPrefix "\n" docs'+ , toCodeWithPrefix "\n" (docs p) ] instance Declaration Parameter where name (Parameter name' _ _) = name'- docs (Parameter _ _ docs') = docs'+ annotations (Parameter _ _ anno') = anno' -- | 'Service' method. data Method = Method { methodName :: Name , parameters :: DeclarationSet Parameter , returnType :: TypeExpression , errorType :: Maybe TypeExpression- , methodDocs :: Maybe Docs , methodAnnotations :: AnnotationSet } deriving (Eq, Ord, Show) +methodDocs :: Method -> Maybe Docs+methodDocs = lookupDocs . methodAnnotations+ instance Construct Method where toCode method@Method { parameters = params , errorType = error'- , methodDocs = docs' , methodAnnotations = annotationSet' } = T.concat $ [ toCode annotationSet'@@ -60,15 +58,14 @@ , toCode $ methodName method , " (" , toCodeWithPrefix "\n " docs'- ] ++ case (docs', params') of+ ] ++ case (docs method, params') of (Nothing, []) -> [] (Just _, []) -> ["\n"]- (Nothing, [p@(Parameter _ _ Nothing)]) ->- [T.dropWhileEnd (== ',') $ toCode p]- _ -> [ "\n"- , T.intercalate "\n" $ map indentedCode params'- , "\n"- ]+ (Nothing, [p@(Parameter _ _ anno')]) ->+ if anno' == empty+ then [T.dropWhileEnd (== ',') $ toCode p]+ else verboseForm params'+ _ -> verboseForm params' ++ [")"] ++ case error' of Nothing -> []@@ -77,14 +74,21 @@ where params' :: [Parameter] params' = toList params+ docs' :: Maybe Docs+ docs' = docs method indentedCode :: Construct a => a -> T.Text indentedCode c = T.concat [ " " , T.intercalate "\n " $ T.lines (toCode c) ]+ verboseForm :: [Parameter] -> [T.Text]+ verboseForm p = [ "\n"+ , T.intercalate "\n" $ map indentedCode p+ , "\n"+ ] instance Declaration Method where name = methodName- docs = methodDocs+ annotations = methodAnnotations -- | RPC service. data Service =
src/Nirum/Constructs/TypeDeclaration.hs view
@@ -1,9 +1,16 @@-{-# LANGUAGE OverloadedStrings #-} module Nirum.Constructs.TypeDeclaration ( EnumMember(EnumMember)- , Field(Field)+ , Field ( Field+ , fieldAnnotations+ , fieldName+ , fieldType+ ) , JsonType(..) , PrimitiveTypeIdentifier(..)- , Tag(Tag)+ , Tag ( Tag+ , tagAnnotations+ , tagFields+ , tagName+ ) , Type(..) , TypeDeclaration( Import , ServiceDeclaration@@ -12,11 +19,9 @@ , modulePath , service , serviceAnnotations- , serviceDocs , serviceName , type' , typeAnnotations- , typeDocs , typename ) ) where@@ -27,23 +32,22 @@ import qualified Data.Text as T import Nirum.Constructs (Construct(toCode))-import Nirum.Constructs.Annotation (AnnotationSet)-import Nirum.Constructs.Declaration ( Declaration (..)- , Docs (..)- , toCodeWithPrefix- )+import Nirum.Constructs.Annotation as A (AnnotationSet, empty, lookupDocs)+import Nirum.Constructs.Declaration (Declaration(..), docs)+import Nirum.Constructs.Docs (Docs(..), toCodeWithPrefix) import Nirum.Constructs.DeclarationSet (DeclarationSet, null', toList) import Nirum.Constructs.Identifier (Identifier) import Nirum.Constructs.ModulePath (ModulePath) import Nirum.Constructs.Name (Name(Name))-import Nirum.Constructs.Service ( Method (Method, methodDocs)+import Nirum.Constructs.Service ( Method , Service (Service)+ , methodDocs ) import Nirum.Constructs.TypeExpression (TypeExpression) data Type = Alias { canonicalType :: TypeExpression }- | BoxedType { innerType :: TypeExpression }+ | UnboxedType { innerType :: TypeExpression } | EnumType { members :: DeclarationSet EnumMember } | RecordType { fields :: DeclarationSet Field } | UnionType { tags :: DeclarationSet Tag }@@ -53,52 +57,59 @@ deriving (Eq, Ord, Show) -- | Member of 'EnumType'.-data EnumMember = EnumMember Name (Maybe Docs) deriving (Eq, Ord, Show)+data EnumMember = EnumMember Name AnnotationSet deriving (Eq, Ord, Show) instance Construct EnumMember where- toCode (EnumMember name' docs') = T.concat [ toCode name'- , toCodeWithPrefix "\n" docs'- ]+ toCode e@(EnumMember name' _) = T.concat [ toCode name'+ , toCodeWithPrefix "\n" (docs e)+ ] instance Declaration EnumMember where name (EnumMember name' _) = name'- docs (EnumMember _ docs') = docs'+ annotations (EnumMember _ anno') = anno' instance IsString EnumMember where- fromString s = EnumMember (fromString s) Nothing+ fromString s = EnumMember (fromString s) A.empty -- | Field of 'RecordType' and 'Tag'.-data Field = Field Name TypeExpression (Maybe Docs) deriving (Eq, Ord, Show)+data Field = Field { fieldName :: Name+ , fieldType :: TypeExpression+ , fieldAnnotations :: AnnotationSet+ } deriving (Eq, Ord, Show) instance Construct Field where- toCode (Field name' typeExpr docs') = T.concat [ toCode typeExpr- , " "- , toCode name'- , ","- , toCodeWithPrefix "\n" docs'- ]+ toCode field@(Field name' typeExpr _) =+ T.concat [ toCode typeExpr+ , " "+ , toCode name'+ , ","+ , toCodeWithPrefix "\n" (docs field)+ ] instance Declaration Field where name (Field name' _ _) = name'- docs (Field _ _ docs') = docs'+ annotations (Field _ _ anno') = anno' -- | Tag of 'UnionType'.-data Tag = Tag Name (DeclarationSet Field) (Maybe Docs) deriving (Eq, Ord, Show)+data Tag = Tag { tagName :: Name+ , tagFields :: DeclarationSet Field+ , tagAnnotations :: AnnotationSet+ } deriving (Eq, Ord, Show) instance Construct Tag where- toCode (Tag name' fields' docs') =+ toCode tag@(Tag name' fields' _) = if null' fields'- then T.concat [toCode name', toCodeWithPrefix "\n" docs']+ then T.concat [toCode name', toCodeWithPrefix "\n" (docs tag)] else T.concat [ toCode name' , " (", fieldsCode, ")"- , toCodeWithPrefix "\n" docs'+ , toCodeWithPrefix "\n" (docs tag) ] where fieldsCode = T.intercalate " " $ map toCode $ toList fields' instance Declaration Tag where name (Tag name' _ _) = name'- docs (Tag _ _ docs') = docs'+ annotations (Tag _ _ anno') = anno' -- | Primitive type identifiers. data PrimitiveTypeIdentifier@@ -113,40 +124,39 @@ data TypeDeclaration = TypeDeclaration { typename :: Name , type' :: Type- , typeDocs :: Maybe Docs , typeAnnotations :: AnnotationSet } | ServiceDeclaration { serviceName :: Name , service :: Service- , serviceDocs :: Maybe Docs , serviceAnnotations :: AnnotationSet } | Import { modulePath :: ModulePath , importName :: Identifier+ , importAnnotations :: AnnotationSet } deriving (Eq, Ord, Show) instance Construct TypeDeclaration where- toCode (TypeDeclaration name' (Alias cname) docs' annotationSet') =+ toCode (TypeDeclaration name' (Alias cname) annotationSet') = T.concat [ toCode annotationSet' , "type ", toCode name' , " = ", toCode cname, ";"- , toCodeWithPrefix "\n" docs'+ , toCodeWithPrefix "\n" (A.lookupDocs annotationSet') ]- toCode (TypeDeclaration name' (BoxedType itype) docs' annotationSet') =+ toCode (TypeDeclaration name' (UnboxedType itype) annotationSet') = T.concat [ toCode annotationSet'- , "boxed ", toCode name'+ , "unboxed ", toCode name' , " (", toCode itype, ");"- , toCodeWithPrefix "\n" docs']- toCode (TypeDeclaration name' (EnumType members') docs' annotationSet') =+ , toCodeWithPrefix "\n" (A.lookupDocs annotationSet')]+ toCode (TypeDeclaration name' (EnumType members') annotationSet') = T.concat [ toCode annotationSet' , "enum ", toCode name'- , toCodeWithPrefix "\n " docs'+ , toCodeWithPrefix "\n " (A.lookupDocs annotationSet') , "\n = ", T.replace "\n" "\n " membersCode, "\n ;" ] where membersCode = T.intercalate "\n| " $ map toCode $ toList members'- toCode (TypeDeclaration name' (RecordType fields') docs' annotationSet') =+ toCode (TypeDeclaration name' (RecordType fields') annotationSet') = T.concat [ toCode annotationSet' , "record ", toCode name', " (" , toCodeWithPrefix "\n " docs'@@ -156,10 +166,11 @@ ] where fieldsCode = T.intercalate "\n" $ map toCode $ toList fields'- toCode (TypeDeclaration name' (UnionType tags') docs' annotationSet') =+ docs' = A.lookupDocs annotationSet'+ toCode (TypeDeclaration name' (UnionType tags') annotationSet') = T.concat [ toCode annotationSet' , "union ", nameCode- , toCodeWithPrefix "\n " docs'+ , toCodeWithPrefix "\n " (A.lookupDocs annotationSet') , "\n = " , tagsCode , "\n ;" ]@@ -173,13 +184,12 @@ ] toCode (TypeDeclaration name' (PrimitiveType typename' jsonType')- docs' annotationSet') = T.concat [ toCode annotationSet' , "// primitive type `", toCode name', "`\n" , "// internal type identifier: ", showT typename', "\n" , "// coded to json ", showT jsonType', " type\n"- , docString docs'+ , docString (A.lookupDocs annotationSet') ] where showT :: Show a => a -> T.Text@@ -188,15 +198,15 @@ docString Nothing = "" docString (Just (Docs d)) = T.concat ["\n// ", T.replace "\n" "\n// " $ T.stripEnd d, "\n"]- toCode (ServiceDeclaration name' (Service methods) docs' annotations') =+ toCode (ServiceDeclaration name' (Service methods) annotations') = T.concat [ toCode annotations' , "service " , toCode name' , " (" , toCodeWithPrefix "\n " docs'- , case (docs', methods') of+ , case (docs', map methodDocs methods') of (_, []) -> ""- (Nothing, [Method { methodDocs = Nothing }]) -> ""+ (Nothing, [Nothing]) -> "" _ -> "\n " , if length methods' > 1 then methodsText@@ -211,17 +221,20 @@ methods' = toList methods methodsText :: T.Text methodsText = T.intercalate "\n" $ map toCode methods'- toCode (Import path ident) = T.concat [ "import "- , toCode path- , " ("- , toCode ident- , ");\n"- ]+ docs' :: Maybe Docs+ docs' = A.lookupDocs annotations'+ toCode (Import path ident aSet) = T.concat [ "import "+ , toCode path+ , " ("+ , toCode aSet+ , toCode ident+ , ");\n"+ ] instance Declaration TypeDeclaration where- name (TypeDeclaration name' _ _ _) = name'- name (ServiceDeclaration name' _ _ _) = name'- name (Import _ identifier) = Name identifier identifier- docs (TypeDeclaration _ _ docs' _) = docs'- docs (ServiceDeclaration _ _ docs' _) = docs'- docs (Import _ _) = Nothing+ name TypeDeclaration { typename = name' } = name'+ name ServiceDeclaration { serviceName = name' } = name'+ name Import { importName = id' } = Name id' id'+ annotations TypeDeclaration { typeAnnotations = anno' } = anno'+ annotations ServiceDeclaration { serviceAnnotations = anno' } = anno'+ annotations Import { importAnnotations = anno' } = anno'
src/Nirum/Constructs/TypeExpression.hs view
@@ -1,5 +1,16 @@-{-# LANGUAGE OverloadedStrings #-}-module Nirum.Constructs.TypeExpression (TypeExpression(..), toCode) where+module Nirum.Constructs.TypeExpression ( TypeExpression ( ListModifier+ , MapModifier+ , OptionModifier+ , SetModifier+ , TypeIdentifier+ , elementType+ , identifier+ , keyType+ , type'+ , valueType+ )+ , toCode+ ) where import Data.String (IsString(fromString))
src/Nirum/Package.hs view
@@ -22,7 +22,7 @@ import System.Directory (doesDirectoryExist, listDirectory) import System.FilePath ((</>)) -import Nirum.Constructs.Declaration (Docs)+import Nirum.Constructs.Docs (Docs) import qualified Nirum.Constructs.DeclarationSet as DS import Nirum.Constructs.Identifier (Identifier) import qualified Nirum.Constructs.Module as Mod@@ -197,7 +197,7 @@ Nothing -> toType Mod.coreModulePath (DS.lookup identifier $ Mod.types Mod.coreModule) Just TypeDeclaration { type' = t } -> Local t- Just (Import path _) ->+ Just (Import path _ _) -> case resolveModule path (boundPackage boundModule) of Nothing -> Missing Just (Mod.Module decls _) ->
src/Nirum/Parser.hs view
@@ -1,11 +1,10 @@-{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-unused-do-bind #-} module Nirum.Parser ( Parser , ParseError , aliasTypeDeclaration , annotation , annotationSet- , boxedTypeDeclaration , docs , enumTypeDeclaration , file@@ -28,6 +27,7 @@ , typeExpression , typeExpressionWithoutOptionModifier , typeIdentifier+ , unboxedTypeDeclaration , unionTypeDeclaration ) where @@ -40,6 +40,7 @@ import qualified Data.Text as T import Data.Text.IO (readFile) import Text.Megaparsec ( Token+ , choice , eof , many , manyTill@@ -68,7 +69,8 @@ import Text.Megaparsec.Lexer (charLiteral) import qualified Nirum.Constructs.Annotation as A-import Nirum.Constructs.Declaration (Declaration, Docs(Docs))+import Nirum.Constructs.Declaration (Declaration)+import Nirum.Constructs.Docs (Docs(Docs)) import Nirum.Constructs.DeclarationSet ( DeclarationSet , NameDuplication( BehindNameDuplication , FacialNameDuplication@@ -92,14 +94,16 @@ , Field(Field) , Tag(Tag) , Type( Alias- , BoxedType , EnumType , RecordType+ , UnboxedType , UnionType ) , TypeDeclaration( Import , ServiceDeclaration , TypeDeclaration+ , serviceAnnotations+ , typeAnnotations ) ) import Nirum.Constructs.TypeExpression ( TypeExpression( ListModifier@@ -237,6 +241,13 @@ }) (eol >> spaces) <?> "comments" return $ Docs $ T.unlines comments +annotationsWithDocs :: Monad m+ => A.AnnotationSet+ -> Maybe Docs+ -> m A.AnnotationSet+annotationsWithDocs set' (Just docs') = A.insertDocs docs' set'+annotationsWithDocs set' Nothing = return set'+ aliasTypeDeclaration :: Parser TypeDeclaration aliasTypeDeclaration = do annotationSet' <- annotationSet <?> "type alias annotations"@@ -251,36 +262,41 @@ spaces char ';' docs' <- optional $ try $ spaces >> (docs <?> "type alias docs")- return $ TypeDeclaration name' (Alias canonicalType) docs' annotationSet'+ annotationSet'' <- annotationsWithDocs annotationSet' docs'+ return $ TypeDeclaration name' (Alias canonicalType) annotationSet'' -boxedTypeDeclaration :: Parser TypeDeclaration-boxedTypeDeclaration = do- annotationSet' <- annotationSet <?> "boxed type annotations"- string' "boxed" <?> "boxed type keyword"+unboxedTypeDeclaration :: Parser TypeDeclaration+unboxedTypeDeclaration = do+ annotationSet' <- annotationSet <?> "unboxed type annotations"+ string' "unboxed" <?> "unboxed type keyword" spaces- typename <- identifier <?> "boxed type name"+ typename <- identifier <?> "unboxed type name" let name' = Name typename typename spaces char '(' spaces- innerType <- typeExpression <?> "inner type of boxed type"+ innerType <- typeExpression <?> "inner type of unboxed type" spaces char ')' spaces char ';'- docs' <- optional $ try $ spaces >> (docs <?> "boxed type docs")- return $ TypeDeclaration name' (BoxedType innerType) docs' annotationSet'+ docs' <- optional $ try $ spaces >> (docs <?> "unboxed type docs")+ annotationSet'' <- annotationsWithDocs annotationSet' docs'+ return $ TypeDeclaration name' (UnboxedType innerType) annotationSet'' enumMember :: Parser EnumMember enumMember = do+ annotationSet' <- annotationSet <?> "enum member annotations"+ spaces memberName <- name <?> "enum member name" spaces docs' <- optional $ do d <- docs <?> "enum member docs" spaces return d- return $ EnumMember memberName docs'+ annotationSet'' <- annotationsWithDocs annotationSet' docs'+ return $ EnumMember memberName annotationSet'' handleNameDuplication :: Declaration a => String -> [a]@@ -315,6 +331,7 @@ d <- docs <?> "enum type docs" spaces return d+ annotationSet'' <- annotationsWithDocs annotationSet' docs' members <- (enumMember `sepBy1` (spaces >> char '|' >> spaces)) <?> "enum members" case fromList members of@@ -328,20 +345,24 @@ spaces char ';' return $ TypeDeclaration typename (EnumType memberSet)- docs' annotationSet'+ annotationSet'' fieldsOrParameters :: forall a. (String, String)- -> (Name -> TypeExpression -> Maybe Docs -> a)+ -> (Name -> TypeExpression -> A.AnnotationSet -> a) -> Parser [a] fieldsOrParameters (label, pluralLabel) make = do+ annotationSet' <- annotationSet <?> (label ++ " annotations")+ spaces type' <- typeExpression <?> (label ++ " type") spaces1 name' <- name <?> (label ++ " name") spaces- let makeWithDocs = make name' type'+ let makeWithDocs = make name' type' . A.union annotationSet'+ . annotationsFromDocs followedByComma makeWithDocs <|> do d <- optional docs' <?> (label ++ " docs") return [makeWithDocs d]+ where recur :: Parser [a] recur = fieldsOrParameters (label, pluralLabel) make@@ -357,6 +378,9 @@ d <- docs <?> (label ++ " docs") spaces return d+ annotationsFromDocs :: Maybe Docs -> A.AnnotationSet+ annotationsFromDocs Nothing = A.empty+ annotationsFromDocs (Just d) = A.singleton $ A.docs d fields :: Parser [Field] fields = fieldsOrParameters ("label", "labels") Field@@ -384,15 +408,20 @@ char ')' spaces char ';'- return $ TypeDeclaration typename (RecordType fields') docs' annotationSet'+ annotationSet'' <- annotationsWithDocs annotationSet' docs'+ return $ TypeDeclaration typename (RecordType fields') annotationSet'' tag :: Parser Tag tag = do+ annotationSet' <- annotationSet <?> "union tag annotations"+ spaces tagName <- name <?> "union tag name" spaces paren <- optional $ char '(' fields' <- case paren of- Just _ -> do { f <- fieldSet <?> "union tag fields"+ Just _ -> do { spaces+ ; f <- fieldSet <?> "union tag fields"+ ; spaces ; char ')' ; return f }@@ -401,7 +430,8 @@ d <- docs <?> "union tag docs" spaces return d- return $ Tag tagName fields' docs'+ annotationSet'' <- annotationsWithDocs annotationSet' docs'+ return $ Tag tagName fields' annotationSet'' unionTypeDeclaration :: Parser TypeDeclaration unionTypeDeclaration = do@@ -420,17 +450,36 @@ <?> "union tags" spaces char ';'+ annotationSet'' <- annotationsWithDocs annotationSet' docs' handleNameDuplication "tag" tags' $ \tagSet ->- return $ TypeDeclaration typename (UnionType tagSet) docs' annotationSet'+ return $ TypeDeclaration typename (UnionType tagSet) annotationSet'' typeDeclaration :: Parser TypeDeclaration-typeDeclaration =- ( try aliasTypeDeclaration <|>- try boxedTypeDeclaration <|>- try enumTypeDeclaration <|>- try recordTypeDeclaration <|>- unionTypeDeclaration- ) <?> "type declaration (e.g. boxed, enum, record, union)"+typeDeclaration = do+ -- Preconsume the common prefix (annotations) to disambiguate+ -- the continued branches of parsers.+ spaces+ annotationSet' <- annotationSet <?> "type annotations"+ spaces+ typeDecl <- choice+ [ unless' ["union", "record", "enum", "unboxed"] aliasTypeDeclaration+ , unless' ["union", "record", "enum"] unboxedTypeDeclaration+ , unless' ["union", "record"] enumTypeDeclaration+ , unless' ["union"] recordTypeDeclaration+ , unionTypeDeclaration+ ] <?> "type declaration (e.g. enum, record, unboxed, union)"+ -- In theory, though it preconsumes annotationSet' before parsing typeDecl+ -- so that typeDecl itself has no annotations, to prepare for an+ -- unlikely situation (that I bet it'll never happen)+ -- unite the preconsumed annotationSet' with typeDecl's annotations+ -- (that must be empty).+ let annotations = A.union annotationSet' $ typeAnnotations typeDecl+ return $ typeDecl { typeAnnotations = annotations }+ where+ unless' :: [String] -> Parser a -> Parser a+ unless' [] _ = fail "no candidates" -- Must never happen+ unless' [s] p = notFollowedBy (string s) >> p+ unless' (x:xs) p = notFollowedBy (string x) >> unless' xs p parameters :: Parser [Parameter] parameters = fieldsOrParameters ("parameter", "parameters") Parameter@@ -463,7 +512,8 @@ e <- typeExpression <?> "method error type" spaces return e- return $ Method methodName params returnType errorType docs' annotationSet'+ annotationSet'' <- annotationsWithDocs annotationSet' docs'+ return $ Method methodName params returnType errorType annotationSet'' methods :: Parser [Method] methods = method `sepEndBy` try (spaces >> char ',' >> spaces)@@ -491,8 +541,8 @@ char ')' spaces char ';'- return $ ServiceDeclaration serviceName (Service methods')- docs' annotationSet'+ annotationSet'' <- annotationsWithDocs annotationSet' docs'+ return $ ServiceDeclaration serviceName (Service methods') annotationSet'' modulePath :: Parser ModulePath modulePath = do@@ -509,6 +559,13 @@ f Nothing i = Just $ ModuleName i f (Just p) i = Just $ ModulePath p i +importName :: Parser (Identifier, A.AnnotationSet)+importName = do+ aSet <- annotationSet <?> "import annotations"+ spaces+ iName <- identifier <?> "name to import"+ return (iName, aSet)+ imports :: Parser [TypeDeclaration] imports = do string' "import" <?> "import keyword"@@ -517,14 +574,14 @@ spaces char '(' spaces- idents <- sepBy1 (identifier <?> "name to import")+ idents <- sepBy1 importName (spaces >> char ',' >> spaces) <?> "names to import" spaces char ')' spaces char ';'- return [Import path ident | ident <- idents]+ return [Import path ident aSet | (ident, aSet) <- idents] module' :: Parser Module@@ -540,8 +597,26 @@ spaces return importList types <- many $ do- typeDecl <- try typeDeclaration <|>- (serviceDeclaration <?> "service declaration")+ typeDecl <- do+ -- Preconsume the common prefix (annotations) to disambiguate+ -- the continued branches of parsers.+ spaces+ annotationSet' <- annotationSet <?> "annotations"+ spaces+ decl <- choice [ notFollowedBy (string "service") >> typeDeclaration+ , serviceDeclaration <?> "service declaration"+ ]+ -- In theory, though it preconsumes annotationSet' before parsing+ -- decl so that decl itself has no annotations, to prepare for an+ -- unlikely situation (that I bet it'll never happen)+ -- unite the preconsumed annotationSet' with decl's annotations+ -- (that must be empty).+ return $ case decl of+ TypeDeclaration { typeAnnotations = set } ->+ decl { typeAnnotations = A.union annotationSet' set }+ ServiceDeclaration { serviceAnnotations = set } ->+ decl { serviceAnnotations = A.union annotationSet' set }+ _ -> decl -- Never happen! spaces return typeDecl handleNameDuplication "type" (types ++ [i | l <- importLists, i <- l]) $
src/Nirum/Targets/Python.hs view
@@ -1,11 +1,11 @@-{-# LANGUAGE ExtendedDefaultRules, OverloadedLists, OverloadedStrings,- QuasiQuotes #-}+{-# LANGUAGE ExtendedDefaultRules, OverloadedLists, QuasiQuotes,+ TypeSynonymInstances, MultiParamTypeClasses #-} module Nirum.Targets.Python ( Code- , CodeGen( code- , localImports- , standardImports- , thirdPartyImports- )+ , CodeGen+ , CodeGenContext ( localImports+ , standardImports+ , thirdPartyImports+ ) , CompileError , InstallRequires ( InstallRequires , dependencies@@ -17,23 +17,24 @@ ) , addDependency , addOptionalDependency- , compileError , compileModule , compilePackage , compilePrimitiveType , compileTypeDeclaration , compileTypeExpression- , hasError+ , emptyContext , toAttributeName , toClassName , toImportPath , toNamePair , unionInstallRequires- , withLocalImport- , withStandardImport- , withThirdPartyImports+ , insertLocalImport+ , insertStandardImport+ , insertThirdPartyImports+ , runCodeGen ) where +import Control.Monad.State (modify) import qualified Data.List as L import Data.Maybe (fromMaybe) import GHC.Exts (IsList(toList))@@ -44,6 +45,8 @@ import System.FilePath (joinPath) import Text.InterpolatedString.Perl6 (qq) +import qualified Nirum.CodeGen as C+import Nirum.CodeGen (Failure) import qualified Nirum.Constructs.DeclarationSet as DS import Nirum.Constructs.Identifier ( Identifier , toPascalCaseText@@ -53,7 +56,11 @@ import Nirum.Constructs.ModulePath (ModulePath, ancestors) import Nirum.Constructs.Name (Name(Name)) import qualified Nirum.Constructs.Name as N-import Nirum.Constructs.Service ( Method(Method, methodName)+import Nirum.Constructs.Service ( Method( Method+ , methodName+ , parameters+ , returnType+ ) , Parameter(Parameter) , Service(Service) )@@ -62,16 +69,13 @@ , PrimitiveTypeIdentifier(..) , Tag(Tag) , Type( Alias- , BoxedType , EnumType , PrimitiveType , RecordType+ , UnboxedType , UnionType )- , TypeDeclaration( Import- , ServiceDeclaration- , TypeDeclaration- )+ , TypeDeclaration(..) ) import Nirum.Constructs.TypeExpression ( TypeExpression( ListModifier , MapModifier@@ -95,65 +99,46 @@ type Code = T.Text type CompileError = T.Text -data CodeGen a = CodeGen { standardImports :: S.Set T.Text- , thirdPartyImports :: M.Map T.Text (S.Set T.Text)- , localImports :: M.Map T.Text (S.Set T.Text)- , code :: a- }- | CodeGenError CompileError- deriving (Eq, Ord, Show)--instance Functor CodeGen where- fmap f codeGen = pure f <*> codeGen--instance Applicative CodeGen where- pure = return- c@CodeGen { code = f } <*> codeGen = codeGen >>= \x -> c { code = f x }- (CodeGenError m) <*> _ = CodeGenError m+instance Failure CodeGenContext CompileError where+ fromString = return . T.pack -instance Monad CodeGen where- return code' = CodeGen { standardImports = []- , thirdPartyImports = []- , localImports = []- , code = code'- }- (CodeGen si ti li c) >>= f = case f c of- (CodeGen si' ti' li' code') ->- let stdImports = S.union si si'- thirdPartyImports' = M.unionWith S.union ti ti'- localImports' = M.unionWith S.union li li'- in- CodeGen stdImports thirdPartyImports' localImports' code'- (CodeGenError m) -> CodeGenError m- (CodeGenError m) >>= _ = CodeGenError m+data CodeGenContext+ = CodeGenContext { standardImports :: S.Set T.Text+ , thirdPartyImports :: M.Map T.Text (S.Set T.Text)+ , localImports :: M.Map T.Text (S.Set T.Text)+ }+ deriving (Eq, Ord, Show) - fail = CodeGenError . T.pack+emptyContext :: CodeGenContext+emptyContext = CodeGenContext { standardImports = []+ , thirdPartyImports = []+ , localImports = []+ } -hasError :: CodeGen a -> Bool-hasError (CodeGenError _) = True-hasError _ = False+type CodeGen = C.CodeGen CodeGenContext CompileError -compileError :: CodeGen a -> Maybe CompileError-compileError CodeGen {} = Nothing-compileError (CodeGenError m) = Just m+runCodeGen :: CodeGen a -> CodeGenContext -> (Either CompileError a, CodeGenContext)+runCodeGen = C.runCodeGen -withStandardImport :: T.Text -> CodeGen a -> CodeGen a-withStandardImport module' c@CodeGen { standardImports = si } =- c { standardImports = S.insert module' si }-withStandardImport _ c@(CodeGenError _) = c+insertStandardImport :: T.Text -> CodeGen ()+insertStandardImport module' = modify insert'+ where+ insert' c@CodeGenContext { standardImports = si } =+ c { standardImports = S.insert module' si } -withThirdPartyImports :: [(T.Text, S.Set T.Text)] -> CodeGen a -> CodeGen a-withThirdPartyImports imports c@CodeGen { thirdPartyImports = ti } =- c { thirdPartyImports = L.foldl (M.unionWith S.union) ti importList }+insertThirdPartyImports :: [(T.Text, S.Set T.Text)] -> CodeGen ()+insertThirdPartyImports imports = modify insert' where+ insert' c@CodeGenContext { thirdPartyImports = ti } =+ c { thirdPartyImports = L.foldl (M.unionWith S.union) ti importList } importList :: [M.Map T.Text (S.Set T.Text)] importList = map (uncurry M.singleton) imports-withThirdPartyImports _ c@(CodeGenError _) = c -withLocalImport :: T.Text -> T.Text -> CodeGen a -> CodeGen a-withLocalImport module' object c@CodeGen { localImports = li } =- c { localImports = M.insertWith S.union module' [object] li }-withLocalImport _ _ c@(CodeGenError _) = c+insertLocalImport :: T.Text -> T.Text -> CodeGen ()+insertLocalImport module' object = modify insert'+ where+ insert' c@CodeGenContext { localImports = li } =+ c { localImports = M.insertWith S.union module' [object] li } -- | The set of Python reserved keywords. -- See also: https://docs.python.org/3/reference/lexical_analysis.html#keywords@@ -202,17 +187,25 @@ -> Name -> DS.DeclarationSet Field -> CodeGen Code-compileUnionTag source parentname typename fields = do+compileUnionTag source parentname typename' fields = do typeExprCodes <- mapM (compileTypeExpression source) [typeExpr | (Field _ typeExpr _) <- toList fields]- let className = toClassName' typename+ let className = toClassName' typename' tagNames = map toAttributeName' [ name | (Field name _ _) <- toList fields ] nameNTypes = zip tagNames typeExprCodes slotTypes = toIndentedCodes (\(n, t) -> [qq|'{n}': {t}|]) nameNTypes ",\n "- slots = toIndentedCodes (\n -> [qq|'{n}'|]) tagNames ",\n "+ slots = if length tagNames == 1+ then [qq|'{head tagNames}'|] `T.snoc` ','+ else toIndentedCodes (\n -> [qq|'{n}'|]) tagNames ",\n "+ hashTuple = if null tagNames+ then "self.__nirum_tag__"+ else [qq|({attributes},)|] :: T.Text+ where+ attributes :: T.Text+ attributes = toIndentedCodes (\n -> [qq|self.{n}|]) tagNames ", " initialArgs = toIndentedCodes (\(n, t) -> [qq|{n}: {t}|]) nameNTypes ", " initialValues =@@ -222,18 +215,18 @@ [name | Field name _ _ <- toList fields] ",\n " parentClass = toClassName' parentname- withStandardImport "typing" $- withThirdPartyImports [ ("nirum.validate", ["validate_union_type"])- , ("nirum.constructs", ["name_dict_type"])- ] $- return [qq|+ insertStandardImport "typing"+ insertThirdPartyImports [ ("nirum.validate", ["validate_union_type"])+ , ("nirum.constructs", ["name_dict_type"])+ ]+ return [qq| class $className($parentClass): # TODO: docstring __slots__ = (- $slots,+ $slots )- __nirum_tag__ = $parentClass.Tag.{toAttributeName' typename}+ __nirum_tag__ = $parentClass.Tag.{toAttributeName' typename'} __nirum_tag_types__ = \{ $slotTypes \}@@ -257,6 +250,9 @@ getattr(self, attr) == getattr(other, attr) for attr in self.__slots__ )++ def __hash__(self) -> int:+ return hash($hashTuple) |] compilePrimitiveType :: PrimitiveTypeIdentifier -> CodeGen Code@@ -264,16 +260,16 @@ case primitiveTypeIdentifier of Bool -> return "bool" Bigint -> return "int"- Decimal -> withStandardImport "decimal" $ return "decimal.Decimal"+ Decimal -> insertStandardImport "decimal" >> return "decimal.Decimal" Int32 -> return "int" Int64 -> return "int" Float32 -> return "float" Float64 -> return "float" Text -> return "str" Binary -> return "bytes"- Date -> withStandardImport "datetime" $ return "datetime.date"- Datetime -> withStandardImport "datetime" $ return "datetime.datetime"- Uuid -> withStandardImport "uuid" $ return"uuid.UUID"+ Date -> insertStandardImport "datetime" >> return "datetime.date"+ Datetime -> insertStandardImport "datetime" >> return "datetime.datetime"+ Uuid -> insertStandardImport "uuid" >> return"uuid.UUID" Uri -> return "str" compileTypeExpression :: Source -> TypeExpression -> CodeGen Code@@ -281,17 +277,19 @@ case lookupType i boundModule of Missing -> fail $ "undefined identifier: " ++ toString i Imported _ (PrimitiveType p _) -> compilePrimitiveType p- Imported m _ ->- withThirdPartyImports [(toImportPath m, [toClassName i])] $- return $ toClassName i+ Imported m _ -> do+ insertThirdPartyImports [(toImportPath m, [toClassName i])]+ return $ toClassName i Local _ -> return $ toClassName i compileTypeExpression source (MapModifier k v) = do kExpr <- compileTypeExpression source k vExpr <- compileTypeExpression source v- withStandardImport "typing" $ return [qq|typing.Mapping[$kExpr, $vExpr]|]+ insertStandardImport "typing"+ return [qq|typing.Mapping[$kExpr, $vExpr]|] compileTypeExpression source modifier = do expr <- compileTypeExpression source typeExpr- withStandardImport "typing" $ return [qq|typing.$className[$expr]|]+ insertStandardImport "typing"+ return [qq|typing.$className[$expr]|] where typeExpr :: TypeExpression className :: T.Text@@ -303,32 +301,33 @@ MapModifier _ _ -> undefined -- never happen! compileTypeDeclaration :: Source -> TypeDeclaration -> CodeGen Code-compileTypeDeclaration _ (TypeDeclaration _ (PrimitiveType _ _) _ _) =+compileTypeDeclaration _ TypeDeclaration { type' = PrimitiveType { } } = return "" -- never used-compileTypeDeclaration src (TypeDeclaration typename (Alias ctype) _ _) = do+compileTypeDeclaration src TypeDeclaration { typename = typename'+ , type' = Alias ctype } = do ctypeExpr <- compileTypeExpression src ctype return [qq| # TODO: docstring-{toClassName' typename} = $ctypeExpr+{toClassName' typename'} = $ctypeExpr |]-compileTypeDeclaration src (TypeDeclaration typename (BoxedType itype) _ _) = do- let className = toClassName' typename+compileTypeDeclaration src TypeDeclaration { typename = typename'+ , type' = UnboxedType itype } = do+ let className = toClassName' typename' itypeExpr <- compileTypeExpression src itype- withStandardImport "typing" $- withThirdPartyImports [ ("nirum.validate", ["validate_boxed_type"])- , ("nirum.serialize", ["serialize_boxed_type"])- , ( "nirum.deserialize"- , ["deserialize_boxed_type"]- )- ] $- return [qq|+ insertStandardImport "typing"+ insertThirdPartyImports+ [ ("nirum.validate", ["validate_unboxed_type"])+ , ("nirum.serialize", ["serialize_unboxed_type"])+ , ("nirum.deserialize", ["deserialize_unboxed_type"])+ ]+ return [qq| class $className: # TODO: docstring - __nirum_boxed_type__ = $itypeExpr+ __nirum_inner_type__ = $itypeExpr def __init__(self, value: $itypeExpr) -> None:- validate_boxed_type(value, $itypeExpr)+ validate_unboxed_type(value, $itypeExpr) self.value = value # type: $itypeExpr def __eq__(self, other) -> bool:@@ -339,25 +338,30 @@ return hash(self.value) def __nirum_serialize__(self) -> typing.Any:- return serialize_boxed_type(self)+ return serialize_unboxed_type(self) @classmethod def __nirum_deserialize__(cls: type, value: typing.Any) -> '{className}':- return deserialize_boxed_type(cls, value)+ return deserialize_unboxed_type(cls, value) def __repr__(self) -> str: return '\{0.__module__\}.\{0.__qualname__\}(\{1!r\})'.format( type(self), self.value )++ def __hash__(self) -> int:+ return hash(self.value) |]-compileTypeDeclaration _ (TypeDeclaration typename (EnumType members) _ _) = do- let className = toClassName' typename+compileTypeDeclaration _ TypeDeclaration { typename = typename'+ , type' = EnumType members } = do+ let className = toClassName' typename' memberNames = T.intercalate "\n " [ [qq|{toAttributeName' memberName} = '{toSnakeCaseText bn}'|] | EnumMember memberName@(Name _ bn) _ <- toList members ]- withStandardImport "enum" $ return [qq|+ insertStandardImport "enum"+ return [qq| class $className(enum.Enum): # TODO: docstring @@ -370,10 +374,11 @@ def __nirum_deserialize__(cls: type, value: str) -> '{className}': return cls(value.replace('-', '_')) # FIXME: validate input |]-compileTypeDeclaration src (TypeDeclaration typename (RecordType fields) _ _) = do+compileTypeDeclaration src TypeDeclaration { typename = typename'+ , type' = RecordType fields } = do typeExprCodes <- mapM (compileTypeExpression src) [typeExpr | (Field _ typeExpr _) <- toList fields]- let className = toClassName' typename+ let className = toClassName' typename' fieldNames = map toAttributeName' [ name | (Field name _ _) <- toList fields ]@@ -389,23 +394,23 @@ toNamePair [name | Field name _ _ <- toList fields] ",\n "- withStandardImport "typing" $- withThirdPartyImports [ ( "nirum.validate"- , ["validate_record_type"]- )- , ("nirum.serialize", ["serialize_record_type"])- , ( "nirum.deserialize"- , ["deserialize_record_type"])- , ("nirum.constructs", ["name_dict_type"])- ] $- return [qq|+ hashTuple = [qq|({attributes},)|] :: T.Text+ where+ attributes = toIndentedCodes (\n -> [qq|self.{n}|]) fieldNames ","+ insertStandardImport "typing"+ insertThirdPartyImports [ ("nirum.validate", ["validate_record_type"])+ , ("nirum.serialize", ["serialize_record_type"])+ , ("nirum.deserialize", ["deserialize_record_type"])+ , ("nirum.constructs", ["name_dict_type"])+ ]+ return [qq| class $className: # TODO: docstring __slots__ = ( $slots, )- __nirum_record_behind_name__ = '{toSnakeCaseText $ N.behindName typename}'+ __nirum_record_behind_name__ = '{toSnakeCaseText $ N.behindName typename'}' __nirum_field_types__ = \{ $slotTypes \}@@ -436,25 +441,27 @@ @classmethod def __nirum_deserialize__(cls: type, value) -> '{className}': return deserialize_record_type(cls, value)++ def __hash__(self) -> int:+ return hash($hashTuple) |]-compileTypeDeclaration src (TypeDeclaration typename (UnionType tags) _ _) = do- fieldCodes <- mapM (uncurry (compileUnionTag src typename)) tagNameNFields- let className = toClassName' typename+compileTypeDeclaration src TypeDeclaration { typename = typename'+ , type' = UnionType tags } = do+ fieldCodes <- mapM (uncurry (compileUnionTag src typename')) tagNameNFields+ let className = toClassName' typename' fieldCodes' = T.intercalate "\n\n" fieldCodes enumMembers = toIndentedCodes (\(t, b) -> [qq|$t = '{b}'|]) enumMembers' "\n "- withStandardImport "typing" $- withStandardImport "enum" $- withThirdPartyImports [ ( "nirum.serialize"- , ["serialize_union_type"])- , ( "nirum.deserialize"- , ["deserialize_union_type"])- , ("nirum.constructs", ["name_dict_type"])- ] $- return [qq|+ insertStandardImport "typing"+ insertStandardImport "enum"+ insertThirdPartyImports [ ("nirum.serialize", ["serialize_union_type"])+ , ("nirum.deserialize", ["deserialize_union_type"])+ , ("nirum.constructs", ["name_dict_type"])+ ]+ return [qq| class $className: - __nirum_union_behind_name__ = '{toSnakeCaseText $ N.behindName typename}'+ __nirum_union_behind_name__ = '{toSnakeCaseText $ N.behindName typename'}' __nirum_field_names__ = name_dict_type([ $nameMaps ])@@ -497,16 +504,25 @@ toNamePair [name | (name, _) <- tagNameNFields] ",\n "-compileTypeDeclaration src (ServiceDeclaration name (Service methods) _ _) = do+compileTypeDeclaration src ServiceDeclaration { serviceName = name+ , service = Service methods } = do let methods' = toList methods methodMetadata <- mapM compileMethodMetadata methods' let methodMetadata' = commaNl methodMetadata dummyMethods <- mapM compileMethod methods'+ clientMethods <- mapM compileClientMethod methods' let dummyMethods' = T.intercalate "\n\n" dummyMethods- withThirdPartyImports [ ("nirum.constructs", ["name_dict_type"])- , ("nirum.rpc", ["service_type"])- ] $- return [qq|+ clientMethods' = T.intercalate "\n\n" clientMethods+ insertStandardImport "urllib.request"+ insertStandardImport "json"+ insertThirdPartyImports [ ("nirum.constructs", ["name_dict_type"])+ , ("nirum.deserialize", ["deserialize_meta"])+ , ("nirum.serialize", ["serialize_meta"])+ , ("nirum.rpc", [ "service_type"+ , "client_type"+ ])+ ]+ return [qq| class $className(service_type): __nirum_service_methods__ = \{@@ -517,6 +533,13 @@ ]) {dummyMethods'}+++# FIXME client MUST be generated & saved on diffrent module+# where service isn't included.+class {className}_Client(client_type, $className):+ {clientMethods'}+ pass |] where className :: T.Text@@ -524,7 +547,7 @@ commaNl :: [T.Text] -> T.Text commaNl = T.intercalate ",\n" compileMethod :: Method -> CodeGen Code- compileMethod (Method mName params rtype _etype _docs _anno) = do+ compileMethod (Method mName params rtype _etype _anno) = do let mName' = toAttributeName' mName params' <- mapM compileParameter $ toList params rtypeExpr <- compileTypeExpression src rtype@@ -537,17 +560,20 @@ pTypeExpr <- compileTypeExpression src pType return [qq|{toAttributeName' pName}: $pTypeExpr|] compileMethodMetadata :: Method -> CodeGen Code- compileMethodMetadata (Method mName params rtype _etype _docs _anno) = do+ compileMethodMetadata Method { methodName = mName+ , parameters = params+ , returnType = rtype+ } = do let params' = toList params :: [Parameter] rtypeExpr <- compileTypeExpression src rtype paramMetadata <- mapM compileParameterMetadata params' let paramMetadata' = commaNl paramMetadata- withThirdPartyImports [("nirum.constructs", ["name_dict_type"])] $- return [qq|'{toAttributeName' mName}': \{- '_return': $rtypeExpr,- '_names': name_dict_type([{paramNameMap params'}]),- {paramMetadata'}- \}|]+ insertThirdPartyImports [("nirum.constructs", ["name_dict_type"])]+ return [qq|'{toAttributeName' mName}': \{+ '_return': $rtypeExpr,+ '_names': name_dict_type([{paramNameMap params'}]),+ {paramMetadata'}+ \}|] compileParameterMetadata :: Parameter -> CodeGen Code compileParameterMetadata (Parameter pName pType _) = do let pName' = toAttributeName' pName@@ -561,7 +587,34 @@ paramNameMap :: [Parameter] -> T.Text paramNameMap params = toIndentedCodes toNamePair [pName | Parameter pName _ _ <- params] ",\n "-compileTypeDeclaration _ (Import _ _) =+ compileClientPayload :: Parameter -> CodeGen Code+ compileClientPayload (Parameter pName _ _) = do+ let pName' = toAttributeName' pName+ return [qq|meta['_names']['{pName'}']: serialize_meta({pName'})|]+ compileClientMethod :: Method -> CodeGen Code+ compileClientMethod Method { methodName = mName+ , parameters = params+ , returnType = rtype+ } = do+ let clientMethodName' = toAttributeName' mName+ params' <- mapM compileParameter $ toList params+ rtypeExpr <- compileTypeExpression src rtype+ payloadArguments <- mapM compileClientPayload $ toList params+ return [qq|+ def {clientMethodName'}(self, {commaNl params'}) -> $rtypeExpr:+ meta = self.__nirum_service_methods__['{clientMethodName'}']+ return deserialize_meta(+ meta['_return'],+ json.loads(+ self.remote_call(+ self.__nirum_method_names__['{clientMethodName'}'],+ payload=\{{commaNl payloadArguments}\}+ )+ )+ )+|]++compileTypeDeclaration _ Import { } = return "" -- Nothing to compile compileModuleBody :: Source -> CodeGen Code@@ -605,17 +658,17 @@ compileModule :: Source -> Either CompileError (InstallRequires, Code) compileModule source =- case code' of- CodeGenError errMsg -> Left errMsg- CodeGen {} -> codeWithDeps $ [qq|-{imports $ standardImports code'}+ case runCodeGen code' emptyContext of+ (Left errMsg, _ ) -> Left errMsg+ (Right code , context) -> codeWithDeps context $ [qq|+{imports $ standardImports context} -{fromImports $ localImports code'}+{fromImports $ localImports context} -{fromImports $ thirdPartyImports code'}+{fromImports $ thirdPartyImports context} -{code code'}- |]+{code}+|] where code' :: CodeGen T.Text code' = compileModuleBody source@@ -636,14 +689,16 @@ require :: T.Text -> T.Text -> S.Set T.Text -> S.Set T.Text require pkg module' set = if set `has` module' then S.singleton pkg else S.empty- deps :: S.Set T.Text- deps = require "nirum" "nirum" $ M.keysSet $ thirdPartyImports code'- optDeps :: M.Map (Int, Int) (S.Set T.Text)- optDeps = [ ((3, 4), require "enum34" "enum" $ standardImports code')- , ((3, 5), require "typing" "typing" $ standardImports code')- ]- codeWithDeps :: Code -> Either CompileError (InstallRequires, Code)- codeWithDeps c = Right (InstallRequires deps optDeps, c)+ codeWithDeps :: CodeGenContext -> Code -> Either CompileError (InstallRequires, Code)+ codeWithDeps context c = Right (InstallRequires deps optDeps, c)+ where+ deps :: S.Set T.Text+ deps = require "nirum" "nirum" $ M.keysSet $ thirdPartyImports context+ optDeps :: M.Map (Int, Int) (S.Set T.Text)+ optDeps =+ [ ((3, 4), require "enum34" "enum" $ standardImports context)+ , ((3, 5), require "typing" "typing" $ standardImports context)+ ] compilePackageMetadata :: Package -> InstallRequires -> Code compilePackageMetadata package (InstallRequires deps optDeps) = [qq|
test/Nirum/CliSpec.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedLists, OverloadedStrings #-}+{-# LANGUAGE OverloadedLists #-} module Nirum.CliSpec where import Control.Monad (forM_)
+ test/Nirum/CodeGenSpec.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE FlexibleInstances, ScopedTypeVariables, RankNTypes, MultiParamTypeClasses #-}+module Nirum.CodeGenSpec where++import Control.Monad.Except (throwError)+import Control.Monad.State (modify)+import Data.Text as T (Text, pack)++import Test.Hspec.Meta++import Nirum.CodeGen (CodeGen, Failure, fromString, runCodeGen)+++data SampleError = SampleError Text+ deriving (Eq, Ord, Show)++instance forall s. Failure s SampleError where+ fromString = return . SampleError . T.pack+++spec :: Spec+spec = parallel $ do+ specify "fail" $ do+ let codeGen' :: CodeGen Integer SampleError () = do+ modify (+1)+ modify (+1)+ fail "test"+ runCodeGen codeGen' 0 `shouldBe` (Left (SampleError "test"), 2)+ let codeGen'' :: CodeGen Integer SampleError Integer = do+ modify (+1)+ _ <- fail "test"+ modify (+1)+ return 42+ runCodeGen codeGen'' 0 `shouldBe` (Left (SampleError "test"), 1)+ specify "throwError" $ do+ let codeGen' :: CodeGen Integer SampleError () = do+ modify (+1)+ _ <- throwError $ SampleError "test"+ modify (+2)+ runCodeGen codeGen' 0 `shouldBe` (Left (SampleError "test"), 1)
test/Nirum/Constructs/AnnotationSpec.hs view
@@ -1,37 +1,52 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedLists #-} module Nirum.Constructs.AnnotationSpec where import Test.Hspec.Meta import qualified Data.Map.Strict as M -import Nirum.Constructs.Annotation+import Nirum.Constructs.Annotation as A ( Annotation (Annotation)- , AnnotationSet (AnnotationSet) , NameDuplication (AnnotationNameDuplication)+ , docs , empty , fromList+ , insertDocs+ , lookup+ , lookupDocs+ , singleton , toCode , toList+ , union )+import Nirum.Constructs.Annotation.Internal ( AnnotationSet (AnnotationSet) ) spec :: Spec spec = do let annotation = Annotation "foo" Nothing loremAnno = Annotation "lorem" (Just "ipsum")- withEscapeChar = Annotation "quote" (Just "\"")- describe "Annotation" $+ escapeCharAnno = Annotation "quote" (Just "\"")+ longNameAnno = Annotation "long-cat-is-long" (Just "nyancat")+ docsAnno = docs "Description"+ describe "Annotation" $ do describe "toCode Annotation" $ it "prints annotation properly" $ do toCode annotation `shouldBe` "@foo" toCode loremAnno `shouldBe` "@lorem(\"ipsum\")"- toCode withEscapeChar `shouldBe` "@quote(\"\\\"\")"+ toCode escapeCharAnno `shouldBe` "@quote(\"\\\"\")"+ specify "docs" $+ docsAnno `shouldBe` Annotation "docs" (Just "Description\n") describe "AnnotationSet" $ do it "empty" $ empty `shouldBe` AnnotationSet M.empty+ it "singleton" $ do+ singleton (Annotation "foo" Nothing) `shouldBe`+ AnnotationSet [("foo", Nothing)]+ singleton (Annotation "bar" (Just "baz")) `shouldBe`+ AnnotationSet [("bar", Just "baz")] describe "fromList" $ do it "success" $ do fromList [] `shouldBe` Right (AnnotationSet M.empty) fromList [annotation] `shouldBe` Right- (AnnotationSet $ M.fromList [("foo", annotation)])+ (AnnotationSet $ M.fromList [("foo", Nothing)]) it "name duplication" $ do let duplicationAnnotations = fromList [ annotation , loremAnno@@ -39,8 +54,42 @@ ] duplicationAnnotations `shouldBe` Left (AnnotationNameDuplication "foo")- let annotationSet = case fromList [annotation, loremAnno] of- Right set -> set- Left _ -> empty+ specify "union" $ do+ let Right a = fromList [annotation, loremAnno]+ let Right b = fromList [docsAnno, escapeCharAnno]+ let c = AnnotationSet [("foo", Just "bar")]+ A.union a b `shouldBe` AnnotationSet [ ("foo", Nothing)+ , ("lorem", Just "ipsum")+ , ("quote", Just "\"")+ , ("docs", Just "Description\n")+ ]+ A.union a c `shouldBe` a+ let Right annotationSet = fromList [ annotation+ , loremAnno+ , escapeCharAnno+ , longNameAnno+ , docsAnno+ ] it "toList" $ fromList (toList annotationSet) `shouldBe` Right annotationSet+ describe "lookup" $ do+ it "should find proper annotation" $ do+ A.lookup "foo" annotationSet `shouldBe` Just annotation+ A.lookup "FOO" annotationSet `shouldBe` Just annotation+ A.lookup "lorem" annotationSet `shouldBe` Just loremAnno+ A.lookup "quote" annotationSet `shouldBe` Just escapeCharAnno+ A.lookup "long-cat-is-long" annotationSet `shouldBe` Just longNameAnno+ A.lookup "long_cat_is_long" annotationSet `shouldBe` Just longNameAnno+ A.lookup "docs" annotationSet `shouldBe` Just docsAnno+ it "should be Nothing if lookup fails" $ do+ A.lookup "bar" annotationSet `shouldBe` Nothing+ A.lookup "longCatIsLong" annotationSet `shouldBe` Nothing+ specify "lookupDocs" $ do+ A.lookupDocs annotationSet `shouldBe` Just "Description"+ A.lookupDocs empty `shouldBe` Nothing+ describe "insertDocs" $ do+ it "should insert the doc comment as an annotation" $+ A.insertDocs "yay" empty `shouldReturn`+ AnnotationSet [("docs", Just "yay\n")]+ it "should fail on the annotation that already have a doc" $+ A.insertDocs "yay" annotationSet `shouldThrow` anyException
test/Nirum/Constructs/DeclarationSetSpec.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedLists, OverloadedStrings #-}+{-# LANGUAGE OverloadedLists #-} module Nirum.Constructs.DeclarationSetSpec (SampleDecl(..), spec) where import Control.Exception.Base (evaluate)@@ -7,7 +7,9 @@ import Test.Hspec.Meta import Nirum.Constructs (Construct(..))-import Nirum.Constructs.Declaration (Declaration(..), Docs)+import qualified Nirum.Constructs.Annotation as A+import Nirum.Constructs.Annotation (AnnotationSet)+import Nirum.Constructs.Declaration (Declaration(..)) import Nirum.Constructs.DeclarationSet ( DeclarationSet , NameDuplication(..) , empty@@ -21,24 +23,24 @@ ) import Nirum.Constructs.Name (Name(Name)) -data SampleDecl = SampleDecl Name (Maybe Docs) deriving (Eq, Ord, Show)+data SampleDecl = SampleDecl Name AnnotationSet deriving (Eq, Ord, Show) instance Construct SampleDecl where toCode _ = "(do not impl)" instance Declaration SampleDecl where name (SampleDecl name' _) = name'- docs (SampleDecl _ docs') = docs'+ annotations (SampleDecl _ anno') = anno' instance IsString SampleDecl where- fromString s = SampleDecl (fromString s) Nothing+ fromString s = SampleDecl (fromString s) A.empty type SampleDeclSet = DeclarationSet SampleDecl spec :: Spec spec = describe "DeclarationSet" $ do- let sd fname bname = SampleDecl (Name fname bname) Nothing+ let sd fname bname = SampleDecl (Name fname bname) A.empty context "fromList" $ do let fl = fromList :: [SampleDecl] -> Either NameDuplication SampleDeclSet
− test/Nirum/Constructs/DeclarationSpec.hs
@@ -1,33 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Nirum.Constructs.DeclarationSpec where--import Test.Hspec.Meta--import Nirum.Constructs (Construct(..))-import Nirum.Constructs.Declaration (Docs(Docs), toCodeWithPrefix)--spec :: Spec-spec =- describe "Docs" $ do- context "toCode" $ do- it "has leading sharps every line" $ do- toCode (Docs "test") `shouldBe` "# test"- toCode (Docs "test\ntest2") `shouldBe` "# test\n# test2"- specify "... except of the last EOL" $ do- toCode (Docs "test\n") `shouldBe` "# test"- toCode (Docs "test\ntest2\n") `shouldBe` "# test\n# test2"- context "toCodeWithPrefix" $ do- it "simply returns an empty string if input is Nothing" $ do- toCodeWithPrefix "\n" Nothing `shouldBe` ""- toCodeWithPrefix "(prefix)" Nothing `shouldBe` ""- it "prepends the given prefix if input is Just Docs" $ do- toCodeWithPrefix "\n" (Just "docs") `shouldBe` "\n# docs"- toCodeWithPrefix "(prefix)" (Just "doc\ndoc")- `shouldBe` "(prefix)# doc\n# doc"- context "fromString" $ do- it "is equivalent to Docs data constructor" $ do- ("test\n" :: Docs) `shouldBe` Docs "test\n"- ("test\ntest2\n" :: Docs) `shouldBe` Docs "test\ntest2\n"- specify "... except it automatically appends EOL if omitted" $ do- ("test" :: Docs) `shouldBe` Docs "test\n"- ("test\ntest2" :: Docs) `shouldBe` Docs "test\ntest2\n"
+ test/Nirum/Constructs/DocsSpec.hs view
@@ -0,0 +1,32 @@+module Nirum.Constructs.DocsSpec where++import Test.Hspec.Meta++import Nirum.Constructs (Construct(..))+import Nirum.Constructs.Docs (Docs(Docs), toCodeWithPrefix)++spec :: Spec+spec =+ describe "Docs" $ do+ context "toCode" $ do+ it "has leading sharps every line" $ do+ toCode (Docs "test") `shouldBe` "# test"+ toCode (Docs "test\ntest2") `shouldBe` "# test\n# test2"+ specify "... except of the last EOL" $ do+ toCode (Docs "test\n") `shouldBe` "# test"+ toCode (Docs "test\ntest2\n") `shouldBe` "# test\n# test2"+ context "toCodeWithPrefix" $ do+ it "simply returns an empty string if input is Nothing" $ do+ toCodeWithPrefix "\n" Nothing `shouldBe` ""+ toCodeWithPrefix "(prefix)" Nothing `shouldBe` ""+ it "prepends the given prefix if input is Just Docs" $ do+ toCodeWithPrefix "\n" (Just "docs") `shouldBe` "\n# docs"+ toCodeWithPrefix "(prefix)" (Just "doc\ndoc")+ `shouldBe` "(prefix)# doc\n# doc"+ context "fromString" $ do+ it "is equivalent to Docs data constructor" $ do+ ("test\n" :: Docs) `shouldBe` Docs "test\n"+ ("test\ntest2\n" :: Docs) `shouldBe` Docs "test\ntest2\n"+ specify "... except it automatically appends EOL if omitted" $ do+ ("test" :: Docs) `shouldBe` Docs "test\n"+ ("test\ntest2" :: Docs) `shouldBe` Docs "test\ntest2\n"
test/Nirum/Constructs/IdentifierSpec.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE OverloadedStrings #-} module Nirum.Constructs.IdentifierSpec where import Control.Exception (evaluate)
test/Nirum/Constructs/ModulePathSpec.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedLists, OverloadedStrings #-}+{-# LANGUAGE OverloadedLists #-} module Nirum.Constructs.ModulePathSpec where import Control.Exception (evaluate)
test/Nirum/Constructs/ModuleSpec.hs view
@@ -1,11 +1,11 @@-{-# LANGUAGE OverloadedLists, OverloadedStrings, QuasiQuotes #-}+{-# LANGUAGE OverloadedLists, QuasiQuotes #-} module Nirum.Constructs.ModuleSpec where import Test.Hspec.Meta import Text.InterpolatedString.Perl6 (q) import Nirum.Constructs (Construct(toCode))-import Nirum.Constructs.Annotation (empty)+import Nirum.Constructs.Annotation as A (docs, empty, singleton) import Nirum.Constructs.DeclarationSet (DeclarationSet) import Nirum.Constructs.Module (Module(..), imports) import Nirum.Constructs.TypeDeclaration ( Type(..)@@ -17,15 +17,15 @@ spec :: Spec spec = describe "Module" $ do- let pathT = TypeDeclaration "path" (Alias "text")- (Just "path string") empty+ let docsAnno = A.docs "path string"+ pathT = TypeDeclaration "path" (Alias "text") (singleton docsAnno) offsetT =- TypeDeclaration "offset" (BoxedType "float64") Nothing empty- decls = [ Import ["foo", "bar"] "baz"- , Import ["foo", "bar"] "qux"- , Import ["zzz"] "qqq"- , Import ["zzz"] "ppp"- , Import ["xyz"] "asdf"+ TypeDeclaration "offset" (UnboxedType "float64") empty+ decls = [ Import ["foo", "bar"] "baz" empty+ , Import ["foo", "bar"] "qux" empty+ , Import ["zzz"] "qqq" empty+ , Import ["zzz"] "ppp" empty+ , Import ["xyz"] "asdf" empty , pathT , offsetT ] :: DeclarationSet TypeDeclaration@@ -45,7 +45,7 @@ type path = text; # path string -boxed offset (float64);+unboxed offset (float64); |] toCode mod2 `shouldBe` [q|# module level docs... # blahblah@@ -56,5 +56,5 @@ type path = text; # path string -boxed offset (float64);+unboxed offset (float64); |]
test/Nirum/Constructs/NameSpec.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE OverloadedStrings #-} module Nirum.Constructs.NameSpec where import Test.Hspec.Meta
+ test/Nirum/Constructs/ServiceSpec.hs view
@@ -0,0 +1,232 @@+{-# LANGUAGE OverloadedLists #-}+module Nirum.Constructs.ServiceSpec where++import Test.Hspec.Meta++import Nirum.Constructs.Annotation (Annotation (Annotation)+ , empty+ , fromList+ , union+ )+import Nirum.Constructs.Docs (toCode)+import Nirum.Constructs.Service (Method(Method), Parameter(Parameter))+import Nirum.Constructs.TypeExpression ( TypeExpression ( ListModifier+ , OptionModifier+ )+ )+import Util (singleDocs)+++spec :: Spec+spec = do+ let Right methodAnno = fromList [Annotation "http-get" (Just "/ping/")]+ let docsAnno = singleDocs "docs..."+ describe "Parameter" $+ specify "toCode" $ do+ toCode (Parameter "dob" "date" empty) `shouldBe` "date dob,"+ toCode (Parameter "dob" "date" docsAnno) `shouldBe`+ "date dob,\n# docs..."+ describe "Method" $+ specify "toCode" $ do+ toCode (Method "ping" [] "bool"+ Nothing+ empty) `shouldBe`+ "bool ping (),"+ toCode (Method "ping" [] "bool"+ Nothing+ methodAnno) `shouldBe`+ "@http-get(\"/ping/\")\nbool ping (),"+ toCode (Method "ping" [] "bool"+ Nothing+ docsAnno) `shouldBe`+ "bool ping (\n # docs...\n),"+ toCode (Method "ping" [] "bool"+ (Just "ping-error")+ empty) `shouldBe`+ "bool ping () throws ping-error,"+ toCode (Method "ping" [] "bool"+ (Just "ping-error")+ docsAnno) `shouldBe`+ "bool ping (\n # docs...\n) throws ping-error,"+ toCode (Method "ping" [] "bool"+ Nothing+ methodAnno) `shouldBe`+ "@http-get(\"/ping/\")\nbool ping (),"+ toCode (Method "ping" [] "bool"+ (Just "ping-error")+ methodAnno) `shouldBe`+ "@http-get(\"/ping/\")\nbool ping () throws ping-error,"+ toCode (Method "get-user"+ [Parameter "user-id" "uuid" empty]+ (OptionModifier "user")+ Nothing+ empty) `shouldBe`+ "user? get-user (uuid user-id),"+ toCode (Method "get-user"+ [Parameter "user-id" "uuid" empty]+ (OptionModifier "user")+ Nothing+ docsAnno) `shouldBe`+ "user? get-user (\n # docs...\n uuid user-id,\n),"+ toCode (Method "get-user"+ [Parameter "user-id" "uuid" empty]+ (OptionModifier "user")+ (Just "get-user-error")+ empty) `shouldBe`+ "user? get-user (uuid user-id) throws get-user-error,"+ toCode (Method "get-user"+ [Parameter "user-id" "uuid" empty]+ (OptionModifier "user")+ (Just "get-user-error")+ docsAnno) `shouldBe`+ "user? get-user (\n\+ \ # docs...\n\+ \ uuid user-id,\n\+ \) throws get-user-error,"+ toCode (Method "get-user"+ [Parameter "user-id" "uuid" $ singleDocs "param docs..."]+ (OptionModifier "user")+ Nothing+ empty) `shouldBe`+ "user? get-user (\n uuid user-id,\n # param docs...\n),"+ toCode (Method "get-user"+ [Parameter "user-id" "uuid" $ singleDocs "param docs..."]+ (OptionModifier "user")+ Nothing+ docsAnno) `shouldBe`+ "user? get-user (\n\+ \ # docs...\n\+ \ uuid user-id,\n\+ \ # param docs...\n\+ \),"+ toCode (Method "get-user"+ [Parameter "user-id" "uuid" $ singleDocs "param docs..."]+ (OptionModifier "user")+ (Just "get-user-error")+ empty) `shouldBe`+ "user? get-user (\n\+ \ uuid user-id,\n\+ \ # param docs...\n\+ \) throws get-user-error,"+ toCode (Method "get-user"+ [Parameter "user-id" "uuid" $ singleDocs "param docs..."]+ (OptionModifier "user")+ (Just "get-user-error")+ docsAnno) `shouldBe`+ "user? get-user (\n\+ \ # docs...\n\+ \ uuid user-id,\n\+ \ # param docs...\n\+ \) throws get-user-error,"+ toCode (Method "search-posts"+ [ Parameter "blog-id" "uuid" empty+ , Parameter "keyword" "text" empty+ ]+ (ListModifier "post")+ Nothing+ empty) `shouldBe`+ "[post] search-posts (\n uuid blog-id,\n text keyword,\n),"+ toCode (Method "search-posts"+ [ Parameter "blog-id" "uuid" empty+ , Parameter "keyword" "text" empty+ ]+ (ListModifier "post")+ Nothing+ docsAnno) `shouldBe`+ "[post] search-posts (\n\+ \ # docs...\n\+ \ uuid blog-id,\n\+ \ text keyword,\n\+ \),"+ toCode (Method "search-posts"+ [ Parameter "blog-id" "uuid" empty+ , Parameter "keyword" "text" empty+ ]+ (ListModifier "post")+ (Just "search-posts-error")+ empty) `shouldBe`+ "[post] search-posts (\n\+ \ uuid blog-id,\n\+ \ text keyword,\n\+ \) throws search-posts-error,"+ toCode (Method "search-posts"+ [ Parameter "blog-id" "uuid" empty+ , Parameter "keyword" "text" empty+ ]+ (ListModifier "post")+ (Just "search-posts-error")+ docsAnno) `shouldBe`+ "[post] search-posts (\n\+ \ # docs...\n\+ \ uuid blog-id,\n\+ \ text keyword,\n\+ \) throws search-posts-error,"+ toCode (Method "search-posts"+ [ Parameter "blog-id" "uuid" $ singleDocs "blog id..."+ , Parameter "keyword" "text" $ singleDocs "keyword..."+ ]+ (ListModifier "post")+ Nothing+ empty) `shouldBe`+ "[post] search-posts (\n\+ \ uuid blog-id,\n\+ \ # blog id...\n\+ \ text keyword,\n\+ \ # keyword...\n\+ \),"+ toCode (Method "search-posts"+ [ Parameter "blog-id" "uuid" $ singleDocs "blog id..."+ , Parameter "keyword" "text" $ singleDocs "keyword..."+ ]+ (ListModifier "post")+ Nothing+ docsAnno) `shouldBe`+ "[post] search-posts (\n\+ \ # docs...\n\+ \ uuid blog-id,\n\+ \ # blog id...\n\+ \ text keyword,\n\+ \ # keyword...\n\+ \),"+ toCode (Method "search-posts"+ [ Parameter "blog-id" "uuid" $ singleDocs "blog id..."+ , Parameter "keyword" "text" $ singleDocs "keyword..."+ ]+ (ListModifier "post")+ (Just "search-posts-error")+ empty) `shouldBe`+ "[post] search-posts (\n\+ \ uuid blog-id,\n\+ \ # blog id...\n\+ \ text keyword,\n\+ \ # keyword...\n\+ \) throws search-posts-error,"+ toCode (Method "search-posts"+ [ Parameter "blog-id" "uuid" $ singleDocs "blog id..."+ , Parameter "keyword" "text" $ singleDocs "keyword..."+ ]+ (ListModifier "post")+ (Just "search-posts-error")+ docsAnno) `shouldBe`+ "[post] search-posts (\n\+ \ # docs...\n\+ \ uuid blog-id,\n\+ \ # blog id...\n\+ \ text keyword,\n\+ \ # keyword...\n\+ \) throws search-posts-error,"+ toCode (Method "search-posts"+ [ Parameter "blog-id" "uuid" $ singleDocs "blog id..."+ , Parameter "keyword" "text" $ singleDocs "keyword..."+ ]+ (ListModifier "post")+ (Just "search-posts-error")+ (docsAnno `union` methodAnno)) `shouldBe`+ "@http-get(\"/ping/\")\n\+ \[post] search-posts (\n\+ \ # docs...\n\+ \ uuid blog-id,\n\+ \ # blog id...\n\+ \ text keyword,\n\+ \ # keyword...\n\+ \) throws search-posts-error,"
test/Nirum/Constructs/TypeDeclarationSpec.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedLists, OverloadedStrings #-}+{-# LANGUAGE OverloadedLists #-} module Nirum.Constructs.TypeDeclarationSpec where import Data.Either (rights)@@ -8,10 +8,10 @@ import Nirum.Constructs (Construct(toCode)) import Nirum.Constructs.Annotation ( Annotation (Annotation) , AnnotationSet- , fromList+ , fromList , empty )-import Nirum.Constructs.Declaration (Declaration(name, docs))+import Nirum.Constructs.Declaration (Declaration(name), docs) import Nirum.Constructs.DeclarationSet (DeclarationSet) import Nirum.Constructs.Service (Method(Method), Service(Service)) import Nirum.Constructs.TypeDeclaration ( EnumMember(EnumMember)@@ -22,6 +22,7 @@ , Type(..) , TypeDeclaration(..) )+import Util (singleDocs) barAnnotationSet :: AnnotationSet barAnnotationSet = head $ rights [fromList [Annotation "bar" (Just "baz")]]@@ -33,10 +34,9 @@ let alias = Alias "text" a = TypeDeclaration { typename = "path" , type' = alias- , typeDocs = Nothing , typeAnnotations = empty }- b = a { typeDocs = Just "docs"}+ b = a { typeAnnotations = singleDocs "docs" } specify "name" $ do name a `shouldBe` "path" name b `shouldBe` "path"@@ -46,14 +46,13 @@ specify "toCode" $ do toCode a `shouldBe` "type path = text;" toCode b `shouldBe` "type path = text;\n# docs"- context "BoxedType" $ do- let boxed = BoxedType "float64"+ context "UnboxedType" $ do+ let unboxed = UnboxedType "float64" a = TypeDeclaration { typename = "offset"- , type' = boxed- , typeDocs = Nothing+ , type' = unboxed , typeAnnotations = empty }- b = a { typeDocs = Just "docs" }+ b = a { typeAnnotations = singleDocs "docs" } specify "name" $ do name a `shouldBe` "offset" name b `shouldBe` "offset"@@ -61,20 +60,19 @@ docs a `shouldBe` Nothing docs b `shouldBe` Just "docs" specify "toCode" $ do- toCode a `shouldBe` "boxed offset (float64);"- toCode b `shouldBe` "boxed offset (float64);\n# docs"+ toCode a `shouldBe` "unboxed offset (float64);"+ toCode b `shouldBe` "unboxed offset (float64);\n# docs" context "EnumType" $ do- let enumMembers = [ EnumMember "kr" Nothing- , EnumMember "jp" $ Just "Japan"- , EnumMember "us" $ Just "United States"+ let enumMembers = [ EnumMember "kr" empty+ , EnumMember "jp" (singleDocs "Japan")+ , EnumMember "us" (singleDocs "United States") ] :: DeclarationSet EnumMember enum = EnumType enumMembers a = TypeDeclaration { typename = "country" , type' = enum- , typeDocs = Nothing , typeAnnotations = empty }- b = a { typeDocs = Just "country codes" }+ b = a { typeAnnotations = singleDocs "country codes" } specify "toCode" $ do toCode a `shouldBe` "enum country\n\ \ = kr\n\@@ -92,17 +90,16 @@ \ # United States\n\ \ ;" context "RecordType" $ do- let fields' = [ Field "name" "text" Nothing- , Field "dob" "date" $ Just "date of birth"- , Field "gender" "gender" Nothing+ let fields' = [ Field "name" "text" empty+ , Field "dob" "date" (singleDocs "date of birth")+ , Field "gender" "gender" empty ] :: DeclarationSet Field record = RecordType fields' a = TypeDeclaration { typename = "person" , type' = record- , typeDocs = Nothing , typeAnnotations = empty }- b = a { typeDocs = Just "person record type" }+ b = a { typeAnnotations = singleDocs "person record type" } specify "toCode" $ do toCode a `shouldBe` "record person (\n\ \ text name,\n\@@ -118,23 +115,22 @@ \ gender gender,\n\ \);" context "UnionType" $ do- let circleFields = [ Field "origin" "point" Nothing- , Field "radius" "offset" Nothing+ let circleFields = [ Field "origin" "point" empty+ , Field "radius" "offset" empty ]- rectangleFields = [ Field "upper-left" "point" Nothing- , Field "lower-right" "point" Nothing+ rectangleFields = [ Field "upper-left" "point" empty+ , Field "lower-right" "point" empty ]- tags' = [ Tag "circle" circleFields Nothing- , Tag "rectangle" rectangleFields Nothing- , Tag "none" [] Nothing+ tags' = [ Tag "circle" circleFields empty+ , Tag "rectangle" rectangleFields empty+ , Tag "none" [] empty ] union = UnionType tags' a = TypeDeclaration { typename = "shape" , type' = union- , typeDocs = Nothing , typeAnnotations = empty }- b = a { typeDocs = Just "shape type" }+ b = a { typeAnnotations = singleDocs "shape type" } specify "toCode" $ do toCode a `shouldBe` "union shape\n\ \ = circle (point origin, \@@ -153,27 +149,23 @@ \ ;" context "PrimitiveType" $ do let primitiveType = PrimitiveType Text String- decl = TypeDeclaration "text" primitiveType Nothing empty+ decl = TypeDeclaration "text" primitiveType empty specify "toCode" $ T.lines (toCode decl) `shouldSatisfy` all (T.isPrefixOf "//" . T.stripStart) context "ServiceDeclaration" $ do let nullService = Service []- nullDecl = ServiceDeclaration "null-service" nullService Nothing- empty+ nullDecl = ServiceDeclaration "null-service" nullService empty nullDecl' = ServiceDeclaration "null-service" nullService- (Just "Null service declaration.")- empty- pingService = Service [ Method "ping" [] "bool" Nothing Nothing empty ]- pingDecl = ServiceDeclaration "ping-service" pingService Nothing- empty+ (singleDocs "Null service declaration.")+ pingService = Service [ Method "ping" [] "bool" Nothing empty ]+ pingDecl = ServiceDeclaration "ping-service" pingService empty pingDecl' = ServiceDeclaration "ping-service" pingService- (Just "Ping service declaration.")- empty+ (singleDocs "Ping service declaration.") annoDecl = ServiceDeclaration "anno-service" pingService- Nothing barAnnotationSet+ barAnnotationSet specify "toCode" $ do toCode nullDecl `shouldBe` "service null-service ();" toCode nullDecl' `shouldBe` "service null-service (\n\@@ -191,7 +183,7 @@ \service anno-service (bool ping ());" -- TODO: more tests context "Import" $ do- let import' = Import ["foo", "bar"] "baz"+ let import' = Import ["foo", "bar"] "baz" empty specify "name" $ name import' `shouldBe` "baz" specify "docs" $@@ -199,26 +191,26 @@ specify "toCode" $ toCode import' `shouldBe` "import foo.bar (baz);\n" describe "EnumMember" $ do- let kr = EnumMember "kr" Nothing- jp = EnumMember "jp" $ Just "Japan"+ let kr = EnumMember "kr" empty+ jp = EnumMember "jp" (singleDocs "Japan") specify "toCode" $ do toCode kr `shouldBe` "kr" toCode jp `shouldBe` "jp\n# Japan" specify "fromString" $- "test" `shouldBe` EnumMember "test" Nothing+ "test" `shouldBe` EnumMember "test" empty describe "Field" $ specify "toCode" $ do- toCode (Field "name" "text" Nothing) `shouldBe` "text name,"- toCode (Field "dob" "date" $ Just "date of birth") `shouldBe`+ toCode (Field "name" "text" empty) `shouldBe` "text name,"+ toCode (Field "dob" "date" (singleDocs "date of birth")) `shouldBe` "date dob,\n# date of birth" describe "Tag" $ specify "toCode" $ do- let fields' = [ Field "origin" "point" Nothing- , Field "radius" "offset" Nothing+ let fields' = [ Field "origin" "point" empty+ , Field "radius" "offset" empty ]- toCode (Tag "circle" fields' Nothing)+ toCode (Tag "circle" fields' empty) `shouldBe` "circle (point origin, offset radius,)"- toCode (Tag "circle" fields' $ Just "docs")+ toCode (Tag "circle" fields' (singleDocs "docs")) `shouldBe` "circle (point origin, offset radius,)\n# docs"- toCode (Tag "unit" [] Nothing) `shouldBe` "unit"- toCode (Tag "unit" [] $ Just "docs") `shouldBe` "unit\n# docs"+ toCode (Tag "unit" [] empty) `shouldBe` "unit"+ toCode (Tag "unit" [] (singleDocs "docs")) `shouldBe` "unit\n# docs"
test/Nirum/Constructs/TypeExpressionSpec.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE OverloadedStrings #-} module Nirum.Constructs.TypeExpressionSpec where import Test.Hspec.Meta
test/Nirum/PackageSpec.hs view
@@ -1,6 +1,7 @@-{-# LANGUAGE OverloadedLists, OverloadedStrings #-}+{-# LANGUAGE OverloadedLists #-} module Nirum.PackageSpec where +import Data.Either (isRight) import qualified Data.Map.Strict as M import System.FilePath ((</>)) import Test.Hspec.Meta@@ -47,46 +48,48 @@ , (["foo"], Module [] $ Just "foo") , (["qux"], Module [] $ Just "qux") , ( ["abc"]- , Module [TypeDeclaration "a" (Alias "text") Nothing empty]+ , Module [TypeDeclaration "a" (Alias "text") empty] Nothing ) , ( ["xyz"]- , Module [ Import ["abc"] "a"- , TypeDeclaration "x" (Alias "text") Nothing empty+ , Module [ Import ["abc"] "a" empty+ , TypeDeclaration "x" (Alias "text") empty ] Nothing ) ] missingImportsModules :: M.Map ModulePath Module missingImportsModules =- [ (["foo"], Module [ Import ["foo", "bar"] "xyz" -- MissingModulePathError- , Import ["foo", "bar"] "zzz" -- MissingModulePathError- , Import ["baz"] "qux"- ] Nothing)+ [ ( ["foo"]+ , Module [ Import ["foo", "bar"] "xyz" empty -- MissingModulePathError+ , Import ["foo", "bar"] "zzz" empty -- MissingModulePathError+ , Import ["baz"] "qux" empty+ ] Nothing+ ) , ( ["baz"]- , Module [ TypeDeclaration "qux" (Alias "text") Nothing empty ] Nothing+ , Module [ TypeDeclaration "qux" (Alias "text") empty ] Nothing )- , (["qux"], Module [ Import ["foo"] "abc" -- MissingImportError- , Import ["foo"] "def" -- MissingImportError+ , (["qux"], Module [ Import ["foo"] "abc" empty -- MissingImportError+ , Import ["foo"] "def" empty -- MissingImportError ] Nothing) ] circularImportsModules :: M.Map ModulePath Module circularImportsModules =- [ (["asdf"], Module [ Import ["asdf"] "foo"- , TypeDeclaration "bar" (Alias "text") Nothing empty+ [ (["asdf"], Module [ Import ["asdf"] "foo" empty+ , TypeDeclaration "bar" (Alias "text") empty ] Nothing)- , (["abc", "def"], Module [ Import ["abc", "ghi"] "bar"+ , (["abc", "def"], Module [ Import ["abc", "ghi"] "bar" empty , TypeDeclaration- "foo" (Alias "text") Nothing empty+ "foo" (Alias "text") empty ] Nothing)- , (["abc", "ghi"], Module [ Import ["abc", "xyz"] "baz"+ , (["abc", "ghi"], Module [ Import ["abc", "xyz"] "baz" empty , TypeDeclaration- "bar" (Alias "text") Nothing empty+ "bar" (Alias "text") empty ] Nothing)- , (["abc", "xyz"], Module [ Import ["abc", "def"] "foo"+ , (["abc", "xyz"], Module [ Import ["abc", "def"] "foo" empty , TypeDeclaration- "baz" (Alias "text") Nothing empty+ "baz" (Alias "text") empty ] Nothing) ] @@ -134,7 +137,9 @@ ] specify "scanPackage" $ do let path = "." </> "examples"- Right package <- scanPackage path+ package' <- scanPackage path+ package' `shouldSatisfy` isRight+ let Right package = package' Right builtinsM <- parseFile (path </> "builtins.nrm") Right productM <- parseFile (path </> "product.nrm") Right shapesM <- parseFile (path </> "shapes.nrm")@@ -184,11 +189,9 @@ docs bm' `shouldBe` Just "foo" specify "types" $ do types bm `shouldBe` []- types abc `shouldBe` [TypeDeclaration- "a" (Alias "text") Nothing empty]- types xyz `shouldBe` [ Import ["abc"] "a"- , TypeDeclaration- "x" (Alias "text") Nothing empty+ types abc `shouldBe` [TypeDeclaration "a" (Alias "text") empty]+ types xyz `shouldBe` [ Import ["abc"] "a" empty+ , TypeDeclaration "x" (Alias "text") empty ] specify "lookupType" $ do lookupType "a" bm `shouldBe` Missing
test/Nirum/ParserSpec.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedLists, OverloadedStrings, TypeFamilies #-}+{-# LANGUAGE OverloadedLists, TypeFamilies #-} module Nirum.ParserSpec where import Control.Monad (forM_)@@ -20,12 +20,13 @@ import qualified Nirum.Parser as P import Nirum.Constructs (Construct (toCode))-import Nirum.Constructs.Annotation ( Annotation (Annotation)- , AnnotationSet- , empty- , fromList- )-import Nirum.Constructs.Declaration (Docs (Docs))+import Nirum.Constructs.Annotation as A ( Annotation (Annotation)+ , AnnotationSet+ , empty+ , fromList+ , union+ )+import Nirum.Constructs.Docs (Docs (Docs)) import Nirum.Constructs.DeclarationSet (DeclarationSet) import Nirum.Constructs.DeclarationSetSpec (SampleDecl(..)) import Nirum.Constructs.Identifier (fromText)@@ -36,12 +37,19 @@ , Service (Service) ) import Nirum.Constructs.TypeDeclaration ( EnumMember (EnumMember)- , Field (Field)- , Tag (Tag)+ , Field (Field, fieldAnnotations)+ , Tag (Tag, tagFields) , Type (..) , TypeDeclaration (..) )-import Nirum.Constructs.TypeExpression (TypeExpression (..))+import Nirum.Constructs.TypeExpression ( TypeExpression ( ListModifier+ , MapModifier+ , OptionModifier+ , SetModifier+ , TypeIdentifier+ )+ )+import Util (singleDocs) shouldBeRight :: (Eq l, Eq r, Show l, Show r) => Either l r -> r -> Expectation shouldBeRight actual expected = actual `shouldBe` Right expected@@ -71,7 +79,10 @@ col' <- mkPos col let parseResult = parse' inputString parseResult `shouldSatisfy` isLeft- erroredPos parseResult `shouldBe` (line', col')+ let Left parseError = parseResult+ msg = parseErrorPretty parseError+ -- msg is just for debug print+ (erroredPos parseResult, msg) `shouldBe` ((line', col'), msg) fooAnnotationSet :: AnnotationSet@@ -109,8 +120,8 @@ it "fails to parse an identifier containing disallowed chars" $ do expectError "무효한-식별자" 1 1 expectError "invalid-식별자" 1 9- let keywords = [ "boxed", "enum", "record", "type", "union"- , "BOXED", "Enum", "rEcord", "tyPE", "unioN"+ let keywords = [ "enum", "record", "type", "unboxed", "union"+ , "Enum", "rEcord", "tyPE", "UNBOXED", "unioN" ] :: [T.Text] it "fails to parse bare identifier if it's a reserved keyword" $ forM_ keywords $ \kwd ->@@ -163,8 +174,8 @@ parse' "`enum`" `shouldBeRight` Name "enum" "enum" parse' "facial/behind" `shouldBeRight` Name "facial" "behind" parse' "facial / behind" `shouldBeRight` Name "facial" "behind"- parse' "`enum`/`boxed`" `shouldBeRight` Name "enum" "boxed"- parse' "`enum` / `boxed`" `shouldBeRight` Name "enum" "boxed"+ parse' "`enum`/`unboxed`" `shouldBeRight` Name "enum" "unboxed"+ parse' "`enum` / `unboxed`" `shouldBeRight` Name "enum" "unboxed" describe "annotation" $ do let (parse', expectError) = helperFuncs P.annotation@@ -178,6 +189,8 @@ parse' "@ name-abc ( \"wo\\\"rld\")" `shouldBeRight` rightAnnotaiton parse' "@name-abc ( \"wo\\\"rld\")" `shouldBeRight` rightAnnotaiton+ parse' "@name-abc(\"wo\\\"rld\\n\")" `shouldBeRight`+ Annotation "name-abc" (Just "wo\"rld\n") it "fails to parse if annotation name start with hyphen" $ do expectError "@-abc(\"helloworld\")" 1 2 expectError "@-abc-d(\"helloworld\")" 1 2@@ -354,7 +367,7 @@ it "fails if there are any duplication on facial names" $ do let ds = [ "a" , "b"- , SampleDecl (Name "b" "c") Nothing+ , SampleDecl (Name "b" "c") A.empty ] :: [SampleDecl] p = P.handleNameDuplication "LABEL" ds cont (parse', expectError) = helperFuncs p@@ -365,7 +378,7 @@ it "fails if there are any duplication on behind names" $ do let ds = [ "a" , "b"- , SampleDecl (Name "c" "b") Nothing+ , SampleDecl (Name "c" "b") A.empty ] :: [SampleDecl] p = P.handleNameDuplication "LABEL" ds cont (parse', expectError) = helperFuncs p@@ -384,52 +397,60 @@ let (parse', expectError) = helpers it "emits (TypeDeclaration (Alias ...)) if succeeded to parse" $ do parse' "type path = text;" `shouldBeRight`- TypeDeclaration "path" (Alias "text") Nothing empty+ TypeDeclaration "path" (Alias "text") empty parse' "type path = text;\n# docs" `shouldBeRight` TypeDeclaration "path" (Alias "text")- (Just $ Docs "docs\n") empty+ (singleDocs "docs\n") parse' "type path = text;\n# docs\n# docs..." `shouldBeRight` TypeDeclaration "path" (Alias "text")- (Just $ Docs "docs\ndocs...\n")- empty+ (singleDocs "docs\ndocs...\n") parse' "@foo ( \"bar\" ) type path = text;\n# docs\n# docs..." `shouldBeRight` TypeDeclaration "path" (Alias "text")- (Just $ Docs "docs\ndocs...\n")- fooAnnotationSet+ (A.union (singleDocs "docs\ndocs...\n")+ fooAnnotationSet) parse' "@baz type path = text;\n# docs\n# docs..." `shouldBeRight` TypeDeclaration "path" (Alias "text")- (Just $ Docs "docs\ndocs...\n")- bazAnnotationSet+ (A.union (singleDocs "docs\ndocs...\n")+ bazAnnotationSet) specify "its name can't have behind name since \ \its canonical type's behind name would be used instead" $ expectError "type path/error = text;" 1 10+ it "fails to parse if trailing semicolon is missing" $ do+ let (_, expectErr) = helperFuncs P.module'+ expectErr "type a = text;\ntype b = text\ntype c = text;" 3 1+ expectErr "unboxed a (text);\ntype b = text\nunboxed c (text);" 3 1+ expectErr "type a = text;\nunboxed b (text)\ntype c = text;" 3 1 - descTypeDecl "boxedTypeDeclaration" P.boxedTypeDeclaration $ \helpers -> do- let (parse', expectError) = helpers- it "emits (TypeDeclaration (BoxedType ...)) if succeeded to parse" $ do- parse' "boxed offset (float64);" `shouldBeRight`- TypeDeclaration "offset" (BoxedType "float64") Nothing empty- parse' "boxed offset (float64);\n# docs" `shouldBeRight`- TypeDeclaration "offset" (BoxedType "float64")- (Just $ Docs "docs\n")- empty- parse' "boxed offset (float64);\n# docs\n# docs..." `shouldBeRight`- TypeDeclaration "offset" (BoxedType "float64")- (Just $ Docs "docs\ndocs...\n")- empty- parse' "@foo(\"bar\")\nboxed offset (float64);\n# docs\n# docs..."+ descTypeDecl "unboxedTypeDeclaration" P.unboxedTypeDeclaration $ \funs -> do+ let (parse', expectError) = funs+ it "emits (TypeDeclaration (UnboxedType ..)) if succeeded to parse" $ do+ parse' "unboxed offset (float64);" `shouldBeRight`+ TypeDeclaration "offset" (UnboxedType "float64") empty+ parse' "unboxed offset (float64);\n# docs" `shouldBeRight`+ TypeDeclaration "offset" (UnboxedType "float64")+ (singleDocs "docs\n")+ parse' "unboxed offset (float64);\n# docs\n# docs..." `shouldBeRight`+ TypeDeclaration "offset" (UnboxedType "float64")+ (singleDocs "docs\ndocs...\n")+ parse' "@foo(\"bar\")\nunboxed offset (float64);\n# docs\n# docs..." `shouldBeRight`- TypeDeclaration "offset" (BoxedType "float64")- (Just $ Docs "docs\ndocs...\n")- fooAnnotationSet- parse' "@baz\nboxed offset (float64);\n# docs\n# docs..."+ TypeDeclaration "offset" (UnboxedType "float64")+ (A.union (singleDocs "docs\ndocs...\n")+ fooAnnotationSet)+ parse' "@baz\nunboxed offset (float64);\n# docs\n# docs..." `shouldBeRight`- TypeDeclaration "offset" (BoxedType "float64")- (Just $ Docs "docs\ndocs...\n")- bazAnnotationSet- expectError "boxed offset/behind (float64);" 1 13+ TypeDeclaration "offset" (UnboxedType "float64")+ (A.union (singleDocs "docs\ndocs...\n")+ bazAnnotationSet)+ expectError "unboxed offset/behind (float64);" 1 15+ it "fails to parse if trailing semicolon is missing" $ do+ let (_, expectErr) = helperFuncs P.module'+ expectErr "unboxed a (text);\nunboxed b (text)\nunboxed c (text);"+ 3 1+ expectErr "type a = text;\nunboxed b (text)\ntype c = text;" 3 1+ expectErr "unboxed a (text);\ntype b = text\nunboxed c (text);" 3 1 descTypeDecl "enumTypeDeclaration" P.enumTypeDeclaration $ \helpers -> do let (parse', expectError) = helpers@@ -438,34 +459,40 @@ , "female" , "unknown" ] :: DeclarationSet EnumMember- membersWithDocs = [ EnumMember "male" (Just "docs\n")+ membersWithDocs = [ EnumMember "male" (singleDocs "docs\n") , "female"- , EnumMember "unknown" (Just "docs2\n")+ , EnumMember "unknown" (singleDocs "docs2\n") ] :: DeclarationSet EnumMember- expected = TypeDeclaration "gender" (EnumType members') Nothing- empty+ membersWithAnnots = [ EnumMember "male" fooAnnotationSet+ , "female"+ , "unknown"+ ] :: DeclarationSet EnumMember+ expected = TypeDeclaration "gender" (EnumType members') empty parse' "enum gender = male | female | unknown;" `shouldBeRight` expected parse' "enum gender=male|female|unknown;" `shouldBeRight` expected -- forward docs of enum type parse' "enum gender\n# gender type\n= male | female | unknown;"- `shouldBeRight` expected { typeDocs = Just "gender type\n" }+ `shouldBeRight` expected { typeAnnotations = singleDocs "gender type\n" } -- backward docs of enum type parse' "enum gender =\n# gender type\nmale | female | unknown;"- `shouldBeRight` expected { typeDocs = Just "gender type\n" }+ `shouldBeRight` expected { typeAnnotations = singleDocs "gender type\n" } parse' "enum gender = male # docs\n| female | unknown # docs2\n;" `shouldBeRight` TypeDeclaration "gender" (EnumType membersWithDocs)- Nothing empty parse' "@foo (\"bar\")\nenum gender=male|female|unknown;" `shouldBeRight` TypeDeclaration "gender" (EnumType members')- Nothing fooAnnotationSet+ fooAnnotationSet parse' "@baz\nenum gender=male|female|unknown;" `shouldBeRight` TypeDeclaration "gender" (EnumType members')- Nothing bazAnnotationSet+ bazAnnotationSet+ parse' "@baz\nenum gender=\n@foo (\"bar\")\nmale|female|unknown;"+ `shouldBeRight`+ TypeDeclaration "gender" (EnumType membersWithAnnots)+ bazAnnotationSet it "fails to parse if there are duplicated facial names" $ expectError "enum dup = a/b\n\ \ | b/c\n\@@ -476,17 +503,22 @@ \ | b/c\n\ \ | c/b\n\ \ ;" 4 10+ it "fails to parse if trailing semicolon is missing" $ do+ let (_, expectErr) = helperFuncs P.module'+ expectErr "enum a = x | y;\nenum b = x | y\nenum c = x | y;" 3 1+ expectErr "unboxed a (text);\nenum b = x | y\nunboxed c (text);" 3 1+ expectErr "enum a = x | y;\nunboxed b (text)\nenum c = x | y;" 3 1 descTypeDecl "recordTypeDeclaration" P.recordTypeDeclaration $ \helpers -> do let (parse', expectError) = helpers it "emits (TypeDeclaration (RecordType ...)) if succeeded to parse" $ do- let fields' = [ Field "name" "text" Nothing- , Field "dob" "date" $ Just "date of birth"- , Field "gender" "gender" Nothing- ] :: DeclarationSet Field+ let nameF = Field "name" "text" empty+ dobF = Field "dob" "date" (singleDocs "date of birth")+ genderF = Field "gender" "gender" empty+ fields' = [nameF, dobF, genderF] :: DeclarationSet Field record = RecordType fields'- a = TypeDeclaration "person" record Nothing empty- b = a { typeDocs = Just "person record type" }+ a = TypeDeclaration "person" record empty+ b = a { typeAnnotations = singleDocs "person record type" } -- without docs, last field with trailing comma parse' "record person (\n\ \ text name,\n\@@ -527,7 +559,7 @@ \ gender gender,\n\ \);" `shouldBeRight`- TypeDeclaration "person" record Nothing fooAnnotationSet+ TypeDeclaration "person" record fooAnnotationSet -- without docs, last field with trailing comma, -- with annotation without arguments parse' "@baz\n\@@ -538,7 +570,39 @@ \ gender gender,\n\ \);" `shouldBeRight`- TypeDeclaration "person" record Nothing bazAnnotationSet+ TypeDeclaration "person" record bazAnnotationSet+ -- with docs, last field with trailing comma,+ -- and annotation without arguments+ parse' "@baz\n\+ \record person (\n\+ \ # person record type\n\n\+ \ text name,\n\+ \ date dob,\n\+ \ # date of birth\n\+ \ gender gender,\n\+ \);"+ `shouldBeRight`+ TypeDeclaration "person" record+ (union bazAnnotationSet $+ singleDocs "person record type")+ -- without docs, last field with trailing comma,+ -- and annotations on fields+ parse' "record person (\n\+ \ text name,\n\+ \ @foo (\"bar\")\n\+ \ date dob,\n\+ \ # date of birth\n\+ \ @baz\n\+ \ gender gender,\n\+ \);"+ `shouldBeRight`+ TypeDeclaration "person" (RecordType+ [ nameF+ , dobF { fieldAnnotations = union fooAnnotationSet $+ singleDocs "date of birth"+ }+ , genderF { fieldAnnotations = bazAnnotationSet }+ ]) empty it "should have one or more fields" $ do expectError "record unit ();" 1 14 expectError "record unit (\n# docs\n);" 3 1@@ -557,23 +621,31 @@ it "fails to parse if there's no space between field type and name" $ do expectError "record a (typename);" 1 11 expectError "record a (typename\n#docs\n);" 1 11+ it "fails to parse if trailing semicolon is missing" $ do+ let (_, expectErr) = helperFuncs P.module'+ expectErr+ "record a (text x);\nrecord b (text y)\nrecord c (text z);"+ 3 1+ expectErr "type a = text;\nrecord b (text x)\ntype c = text;" 3 1+ expectErr "record a (text x);\ntype b = text\nrecord c (text y);"+ 3 1 descTypeDecl "unionTypeDeclaration" P.unionTypeDeclaration $ \helpers -> do let (parse', expectError) = helpers it "emits (TypeDeclaration (UnionType ...)) if succeeded to parse" $ do- let circleFields = [ Field "origin" "point" Nothing- , Field "radius" "offset" Nothing- ]- rectangleFields = [ Field "upper-left" "point" Nothing- , Field "lower-right" "point" Nothing- ]- tags' = [ Tag "circle" circleFields Nothing- , Tag "rectangle" rectangleFields Nothing- , Tag "none" [] Nothing- ]- union = UnionType tags'- a = TypeDeclaration "shape" union Nothing empty- b = a { typeDocs = Just "shape type" }+ let cOriginF = Field "origin" "point" empty+ cRadiusF = Field "radius" "offset" empty+ circleFields = [cOriginF, cRadiusF]+ rUpperLeftF = Field "upper-left" "point" empty+ rLowerRightF = Field "lower-right" "point" empty+ rectangleFields = [rUpperLeftF, rLowerRightF]+ circleTag = Tag "circle" circleFields empty+ rectTag = Tag "rectangle" rectangleFields empty+ noneTag = Tag "none" [] empty+ tags' = [circleTag, rectTag, noneTag]+ union' = UnionType tags'+ a = TypeDeclaration "shape" union' empty+ b = a { typeAnnotations = singleDocs "shape type" } parse' "union shape\n\ \ = circle (point origin, \ \offset radius,)\n\@@ -582,6 +654,17 @@ \ | none\n\ \ ;" `shouldBeRight` a parse' "union shape\n\+ \ = circle (\n\+ \ point origin,\n\+ \ offset radius,\n\+ \ )\n\+ \ | rectangle (\n\+ \ point upper-left,\n\+ \ point lower-right,\n\+ \ )\n\+ \ | none\n\+ \ ;" `shouldBeRight` a+ parse' "union shape\n\ \ # shape type\n\ \ = circle (point origin, \ \offset radius,)\n\@@ -589,6 +672,58 @@ \point lower-right,)\n\ \ | none\n\ \ ;" `shouldBeRight` b+ parse' "@docs (\"shape type\\n\")\n\+ \union shape\n\+ \ = circle (point origin, \+ \offset radius,)\n\+ \ | rectangle (point upper-left, \+ \point lower-right,)\n\+ \ | none\n\+ \ ;" `shouldBeRight` b+ parse' "union shape\n\+ \ = circle (point origin, \+ \offset radius,)\n\+ \ | rectangle (point upper-left, \+ \point lower-right,)\n\+ \ | @foo (\"bar\") none\n\+ \ ;"+ `shouldBeRight`+ a { type' = union' { tags = [ circleTag+ , rectTag+ , Tag "none" [] fooAnnotationSet+ ]+ }+ }+ parse' "union shape\n\+ \ = circle (point origin, \+ \@baz \+ \offset radius,)\n\+ \ | rectangle (point upper-left, \+ \@foo (\"bar\") \+ \point lower-right,)\n\+ \ | none\n\+ \ ;"+ `shouldBeRight`+ a { type' = union'+ { tags = [ circleTag+ { tagFields =+ [ cOriginF+ , cRadiusF { fieldAnnotations =+ bazAnnotationSet }+ ]+ }+ , rectTag+ { tagFields =+ [ rUpperLeftF+ , rLowerRightF+ { fieldAnnotations =+ fooAnnotationSet }+ ]+ }+ , noneTag+ ]+ }+ } it "fails to parse if there are duplicated facial names" $ do expectError "union dup\n\ \ = a/b\n\@@ -609,6 +744,12 @@ \ = a (text a/b, text b/c, text c/b)\n\ \ | b\n\ \ ;" 2 38+ it "fails to parse if trailing semicolon is missing" $ do+ let (_, expectErr) = helperFuncs P.module'+ expectErr "union a = x | y;\nunion b = x | y\nunion c = x | y;" 3 1+ expectErr "unboxed a (text);\nunion b = x | y\nunboxed c (text);"+ 3 1+ expectErr "union a = x | y;\nunboxed b (text)\nunion c = x | y;" 3 1 describe "method" $ do let (parse', expectError) = helperFuncs P.method@@ -616,74 +757,70 @@ head $ rights [fromList [Annotation "http-get" (Just "/get-name/")]] it "emits Method if succeeded to parse" $ do parse' "text get-name()" `shouldBeRight`- Method "get-name" [] "text" Nothing Nothing empty+ Method "get-name" [] "text" Nothing empty parse' "text get-name (person user)" `shouldBeRight`- Method "get-name" [Parameter "user" "person" Nothing]- "text" Nothing Nothing empty+ Method "get-name" [Parameter "user" "person" empty]+ "text" Nothing empty parse' "text get-name ( person user,text default )" `shouldBeRight` Method "get-name"- [ Parameter "user" "person" Nothing- , Parameter "default" "text" Nothing+ [ Parameter "user" "person" empty+ , Parameter "default" "text" empty ]- "text" Nothing Nothing empty+ "text" Nothing empty parse' "@http-get(\"/get-name/\") text get-name ( person user,text default )" `shouldBeRight` Method "get-name"- [ Parameter "user" "person" Nothing- , Parameter "default" "text" Nothing+ [ Parameter "user" "person" empty+ , Parameter "default" "text" empty ]- "text" Nothing Nothing httpGetAnnotation+ "text" Nothing httpGetAnnotation parse' "text get-name() throws name-error" `shouldBeRight`- Method "get-name" [] "text" (Just "name-error") Nothing empty+ Method "get-name" [] "text" (Just "name-error") empty parse' "text get-name ( person user,text default )\n\ \ throws get-name-error" `shouldBeRight` Method "get-name"- [ Parameter "user" "person" Nothing- , Parameter "default" "text" Nothing+ [ Parameter "user" "person" empty+ , Parameter "default" "text" empty ]- "text" (Just "get-name-error") Nothing empty+ "text" (Just "get-name-error") empty parse' "@http-get(\"/get-name/\")\n\ \text get-name ( person user,text default )\n\ \ throws get-name-error" `shouldBeRight` Method "get-name"- [ Parameter "user" "person" Nothing- , Parameter "default" "text" Nothing+ [ Parameter "user" "person" empty+ , Parameter "default" "text" empty ] "text" (Just "get-name-error")- Nothing httpGetAnnotation it "can have docs" $ do parse' "text get-name (\n\ \ # Gets the name.\n\ \)" `shouldBeRight` Method "get-name" [] "text"- Nothing (Just "Gets the name.") empty+ Nothing (singleDocs "Gets the name.") parse' "text get-name (\n\ \ # Gets the name.\n\ \)throws name-error " `shouldBeRight` Method "get-name" [] "text" (Just "name-error")- (Just "Gets the name.")- empty+ (singleDocs "Gets the name.") parse' "text get-name (\n\ \ # Gets the name of the user.\n\ \ person user,\n\ \)" `shouldBeRight` Method "get-name"- [Parameter "user" "person" Nothing]+ [Parameter "user" "person" empty] "text" Nothing- (Just "Gets the name of the user.")- empty+ (singleDocs "Gets the name of the user.") parse' "text get-name (\n\ \ # Gets the name of the user.\n\ \ person user,\n\ \) throws get-name-error" `shouldBeRight` Method "get-name"- [Parameter "user" "person" Nothing]+ [Parameter "user" "person" empty] "text" (Just "get-name-error")- (Just "Gets the name of the user.")- empty+ (singleDocs "Gets the name of the user.") parse' "text get-name (\n\ \ # Gets the name of the user.\n\ \ person user,\n\@@ -693,15 +830,14 @@ \)" `shouldBeRight` Method "get-name" [ Parameter "user" "person" $- Just "The person to find their name."+ singleDocs "The person to find their name." , Parameter "default" "text" $- Just "The default name used when \- \the user has no name."+ singleDocs "The default name used when \+ \the user has no name." ] "text" Nothing- (Just "Gets the name of the user.")- empty+ (singleDocs "Gets the name of the user.") it "fails to parse if there are parameters of the same facial name" $ do expectError "bool pred(text a, text a/b)" 1 11 expectError "bool pred(text a/b, text a)" 1 11@@ -713,29 +849,30 @@ describe "serviceDeclaration" $ do let (parse', expectError) = helperFuncs P.serviceDeclaration+ getUserD = singleDocs "Gets an user by its id."+ createUserD = singleDocs "Creates a new user"+ noMethodsD = singleDocs "Service having no methods."+ oneMethodD = singleDocs "Service having only one method."+ multiMethodsD = singleDocs "Service having multiple methods."+ userIdD = singleDocs "The unique user identifier." it "emits ServiceDeclaration if succeeded to parse" $ do parse' "service null-service();" `shouldBeRight`- ServiceDeclaration "null-service" (Service []) Nothing empty+ ServiceDeclaration "null-service" (Service []) empty parse' "service null-service (\n\ \ # Service having no methods.\n\ \);" `shouldBeRight`- ServiceDeclaration "null-service"- (Service [])- (Just "Service having no methods.")- empty+ ServiceDeclaration "null-service" (Service []) noMethodsD parse' "service one-method-service(\n\ \ user get-user(uuid user-id)\n\ \);" `shouldBeRight` ServiceDeclaration "one-method-service" (Service [ Method "get-user"- [Parameter "user-id" "uuid" Nothing]+ [Parameter "user-id" "uuid" empty] "user" Nothing- Nothing empty ])- Nothing empty parse' "service one-method-service (\n\ \ # Service having only one method.\n\@@ -747,14 +884,12 @@ ServiceDeclaration "one-method-service" (Service [ Method "get-user"- [Parameter "user-id" "uuid" Nothing]+ [Parameter "user-id" "uuid" empty] "user" (Just "get-user-error")- (Just "Gets an user by its id.")- empty+ getUserD ])- (Just "Service having only one method.")- empty+ oneMethodD parse' "service user-service (\n\ \ # Service having multiple methods.\n\ \ user create-user (\n\@@ -769,36 +904,73 @@ ServiceDeclaration "user-service" (Service [ Method "create-user"- [Parameter "user" "user" Nothing]+ [Parameter "user" "user" empty] "user" Nothing- (Just "Creates a new user")- empty+ createUserD , Method "get-user"- [Parameter "user-id" "uuid" Nothing]+ [Parameter "user-id" "uuid" empty] "user" Nothing- (Just "Gets an user by its id.")- empty+ getUserD ])- (Just "Service having multiple methods.")- empty+ multiMethodsD parse' "@foo(\"bar\")\n\ \service null-service (\n\ \ # Service having no methods.\n\ \);" `shouldBeRight` ServiceDeclaration "null-service" (Service [])- (Just "Service having no methods.")- fooAnnotationSet+ (A.union noMethodsD fooAnnotationSet) parse' "@baz\n\ \service null-service (\n\ \ # Service having no methods.\n\ \);" `shouldBeRight` ServiceDeclaration "null-service" (Service [])- (Just "Service having no methods.")- bazAnnotationSet+ (A.union noMethodsD bazAnnotationSet)+ parse' "service user-service (\n\+ \ @docs (\"Creates a new user\\n\")\n\+ \ user create-user (\n\+ \ user user\n\+ \ ),\n\+ \ @docs (\"Gets an user by its id.\\n\")\n\+ \ user get-user (\n\+ \ uuid user-id\n\+ \ ),\n\+ \);" `shouldBeRight`+ ServiceDeclaration+ "user-service"+ (Service [ Method "create-user"+ [Parameter "user" "user" empty]+ "user"+ Nothing+ createUserD+ , Method "get-user"+ [Parameter "user-id" "uuid" empty]+ "user"+ Nothing+ getUserD+ ])+ empty+ parse' "service user-service (\n\+ \ user get-user (\n\+ \ @baz\n\+ \ uuid user-id\n\+ \ # The unique user identifier.\n\+ \ ),\n\+ \);" `shouldBeRight`+ ServiceDeclaration+ "user-service"+ (Service [ Method "get-user"+ [ Parameter "user-id" "uuid" $+ A.union bazAnnotationSet userIdD+ ]+ "user"+ Nothing+ empty+ ])+ empty it "fails to parse if there are methods of the same facial name" $ do expectError "service method-dups (\n\ \ bool same-name ()\n\@@ -825,6 +997,11 @@ \ bool unique-name/same-name ()\n\ \ text different-facial-name/same-name (uuid id)\n\ \);" 3 3+ it "fails to parse if trailing semicolon is missing" $ do+ let (_, expectErr) = helperFuncs P.module'+ expectErr "service a ();\nservice b ()\nservice c ();" 3 1+ expectErr "type a = text;\nservice b ()\ntype c = text;" 3 1+ expectErr "service a ();\ntype b = text\nservice c ();" 3 1 let moduleParsers = [ ("module'", P.module') , ("file", P.file) ] :: [(String, Parser Module)]@@ -832,23 +1009,22 @@ describe label $ do let (parse', expectError) = helperFuncs parser' it "emits Module if succeeded to parse" $ do- let decls = [ TypeDeclaration "path" (Alias "text") Nothing- empty+ let decls = [ TypeDeclaration "path" (Alias "text") empty , TypeDeclaration "offset"- (BoxedType "float64") Nothing- empty+ (UnboxedType "float64") empty ]- parse' "type path = text; boxed offset (float64);"+ parse' "type path = text; unboxed offset (float64);" `shouldBeRight` Module decls Nothing- parse' "#docs\n#...\ntype path = text; boxed offset (float64);"- `shouldBeRight` Module decls (Just "docs\n...")+ parse'+ "#docs\n#...\ntype path = text; unboxed offset (float64);"+ `shouldBeRight` Module decls (Just "docs\n...") it "may have no type declarations" $ do parse' "" `shouldBeRight` Module [] Nothing parse' "# docs" `shouldBeRight` Module [] (Just "docs") it "errors if there are any duplicated facial names" $- expectError "type a = text;\ntype a/b = text;" 2 1+ expectError "type a = text;\ntype a/b = text;" 2 7 it "errors if there are any duplicated behind names" $- expectError "type b = text;\ntype a/b = text;" 2 1+ expectError "type b = text;\ntype a/b = text;" 2 7 describe "modulePath" $ do let (parse', expectError) = helperFuncs P.modulePath@@ -873,8 +1049,18 @@ let (parse', expectError) = helperFuncs P.imports it "emits Import values if succeeded to parse" $ parse' "import foo.bar (a, b);" `shouldBeRight`- [ Import ["foo", "bar"] "a"- , Import ["foo", "bar"] "b"+ [ Import ["foo", "bar"] "a" empty+ , Import ["foo", "bar"] "b" empty+ ]+ it "can be annotated" $ do+ parse' "import foo.bar (@foo (\"bar\") a, @baz b);" `shouldBeRight`+ [ Import ["foo", "bar"] "a" fooAnnotationSet+ , Import ["foo", "bar"] "b" bazAnnotationSet+ ]+ parse' "import foo.bar (@foo (\"bar\") @baz a, b);" `shouldBeRight`+ [ Import ["foo", "bar"] "a" $+ union fooAnnotationSet bazAnnotationSet+ , Import ["foo", "bar"] "b" empty ] it "errors if parentheses have nothing" $ expectError "import foo.bar ();" 1 17
test/Nirum/Targets/PythonSpec.hs view
@@ -1,5 +1,4 @@-{-# LANGUAGE OverloadedLists, OverloadedStrings, QuasiQuotes,- ScopedTypeVariables #-}+{-# LANGUAGE OverloadedLists, QuasiQuotes, ScopedTypeVariables #-} {-| This unit test module optionally depends on Python interpreter. It internally tries to popen python3 executable, and import nirum Python@@ -23,6 +22,7 @@ import Data.Maybe (fromJust, isJust) import System.IO.Error (catchIOError) +import Data.Either (isRight) import Data.List (dropWhileEnd) import qualified Data.Map.Strict as M import qualified Data.Text as T@@ -57,9 +57,9 @@ , PrimitiveTypeIdentifier(..) , Tag(Tag) , Type( Alias- , BoxedType , EnumType , RecordType+ , UnboxedType , UnionType ) , TypeDeclaration ( Import@@ -78,11 +78,11 @@ import Nirum.PackageSpec (createPackage) import Nirum.Targets.Python ( Source (Source) , Code- , CodeGen( code- , localImports- , standardImports- , thirdPartyImports- )+ , CodeGen+ , CodeGenContext ( localImports+ , standardImports+ , thirdPartyImports+ ) , CompileError , InstallRequires ( InstallRequires , dependencies@@ -90,19 +90,19 @@ ) , addDependency , addOptionalDependency- , compileError , compilePackage , compilePrimitiveType , compileTypeExpression- , hasError+ , emptyContext , toAttributeName , toClassName , toImportPath , toNamePair , unionInstallRequires- , withLocalImport- , withStandardImport- , withThirdPartyImports+ , insertLocalImport+ , insertStandardImport+ , insertThirdPartyImports+ , runCodeGen ) codeGen :: a -> CodeGen a@@ -262,23 +262,21 @@ pkg = createPackage [ (mp ["foo"], m) , ( mp ["foo", "bar"]- , Module [ Import (mp ["qux"]) "path"- , TypeDeclaration "path-box" (BoxedType "path") Nothing- empty- , TypeDeclaration "int-box" (BoxedType "bigint")- Nothing empty+ , Module [ Import (mp ["qux"]) "path" empty+ , TypeDeclaration "path-unbox" (UnboxedType "path") empty+ , TypeDeclaration "int-unbox"+ (UnboxedType "bigint") empty , TypeDeclaration "point"- (RecordType [ Field "x" "int64" Nothing- , Field "y" "int64" Nothing+ (RecordType [ Field "x" "int64" empty+ , Field "y" "int64" empty ])- Nothing empty ] Nothing ) , ( mp ["qux"] , Module- [ TypeDeclaration "path" (Alias "text") Nothing empty- , TypeDeclaration "name" (BoxedType "text") Nothing empty+ [ TypeDeclaration "path" (Alias "text") empty+ , TypeDeclaration "name" (UnboxedType "text") empty ] Nothing )@@ -287,142 +285,103 @@ makeDummySource :: Module -> Source makeDummySource = makeDummySource' [] +run' :: CodeGen a -> (Either CompileError a, CodeGenContext)+run' c = runCodeGen c emptyContext++code :: CodeGen a -> a+code = either (const undefined) id . fst . run'++codeContext :: CodeGen a -> CodeGenContext+codeContext = snd . run'++compileError :: CodeGen a -> Maybe CompileError+compileError cg = either Just (const Nothing) $ fst $ runCodeGen cg emptyContext++ spec :: Spec spec = parallel $ do describe "CodeGen" $ do- let v = 123 :: Int- cg = return v :: CodeGen Int- f = return . g :: Int -> CodeGen Int- f' = return . h :: Int -> CodeGen Int- g = (+ 5) :: Int -> Int- h = (* 2) :: Int -> Int- g' = pure g :: CodeGen (Int -> Int)- h' = pure h :: CodeGen (Int -> Int)- id' x = x- context "Functor" $ do- specify "identity morphisms" $- fmap id' (return 123 :: CodeGen Int) `shouldBe` id' (return 123)- specify "composition of morphisms" $ do- fmap (g . h) cg `shouldBe` (fmap g . fmap h) cg- fmap (h . g) cg `shouldBe` (fmap h . fmap g) cg- context "Applicative" $ do- specify "identity law" $- (pure id' <*> cg) `shouldBe` cg- specify "homomorphism" $ do- let pure' = pure :: a -> CodeGen a- (pure g <*> pure v) `shouldBe` pure' (g v)- (pure h <*> pure v) `shouldBe` pure' (h v)- specify "interchange" $ do- (g' <*> pure v) `shouldBe` (pure ($ v) <*> g')- (h' <*> pure v) `shouldBe` (pure ($ v) <*> h')- specify "composition" $ do- (g' <*> (h' <*> cg)) `shouldBe` (pure (.) <*> g' <*> h' <*> cg)- (h' <*> (g' <*> cg)) `shouldBe` (pure (.) <*> h' <*> g' <*> cg)- context "Monad" $ do- specify "left identity" $ do- (return v >>= f) `shouldBe` f v- (return v >>= f') `shouldBe` f' v- specify "right identity" $- (cg >>= return) `shouldBe` cg- specify "associativity" $ do- ((cg >>= f) >>= f') `shouldBe` (cg >>= (\x -> f x >>= f'))- ((cg >>= f') >>= f) `shouldBe` (cg >>= (\x -> f' x >>= f))- specify "packages and imports" $ do- let (c :: CodeGen Int) = do- a <- withStandardImport "sys" cg- b <- withThirdPartyImports- [("nirum", ["serialize_boxed_type"])]- cg- c' <- withLocalImport ".." "Gender" cg- d <- withStandardImport "os" cg- e <- withThirdPartyImports- [("nirum", ["serialize_enum_type"])]- cg- f'' <- withLocalImport ".." "Path" cg- return $ sum ([a, b, c', d, e, f''] :: [Int])- c `shouldSatisfy` (not . hasError)- standardImports c `shouldBe` ["os", "sys"]- thirdPartyImports c `shouldBe`- [("nirum", ["serialize_boxed_type", "serialize_enum_type"])]- localImports c `shouldBe` [("..", ["Gender", "Path"])]- code c `shouldBe` (123 * 6)- specify "withStandardImport" $ do- let codeGen1 = withStandardImport "sys" (pure True)- codeGen1 `shouldSatisfy` (not . hasError)- standardImports codeGen1 `shouldBe` ["sys"]- thirdPartyImports codeGen1 `shouldBe` []- localImports codeGen1 `shouldBe` []- code codeGen1 `shouldBe` True+ specify "packages and imports" $ do+ let c = do+ insertStandardImport "sys"+ insertThirdPartyImports+ [("nirum", ["serialize_unboxed_type"])]+ insertLocalImport ".." "Gender"+ insertStandardImport "os"+ insertThirdPartyImports [("nirum", ["serialize_enum_type"])]+ insertLocalImport ".." "Path"+ let (e, ctx) = runCodeGen c emptyContext+ e `shouldSatisfy` isRight+ standardImports ctx `shouldBe` ["os", "sys"]+ thirdPartyImports ctx `shouldBe`+ [("nirum", ["serialize_unboxed_type", "serialize_enum_type"])]+ localImports ctx `shouldBe` [("..", ["Gender", "Path"])]+ specify "insertStandardImport" $ do+ let codeGen1 = insertStandardImport "sys"+ let (e1, ctx1) = runCodeGen codeGen1 emptyContext+ e1 `shouldSatisfy` isRight+ standardImports ctx1 `shouldBe` ["sys"]+ thirdPartyImports ctx1 `shouldBe` []+ localImports ctx1 `shouldBe` [] compileError codeGen1 `shouldBe` Nothing- let codeGen2 = withStandardImport "os" codeGen1- codeGen2 `shouldSatisfy` (not . hasError)- standardImports codeGen2 `shouldBe` ["os", "sys"]- thirdPartyImports codeGen2 `shouldBe` []- localImports codeGen2 `shouldBe` []- code codeGen2 `shouldBe` True+ let codeGen2 = codeGen1 >> insertStandardImport "os"+ let (e2, ctx2) = runCodeGen codeGen2 emptyContext+ e2 `shouldSatisfy` isRight+ standardImports ctx2 `shouldBe` ["os", "sys"]+ thirdPartyImports ctx2 `shouldBe` []+ localImports ctx2 `shouldBe` [] compileError codeGen2 `shouldBe` Nothing- specify "fail" $ do- let codeGen' = do- val <- withStandardImport "sys" (pure True)- _ <- fail "test"- withStandardImport "sys" (pure val)- compileError codeGen' `shouldBe` Just "test" specify "compilePrimitiveType" $ do code (compilePrimitiveType Bool) `shouldBe` "bool" code (compilePrimitiveType Bigint) `shouldBe` "int"- let decimal = compilePrimitiveType Decimal- code decimal `shouldBe` "decimal.Decimal"- standardImports decimal `shouldBe` ["decimal"]+ let (decimalCode, decimalContext) = run' (compilePrimitiveType Decimal)+ decimalCode `shouldBe` Right "decimal.Decimal"+ standardImports decimalContext `shouldBe` ["decimal"] code (compilePrimitiveType Int32) `shouldBe` "int" code (compilePrimitiveType Int64) `shouldBe` "int" code (compilePrimitiveType Float32) `shouldBe` "float" code (compilePrimitiveType Float64) `shouldBe` "float" code (compilePrimitiveType Text) `shouldBe` "str" code (compilePrimitiveType Binary) `shouldBe` "bytes"- let date = compilePrimitiveType Date- code date `shouldBe` "datetime.date"- standardImports date `shouldBe` ["datetime"]- let datetime = compilePrimitiveType Datetime- code datetime `shouldBe` "datetime.datetime"- standardImports datetime `shouldBe` ["datetime"]- let uuid = compilePrimitiveType Uuid- code uuid `shouldBe` "uuid.UUID"- standardImports uuid `shouldBe` ["uuid"]+ let (dateCode, dateContext) = run' (compilePrimitiveType Date)+ dateCode `shouldBe` Right "datetime.date"+ standardImports dateContext `shouldBe` ["datetime"]+ let (datetimeCode, datetimeContext) = run' (compilePrimitiveType Datetime)+ datetimeCode `shouldBe` Right "datetime.datetime"+ standardImports datetimeContext `shouldBe` ["datetime"]+ let (uuidCode, uuidContext) = run' (compilePrimitiveType Uuid)+ uuidCode `shouldBe` Right "uuid.UUID"+ standardImports uuidContext `shouldBe` ["uuid"] code (compilePrimitiveType Uri) `shouldBe` "str" describe "compileTypeExpression" $ do let s = makeDummySource $ Module [] Nothing specify "TypeIdentifier" $ do- let c = compileTypeExpression s (TypeIdentifier "bigint")- c `shouldSatisfy` (not . hasError)- standardImports c `shouldBe` []- localImports c `shouldBe` []- code c `shouldBe` "int"+ let (c, ctx) = run' $ compileTypeExpression s (TypeIdentifier "bigint")+ standardImports ctx `shouldBe` []+ localImports ctx `shouldBe` []+ c `shouldBe` Right "int" specify "OptionModifier" $ do- let c' = compileTypeExpression s (OptionModifier "text")- c' `shouldSatisfy` (not . hasError)- standardImports c' `shouldBe` ["typing"]- localImports c' `shouldBe` []- code c' `shouldBe` "typing.Optional[str]"+ let (c', ctx') = run' $ compileTypeExpression s (OptionModifier "text")+ standardImports ctx' `shouldBe` ["typing"]+ localImports ctx' `shouldBe` []+ c' `shouldBe` Right "typing.Optional[str]" specify "SetModifier" $ do- let c'' = compileTypeExpression s (SetModifier "text")- c'' `shouldSatisfy` (not . hasError)- standardImports c'' `shouldBe` ["typing"]- localImports c'' `shouldBe` []- code c'' `shouldBe` "typing.AbstractSet[str]"+ let (c'', ctx'') = run' $ compileTypeExpression s (SetModifier "text")+ standardImports ctx'' `shouldBe` ["typing"]+ localImports ctx'' `shouldBe` []+ c'' `shouldBe` Right "typing.AbstractSet[str]" specify "ListModifier" $ do- let c''' = compileTypeExpression s (ListModifier "text")- c''' `shouldSatisfy` (not . hasError)- standardImports c''' `shouldBe` ["typing"]- localImports c''' `shouldBe` []- code c''' `shouldBe` "typing.Sequence[str]"+ let (c''', ctx''') = run' $ compileTypeExpression s (ListModifier "text")+ standardImports ctx''' `shouldBe` ["typing"]+ localImports ctx''' `shouldBe` []+ c''' `shouldBe` Right "typing.Sequence[str]" specify "MapModifier" $ do- let c'''' = compileTypeExpression s (MapModifier "uuid" "text")- c'''' `shouldSatisfy` (not . hasError)- standardImports c'''' `shouldBe` ["uuid", "typing"]- localImports c'''' `shouldBe` []- code c'''' `shouldBe` "typing.Mapping[uuid.UUID, str]"+ let (c'''', ctx'''') = run' $ compileTypeExpression s (MapModifier "uuid" "text")+ standardImports ctx'''' `shouldBe` ["uuid", "typing"]+ localImports ctx'''' `shouldBe` []+ c'''' `shouldBe` Right "typing.Mapping[uuid.UUID, str]" describe "toClassName" $ do it "transform the facial name of the argument into PascalCase" $ do@@ -465,6 +424,10 @@ dirName = takeDirectory filePath' createDirectoryIfMissing True dirName TI.writeFile filePath' code'+ {-- <- Remove '{' to print debug log+ TI.putStrLn $ T.pack filePath'+ TI.putStrLn code'+ -- --} testRunner (Just dir) defCode testCode where files :: M.Map FilePath (Either CompileError Code)@@ -529,73 +492,81 @@ let Just result = out T.strip (T.pack result) `shouldBe` expected test testRunner source T.empty- specify "boxed type" $ do- let decl = TypeDeclaration "float-box" (BoxedType "float64")- Nothing empty- tT decl "isinstance(FloatBox, type)"- tT decl "FloatBox(3.14).value == 3.14"- tT decl "FloatBox(3.14) == FloatBox(3.14)"- tT decl "FloatBox(3.14) != FloatBox(1.0)"- tT decl [q|{FloatBox(3.14), FloatBox(3.14), FloatBox(1.0)} ==- {FloatBox(3.14), FloatBox(1.0)}|]- tT decl "FloatBox(3.14).__nirum_serialize__() == 3.14"- tT decl "FloatBox.__nirum_deserialize__(3.14) == FloatBox(3.14)"- tT decl "FloatBox.__nirum_deserialize__(3.14) == FloatBox(3.14)"- tR' decl "TypeError" "FloatBox.__nirum_deserialize__('a')"- tR' decl "TypeError" "FloatBox('a')"- let decls = [ Import ["foo", "bar"] "path-box"- , TypeDeclaration "imported-type-box"- (BoxedType "path-box") Nothing- empty+ specify "unboxed type" $ do+ let decl = TypeDeclaration "float-unbox" (UnboxedType "float64")+ empty+ tT decl "isinstance(FloatUnbox, type)"+ tT decl "FloatUnbox(3.14).value == 3.14"+ tT decl "FloatUnbox(3.14) == FloatUnbox(3.14)"+ tT decl "FloatUnbox(3.14) != FloatUnbox(1.0)"+ tT decl [q|{FloatUnbox(3.14), FloatUnbox(3.14), FloatUnbox(1.0)} ==+ {FloatUnbox(3.14), FloatUnbox(1.0)}|]+ tT decl "FloatUnbox(3.14).__nirum_serialize__() == 3.14"+ tT decl "FloatUnbox.__nirum_deserialize__(3.14) == FloatUnbox(3.14)"+ tT decl "FloatUnbox.__nirum_deserialize__(3.14) == FloatUnbox(3.14)"+ tT decl "hash(FloatUnbox(3.14))"+ tT decl "hash(FloatUnbox(3.14)) != 3.14"+ -- FIXME: Is TypeError/ValueError is appropriate exception type+ -- for deserialization error? For such case, json.loads() raises+ -- JSONDecodeError (which inherits ValueError).+ tR' decl "(TypeError, ValueError)"+ "FloatUnbox.__nirum_deserialize__('a')"+ tR' decl "TypeError" "FloatUnbox('a')"+ let decls = [ Import ["foo", "bar"] "path-unbox" empty+ , TypeDeclaration "imported-type-unbox"+ (UnboxedType "path-unbox") empty ]- tT' decls "isinstance(ImportedTypeBox, type)"- tT' decls [q|ImportedTypeBox(PathBox('/path/string')).value.value ==- '/path/string'|]- tT' decls [q|ImportedTypeBox(PathBox('/path/string')) ==- ImportedTypeBox(PathBox('/path/string'))|]- tT' decls [q|ImportedTypeBox(PathBox('/path/string')) !=- ImportedTypeBox(PathBox('/other/path'))|]- tT' decls [q|{ImportedTypeBox(PathBox('/path/string')),- ImportedTypeBox(PathBox('/path/string')),- ImportedTypeBox(PathBox('/other/path')),- ImportedTypeBox(PathBox('/path/string')),- ImportedTypeBox(PathBox('/other/path'))} ==- {ImportedTypeBox(PathBox('/path/string')),- ImportedTypeBox(PathBox('/other/path'))}|]+ tT' decls "isinstance(ImportedTypeUnbox, type)" tT' decls [q|- ImportedTypeBox(PathBox('/path/string')).__nirum_serialize__()- == '/path/string'+ ImportedTypeUnbox(PathUnbox('/path/string')).value.value ==+ '/path/string' |]+ tT' decls [q|ImportedTypeUnbox(PathUnbox('/path/string')) ==+ ImportedTypeUnbox(PathUnbox('/path/string'))|]+ tT' decls [q|ImportedTypeUnbox(PathUnbox('/path/string')) !=+ ImportedTypeUnbox(PathUnbox('/other/path'))|]+ tT' decls [q|{ImportedTypeUnbox(PathUnbox('/path/string')),+ ImportedTypeUnbox(PathUnbox('/path/string')),+ ImportedTypeUnbox(PathUnbox('/other/path')),+ ImportedTypeUnbox(PathUnbox('/path/string')),+ ImportedTypeUnbox(PathUnbox('/other/path'))} ==+ {ImportedTypeUnbox(PathUnbox('/path/string')),+ ImportedTypeUnbox(PathUnbox('/other/path'))}|] tT' decls [q|- ImportedTypeBox.__nirum_deserialize__('/path/string') ==- ImportedTypeBox(PathBox('/path/string'))+ ImportedTypeUnbox(PathUnbox('/path/string')+ ).__nirum_serialize__() == '/path/string' |]- tR'' decls "TypeError" "ImportedTypeBox.__nirum_deserialize__(123)"- tR'' decls "TypeError" "ImportedTypeBox(123)"- let boxedAlias = [ Import ["qux"] "path"+ tT' decls [q|+ ImportedTypeUnbox.__nirum_deserialize__('/path/string') ==+ ImportedTypeUnbox(PathUnbox('/path/string'))+ |]+ -- FIXME: Is TypeError/ValueError is appropriate exception type+ -- for deserialization error? For such case, json.loads() raises+ -- JSONDecodeError (which inherits ValueError).+ tR'' decls "(TypeError, ValueError)"+ "ImportedTypeUnbox.__nirum_deserialize__(123)"+ tR'' decls "TypeError" "ImportedTypeUnbox(123)"+ let boxedAlias = [ Import ["qux"] "path" empty , TypeDeclaration "way"- (BoxedType "path") Nothing- empty+ (UnboxedType "path") empty ] tT' boxedAlias "Way('.').value == '.'" tT' boxedAlias "Way(Path('.')).value == '.'" tT' boxedAlias "Way.__nirum_deserialize__('.') == Way('.')" tT' boxedAlias "Way('.').__nirum_serialize__() == '.'"- let aliasBoxed = [ Import ["qux"] "name"- , TypeDeclaration "irum" (Alias "name") Nothing- empty- ]- tT' aliasBoxed "Name('khj') == Irum('khj')"- tT' aliasBoxed "Irum.__nirum_deserialize__('khj') == Irum('khj')"- tT' aliasBoxed "Irum('khj').__nirum_serialize__() == 'khj'"- tT' aliasBoxed "Irum.__nirum_deserialize__('khj') == Name('khj')"- tT' aliasBoxed "Irum.__nirum_deserialize__('khj') == Irum('khj')"+ let aliasUnboxed = [ Import ["qux"] "name" empty+ , TypeDeclaration "irum" (Alias "name") empty+ ]+ tT' aliasUnboxed "Name('khj') == Irum('khj')"+ tT' aliasUnboxed "Irum.__nirum_deserialize__('khj') == Irum('khj')"+ tT' aliasUnboxed "Irum('khj').__nirum_serialize__() == 'khj'"+ tT' aliasUnboxed "Irum.__nirum_deserialize__('khj') == Name('khj')"+ tT' aliasUnboxed "Irum.__nirum_deserialize__('khj') == Irum('khj')" specify "enum type" $ do let members = [ "male"- , EnumMember (Name "female" "yeoseong") Nothing+ , EnumMember (Name "female" "yeoseong") empty ] :: DeclarationSet EnumMember- decl = TypeDeclaration "gender" (EnumType members) Nothing- empty+ decl = TypeDeclaration "gender" (EnumType members) empty tT decl "type(Gender) is enum.EnumMeta" tT decl "set(Gender) == {Gender.male, Gender.female}" tT decl "Gender.male.value == 'male'"@@ -611,8 +582,7 @@ , "katsuragi-misato" , "nagisa-kaworu" ] :: DeclarationSet EnumMember- decl' = TypeDeclaration "eva-char" (EnumType members') Nothing- empty+ decl' = TypeDeclaration "eva-char" (EnumType members') empty tT decl' "type(EvaChar) is enum.EnumMeta" tT decl' "set(EvaChar) == {EvaChar.soryu_asuka_langley, \ \ EvaChar.ayanami_rei, \@@ -627,12 +597,11 @@ tT decl' "EvaChar.__nirum_deserialize__('soryu-asuka-langley') == \ \ EvaChar.soryu_asuka_langley" -- to be robust specify "record type" $ do- let fields = [ Field (Name "left" "x") "bigint" Nothing- , Field "top" "bigint" Nothing+ let fields = [ Field (Name "left" "x") "bigint" empty+ , Field "top" "bigint" empty ] payload = "{'_type': 'point', 'x': 3, 'top': 14}" :: T.Text- decl = TypeDeclaration "point" (RecordType fields) Nothing- empty+ decl = TypeDeclaration "point" (RecordType fields) empty tT decl "isinstance(Point, type)" tT decl "Point(left=3, top=14).left == 3" tT decl "Point(left=3, top=14).top == 14"@@ -641,6 +610,7 @@ tT decl "Point(left=3, top=14) != Point(left=4, top=14)" tT decl "Point(left=3, top=14) != Point(left=4, top=15)" tT decl "Point(left=3, top=14) != 'foo'"+ tT decl "hash(Point(left=3, top=14))" tT decl [q|Point(left=3, top=14).__nirum_serialize__() == {'_type': 'point', 'x': 3, 'top': 14}|] tT decl [qq|Point.__nirum_deserialize__($payload) ==@@ -652,44 +622,44 @@ tR' decl "TypeError" "Point(left=1, top='a')" tR' decl "TypeError" "Point(left='a', top=1)" tR' decl "TypeError" "Point(left='a', top='b')"- let fields' = [ Field "left" "int-box" Nothing- , Field "top" "int-box" Nothing+ let fields' = [ Field "left" "int-unbox" empty+ , Field "top" "int-unbox" empty ]- decls = [ Import ["foo", "bar"] "int-box"- , TypeDeclaration "point" (RecordType fields') Nothing- empty+ decls = [ Import ["foo", "bar"] "int-unbox" empty+ , TypeDeclaration "point" (RecordType fields') empty ] payload' = "{'_type': 'point', 'left': 3, 'top': 14}" :: T.Text tT' decls "isinstance(Point, type)"- tT' decls "Point(left=IntBox(3), top=IntBox(14)).left == IntBox(3)"- tT' decls "Point(left=IntBox(3), top=IntBox(14)).top == IntBox(14)"- tT' decls [q|Point(left=IntBox(3), top=IntBox(14)) ==- Point(left=IntBox(3), top=IntBox(14))|]- tT' decls [q|Point(left=IntBox(3), top=IntBox(14)) !=- Point(left=IntBox(3), top=IntBox(15))|]- tT' decls [q|Point(left=IntBox(3), top=IntBox(14)) !=- Point(left=IntBox(4), top=IntBox(14))|]- tT' decls [q|Point(left=IntBox(3), top=IntBox(14)) !=- Point(left=IntBox(4), top=IntBox(15))|]- tT' decls "Point(left=IntBox(3), top=IntBox(14)) != 'foo'"- tT' decls [q|Point(left=IntBox(3),- top=IntBox(14)).__nirum_serialize__() ==+ tT' decls [q|Point(left=IntUnbox(3), top=IntUnbox(14)).left ==+ IntUnbox(3)|]+ tT' decls [q|Point(left=IntUnbox(3), top=IntUnbox(14)).top ==+ IntUnbox(14)|]+ tT' decls [q|Point(left=IntUnbox(3), top=IntUnbox(14)) ==+ Point(left=IntUnbox(3), top=IntUnbox(14))|]+ tT' decls [q|Point(left=IntUnbox(3), top=IntUnbox(14)) !=+ Point(left=IntUnbox(3), top=IntUnbox(15))|]+ tT' decls [q|Point(left=IntUnbox(3), top=IntUnbox(14)) !=+ Point(left=IntUnbox(4), top=IntUnbox(14))|]+ tT' decls [q|Point(left=IntUnbox(3), top=IntUnbox(14)) !=+ Point(left=IntUnbox(4), top=IntUnbox(15))|]+ tT' decls "Point(left=IntUnbox(3), top=IntUnbox(14)) != 'foo'"+ tT' decls [q|Point(left=IntUnbox(3),+ top=IntUnbox(14)).__nirum_serialize__() == {'_type': 'point', 'left': 3, 'top': 14}|] tT' decls [qq|Point.__nirum_deserialize__($payload') ==- Point(left=IntBox(3), top=IntBox(14))|]+ Point(left=IntUnbox(3), top=IntUnbox(14))|] tR'' decls "ValueError" "Point.__nirum_deserialize__({'left': 3, 'top': 14})" tR'' decls "ValueError" "Point.__nirum_deserialize__({'_type': 'foo'})"- tR'' decls "TypeError" "Point(left=IntBox(1), top='a')"- tR'' decls "TypeError" "Point(left=IntBox(1), top=2)"- let fields'' = [ Field "xy" "point" Nothing- , Field "z" "int64" Nothing+ tR'' decls "TypeError" "Point(left=IntUnbox(1), top='a')"+ tR'' decls "TypeError" "Point(left=IntUnbox(1), top=2)"+ let fields'' = [ Field "xy" "point" empty+ , Field "z" "int64" empty ]- decls' = [ Import ["foo", "bar"] "point"+ decls' = [ Import ["foo", "bar"] "point" empty , TypeDeclaration "point3d" (RecordType fields'')- Nothing empty ] tT' decls' "isinstance(Point3d, type)"@@ -708,32 +678,32 @@ 'z': 3 }) == Point3d(xy=Point(x=1, y=2), z=3)|] specify "record type with one field" $ do- let fields = [ Field "length" "bigint" Nothing ]+ let fields = [ Field "length" "bigint" empty ] payload = "{'_type': 'line', 'length': 3}" :: T.Text- decl = TypeDeclaration "line" (RecordType fields) Nothing empty+ decl = TypeDeclaration "line" (RecordType fields) empty tT decl "isinstance(Line, type)" tT decl "Line(length=10).length == 10" tT decl "Line.__slots__ == ('length', )" tT decl [qq|Line(length=3).__nirum_serialize__() == $payload|] specify "union type" $ do- let wasternNameTag =- Tag "western-name" [ Field "first-name" "text" Nothing- , Field "middle-name" "text" Nothing- , Field "last-name" "text" Nothing- ] Nothing+ let westernNameTag =+ Tag "western-name" [ Field "first-name" "text" empty+ , Field "middle-name" "text" empty+ , Field "last-name" "text" empty+ ] empty eastAsianNameTag =- Tag "east-asian-name" [ Field "family-name" "text" Nothing- , Field "given-name" "text" Nothing- ] Nothing+ Tag "east-asian-name" [ Field "family-name" "text" empty+ , Field "given-name" "text" empty+ ] empty cultureAgnosticNameTag = Tag "culture-agnostic-name"- [ Field "fullname" "text" Nothing ]- Nothing- tags = [ wasternNameTag+ [ Field "fullname" "text" empty ]+ empty+ tags = [ westernNameTag , eastAsianNameTag , cultureAgnosticNameTag ]- decl = TypeDeclaration "name" (UnionType tags) Nothing empty+ decl = TypeDeclaration "name" (UnionType tags) empty tT decl "isinstance(Name, type)" tT decl "Name.Tag.western_name.value == 'western_name'" tT decl "Name.Tag.east_asian_name.value == 'east_asian_name'"@@ -780,6 +750,8 @@ last_name='wrong') != WesternName(first_name='foo', middle_name='bar', last_name='baz')|]+ tT decl [q|hash(WesternName(first_name='foo', middle_name='bar',+ last_name='baz'))|] tT decl "isinstance(EastAsianName, type)" tT decl "issubclass(EastAsianName, Name)" tT decl [q|EastAsianName(family_name='foo',@@ -817,10 +789,10 @@ specify "union type with one tag" $ do let cultureAgnosticNameTag = Tag "pop"- [ Field "country" "text" Nothing ]- Nothing+ [ Field "country" "text" empty ]+ empty tags = [cultureAgnosticNameTag]- decl = TypeDeclaration "music" (UnionType tags) Nothing empty+ decl = TypeDeclaration "music" (UnionType tags) empty tT decl "Pop(country='KR').country == 'KR'" tT decl "Pop(country='KR') == Pop(country='KR')" tT decl "Pop(country='US') != Pop(country='KR')"@@ -829,22 +801,26 @@ specify "union type with behind names" $ do let pop = Tag (Name "pop" "popular_music")- [ Field "country" "text" Nothing ]- Nothing+ [ Field "country" "text" empty ]+ empty tags = [pop]- decl = TypeDeclaration "music" (UnionType tags) Nothing empty+ decl = TypeDeclaration "music" (UnionType tags) empty tT decl "Pop(country='KR').__nirum_tag__.value == 'popular_music'"+ specify "union type with tag has no field" $ do+ let decl = TypeDeclaration+ "status"+ (UnionType [Tag "run" [] empty, Tag "stop" [] empty])+ empty+ tT decl "Run().__nirum_tag__.value == 'run'"+ tT decl "Stop().__nirum_tag__.value == 'stop'" specify "service" $ do- let null' = ServiceDeclaration "null-service" (Service [])- Nothing empty+ let null' = ServiceDeclaration "null-service" (Service []) empty pingService = Service [Method "ping"- [Parameter "nonce" "text" Nothing]+ [Parameter "nonce" "text" empty] "bool" Nothing- Nothing empty]- ping' = ServiceDeclaration "ping-service" pingService- Nothing empty+ ping' = ServiceDeclaration "ping-service" pingService empty tT null' "issubclass(NullService, __import__('nirum').rpc.Service)" tT ping' "issubclass(PingService, __import__('nirum').rpc.Service)" tT ping' "set(PingService.ping.__annotations__) == \
test/Nirum/VersionSpec.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE OverloadedStrings #-} module Nirum.VersionSpec where import Data.Text (unpack)@@ -18,7 +17,7 @@ version `shouldSatisfy` SV.isDevelopment it "is the proper version" $ -- is it a necessary test?- version `shouldBe` SV.version 0 1 0 [] []+ version `shouldBe` SV.version 0 2 0 [] [] describe "versionText" $ do it "is equivalent to version" $ versionText `shouldBe` SV.toText version
+ test/Util.hs view
@@ -0,0 +1,7 @@+module Util (singleDocs) where++import Nirum.Constructs.Annotation as A (AnnotationSet, singleton, docs)+import Nirum.Constructs.Docs (Docs)++singleDocs :: Docs -> AnnotationSet+singleDocs = A.singleton . A.docs