nirum 0.2.0 → 0.3.0
raw patch · 58 files changed
+6565/−2975 lines, 58 filesdep +blaze-htmldep +blaze-markupdep +bytestringdep −cmdargsdep ~directorydep ~hlintdep ~megaparsec
Dependencies added: blaze-html, blaze-markup, bytestring, cmark, email-validate, fsnotify, heterocephalus, htoml, optparse-applicative, parsec, pretty, shakespeare, stm, string-qq, template-haskell, turtle, unordered-containers, uri
Dependencies removed: cmdargs
Dependency ranges changed: directory, hlint, megaparsec
Files
- CHANGES.md +248/−0
- Main.hs +0/−3
- README.md +71/−30
- app/nirum.hs +3/−0
- app/test-targets.hs +59/−0
- nirum.cabal +277/−119
- src/Nirum/Cli.hs +174/−66
- src/Nirum/CodeBuilder.hs +131/−0
- src/Nirum/CodeGen.hs +6/−2
- src/Nirum/Constructs/Annotation.hs +46/−39
- src/Nirum/Constructs/Annotation/Internal.hs +31/−21
- src/Nirum/Constructs/Declaration.hs +18/−11
- src/Nirum/Constructs/DeclarationSet.hs +10/−10
- src/Nirum/Constructs/Docs.hs +27/−9
- src/Nirum/Constructs/Identifier.hs +26/−24
- src/Nirum/Constructs/Module.hs +30/−8
- src/Nirum/Constructs/ModulePath.hs +32/−15
- src/Nirum/Constructs/Name.hs +11/−11
- src/Nirum/Constructs/Service.hs +17/−9
- src/Nirum/Constructs/TypeDeclaration.hs +60/−21
- src/Nirum/Constructs/TypeExpression.hs +2/−2
- src/Nirum/Docs.hs +184/−0
- src/Nirum/Docs/Html.hs +78/−0
- src/Nirum/Docs/ReStructuredText.hs +138/−0
- src/Nirum/Package.hs +56/−161
- src/Nirum/Package/Metadata.hs +348/−0
- src/Nirum/Package/ModuleSet.hs +124/−0
- src/Nirum/Parser.hs +124/−114
- src/Nirum/Targets.hs +88/−0
- src/Nirum/Targets/Docs.hs +378/−0
- src/Nirum/Targets/List.hs +34/−0
- src/Nirum/Targets/Python.hs +1647/−806
- src/Nirum/TypeInstance/BoundModule.hs +71/−0
- test/Nirum/CliSpec.hs +7/−8
- test/Nirum/CodeBuilderSpec.hs +96/−0
- test/Nirum/CodeGenSpec.hs +10/−10
- test/Nirum/Constructs/AnnotationSpec.hs +33/−38
- test/Nirum/Constructs/DeclarationSetSpec.hs +8/−6
- test/Nirum/Constructs/DocsSpec.hs +29/−2
- test/Nirum/Constructs/IdentifierSpec.hs +3/−3
- test/Nirum/Constructs/ModulePathSpec.hs +48/−7
- test/Nirum/Constructs/ModuleSpec.hs +6/−6
- test/Nirum/Constructs/NameSpec.hs +1/−1
- test/Nirum/Constructs/ServiceSpec.hs +143/−127
- test/Nirum/Constructs/TypeDeclarationSpec.hs +75/−74
- test/Nirum/Constructs/TypeExpressionSpec.hs +1/−1
- test/Nirum/Docs/HtmlSpec.hs +30/−0
- test/Nirum/Docs/ReStructuredTextSpec.hs +32/−0
- test/Nirum/DocsSpec.hs +93/−0
- test/Nirum/Package/MetadataSpec.hs +267/−0
- test/Nirum/Package/ModuleSetSpec.hs +152/−0
- test/Nirum/PackageSpec.hs +102/−176
- test/Nirum/ParserSpec.hs +468/−362
- test/Nirum/Targets/DocsSpec.hs +33/−0
- test/Nirum/Targets/PythonSpec.hs +249/−672
- test/Nirum/TargetsSpec.hs +69/−0
- test/Nirum/TypeInstance/BoundModuleSpec.hs +60/−0
- test/Nirum/VersionSpec.hs +1/−1
+ CHANGES.md view
@@ -0,0 +1,248 @@+Nirum changelog+===============++Version 0.3.0+-------------++Released on February 18, 2018.++### Language++ - [Package](./docs/package.md) is now a new compilation unit of Nirum.+ Every Nirum package needs *package.toml* manifest file.+ [[#83], [#99]]+ - Since a Nirum package can be compiled to more than one target languages,+ the `nirum` command became to have `-t`/`--target` required parameter.+ [[#106], [#111], [#114]]+ - Added `-w`/`--watch` mode. [[#91], [#104], [#218]]+ - Annotations became able to have multiple arguments and every parameter+ became necessary to having its name (keyword). [[#178], [#190], [#197]]+ - Service methods became able to omit their return types.+ [[#179], [#199] by Yang Chun Ung]+ - Added `@error` annotation to make a type to subclass an exception base+ class (e.g., [`Exception`][python-exception] in Python) when it's compiled+ to OO languages. [[#38], [#127]]+ - Union tag docstrings in parentheses became allowed. [[#153], [#154]]+ - Fixed a parser bug that a bare identifier (i.e., unquoted identifier) cannot+ start with a reserved keyword, e.g., `types` (`type` is reserved),+ `enumeration` (`enum` is reserved). [[#184], [#189]]+ - Fixed a parser bug that `import` names had been disallowing to have+ a trailing comma or newlines. [[#202]]+ - Fixed the `nirum` command bug that it had always terminated with exit code+ 0 even when it errored. [[#97], [#108]]++### Docs target++ - A new target, `docs` is now available. To generate docs for a Nirum+ package, specify `--target docs` option to the `nirum` command.+ [[#10], [#113], [#116], [#125], [#131], [#152], [#170], [#223]]++### Python target++ - Now supports Python 2.7 besides Python 3.4 or later.+ [[#50], [#85], [#93], [#117], [nirum-python #22]]+ - Now requires *nirum-python* 0.6.0 or later. [[#119], [#141], [#146]]+ - From now on, in order to compile a Nirum package to Python,+ *package.toml* manifest need [`targets.python`][targets.python] section+ and `targets.python.name` field. [[#99]]+ - Added `targets.python.minimum_runtime` option to specify the minimum+ version of *nirum-python* runtime library. [[#118], [#119]]+ - Added `targets.python.renames` option to rename module names when they+ are compiled to a Python module. [[#121]]+ - More package metadata became configurable. [[#100]]+ - `targets.python.description` [[#174] by Seunghun Lee]+ - `targets.python.license` [[#180] by Seunghun Lee]+ - `targets.python.keywords` [[#183] by Seunghun Lee]+ - Added new transport layer. [[#149], [nirum-python #79], [nirum-python #92]]+ - Generated constructors of service clients became to take a+ `nirum.transport.Transport` instance.+ - Followed renamed/moved import paths of the runtime classes+ (e.g., `nirum.rpc.Service` became to `nirum.service.Service`).+ - The way to avoid name collision between generated types and runtime+ classes is changed. The runtime library had provided alternative names+ like `service_type` for `Service` and generated imports had been like+ `from nirum.rpc import service_type`, but it's now+ `from nirum.service import Service as service_type`.+ - Record/union tag fields of an optional type can be omitted when+ the constructor is called.+ [[#70], [#165] by Seunghun Lee]+ - Generated tag classes became qualified under its union class+ (e.g., `Shape.Rectangle` instead of `Rectangle`).+ Deprecated the old style and it is going to be obsolete in the near future.+ [[#68], [#193]]+ - Generated service clients became qualified under its service class+ (e.g., `FooService.Client` instead of `FooService_Client`).+ Deprecated the old style and it is going to be obsolete in the near future.+ [[#167], [#222]].+ - Generated serializers became independent from *nirum-python* runtime+ library. [[#160], [#201], [#203], [#204]]+ - Deserializers became to show multiple error messages at a time.+ [[#168], [#224]]+ - Generated Python classes became having `__nirum_type__` metadata for RTTI.+ [[nirum-python #34], [#192]]+ - Generated service classes became having `__nirum_method_annotations__`+ metadata for processing annotations. [[#194]]+ - Docstrings in a Nirum schema became to generate corresponding Python+ docstrings. [[#102], [#128]]+ - Sets, lists, and maps became compiled to immutable data structures+ so that thay are easily hashable. [[nirum-python #49], [#123]]+ - Fixed a bug that implicit ancestor packages hadn't been generated even+ if they have submodules. [[#92], [#105]]+ - Fixed a bug that a generated Python code had raised+ [`NameError`][python-name-error] when a referring type is above than+ a referred type. [[#138], [nirum-python #88], [#146]]+ - Fixed a bug that a generated Python `enum` code had became broken+ when an enum type has a member named `mro`. [[#185], [#188]]++### Et cetera++ - The officialy distributed executable binaries for Linux became+ independent from [glibc]; instead statically linked to [musl]. [#216]+ - The Docker image now has `nirum` command in `PATH`. [[#155]]+ - The Docker image became based and built on [Alpine Linux][] so that+ the image is now much lighter.++[#10]: https://github.com/spoqa/nirum/issues/10+[#38]: https://github.com/spoqa/nirum/issues/38+[#50]: https://github.com/spoqa/nirum/issues/50+[#68]: https://github.com/spoqa/nirum/issues/68+[#70]: https://github.com/spoqa/nirum/issues/70+[#83]: https://github.com/spoqa/nirum/pull/83+[#85]: https://github.com/spoqa/nirum/pull/85+[#91]: https://github.com/spoqa/nirum/issues/91+[#92]: https://github.com/spoqa/nirum/issues/92+[#93]: https://github.com/spoqa/nirum/issues/93+[#99]: https://github.com/spoqa/nirum/pull/99+[#97]: https://github.com/spoqa/nirum/issues/97+[#100]: https://github.com/spoqa/nirum/issues/100+[#102]: https://github.com/spoqa/nirum/issues/102+[#104]: https://github.com/spoqa/nirum/pull/104+[#105]: https://github.com/spoqa/nirum/pull/105+[#106]: https://github.com/spoqa/nirum/pull/106+[#108]: https://github.com/spoqa/nirum/pull/108+[#111]: https://github.com/spoqa/nirum/pull/111+[#113]: https://github.com/spoqa/nirum/pull/113+[#114]: https://github.com/spoqa/nirum/pull/114+[#116]: https://github.com/spoqa/nirum/pull/116+[#117]: https://github.com/spoqa/nirum/pull/117+[#118]: https://github.com/spoqa/nirum/issues/118+[#119]: https://github.com/spoqa/nirum/pull/119+[#121]: https://github.com/spoqa/nirum/pull/121+[#123]: https://github.com/spoqa/nirum/pull/123+[#128]: https://github.com/spoqa/nirum/pull/128+[#125]: https://github.com/spoqa/nirum/issues/125+[#127]: https://github.com/spoqa/nirum/pull/127+[#131]: https://github.com/spoqa/nirum/pull/131+[#138]: https://github.com/spoqa/nirum/issues/138+[#141]: https://github.com/spoqa/nirum/pull/141+[#146]: https://github.com/spoqa/nirum/pull/146+[#149]: https://github.com/spoqa/nirum/pull/149+[#152]: https://github.com/spoqa/nirum/pull/152+[#153]: https://github.com/spoqa/nirum/issues/153+[#154]: https://github.com/spoqa/nirum/pull/154+[#155]: https://github.com/spoqa/nirum/pull/155+[#160]: https://github.com/spoqa/nirum/issues/160+[#165]: https://github.com/spoqa/nirum/pull/165+[#167]: https://github.com/spoqa/nirum/pull/167+[#168]: https://github.com/spoqa/nirum/issues/168+[#170]: https://github.com/spoqa/nirum/pull/170+[#174]: https://github.com/spoqa/nirum/pull/174+[#178]: https://github.com/spoqa/nirum/issues/178+[#179]: https://github.com/spoqa/nirum/issues/179+[#180]: https://github.com/spoqa/nirum/pull/180+[#183]: https://github.com/spoqa/nirum/pull/183+[#184]: https://github.com/spoqa/nirum/issues/184+[#185]: https://github.com/spoqa/nirum/issues/185+[#188]: https://github.com/spoqa/nirum/pull/188+[#189]: https://github.com/spoqa/nirum/pull/189+[#190]: https://github.com/spoqa/nirum/pull/190+[#192]: https://github.com/spoqa/nirum/pull/192+[#193]: https://github.com/spoqa/nirum/pull/193+[#194]: https://github.com/spoqa/nirum/pull/194+[#197]: https://github.com/spoqa/nirum/pull/197+[#199]: https://github.com/spoqa/nirum/pull/199+[#201]: https://github.com/spoqa/nirum/pull/201+[#202]: https://github.com/spoqa/nirum/pull/202+[#203]: https://github.com/spoqa/nirum/pull/203+[#204]: https://github.com/spoqa/nirum/pull/204+[#216]: https://github.com/spoqa/nirum/issues/216+[#222]: https://github.com/spoqa/nirum/pull/222+[#218]: https://github.com/spoqa/nirum/issues/218+[#222]: https://github.com/spoqa/nirum/pull/222+[#223]: https://github.com/spoqa/nirum/pull/223+[#224]: https://github.com/spoqa/nirum/pull/224+[nirum-python #22]: https://github.com/spoqa/nirum-python/issues/22+[nirum-python #34]: https://github.com/spoqa/nirum-python/issues/34+[nirum-python #49]: https://github.com/spoqa/nirum-python/issues/49+[nirum-python #79]: https://github.com/spoqa/nirum-python/issues/79+[nirum-python #88]: https://github.com/spoqa/nirum-python/pull/88+[nirum-python #92]: https://github.com/spoqa/nirum-python/pull/92+[python-exception]: https://docs.python.org/3/library/exceptions.html#Exception+[targets.python]: ./target/python.md+[python-name-error]: https://docs.python.org/3/library/exceptions.html#NameError+[glibc]: https://www.gnu.org/software/libc/+[musl]: https://www.musl-libc.org/+[Alpine Linux]: https://alpinelinux.org/+++Version 0.2.0+-------------++Still unstable release. Released on September 26, 2016.++### Language++ - The `boxed` keyword was renamed to `unboxed`. [[#65], [#81]]+ - [Annotations](./docs/annotation.md) became renewed and complete+ so that every type and module now can be annotated.+ [[#40], [#73]]+ - Docstrings became merely a syntactic sugar of `@docs` annotation.+ [[#53], [#57]]+ - Fixed a parser bug which had failed to parse spaces right before/after tag+ parentheses. [[#69], [#71]]+ - Fixed a parser bug which had referred to a wrong line/column position on+ syntax error message when a trailing semicolon is missing. [[#64]]++[#40]: https://github.com/spoqa/nirum/issues/40+[#53]: https://github.com/spoqa/nirum/pull/53+[#57]: https://github.com/spoqa/nirum/pull/57+[#64]: https://github.com/spoqa/nirum/pull/64+[#65]: https://github.com/spoqa/nirum/issues/65+[#69]: https://github.com/spoqa/nirum/issues/69+[#71]: https://github.com/spoqa/nirum/pull/71+[#73]: https://github.com/spoqa/nirum/pull/73+[#81]: https://github.com/spoqa/nirum/pull/81++### Python target++ - Services became to have their own client implementation of a name with+ `_Client` postfix when they are compiled to Python. [[#52]]+ - Generated types became to have `__hash__()` method so that they are now+ hashable. [[#75], [#76]]+ - Fixed a bug that a Python class generated from a parameterless tag had+ been broken. [[#55], [#66]]++[#52]: https://github.com/spoqa/nirum/pull/52+[#75]: https://github.com/spoqa/nirum/issues/75+[#76]: https://github.com/spoqa/nirum/pull/76+[#66]: https://github.com/spoqa/nirum/pull/66+[#55]: https://github.com/spoqa/nirum/issues/55++### Et cetera++ - Introduced the official Docker image. The image repository is located to+ [spoqa/nirum](https://hub.docker.com/r/spoqa/nirum/).+ [[#48] by Minyoung Jeong]++[#48]: https://github.com/spoqa/nirum/pull/48++++Version 0.1.0+-------------++Initial and unstable release for a+[demo session at PyCon APAC 2016][pycon-apac-2016].+Released on August 14, 2016.++[pycon-apac-2016]: https://www.pycon.kr/2016apac/program/36
− Main.hs
@@ -1,3 +0,0 @@-module Main (main) where--import Nirum.Cli (main)
README.md view
@@ -1,17 +1,26 @@ Nirum ===== -[![Build Status (Travis CI)][ci-svg]][ci]-[![Build Status (AppVeyor)][ciw-svg]][ciw]-[![Docker Automated Build][docker-svg]][docker]+[![The latest release on GitHub][release-svg]][release]+[![Docker automated build][docker-svg]][docker]+[![Build status on Linux and macOS (Travis CI)][ci-svg]][ci]+[![Build status on Windows (AppVeyor)][ciw-svg]][ciw]+[![Test coverage (codecov)][cov-svg]][cov]+[![Total lines of code][loc]][repo] [![Gitter][chat-svg]][chat] -[ci-svg]: https://travis-ci.org/spoqa/nirum.svg+[release-svg]: https://img.shields.io/github/release/spoqa/nirum/all.svg+[release]: https://github.com/spoqa/nirum/releases+[docker]: https://hub.docker.com/r/spoqa/nirum/+[docker-svg]: https://img.shields.io/docker/automated/spoqa/nirum.svg+[ci-svg]: https://travis-ci.org/spoqa/nirum.svg?branch=master [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+[cov-svg]: https://codecov.io/gh/spoqa/nirum/branch/master/graph/badge.svg+[cov]: https://codecov.io/gh/spoqa/nirum+[loc]: https://tokei.rs/b1/github/spoqa/nirum+[repo]: https://github.com/spoqa/nirum [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 @@ -19,7 +28,7 @@ for [microservices][4], 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/`+You can find how the language looks like from source codes in the `examples/` directory. **Note that its design is highly unstable and could be changed.**@@ -50,49 +59,81 @@ In order to compile a Nirum package (`examples/`) to a Python package: $ mkdir out/ # directory to place generated Python files- $ nirum -o out/ examples/+ $ nirum -t python -o out/ examples/ For more infomration, use `--help` option: $ nirum --help- Nirum Compiler 0.1.0+ Nirum: The IDL compiler and RPC/distributed object framework - nirum [OPTIONS] DIR+ Usage: nirum [-v|--version] (-o|--output-dir DIR) (-t|--target TARGET) DIR+ Nirum compiler 0.3.0 - Common flags:- -o --output-dir=DIR The directory to place object files- -? --help Display help message- -V --version Print version information- --numeric-version Print just the version number+ Available options:+ -h,--help Show this help text+ -v,--version Show version+ -o,--output-dir DIR Output directory+ -t,--target TARGET Target language name. Available: docs, python+ DIR Package directory +There is a [step-by-step tutorial](./docs/tutorial.md) as well. + 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:+If you already installed [Haskell Stack][5], you can build the project+in the same way to build other Haskell softwares: $ stack build -Using vanilla Cabal:+You can run the test suite of Nirum: - $ cabal sandbox init- $ cabal install --only-dependencies- $ cabal configure- $ cabal build+ $ stack test # unit test for compiler+ $ ./lint.sh # style lint -[5]: https://www.haskell.org/platform/-[6]: https://www.haskellstack.org/+For details, please read the [contribution guide](./CONTRIBUTING.md). +[5]: https://www.haskellstack.org/ ++Related projects & tools+------------------------++See also the [list of Nirum-related projects][7] on GitHub. Have you kicked off+a new project related to Nirum? Please add *nirum* [topic][8] to your project+on GitHub!++### Language runtimes++ - [nirum-python](https://github.com/spoqa/nirum-python): The official Python+ runtime library for Nirum.+ - [nirum-python-http](https://github.com/spoqa/nirum-python-http):+ Nirum HTTP transport for Python.+ - [nirum-python-wsgi](https://github.com/spoqa/nirum-python-wsgi):+ Adapt Nirum services to WSGI apps.++### Editor supports++ - [nirum.tmbundle](https://github.com/spoqa/nirum.tmbundle): TextMate bundle+ for Nirum. Also can be used by IntelliJ IDEA (or any other JetBrain's+ IDEs, e.g., PyCharm, WebStorm) through [TextMate bundles support][9].+ - [nirum.vim](https://github.com/spoqa/nirum.vim): Nirum syntax highlighter for+ Vim/Neovim.+ - [sublime-nirum](https://github.com/spoqa/sublime-nirum): Nirum package for+ Sublime Text 3.++[7]: https://github.com/search?q=topic:nirum+fork:false+[8]: https://github.com/blog/2309-introducing-topics+[9]: https://github.com/spoqa/nirum.tmbundle#installation-intellij-idea-pycharm-etc++ Etymology --------- **니름** (IPA: /niɾɯm/; *nireum*) is a sort of telepathy in the fictional world-of [The Bird That Drinks Tears][7] (눈물을 마시는 새 *Nunmureul masineun sae*)-by [Lee Yeongdo][8] (이영도).+of [The Bird That Drinks Tears][9] (눈물을 마시는 새 *Nunmureul masineun sae*)+by [Lee Yeongdo][10] (이영도). -[7]: https://en.wikipedia.org/wiki/The_Bird_That_Drinks_Tears-[8]: https://en.wikipedia.org/wiki/Lee_Yeongdo+[9]: https://en.wikipedia.org/wiki/The_Bird_That_Drinks_Tears+[10]: https://en.wikipedia.org/wiki/Lee_Yeongdo
+ app/nirum.hs view
@@ -0,0 +1,3 @@+module Main (main) where++import Nirum.Cli (main)
+ app/test-targets.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE OverloadedStrings, QuasiQuotes #-}+-- How to add a test suite for a new target+--+-- a. Define a function of the same name to the target name+-- (i.e. `targetName :: Target t => Proxy t -> TargetName`),+-- which is a type of `IO ()`. See `python :: IO ()` for example.+--+-- b. If a test suite requires any external programs list them+-- in "External dependencies" section of CONTRIBUTING.md docs.+--+-- c. Add the defined function to `do` block of `main` function.+-- Please keep functions in lexicographical order.+--+-- d. If an action is necessary for only CI builds invoke it using+-- `whenCi :: IO () -> IO ()`.+--+-- e. This script is written in Turtle, a DSL embeded in Haskell for+-- shell scripting.+-- See also <https://github.com/Gabriel439/Haskell-Turtle-Library>.+import Control.Monad (when)+import System.Environment (lookupEnv)+import System.IO.Error (catchIOError, isDoesNotExistError)++import qualified Data.Text as T+import Text.InterpolatedString.Perl6 (qq)++import Turtle++-- | Invoke a process.+proc' :: T.Text -> [T.Text] -> IO ()+proc' prog args =+ catchIOError (procs prog args empty) $ \ex ->+ if isDoesNotExistError ex+ then do err ""+ err [qq|Couldn't find executable: "$prog"|]+ exit $ ExitFailure 1+ else ioError ex++-- | Run the IO operation only if it's run on CI.+whenCi :: IO () -> IO ()+whenCi block = do+ ciEnv <- lookupEnv "CI"+ let ci = maybe False (/= "") ciEnv+ when ci block++-- | Teget all targets.+main :: IO ()+main =+ -- CHECK: If an added test suite requires any external programs+ -- list them in "External dependencies" section of CONTRIBUTING.md docs.+ python++-- | Test Python target.+python :: IO ()+python = do+ toxEnv <- lookupEnv "TOX"+ let tox = maybe "tox" T.pack toxEnv+ whenCi $ proc' tox ["-e", "devruntime"]+ proc' tox ["--skip-missing-interpreters"]
nirum.cabal view
@@ -1,127 +1,285 @@-name: nirum-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-license-file: LICENSE-author: Nirum team-maintainer: Nirum team-copyright: (c) 2016 Nirum team-stability: alpha-category: Language-build-type: Simple-extra-source-files: README.md-cabal-version: >=1.10+-- This file has been generated from package.yaml by hpack version 0.20.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: d73e14bde196f4880bd9edb7786571142a599151fd80cd02969fddf22f561a27 +name: nirum+version: 0.3.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 the language looks like from source codes in the examples/ directory.+ See also README.md for more details.+category: Language+stability: alpha+homepage: http://nirum.org/+bug-reports: https://github.com/spoqa/nirum/issues+author: Nirum team+maintainer: Nirum team+copyright: (c) 2016–2018 Nirum team+license: GPL-3+license-file: LICENSE+build-type: Simple+cabal-version: >= 1.10++extra-source-files:+ CHANGES.md+ README.md++source-repository head+ type: git+ location: git@github.com/spoqa/nirum.git++flag static+ description: Static link+ manual: True+ default: False+ 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- , Nirum.Constructs.Name- , Nirum.Constructs.Service- , Nirum.Constructs.TypeDeclaration- , Nirum.Constructs.TypeExpression- , Nirum.Package- , Nirum.Parser- , Nirum.Targets.Python- , Nirum.Version- build-depends: base >=4.7 && <5- , containers >=0.5.6.2 && <0.6- , cmdargs >=0.10.14 && <0.11- , directory >=1.2.5 && <1.3- , 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+ hs-source-dirs:+ src+ default-extensions: OverloadedStrings+ ghc-options: -Wall -fwarn-incomplete-uni-patterns -fprint-explicit-kinds+ build-depends:+ base >=4.7 && <5+ , blaze-html >=0.9.0.1 && <0.10+ , blaze-markup >=0.8.0.0 && <0.9+ , bytestring+ , cmark >=0.5 && <0.6+ , containers >=0.5.6.2 && <0.6+ , directory >=1.2.5 && <1.4+ , email-validate >=2.0.0 && <3.0.0+ , filepath >=1.4 && <1.5+ , fsnotify >=0.2.1 && <0.3.0+ , heterocephalus >=1.0.5 && <1.1.0+ , htoml >=1.0.0.0 && <1.1.0.0+ , interpolatedstring-perl6 >=1.0.0 && <1.1.0+ , megaparsec >=5 && <5.4+ , mtl >=2.2.1 && <3+ , optparse-applicative >=0.13.1 && <0.14+ , parsec+ , pretty >=1.1.3 && <2+ , semver >=0.3.0 && <1.0+ , shakespeare >=2.0.12 && <2.1+ , stm >=2.4.4.1+ , template-haskell >=2.11 && <3+ , text >=0.9.1.0 && <1.3+ , unordered-containers+ , uri >=0.1 && <1.0+ exposed-modules:+ Nirum.Cli+ Nirum.CodeBuilder+ 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+ Nirum.Constructs.Name+ Nirum.Constructs.Service+ Nirum.Constructs.TypeDeclaration+ Nirum.Constructs.TypeExpression+ Nirum.Docs+ Nirum.Docs.Html+ Nirum.Docs.ReStructuredText+ Nirum.Package+ Nirum.Package.Metadata+ Nirum.Package.ModuleSet+ Nirum.Parser+ Nirum.Targets+ Nirum.Targets.Docs+ Nirum.Targets.List+ Nirum.Targets.Python+ Nirum.TypeInstance.BoundModule+ Nirum.Version+ other-modules:+ Paths_nirum+ default-language: Haskell2010 executable nirum- build-depends: base >=4.7 && <5- , nirum- main-is: Main.hs- default-language: Haskell2010- ghc-options: -fwarn-incomplete-uni-patterns- -threaded -with-rtsopts=-N+ main-is: nirum.hs+ hs-source-dirs:+ app+ default-extensions: OverloadedStrings+ ghc-options: -Wall+ build-depends:+ base >=4.7 && <5+ , blaze-html >=0.9.0.1 && <0.10+ , bytestring+ , containers >=0.5.6.2 && <0.6+ , directory >=1.2.5 && <1.4+ , email-validate >=2.0.0 && <3.0.0+ , filepath >=1.4 && <1.5+ , htoml >=1.0.0.0 && <1.1.0.0+ , interpolatedstring-perl6 >=1.0.0 && <1.1.0+ , megaparsec >=5 && <5.4+ , mtl >=2.2.1 && <3+ , nirum+ , parsec+ , pretty >=1.1.3 && <2+ , semver >=0.3.0 && <1.0+ , text >=0.9.1.0 && <1.3+ , unordered-containers+ if flag(static)+ if os(darwin) || os(windows)+ ghc-options: -fwarn-incomplete-uni-patterns -threaded -with-rtsopts=-N -static -optc-Os+ else+ ghc-options: -fwarn-incomplete-uni-patterns -threaded -with-rtsopts=-N -static -optl-static -optl-pthread -optc-Os -fPIC+ else+ ghc-options: -fwarn-incomplete-uni-patterns -threaded -with-rtsopts=-N+ other-modules:+ Paths_nirum+ default-language: Haskell2010 -executable nirum-static- build-depends: base >=4.7 && <5- , nirum- main-is: Main.hs- default-language: Haskell2010- ghc-options: -fwarn-incomplete-uni-patterns- -threaded -with-rtsopts=-N- -static+test-suite hlint+ type: exitcode-stdio-1.0+ main-is: HLint.hs+ hs-source-dirs:+ test+ default-extensions: OverloadedStrings+ ghc-options: -Wall+ build-depends:+ base >=4.7 && <5+ , blaze-html >=0.9.0.1 && <0.10+ , bytestring+ , containers >=0.5.6.2 && <0.6+ , directory >=1.2.5 && <1.4+ , email-validate >=2.0.0 && <3.0.0+ , filepath >=1.4 && <1.5+ , hlint >=2.0.9 && <2.1+ , htoml >=1.0.0.0 && <1.1.0.0+ , interpolatedstring-perl6 >=1.0.0 && <1.1.0+ , megaparsec >=5 && <5.4+ , mtl >=2.2.1 && <3+ , parsec+ , pretty >=1.1.3 && <2+ , semver >=0.3.0 && <1.0+ , text >=0.9.1.0 && <1.3+ , unordered-containers+ other-modules:+ Nirum.CliSpec+ Nirum.CodeBuilderSpec+ Nirum.CodeGenSpec+ Nirum.Constructs.AnnotationSpec+ Nirum.Constructs.DeclarationSetSpec+ Nirum.Constructs.DocsSpec+ Nirum.Constructs.IdentifierSpec+ Nirum.Constructs.ModulePathSpec+ Nirum.Constructs.ModuleSpec+ Nirum.Constructs.NameSpec+ Nirum.Constructs.ServiceSpec+ Nirum.Constructs.TypeDeclarationSpec+ Nirum.Constructs.TypeExpressionSpec+ Nirum.Docs.HtmlSpec+ Nirum.Docs.ReStructuredTextSpec+ Nirum.DocsSpec+ Nirum.Package.MetadataSpec+ Nirum.Package.ModuleSetSpec+ Nirum.PackageSpec+ Nirum.ParserSpec+ Nirum.Targets.DocsSpec+ Nirum.Targets.PythonSpec+ Nirum.TargetsSpec+ Nirum.TypeInstance.BoundModuleSpec+ Nirum.VersionSpec+ Spec+ Util+ Paths_nirum+ default-language: Haskell2010 test-suite spec- type: exitcode-stdio-1.0- hs-source-dirs: test- main-is: Spec.hs- other-modules: Nirum.CliSpec- , Nirum.CodeGenSpec- , Nirum.Constructs.AnnotationSpec- , 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- , filepath >=1.4 && <1.5- , hspec- , hspec-core- , 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- , semver >=0.3.0 && <1.0- , temporary >=1.2 && <1.3- , text >=0.9.1.0 && <1.3- ghc-options: -fno-warn-incomplete-uni-patterns- -fno-warn-missing-signatures- -threaded -with-rtsopts=-N+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ hs-source-dirs:+ test+ default-extensions: OverloadedStrings+ ghc-options: -Wall -fno-warn-incomplete-uni-patterns -fno-warn-missing-signatures -threaded -with-rtsopts=-N+ build-depends:+ base >=4.7 && <5+ , blaze-html >=0.9.0.1 && <0.10+ , bytestring+ , containers >=0.5.6.2 && <0.6+ , directory >=1.2.5 && <1.4+ , email-validate >=2.0.0 && <3.0.0+ , filepath >=1.4 && <1.5+ , hspec+ , hspec-core+ , hspec-meta+ , htoml >=1.0.0.0 && <1.1.0.0+ , interpolatedstring-perl6 >=1.0.0 && <1.1.0+ , megaparsec >=5 && <5.4+ , mtl >=2.2.1 && <3+ , nirum+ , parsec+ , pretty >=1.1.3 && <2+ , process >=1.1 && <2+ , semigroups+ , semver >=0.3.0 && <1.0+ , string-qq >=0.0.2 && <0.1.0+ , temporary >=1.2 && <1.3+ , text >=0.9.1.0 && <1.3+ , unordered-containers+ other-modules:+ HLint+ Nirum.CliSpec+ Nirum.CodeBuilderSpec+ Nirum.CodeGenSpec+ Nirum.Constructs.AnnotationSpec+ Nirum.Constructs.DeclarationSetSpec+ Nirum.Constructs.DocsSpec+ Nirum.Constructs.IdentifierSpec+ Nirum.Constructs.ModulePathSpec+ Nirum.Constructs.ModuleSpec+ Nirum.Constructs.NameSpec+ Nirum.Constructs.ServiceSpec+ Nirum.Constructs.TypeDeclarationSpec+ Nirum.Constructs.TypeExpressionSpec+ Nirum.Docs.HtmlSpec+ Nirum.Docs.ReStructuredTextSpec+ Nirum.DocsSpec+ Nirum.Package.MetadataSpec+ Nirum.Package.ModuleSetSpec+ Nirum.PackageSpec+ Nirum.ParserSpec+ Nirum.Targets.DocsSpec+ Nirum.Targets.PythonSpec+ Nirum.TargetsSpec+ Nirum.TypeInstance.BoundModuleSpec+ Nirum.VersionSpec+ Util+ Paths_nirum+ default-language: Haskell2010 -test-suite hlint- type: exitcode-stdio-1.0- hs-source-dirs: test- main-is: HLint.hs- default-language: Haskell2010- build-depends: base >=4.7 && <5- , hlint >=1.9 && <2+test-suite targets+ type: exitcode-stdio-1.0+ main-is: test-targets.hs+ hs-source-dirs:+ app+ default-extensions: OverloadedStrings+ ghc-options: -Wall+ build-depends:+ base >=4.7 && <5+ , blaze-html >=0.9.0.1 && <0.10+ , bytestring+ , containers >=0.5.6.2 && <0.6+ , directory >=1.2.5 && <1.4+ , email-validate >=2.0.0 && <3.0.0+ , filepath >=1.4 && <1.5+ , htoml >=1.0.0.0 && <1.1.0.0+ , interpolatedstring-perl6 >=1.0.0 && <1.1.0+ , megaparsec >=5 && <5.4+ , mtl >=2.2.1 && <3+ , parsec+ , pretty >=1.1.3 && <2+ , semver >=0.3.0 && <1.0+ , text >=0.9.1.0 && <1.3+ , turtle+ , unordered-containers+ other-modules:+ Paths_nirum+ default-language: Haskell2010
src/Nirum/Cli.hs view
@@ -1,55 +1,72 @@-{-# LANGUAGE ExtendedDefaultRules, QuasiQuotes, DeriveDataTypeable #-}+{-# LANGUAGE ExtendedDefaultRules, QuasiQuotes #-} module Nirum.Cli (main, writeFiles) where -import Control.Monad (forM_)-import GHC.Exts (IsList(toList))-import System.IO.Error (catchIOError, ioeGetErrorString)+import Control.Concurrent (threadDelay)+import Control.Monad (forM_, forever, when)+import GHC.Exts (IsList (toList))+import System.IO +import qualified Data.ByteString as B import qualified Data.Map.Strict as M import qualified Data.Set as S import qualified Data.Text as T-import qualified Data.Text.IO as TI-import System.Console.CmdArgs.Implicit ( Data- , Typeable- , argPos- , cmdArgs- , explicit- , help- , name- , program- , summary- , typDir- , (&=)- )-import System.Console.CmdArgs.Default (def)+import Control.Concurrent.STM (atomically, newTVar, readTVar, TVar, writeTVar)+import Data.Monoid ((<>))+import qualified Options.Applicative as OPT import System.Directory (createDirectoryIfMissing)-import System.FilePath (takeDirectory, (</>))+import System.Exit (die)+import System.FilePath (takeDirectory, takeExtension, (</>))+import System.FSNotify import Text.InterpolatedString.Perl6 (qq) import Text.Megaparsec (Token) import Text.Megaparsec.Error ( Dec- , ParseError(errorPos)+ , ParseError (errorPos) , parseErrorPretty )-import Text.Megaparsec.Pos (SourcePos(sourceLine, sourceColumn), unPos)+import Text.Megaparsec.Pos (SourcePos (sourceLine, sourceColumn), unPos) -import Nirum.Constructs (Construct(toCode))+import Nirum.Constructs (Construct (toCode)) import Nirum.Constructs.Identifier (toText) import Nirum.Constructs.ModulePath (ModulePath)-import Nirum.Package ( PackageError(ParseError, ImportError, ScanError)- , ImportError ( CircularImportError- , MissingImportError- , MissingModulePathError- )+import Nirum.Package ( PackageError ( ImportError+ , MetadataError+ , ParseError+ , ScanError+ ) , scanModules- , scanPackage )-import Nirum.Targets.Python (compilePackage)+import Nirum.Package.ModuleSet ( ImportError ( CircularImportError+ , MissingImportError+ , MissingModulePathError+ )+ )+import Nirum.Targets ( BuildError (CompileError, PackageError, TargetNameError)+ , BuildResult+ , buildPackage+ , targetNames+ ) import Nirum.Version (versionString) -data NirumCli = NirumCli { sourcePath :: FilePath- , objectPath :: FilePath- } deriving (Show, Data, Typeable)+type TFlag = TVar Bool+type Nanosecond = Int +data Opts = Opts { outDirectory :: !String+ , targetOption :: !String+ , watch :: !Bool+ , packageDirectory :: !String+ }++data AppOptions = AppOptions { outputPath :: FilePath+ , packagePath :: FilePath+ , targetLanguage :: T.Text+ , watching :: Bool+ , building :: TFlag+ , changed :: TFlag+ }++debounceDelay :: Nanosecond+debounceDelay = 1 * 1000 * 1000+ parseErrortoPrettyMessage :: ParseError (Token T.Text) Dec -> FilePath -> IO String@@ -116,48 +133,139 @@ withListStyleText = map (T.append "- ") (importErrorsToMessageList importErrors) -nirumCli :: NirumCli-nirumCli = NirumCli { objectPath = def &= explicit- &= name "o" &= name "output-dir" &= typDir- &= help "The directory to place object files"- , sourcePath = def &= argPos 1 &= typDir- }- &= program "nirum"- &= summary ("Nirum Compiler " ++ versionString)+targetNamesText :: T.Text+targetNamesText = T.intercalate ", " $ S.toAscList targetNames -main' :: IO ()-main' = do- NirumCli src obj <- cmdArgs nirumCli- scanResult <- scanPackage src- case scanResult of- Left (ParseError modulePath error') -> do- -- FIXME: find more efficient way to determine filename from- -- the given module path+build :: AppOptions -> IO ()+build options@AppOptions { packagePath = src+ , outputPath = outDir+ , targetLanguage = target+ } = do+ result <- buildPackage target src+ case result of+ Left (TargetNameError targetName') ->+ tryDie' [qq|Couldn't find "$targetName'" target.+Available targets: $targetNamesText|]+ Left (PackageError (ParseError modulePath error')) -> do+ {- FIXME: find more efficient way to determine filename from+ the given module path -} filePaths <- scanModules src case M.lookup modulePath filePaths of Just filePath' -> do m <- parseErrortoPrettyMessage error' filePath'- putStrLn m- Nothing -> putStrLn [qq|$modulePath not found|]- Left (ImportError importErrors) ->- putStrLn [qq|Import error:+ tryDie' m+ Nothing -> tryDie' [qq|$modulePath not found|]+ Left (PackageError (ImportError importErrors)) ->+ tryDie' [qq|Import error: {importErrorsToPrettyMessage importErrors} |]- Left (ScanError _ error') -> putStrLn [qq|Scan error: $error'|]- Right pkg -> writeFiles obj $ compilePackage pkg+ Left (PackageError (ScanError _ error')) ->+ tryDie' [qq|Scan error: $error'|]+ Left (PackageError (MetadataError error')) ->+ tryDie' [qq|Metadata error: $error'|]+ Left (CompileError errors) ->+ forM_ (M.toList errors) $ \ (filePath, compileError) ->+ tryDie' [qq|error: $filePath: $compileError|]+ Right buildResult -> writeFiles outDir buildResult+ where+ tryDie' = tryDie options -writeFiles :: FilePath -> M.Map FilePath (Either T.Text T.Text) -> IO ()-writeFiles obj m =- forM_ files $ \(filePath, result) ->- case result of- Left compileError -> putStrLn [qq|error: $filePath: $compileError|]- Right code -> do- createDirectoryIfMissing True $ takeDirectory filePath- putStrLn filePath- TI.writeFile filePath code+writeFiles :: FilePath -> BuildResult -> IO ()+writeFiles outDir files =+ forM_ (M.toAscList files) $ \ (filePath, code) -> do+ let outPath = outDir </> filePath+ createDirectoryIfMissing True $ takeDirectory outPath+ putStrLn outPath+ B.writeFile outPath code+++onFileChanged :: AppOptions -> Event -> IO ()+onFileChanged+ options@AppOptions { building = building'+ , changed = changed'+ }+ event+ | takeExtension path == ".nrm" = do+ atomically $ writeTVar changed' True+ buildable <- atomically $ do+ b <- readTVar building'+ writeTVar building' True+ return $ not b+ when buildable $ do+ threadDelay debounceDelay+ reactiveBuild options+ | otherwise = return () where- files :: [(FilePath, Either T.Text T.Text)]- files = [(obj </> f, r) | (f, r) <- M.toList m]+ path :: FilePath+ path = eventPath event +reactiveBuild :: AppOptions -> IO ()+reactiveBuild options@AppOptions { building = building'+ , changed = changed'+ } = do+ changed'' <- atomically $ readTVar changed'+ when changed'' $ do+ atomically $ writeTVar changed' False+ build options+ atomically $ writeTVar building' False+ changedDuringBuild <- atomically $ readTVar changed'+ when changedDuringBuild $ reactiveBuild options++tryDie :: AppOptions -> String -> IO ()+tryDie AppOptions { watching = watching' } errorMessage+ | watching' = hPutStrLn stderr errorMessage+ | otherwise = die errorMessage+ main :: IO ()-main = catchIOError main' $ putStrLn . ioeGetErrorString+main =+ withManager $ \ mgr -> do+ opts <- OPT.execParser optsParser+ building' <- atomically $ newTVar False+ changed' <- atomically $ newTVar True+ let watch' = watch opts+ packagePath' = packageDirectory opts+ options = AppOptions+ { outputPath = outDirectory opts+ , packagePath = packagePath'+ , targetLanguage = T.pack $ targetOption opts+ , watching = watch'+ , building = building'+ , changed = changed'+ }++ when watch' $ do+ _ <- watchDir mgr packagePath' (const True) (onFileChanged options)+ return ()+ reactiveBuild options+ -- sleep forever (until interrupted)+ when watch' $ forever $ threadDelay 1000000+ where+ -- CHECK: When the CLI options changes, update the CLI examples of docs+ -- and README.md file.+ optsParser :: OPT.ParserInfo Opts+ optsParser =+ OPT.info+ (OPT.helper <*> versionOption <*> programOptions)+ (OPT.fullDesc <>+ OPT.progDesc ("Nirum compiler " ++ versionString) <>+ OPT.header header)+ header :: String+ header = "Nirum: The IDL compiler and RPC/distributed object framework"+ versionOption :: OPT.Parser (Opts -> Opts)+ versionOption = OPT.infoOption+ versionString (OPT.long "version" <>+ OPT.short 'v' <> OPT.help "Show version")+ programOptions :: OPT.Parser Opts+ programOptions =+ Opts <$> OPT.strOption+ (OPT.long "output-dir" <> OPT.short 'o' <> OPT.metavar "DIR" <>+ OPT.help "Output directory") <*>+ OPT.strOption+ (OPT.long "target" <> OPT.short 't' <> OPT.metavar "TARGET" <>+ OPT.help [qq|Target language name.+ Available: $targetNamesText|]) <*>+ OPT.switch+ (OPT.long "watch" <> OPT.short 'w' <>+ OPT.help "Watch files for change and rebuild") <*>+ OPT.strArgument+ (OPT.metavar "DIR" <> OPT.help "Package directory")
+ src/Nirum/CodeBuilder.hs view
@@ -0,0 +1,131 @@+{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving,+ MultiParamTypeClasses, TypeOperators #-}+-- | The 'CodeBuilder' monad.+module Nirum.CodeBuilder (+ -- * The CodeBuilder monad+ CodeBuilder,+ runBuilder,+ -- * Builder operations+ writeLine,+ nest,+ lookupType,+ -- * Examples+ -- $examples+ ) where++import Control.Applicative (Applicative)+import Control.Monad (Monad)+import qualified Control.Monad.State as ST+import Control.Monad.State (MonadState, State, state, runState)+import Data.Functor (Functor)+import Data.Maybe (fromMaybe)+import Data.Monoid ((<>))+import qualified Data.Text.Lazy.Builder as B+import qualified Text.PrettyPrint as P+import Text.PrettyPrint (($+$))++import Nirum.Constructs.Identifier (Identifier)+import Nirum.Constructs.ModulePath (ModulePath)+import Nirum.Package.Metadata (Package (..), Target (..))+import qualified Nirum.TypeInstance.BoundModule as BoundModule++-- | A code builder monad parameterized by:+--+-- * @t@ - The build target+-- * @s@ - The state+newtype Target t => CodeBuilder t s a = CodeBuilder (State (BuildState t s) a)+ deriving ( Applicative+ , Functor+ , Monad+ )++data Target t => BuildState t s =+ BuildState { output :: P.Doc+ , boundModule :: BoundModule.BoundModule t+ , innerState :: s+ }++instance Target t => MonadState s (CodeBuilder t s) where+ state f = do+ st <- get'+ let (a, s) = f (innerState st)+ put' $ st { innerState = s }+ return a++get' :: Target t => CodeBuilder t s (BuildState t s)+get' = CodeBuilder ST.get++put' :: Target t => BuildState t s -> CodeBuilder t s ()+put' = CodeBuilder . ST.put++modify' :: Target t+ => (BuildState t s -> BuildState t s)+ -> CodeBuilder t s ()+modify' = CodeBuilder . ST.modify++-- | Put the line below the builder output.+writeLine :: Target t+ => P.Doc -- ^ The line to append+ -> CodeBuilder t s ()+writeLine code = modify' $ \ s -> s { output = output s $+$ code }++-- | Nest (or indent) an output of inner builder computation by a given number+-- of positions.+nest :: Target t+ => Integer -- ^ indentation size (may also be negative)+ -> CodeBuilder t s a -- ^ inner builder computation to generate the+ -- nested document+ -> CodeBuilder t s a+nest n code = do+ st <- get'+ let st' = st { output = P.empty }+ put' st'+ ret <- code+ after <- get'+ modify' $ \ s -> s {+ output = output st $+$ P.nest (fromIntegral n) (output after)+ }+ return ret++-- | Look up the actual type by the name from the context of the builder+-- computation.+lookupType :: Target t+ => Identifier -- ^ name of the type to find+ -> CodeBuilder t s BoundModule.TypeLookup+lookupType identifier = do+ m <- fmap boundModule get'+ return $ BoundModule.lookupType identifier m++-- | Execute the builder computation and retrive output.+runBuilder :: Target t+ => Package t+ -> ModulePath+ -> s -- ^ initial state+ -> CodeBuilder t s a -- ^ code builder computation to execute+ -> (a, B.Builder) -- ^ return value and build result+runBuilder package modPath st (CodeBuilder a) = (ret, rendered)+ where+ mod' = fromMaybe (error "asdf")+ (BoundModule.resolveBoundModule modPath package)+ initialState = BuildState { output = P.empty+ , boundModule = mod'+ , innerState = st+ }+ (ret, finalState) = runState a initialState+ out' = output finalState+ rendered = P.fullRender P.PageMode 80 1.5 concat' (B.singleton '\n') out'+ concat' (P.Chr c) rest = B.singleton c <> rest+ concat' (P.Str s) rest = B.fromString s <> rest+ concat' (P.PStr s) rest = concat' (P.Str s) rest++{- $examples++> import Text.PrettyPrint (colon, empty, parens, quotes, (<>), (<+>))+>+> hello = do+> writeLine $ "def" <+> "hello" <> parens empty <> colon+> nest 4 $ do+> writeLine $ "print" <> parens (quotes "Hello, world!")+> writeLine $ "return" <+> "42"++-}
src/Nirum/CodeGen.hs view
@@ -7,7 +7,11 @@ import Control.Applicative (Applicative) import Control.Monad (Monad)-import Control.Monad.Except (MonadError, ExceptT(ExceptT), mapExceptT, runExceptT)+import Control.Monad.Except ( MonadError+ , ExceptT (ExceptT)+ , mapExceptT+ , runExceptT+ ) import Control.Monad.State (MonadState, State, mapState, runState) import Data.Functor (Functor) @@ -33,7 +37,7 @@ {-# INLINE (>>=) #-} fail str = CodeGen $ mapExceptT mutate (fromString str) where- mutate = mapState (\(a, s) -> case a of+ mutate = mapState (\ (a, s) -> case a of Left _ -> undefined Right e -> (Left e, s)) {-# INLINE fail #-}
src/Nirum/Constructs/Annotation.hs view
@@ -1,86 +1,93 @@-module Nirum.Constructs.Annotation ( Annotation(Annotation)- , AnnotationSet- , Metadata- , NameDuplication(AnnotationNameDuplication)- , annotations- , docs- , empty- , fromList- , insertDocs- , lookup- , lookupDocs- , singleton- , toCode- , toList- , union- ) where+module Nirum.Constructs.Annotation+ ( Annotation (Annotation, name, arguments)+ , AnnotationSet+ , AnnotationArgumentSet+ , NameDuplication (AnnotationNameDuplication)+ , annotations+ , docs+ , empty+ , fromList+ , insertDocs+ , lookup+ , lookupDocs+ , null+ , singleton+ , toCode+ , toList+ , union+ ) where -import Prelude hiding (lookup)+import Prelude hiding (lookup, null) import qualified Data.Map.Strict as M import qualified Data.Set as S import Nirum.Constructs (Construct (toCode)) import Nirum.Constructs.Annotation.Internal-import Nirum.Constructs.Docs (Docs (Docs), annotationDocsName, toText)+import Nirum.Constructs.Docs import Nirum.Constructs.Identifier (Identifier) docs :: Docs -> Annotation-docs (Docs d) = Annotation { name = annotationDocsName, metadata = Just d }+docs (Docs d) = Annotation { name = docsAnnotationName+ , arguments = M.singleton docsAnnotationParameter d+ } -data NameDuplication = AnnotationNameDuplication Identifier- deriving (Eq, Ord, Show)+newtype NameDuplication = AnnotationNameDuplication Identifier+ deriving (Eq, Ord, Show) empty :: AnnotationSet empty = AnnotationSet { annotations = M.empty } +null :: AnnotationSet -> Bool+null (AnnotationSet m) = M.null m+ singleton :: Annotation -> AnnotationSet-singleton Annotation { name = name', metadata = metadata' } =- AnnotationSet { annotations = M.singleton name' metadata' }+singleton Annotation { name = name', arguments = args } =+ AnnotationSet { annotations = M.singleton name' args } fromList :: [Annotation] -> Either NameDuplication AnnotationSet fromList annotations' = case findDup names S.empty of Just duplication -> Left (AnnotationNameDuplication duplication)- _ -> Right $ AnnotationSet ( M.fromList [ (name a, metadata a)- | a <- annotations'- ]- )+ _ -> Right . AnnotationSet . M.fromList $+ [(n, a) | Annotation n a <- annotations'] where names :: [Identifier] names = [name a | a <- annotations'] findDup :: [Identifier] -> S.Set Identifier -> Maybe Identifier findDup identifiers dups = case identifiers of- x:xs -> if x `S.member` dups- then Just x- else findDup xs $ S.insert x dups+ x : xs -> if x `S.member` dups+ then Just x+ else findDup xs $ S.insert x dups _ -> Nothing toList :: AnnotationSet -> [Annotation] toList AnnotationSet { annotations = annotations' } =- map fromTuple $ M.assocs annotations'+ [Annotation n a | (n, a) <- 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' }+ args <- M.lookup id' anno+ return $ Annotation id' args lookupDocs :: AnnotationSet -> Maybe Docs lookupDocs annotationSet = do- Annotation _ m <- lookup annotationDocsName annotationSet- data' <- m- return $ Docs data'+ Annotation _ args <- lookup docsAnnotationName annotationSet+ d <- M.lookup docsAnnotationParameter args+ return $ Docs d insertDocs :: (Monad m) => Docs -> AnnotationSet -> m AnnotationSet insertDocs docs' (AnnotationSet anno) =- case insertLookup annotationDocsName (Just $ toText docs') anno of- (Just _ , _ ) -> fail "<duplicated>"+ case insertLookup docsAnnotationName args 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)+ insertLookup = M.insertLookupWithKey $ \ _ a _ -> a+ args :: AnnotationArgumentSet+ args = M.singleton docsAnnotationParameter $ toText docs'
src/Nirum/Constructs/Annotation/Internal.hs view
@@ -1,49 +1,59 @@ {-# LANGUAGE QuasiQuotes #-}-module Nirum.Constructs.Annotation.Internal ( Annotation(..)- , AnnotationSet(..)- , Metadata- , fromTuple- ) where+module Nirum.Constructs.Annotation.Internal+ ( Annotation ( Annotation+ , arguments+ , name+ )+ , AnnotationArgumentSet+ , AnnotationSet ( AnnotationSet+ , annotations+ )+ ) 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.Docs import Nirum.Constructs.Identifier (Identifier) --type Metadata = T.Text+type AnnotationArgumentSet = M.Map Identifier T.Text -- | Annotation for 'Declaration'. data Annotation = Annotation { name :: Identifier- , metadata :: Maybe Metadata+ , arguments :: AnnotationArgumentSet } deriving (Eq, Ord, Show) instance Construct Annotation where- toCode Annotation {name = n, metadata = Just m} = [qq|@{toCode n}("$m'")|]+ toCode Annotation { name = n, arguments = args }+ | M.null args = '@' `T.cons` toCode n+ | otherwise = [qq|@{toCode n}({showArgs $ M.toList args})|] where- m' = (showLitString $ T.unpack m) ""+ showArgs :: [(Identifier, T.Text)] -> T.Text+ showArgs args' = T.intercalate ", " $ map showArg args'+ showArg :: (Identifier, T.Text) -> T.Text+ showArg (key, value) = [qq|{toCode key} = {literal value}|]+ literal :: T.Text -> T.Text+ literal s = [qq|"{(showLitString $ T.unpack s) ""}"|] 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' }+ showLitChar' c = C.showLitChar c -data AnnotationSet+newtype AnnotationSet -- | The set of 'Annotation' values. -- Every annotation name has to be unique in the set.- = AnnotationSet { annotations :: M.Map Identifier (Maybe Metadata) }+ = AnnotationSet { annotations :: M.Map Identifier AnnotationArgumentSet } 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"]]+ T.concat [ s+ | (name', args) <- M.assocs annotations'+ , name' /= docsAnnotationName+ , s <- [toCode $ Annotation name' args, "\n"]+ ]
src/Nirum/Constructs/Declaration.hs view
@@ -1,18 +1,25 @@-module Nirum.Constructs.Declaration ( Declaration- , annotations- , docs- , name+{-# LANGUAGE DefaultSignatures #-}+module Nirum.Constructs.Declaration ( Declaration (annotations, name)+ , Documented (docs, docsBlock) ) where import Nirum.Constructs (Construct) import Nirum.Constructs.Annotation (AnnotationSet, lookupDocs)-import Nirum.Constructs.Docs (Docs)+import Nirum.Constructs.Docs (Docs, toBlock) import Nirum.Constructs.Name (Name)+import Nirum.Docs (Block) --- 'Construct' which has its own unique 'name' and can has its 'docs'.-class Construct a => Declaration a where- name :: a -> Name- annotations :: a -> AnnotationSet+class Documented a where+ -- | The docs of the construct.+ docs :: a -> Maybe Docs+ default docs :: Declaration a => a -> Maybe Docs+ docs = lookupDocs . annotations -docs :: Declaration a => a -> Maybe Docs-docs = lookupDocs . annotations+ -- | The parsed docs tree.+ docsBlock :: a -> Maybe Block+ docsBlock = fmap toBlock . docs++-- Construct which has its own unique 'name' and can has its 'docs'.+class (Construct a, Documented a) => Declaration a where+ name :: a -> Name+ annotations :: a -> AnnotationSet
src/Nirum/Constructs/DeclarationSet.hs view
@@ -1,8 +1,8 @@ {-# LANGUAGE OverloadedLists, TypeFamilies #-}-module Nirum.Constructs.DeclarationSet ( DeclarationSet()- , NameDuplication( BehindNameDuplication- , FacialNameDuplication- )+module Nirum.Constructs.DeclarationSet ( DeclarationSet ()+ , NameDuplication ( BehindNameDuplication+ , FacialNameDuplication+ ) , empty , fromList , lookup@@ -22,9 +22,9 @@ import qualified Data.Map.Strict as M import qualified Data.Set as S -import Nirum.Constructs.Declaration (Declaration(name))+import Nirum.Constructs.Declaration (Declaration (name)) import Nirum.Constructs.Identifier (Identifier)-import Nirum.Constructs.Name (Name(Name, behindName, facialName))+import Nirum.Constructs.Name (Name (Name, behindName, facialName)) data Declaration a => DeclarationSet a -- | The set of 'Declaration' values.@@ -62,10 +62,10 @@ findDup :: [Name] -> (Name -> Identifier) -> S.Set Identifier -> Maybe Name findDup names' f dups = case names' of- x:xs -> let name' = f x- in if name' `S.member` dups- then Just x- else findDup xs f $ S.insert name' dups+ x : xs -> let name' = f x+ in if name' `S.member` dups+ then Just x+ else findDup xs f $ S.insert name' dups _ -> Nothing toList :: Declaration a => DeclarationSet a -> [a]
src/Nirum/Constructs/Docs.hs view
@@ -1,24 +1,42 @@ {-# LANGUAGE OverloadedStrings #-}-module Nirum.Constructs.Docs ( Docs(Docs)- , annotationDocsName+module Nirum.Constructs.Docs ( Docs (Docs)+ , docsAnnotationName+ , docsAnnotationParameter+ , title+ , toBlock , toCode , toCodeWithPrefix , toText ) where -import Data.String (IsString(fromString))+import Data.String (IsString (fromString)) import qualified Data.Text as T -import Nirum.Constructs (Construct(toCode))+import Nirum.Constructs (Construct (toCode)) import Nirum.Constructs.Identifier (Identifier)+import Nirum.Docs (Block (Document, Heading), parse) -annotationDocsName :: Identifier-annotationDocsName = "docs"+docsAnnotationName :: Identifier+docsAnnotationName = "docs" +docsAnnotationParameter :: Identifier+docsAnnotationParameter = "docs"+ -- | Docstring for constructs.-data Docs = Docs T.Text deriving (Eq, Ord, Show)+newtype Docs = Docs T.Text deriving (Eq, Ord, Show) +-- | Convert the docs to a tree.+toBlock :: Docs -> Block+toBlock (Docs docs') = parse docs'++-- | Gets the heading title of the module if it has any title.+title :: Docs -> Maybe Block+title docs =+ case toBlock docs of+ Document (firstBlock@Heading {} : _) -> Just firstBlock+ _ -> Nothing+ -- | Convert the docs to text. toText :: Docs -> T.Text toText (Docs docs') = docs'@@ -26,8 +44,8 @@ -- | 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.+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'
src/Nirum/Constructs/Identifier.hs view
@@ -21,7 +21,7 @@ import Data.Char (toLower, toUpper) import Data.Maybe (fromMaybe)-import Data.String (IsString(fromString))+import Data.String (IsString (fromString)) import qualified Data.Text as T import qualified Data.Set as S@@ -29,28 +29,30 @@ import Text.Megaparsec.Char (oneOf, satisfy) import Text.Megaparsec.Text (Parser) -import Nirum.Constructs (Construct(toCode))+import Nirum.Constructs (Construct (toCode)) --- | Case-insensitive identifier. It also doesn't distinguish hyphens--- from underscores.------ It has more restrict rules than the most of programming languages:------ * It can't start with digits or hyphens/underscores.--- * Hyphens/underscores can't continuously appear more than once.--- * Only roman alphabets, Arabic numerals, hyphens and underscores--- are allowed.--- --- These rules are for portability between various programming languages.--- For example, @BOOK_CATEGORY@ and @Book-Category@ are all normalized--- to @book-category@, and it can be translated to:--- --- [snake_case] @book_category@--- [camelCase] @bookCategory@--- [PascalCase] @BookCategory@--- [lisp-case] @book-category@-data Identifier = Identifier T.Text deriving (Show)+{- |+Case-insensitive identifier. It also doesn't distinguish hyphens+from underscores. +It has more restrict rules than the most of programming languages:++* It can't start with digits or hyphens/underscores.+* Hyphens/underscores can't continuously appear more than once.+* Only roman alphabets, Arabic numerals, hyphens and underscores+ are allowed.++These rules are for portability between various programming languages.+For example, @BOOK_CATEGORY@ and @Book-Category@ are all normalized+to @book-category@, and it can be translated to:++[snake_case] @book_category@+[camelCase] @bookCategory@+[PascalCase] @BookCategory@+[lisp-case] @book-category@+-}+newtype Identifier = Identifier T.Text deriving (Show)+ reservedKeywords :: S.Set Identifier reservedKeywords = [ "enum" , "record"@@ -68,7 +70,7 @@ restWords <- P.many $ do sep <- oneOf ("-_" :: String) chars <- P.some $ satisfy isAlnum- return $ T.pack $ sep:chars+ return $ T.pack $ sep : chars return $ Identifier $ T.concat $ T.pack (firstChar : restChars) : restWords where isAlpha :: Char -> Bool@@ -78,7 +80,7 @@ isAlnum :: Char -> Bool isAlnum c = isAlpha c || isDigit c --- | Constructs a 'Identifier' value from the given identifier string.+-- | Constructs an 'Identifier' value from the given identifier string. -- It could return 'Nothing' if the given identifier is invalid. fromText :: T.Text -> Maybe Identifier fromText text =@@ -94,7 +96,7 @@ normalize :: Identifier -> Identifier normalize (Identifier i) =- Identifier $ T.map (\c -> if c == '_' then '-' else toLower c) i+ Identifier $ T.map (\ c -> if c == '_' then '-' else toLower c) i toText :: Identifier -> T.Text toText (Identifier text) = text
src/Nirum/Constructs/Module.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE OverloadedLists, QuasiQuotes #-}-module Nirum.Constructs.Module ( Module(Module, docs, types)+{-# LANGUAGE OverloadedLists, QuasiQuotes #-}+module Nirum.Constructs.Module ( Module (Module, docs, types) , coreModule , coreModulePath , coreTypes@@ -11,16 +11,35 @@ import qualified Data.Text as T import Text.InterpolatedString.Perl6 (q) -import Nirum.Constructs (Construct(toCode))+import Nirum.Constructs (Construct (toCode)) import Nirum.Constructs.Annotation (empty)-import Nirum.Constructs.Docs (Docs)+import Nirum.Constructs.Declaration (Documented (docs)) import qualified Nirum.Constructs.DeclarationSet as DS+import Nirum.Constructs.Docs (Docs) import Nirum.Constructs.Identifier (Identifier) import Nirum.Constructs.ModulePath (ModulePath)-import Nirum.Constructs.TypeDeclaration ( JsonType(..)- , PrimitiveTypeIdentifier(..)- , Type(..)- , TypeDeclaration(..)+import Nirum.Constructs.TypeDeclaration ( JsonType (Boolean, Number, String)+ , PrimitiveTypeIdentifier ( Bigint+ , Binary+ , Bool+ , Date+ , Datetime+ , Decimal+ , Float32+ , Float64+ , Int32+ , Int64+ , Text+ , Uri+ , Uuid+ )+ , Type (PrimitiveType)+ , TypeDeclaration ( Import+ , TypeDeclaration+ , type'+ , typeAnnotations+ , typename+ ) ) data Module = Module { types :: DS.DeclarationSet TypeDeclaration@@ -53,6 +72,9 @@ Import {} -> False _ -> True ]++instance Documented Module where+ docs (Module _ docs') = docs' imports :: Module -> M.Map ModulePath (S.Set Identifier) imports (Module decls _) =
src/Nirum/Constructs/ModulePath.hs view
@@ -1,30 +1,36 @@ {-# LANGUAGE TypeFamilies #-}-module Nirum.Constructs.ModulePath ( ModulePath( ModuleName- , ModulePath- , moduleName- , path- )- , ancestors+module Nirum.Constructs.ModulePath ( ModulePath ( ModuleName+ , ModulePath+ , moduleName+ , path+ ) , fromFilePath , fromIdentifiers+ , hierarchy+ , hierarchies+ , replacePrefix ) where import Data.Char (toLower) import Data.Maybe (fromMaybe, mapMaybe)-import GHC.Exts (IsList(Item, fromList, toList))+import GHC.Exts (IsList (Item, fromList, toList)) -import Data.Set (Set, insert, singleton)+import qualified Data.Set as S import Data.Text (intercalate, pack) import System.FilePath (splitDirectories, stripExtension) -import Nirum.Constructs (Construct(toCode))+import Nirum.Constructs (Construct (toCode)) import Nirum.Constructs.Identifier (Identifier, fromText) data ModulePath = ModulePath { path :: ModulePath- , moduleName :: Identifier }+ , moduleName :: Identifier+ } | ModuleName { moduleName :: Identifier }- deriving (Eq, Ord, Show)+ deriving (Eq, Show) +instance Ord ModulePath where+ a <= b = toList a <= toList b+ instance Construct ModulePath where toCode = intercalate "." . map toCode . toList @@ -51,14 +57,25 @@ fileIdentifiers :: [Identifier] fileIdentifiers = mapMaybe (fromText . pack) paths -ancestors :: ModulePath -> Set ModulePath-ancestors m@ModuleName {} = singleton m-ancestors m@(ModulePath parent _) = m `insert` ancestors parent+hierarchy :: ModulePath -> S.Set ModulePath+hierarchy m@ModuleName {} = S.singleton m+hierarchy m@(ModulePath parent _) = m `S.insert` hierarchy parent +hierarchies :: S.Set ModulePath -> S.Set ModulePath+hierarchies modulePaths = S.unions $ toList $ S.map hierarchy modulePaths++replacePrefix :: ModulePath -> ModulePath -> ModulePath -> ModulePath+replacePrefix from to path'+ | path' == from = to+ | otherwise = case path' of+ ModuleName {} -> path'+ ModulePath p n -> ModulePath (replacePrefix from to p) n++ instance IsList ModulePath where type Item ModulePath = Identifier fromList identifiers =- fromMaybe (error "ModulePath cannot be empty") + fromMaybe (error "ModulePath cannot be empty") (fromIdentifiers identifiers) toList (ModuleName identifier) = [identifier] toList (ModulePath path' identifier) = toList path' ++ [identifier]
src/Nirum/Constructs/Name.hs view
@@ -1,25 +1,25 @@-module Nirum.Constructs.Name ( Name(Name)- , behindName- , facialName+module Nirum.Constructs.Name ( Name (Name, behindName, facialName) , isComplex , isSimple , toCode ) where -import Data.String (IsString(fromString))+import Data.String (IsString (fromString)) import Data.Text (append, snoc) import Nirum.Constructs (Construct) import Nirum.Constructs.Identifier (Identifier, toCode) --- | Name consists of a 'facialName' and a 'behindName'.--- The 'behindName' is for internal coding, while the 'facialName' is for--- human-readable identifier of programming language bindings.------ If 'behind_Name' is omitted, 'facialName' is used also for--- 'behindName'. Explicit 'behindName' is useful to maintain--- old name for backward compatibility with new 'facialName'.+{- |+Name consists of a 'facialName' and a 'behindName'.+The 'behindName' is for internal coding, while the 'facialName' is for+human-readable identifier of programming language bindings.++If 'behind_Name' is omitted, 'facialName' is used also for+'behindName'. Explicit 'behindName' is useful to maintain+old name for backward compatibility with new 'facialName'.+-} data Name = Name { facialName :: Identifier , behindName :: Identifier } deriving (Eq, Ord, Show)
src/Nirum/Constructs/Service.hs view
@@ -1,19 +1,22 @@ module Nirum.Constructs.Service ( Method ( Method+ , errorType , methodAnnotations , methodName , parameters , returnType )- , Parameter(Parameter)- , Service(Service, methods)+ , Parameter (Parameter)+ , Service (Service, methods) , methodDocs ) where import qualified Data.Text as T -import Nirum.Constructs (Construct(toCode))+import Nirum.Constructs (Construct (toCode)) import Nirum.Constructs.Annotation (AnnotationSet, empty, lookupDocs)-import Nirum.Constructs.Declaration (Declaration(annotations, name), docs)+import Nirum.Constructs.Declaration ( Declaration (annotations, name)+ , Documented (docs)+ ) import Nirum.Constructs.Docs (Docs, toCodeWithPrefix) import Nirum.Constructs.DeclarationSet (DeclarationSet, toList) import Nirum.Constructs.Name (Name)@@ -32,6 +35,8 @@ , toCodeWithPrefix "\n" (docs p) ] +instance Documented Parameter+ instance Declaration Parameter where name (Parameter name' _ _) = name' annotations (Parameter _ _ anno') = anno'@@ -39,8 +44,8 @@ -- | 'Service' method. data Method = Method { methodName :: Name , parameters :: DeclarationSet Parameter- , returnType :: TypeExpression- , errorType :: Maybe TypeExpression+ , returnType :: Maybe TypeExpression+ , errorType :: Maybe TypeExpression , methodAnnotations :: AnnotationSet } deriving (Eq, Ord, Show) @@ -53,8 +58,9 @@ , methodAnnotations = annotationSet' } = T.concat $ [ toCode annotationSet'- , toCode $ returnType method- , " "+ , case returnType method of+ Just v -> T.append (toCode v) " "+ Nothing -> "" , toCode $ methodName method , " (" , toCodeWithPrefix "\n " docs'@@ -86,10 +92,12 @@ , "\n" ] +instance Documented Method+ instance Declaration Method where name = methodName annotations = methodAnnotations -- | RPC service.-data Service =+newtype Service = Service { methods :: DeclarationSet Method } deriving (Eq, Ord, Show)
src/Nirum/Constructs/TypeDeclaration.hs view
@@ -1,44 +1,75 @@-module Nirum.Constructs.TypeDeclaration ( EnumMember(EnumMember)+module Nirum.Constructs.TypeDeclaration ( EnumMember (EnumMember) , Field ( Field , fieldAnnotations , fieldName , fieldType )- , JsonType(..)- , PrimitiveTypeIdentifier(..)+ , JsonType ( Boolean+ , Number+ , String+ )+ , PrimitiveTypeIdentifier ( Bigint+ , Binary+ , Bool+ , Date+ , Datetime+ , Decimal+ , Float32+ , Float64+ , Int32+ , Int64+ , Text+ , Uri+ , Uuid+ ) , Tag ( Tag , tagAnnotations , tagFields , tagName )- , Type(..)- , TypeDeclaration( Import- , ServiceDeclaration- , TypeDeclaration- , importName- , modulePath- , service- , serviceAnnotations- , serviceName- , type'- , typeAnnotations- , typename- )+ , Type ( Alias+ , EnumType+ , PrimitiveType+ , RecordType+ , UnboxedType+ , UnionType+ , canonicalType+ , fields+ , innerType+ , jsonType+ , members+ , primitiveTypeIdentifier+ , tags+ )+ , TypeDeclaration ( Import+ , ServiceDeclaration+ , TypeDeclaration+ , importName+ , modulePath+ , service+ , serviceAnnotations+ , serviceName+ , type'+ , typeAnnotations+ , typename+ ) ) where import Data.Maybe (isJust)-import Data.String (IsString(fromString))+import Data.String (IsString (fromString)) import qualified Data.Text as T -import Nirum.Constructs (Construct(toCode))+import Nirum.Constructs (Construct (toCode)) import Nirum.Constructs.Annotation as A (AnnotationSet, empty, lookupDocs)-import Nirum.Constructs.Declaration (Declaration(..), docs)-import Nirum.Constructs.Docs (Docs(..), toCodeWithPrefix)+import Nirum.Constructs.Declaration ( Declaration (annotations, name)+ , Documented (docs)+ )+import Nirum.Constructs.Docs (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.Name (Name (Name)) import Nirum.Constructs.Service ( Method , Service (Service) , methodDocs@@ -64,6 +95,8 @@ , toCodeWithPrefix "\n" (docs e) ] +instance Documented EnumMember+ instance Declaration EnumMember where name (EnumMember name' _) = name' annotations (EnumMember _ anno') = anno'@@ -86,6 +119,8 @@ , toCodeWithPrefix "\n" (docs field) ] +instance Documented Field+ instance Declaration Field where name (Field name' _ _) = name' annotations (Field _ _ anno') = anno'@@ -107,6 +142,8 @@ where fieldsCode = T.intercalate " " $ map toCode $ toList fields' +instance Documented Tag+ instance Declaration Tag where name (Tag name' _ _) = name' annotations (Tag _ _ anno') = anno'@@ -230,6 +267,8 @@ , toCode ident , ");\n" ]++instance Documented TypeDeclaration instance Declaration TypeDeclaration where name TypeDeclaration { typename = name' } = name'
src/Nirum/Constructs/TypeExpression.hs view
@@ -12,11 +12,11 @@ , toCode ) where -import Data.String (IsString(fromString))+import Data.String (IsString (fromString)) import qualified Data.Text as T -import Nirum.Constructs (Construct(toCode))+import Nirum.Constructs (Construct (toCode)) import Nirum.Constructs.Identifier (Identifier) -- | Refers a type.
+ src/Nirum/Docs.hs view
@@ -0,0 +1,184 @@+module Nirum.Docs ( Block ( BlockQuote+ , CodeBlock+ , Document+ , Heading+ , HtmlBlock+ , List+ , Paragraph+ , ThematicBreak+ , infoString+ , code+ )+ , HeadingLevel (H1, H2, H3, H4, H5, H6)+ , Html+ , Inline ( Code+ , Emphasis+ , HardLineBreak+ , HtmlInline+ , Image+ , Link+ , SoftLineBreak+ , Strong+ , Text+ , imageTitle+ , imageUrl+ , linkContents+ , linkTitle+ , linkUrl+ )+ , ItemList (LooseItemList, TightItemList)+ , ListType (BulletList, OrderedList, startNumber, delimiter)+ , ListDelimiter (Parenthesis, Period)+ , LooseItem+ , TightItem+ , Title+ , Url+ , filterReferences+ , headingLevelFromInt+ , headingLevelInt+ , parse+ ) where++import Data.String (IsString (fromString))++import qualified CMark as M+import qualified Data.Text as T++type Url = T.Text+type Title = T.Text+type Html = T.Text++-- | The level of heading.+-- See also: http://spec.commonmark.org/0.25/#atx-heading+data HeadingLevel = H1 | H2 | H3 | H4 | H5 | H6 deriving (Eq, Ord, Show)++headingLevelFromInt :: Int -> HeadingLevel+headingLevelFromInt 2 = H2+headingLevelFromInt 3 = H3+headingLevelFromInt 4 = H4+headingLevelFromInt 5 = H5+headingLevelFromInt i = if i > 5 then H6 else H1++headingLevelInt :: HeadingLevel -> Int+headingLevelInt H1 = 1+headingLevelInt H2 = 2+headingLevelInt H3 = 3+headingLevelInt H4 = 4+headingLevelInt H5 = 5+headingLevelInt H6 = 6++-- | Whether a list is a bullet list or an ordered list.+-- See also: http://spec.commonmark.org/0.25/#of-the-same-type+data ListType = BulletList+ | OrderedList { startNumber :: Int+ , delimiter :: ListDelimiter+ }+ deriving (Eq, Ord, Show)++-- | Whether ordered list markers are followed by period (@.@) or+-- parenthesis (@)@).+-- See also: http://spec.commonmark.org/0.25/#ordered-list-marker+data ListDelimiter = Period | Parenthesis deriving (Eq, Ord, Show)++data Block = Document [Block]+ | ThematicBreak+ | Paragraph [Inline]+ | BlockQuote [Block]+ | HtmlBlock Html+ | CodeBlock { infoString :: T.Text, code :: T.Text }+ | Heading HeadingLevel [Inline]+ | List ListType ItemList+ deriving (Eq, Ord, Show)++data ItemList = LooseItemList [LooseItem]+ | TightItemList [TightItem]+ deriving (Eq, Ord, Show)++type LooseItem = [Block]++type TightItem = [Inline]++data Inline+ = Text T.Text+ | SoftLineBreak -- | See also:+ -- http://spec.commonmark.org/0.25/#soft-line-breaks+ | HardLineBreak -- | See also:+ -- http://spec.commonmark.org/0.25/#hard-line-breaks+ | HtmlInline Html+ | Code T.Text+ | Emphasis [Inline]+ | Strong [Inline]+ | Link { linkUrl :: Url, linkTitle :: Title, linkContents :: [Inline] }+ | Image { imageUrl :: Url, imageTitle :: Title }+ deriving (Eq, Ord, Show)++parse :: T.Text -> Block+parse =+ transBlock . M.commonmarkToNode [M.optNormalize, M.optSmart]+ where+ transBlock :: M.Node -> Block+ transBlock n@(M.Node _ nodeType children) =+ case nodeType of+ M.DOCUMENT -> Document blockChildren+ M.THEMATIC_BREAK -> ThematicBreak+ M.PARAGRAPH -> Paragraph inlineChildren+ M.BLOCK_QUOTE -> BlockQuote blockChildren+ M.HTML_BLOCK rawHtml -> HtmlBlock rawHtml+ M.CUSTOM_BLOCK _ _ -> error $ "custom block is unsupported: " ++ n'+ M.CODE_BLOCK info codeText -> CodeBlock info codeText+ M.HEADING lv -> Heading (headingLevelFromInt lv) inlineChildren+ M.LIST (M.ListAttributes listType' tight start delim) ->+ List (case listType' of+ M.BULLET_LIST -> BulletList+ M.ORDERED_LIST ->+ OrderedList start $+ case delim of+ M.PERIOD_DELIM -> Period+ M.PAREN_DELIM -> Parenthesis+ ) $+ if tight+ then TightItemList $ map stripParagraph listItems+ else LooseItemList $ map (map transBlock) listItems+ _ -> error $ "expected block, but got inline: " ++ n'+ where+ blockChildren :: [Block]+ blockChildren = map transBlock children+ inlineChildren :: [Inline]+ inlineChildren = map transInline children+ listItems :: [[M.Node]]+ listItems = [nodes | (M.Node _ M.ITEM nodes) <- children]+ stripParagraph :: [M.Node] -> [Inline]+ stripParagraph [M.Node _ M.PARAGRAPH nodes] = map transInline nodes+ stripParagraph ns = error $ "expected a paragraph, but got " ++ show ns+ n' :: String+ n' = show n+ transInline :: M.Node -> Inline+ transInline n@(M.Node _ nodeType childNodes) =+ case nodeType of+ M.TEXT text -> Text text+ M.SOFTBREAK -> SoftLineBreak+ M.LINEBREAK -> HardLineBreak+ M.HTML_INLINE rawHtml -> HtmlInline rawHtml+ M.CODE code' -> Code code'+ M.EMPH -> Emphasis children+ M.STRONG -> Strong children+ M.LINK url title -> Link url title children+ M.IMAGE url title -> Image url title+ _ -> error $ "expected inline, but got block: " ++ show n+ where+ children :: [Inline]+ children = map transInline childNodes++instance IsString Block where+ fromString = parse . T.pack++instance IsString Inline where+ fromString = Text . T.pack++-- | Replace all 'Link' and 'Image' nodes with normal 'Text' nodes.+filterReferences :: [Inline] -> [Inline]+filterReferences [] = []+filterReferences (Image { imageTitle = t } : ix) = Text t : filterReferences ix+filterReferences (Link { linkContents = children } : ix) =+ children ++ filterReferences ix+filterReferences (i : ix) = i : filterReferences ix
+ src/Nirum/Docs/Html.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE OverloadedStrings, QuasiQuotes #-}+module Nirum.Docs.Html (render, renderInline, renderInlines, renderBlock) where++import qualified Data.Text as T+import Text.InterpolatedString.Perl6 (qq)++import Nirum.Docs++renderInline :: Inline -> Html+renderInline (Text t) = escape t+renderInline SoftLineBreak = "\n"+renderInline HardLineBreak = "<br>"+renderInline (HtmlInline html) = html+renderInline (Code code') = [qq|<code>{escape code'}</code>|]+renderInline (Emphasis inlines) = [qq|<em>{renderInlines inlines}</em>|]+renderInline (Strong inlines) = [qq|<strong>{renderInlines inlines}</strong>|]+renderInline (Link url title inlines) =+ let body = renderInlines inlines+ in+ if T.null title+ then [qq|<a href="{escape url}">$body</a>|]+ else [qq|<a href="{escape url}" title="{escape title}">$body</a>|]+renderInline (Image url title) =+ if T.null title+ then [qq|<img src="{escape url}">|]+ else [qq|<img src="{escape url}" title="{escape title}">|]++escape :: T.Text -> Html+escape = T.concatMap escapeChar++escapeChar :: Char -> Html+escapeChar '&' = "&"+escapeChar '"' = """+escapeChar '<' = "<"+escapeChar '>' = ">"+escapeChar c = T.singleton c++renderInlines :: [Inline] -> Html+renderInlines = T.concat . map renderInline++renderBlock :: Block -> Html+renderBlock (Document blocks) = renderBlocks blocks `T.snoc` '\n'+renderBlock ThematicBreak = "<hr>"+renderBlock (Paragraph inlines) = [qq|<p>{renderInlines inlines}</p>|]+renderBlock (BlockQuote blocks) =+ [qq|<blockquote>{renderBlocks blocks}</blockquotes>|]+renderBlock (HtmlBlock html) = html+renderBlock (CodeBlock lang code') =+ if T.null lang+ then [qq|<pre><code>$code'</code></pre>|]+ else [qq|<pre><code class="language-$lang">$code'</code></pre>|]+renderBlock (Heading level inlines) =+ let lv = headingLevelInt level+ in [qq|<h$lv>{renderInlines inlines}</h$lv>|]+renderBlock (List listType itemList) =+ let liList = case itemList of+ TightItemList items ->+ [ [qq|<li>{renderInlines item}</li>|]+ | item <- items+ ]+ LooseItemList items ->+ [ [qq|<li>{renderBlocks item}</li>|]+ | item <- items+ ]+ tag = case listType of+ BulletList -> "ul" :: T.Text+ OrderedList { startNumber = 1 } -> "ol"+ OrderedList { startNumber = startNumber' } ->+ [qq|ol start="$startNumber'"|]+ nl = '\n'+ liListT = T.intercalate "\n" liList+ in [qq|<$tag>$nl$liListT$nl</$tag>|]++renderBlocks :: [Block] -> Html+renderBlocks = T.intercalate "\n" . map renderBlock++render :: Block -> Html+render = renderBlock
+ src/Nirum/Docs/ReStructuredText.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE OverloadedStrings, QuasiQuotes #-}+module Nirum.Docs.ReStructuredText (ReStructuredText, render) where++import qualified Data.Text as T+import Text.InterpolatedString.Perl6 (qq)++import Nirum.Docs++type ReStructuredText = T.Text++renderInline :: Inline -> ReStructuredText+renderInline (Text t) = escape t+renderInline SoftLineBreak = "\n"+renderInline HardLineBreak = "\n"+renderInline (HtmlInline html) = [qq|:raw:`$html`|]+renderInline (Code code') = [qq|``{code'}``|]+renderInline (Emphasis inlines) = [qq|*{escape $ bareText inlines}*|]+renderInline (Strong inlines) = [qq|**{escape $ bareText inlines}**|]+renderInline (Image url title)+ | T.null title = T.concat ["\n\n.. image:: ", url, "\n\n"]+ | otherwise = T.concat ["\n\n.. image:: ", url, "\n :alt: ", title, "\n\n"]+renderInline (Link url _ inlines)+ | length images < length inlines = [qq|`{escape $ bareText inlines} <$url>`_|]+ | otherwise = T.replace "\n\n\n\n" "\n\n" $ T.concat [image i | i <- images]+ where+ images :: [(T.Text, T.Text)]+ images = [(url', title) | Image url' title <- inlines]+ image :: (T.Text, T.Text) -> ReStructuredText+ image (url', title)+ | T.null title = T.concat [ "\n\n.. image:: ", url', "\n :target: "+ , url, "\n\n"+ ]+ | otherwise = T.concat ["\n\n.. image:: ", url', "\n :alt: ", title+ , "\n :target: ", url, "\n\n"]++bareText :: [Inline] -> T.Text+bareText inlines =+ T.concat $ map t inlines+ where+ t :: Inline -> T.Text+ t (Text t') = t'+ t SoftLineBreak = "\n"+ t HardLineBreak = "\n"+ t (HtmlInline _) = ""+ t (Code code') = code'+ t (Emphasis inlines') = bareText inlines'+ t (Strong inlines') = bareText inlines'+ t (Link _ _ inlines') = bareText inlines'+ t (Image _ _) = ""++escape :: T.Text -> ReStructuredText+escape = T.concatMap escapeChar++escapeChar :: Char -> Html+escapeChar '\\' = "\\\\"+escapeChar ':' = "\\:"+escapeChar '`' = "\\`"+escapeChar '.' = "\\."+escapeChar c = T.singleton c++renderInlines :: [Inline] -> ReStructuredText+renderInlines inlines =+ T.concat $ prependBar $ map renderInline inlines+ where+ useLineblocks :: Bool+ useLineblocks = not $ null [i | i@HardLineBreak <- inlines]+ prependBar :: [ReStructuredText] -> [ReStructuredText]+ prependBar ts = if useLineblocks then "| " : ts else ts++indent :: T.Text -> ReStructuredText -> ReStructuredText+indent spaces =+ T.intercalate "\n" . map indent' . T.lines+ where+ indent' :: T.Text -> T.Text+ indent' line+ | T.null line = T.empty+ | otherwise = spaces `T.append` line++indent2 :: ReStructuredText -> ReStructuredText+indent2 = indent " "++indent3 :: ReStructuredText -> ReStructuredText+indent3 = indent " "++indent4 :: ReStructuredText -> ReStructuredText+indent4 = indent " "++renderBlock :: Block -> ReStructuredText+renderBlock (Document blocks) = renderBlocks blocks `T.snoc` '\n'+renderBlock ThematicBreak = "----------"+renderBlock (Paragraph inlines) = renderInlines inlines+renderBlock (BlockQuote blocks) = indent4 (renderBlocks blocks)+renderBlock (HtmlBlock html) =+ T.concat [ ".. raw:: html\n\n"+ , indent3 html+ ]+renderBlock (CodeBlock lang code') =+ T.concat [ if T.null lang then "::" else [qq|.. code:: $lang|]+ , "\n\n"+ , indent3 code'+ ]+renderBlock (Heading level inlines) =+ T.concat [text, "\n", T.pack [hChar | _ <- [1 .. (T.length text)]]]+ where+ text :: ReStructuredText+ text = renderInlines inlines+ hChar :: Char+ hChar = case level of+ H1 -> '='+ H2 -> '-'+ H3 -> '~'+ H4 -> '`'+ H5 -> '.'+ H6 -> '\''+renderBlock (List BulletList (TightItemList items)) =+ T.intercalate "\n" [[qq|- {renderInlines i}|] | i <- items]+renderBlock (List BulletList (LooseItemList items)) =+ T.intercalate "\n\n" [ [qq|- {T.drop 2 $ indent2 $ renderBlocks i}|]+ | i <- items+ ]+renderBlock (List (OrderedList startNum _) (TightItemList items)) =+ T.intercalate "\n" [ [qq|$n. {renderInlines i}|]+ | (n, i) <- indexed startNum items+ ]+renderBlock (List (OrderedList startNum _) (LooseItemList items)) =+ T.intercalate "\n\n" [ [qq|$n. {T.drop 3 $ indent3 $ renderBlocks i}|]+ | (n, i) <- indexed startNum items+ ]++indexed :: Enum i => i -> [a] -> [(i, a)]+indexed _ [] = []+indexed start (x : xs) = (start, x) : indexed (succ start) xs++renderBlocks :: [Block] -> ReStructuredText+renderBlocks = T.intercalate "\n\n" . map renderBlock++render :: Block -> ReStructuredText+render = renderBlock
src/Nirum/Package.hs view
@@ -1,144 +1,80 @@-module Nirum.Package ( BoundModule(boundPackage, modulePath)- , ImportError ( CircularImportError- , MissingImportError- , MissingModulePathError- )- , Package(modules)- , PackageError(ImportError, ParseError, ScanError)- , TypeLookup(Imported, Local, Missing)- , docs- , findInBoundModule- , lookupType- , makePackage- , resolveBoundModule- , resolveModule- , scanModules- , scanPackage- , types- ) where+module Nirum.Package+ ( Package (..)+ , PackageError (..)+ , docs+ , resolveModule+ , scanModules+ , scanPackage+ , target+ ) where +import System.IO.Error (catchIOError)++import Control.Monad.Except ( ExceptT+ , MonadError (throwError)+ , liftIO+ , runExceptT+ ) import qualified Data.Map.Strict as M import qualified Data.Set as S import System.Directory (doesDirectoryExist, listDirectory) import System.FilePath ((</>)) -import Nirum.Constructs.Docs (Docs)-import qualified Nirum.Constructs.DeclarationSet as DS-import Nirum.Constructs.Identifier (Identifier)-import qualified Nirum.Constructs.Module as Mod+import Nirum.Constructs.Module import Nirum.Constructs.ModulePath (ModulePath, fromFilePath)-import Nirum.Constructs.TypeDeclaration ( Type- , TypeDeclaration ( Import- , ServiceDeclaration- , TypeDeclaration- , type'- )- )+import Nirum.Package.Metadata ( MetadataError+ , Package (Package, metadata, modules)+ , Target+ , metadataPath+ , packageTarget+ , readFromPackage+ )+import qualified Nirum.Package.ModuleSet as MS import Nirum.Parser (ParseError, parseFile) --- | Represents a package which consists of modules.-data Package = Package { modules :: M.Map ModulePath Mod.Module- } deriving (Eq, Ord, Show)--- TODO: uri, version, dependencies--data ImportError = CircularImportError [ModulePath]- | MissingModulePathError ModulePath ModulePath- | MissingImportError ModulePath ModulePath Identifier- deriving (Eq, Ord, Show)--makePackage :: M.Map ModulePath Mod.Module -> Either (S.Set ImportError) Package-makePackage modules'- | S.null importErrors = Right package- | otherwise = Left importErrors- where- package :: Package- package = Package modules'- importErrors :: S.Set ImportError- importErrors = detectImportErrors package--resolveModule :: ModulePath -> Package -> Maybe Mod.Module-resolveModule path Package { modules = ms } = M.lookup path ms--resolveBoundModule :: ModulePath -> Package -> Maybe BoundModule-resolveBoundModule path package =- case resolveModule path package of- Just _ -> Just $ BoundModule package path- Nothing -> Nothing--detectImportErrors :: Package -> S.Set ImportError-detectImportErrors package = detectMissingImports package `S.union`- detectCircularImports package--detectMissingImports :: Package -> S.Set ImportError-detectMissingImports package@Package { modules = ms } =- S.fromList [e | (path, module') <- M.toList ms, e <- detect path module']- where- detect :: ModulePath -> Mod.Module -> [ImportError]- detect path module' =- [ e- | (path', idents) <- M.toList (Mod.imports module')- , e <- case resolveModule path' package of- Nothing -> [MissingModulePathError path path']- Just (Mod.Module decls _) ->- [ e- | i <- S.toList idents- , e <- case DS.lookup i decls of- Just TypeDeclaration {} -> []- Just ServiceDeclaration {} -> []- Just Import {} -> [MissingImportError path path' i]- Nothing -> [MissingImportError path path' i]- ]- ]+target :: Target t => Package t -> t+target = packageTarget -detectCircularImports :: Package -> S.Set ImportError-detectCircularImports Package { modules = ms } =- S.fromList [e | path <- M.keys ms, e <- detect path []]- where- moduleImports :: M.Map ModulePath (S.Set ModulePath)- moduleImports =- M.fromList [ (path, M.keysSet $ Mod.imports module')- | (path, module') <- M.toList ms- ]- detect :: ModulePath -> [ModulePath] -> [ImportError]- detect path reversedCycle- | path `elem` reversedCycle =- [CircularImportError $ reverse reversedCycle']- | otherwise =- case M.lookup path moduleImports of- Just paths -> [ e- | path' <- S.toList paths- , e <- detect path' reversedCycle'- ]- Nothing -> []- where- reversedCycle' :: [ModulePath]- reversedCycle' = path : reversedCycle+resolveModule :: ModulePath -> Package t -> Maybe Module+resolveModule path Package { modules = ms } = MS.lookup path ms data PackageError = ScanError FilePath IOError | ParseError ModulePath ParseError- | ImportError (S.Set ImportError)+ | ImportError (S.Set MS.ImportError)+ | MetadataError MetadataError deriving (Eq, Show) -- | Scan the given package path, and then return the read package.-scanPackage :: FilePath -> IO (Either PackageError Package)-scanPackage packagePath = do- modulePaths <- scanModules packagePath- -- FIXME: catch IO errors- modules' <- mapM parseFile modulePaths- return $ case M.foldrWithKey excludeFailedParse (Right M.empty) modules' of- Right parsedModules -> case makePackage parsedModules of- Right p -> Right p- Left errors -> Left $ ImportError errors- Left error' -> Left error'+scanPackage :: Target t => FilePath -> IO (Either PackageError (Package t))+scanPackage packagePath = runExceptT $ do+ metadataE <- catch (readFromPackage packagePath)+ (ScanError $ metadataPath packagePath)+ metadata' <- case metadataE of+ Right m -> return m+ Left e -> throwError $ MetadataError e+ modulePaths <- liftIO $ scanModules packagePath+ modules' <- mapM (\ p -> catch (parseFile p) $ ScanError p) modulePaths+ case M.foldrWithKey excludeFailedParse (Right M.empty) modules' of+ Right parsedModules -> case MS.fromMap parsedModules of+ Right ms -> return $ Package metadata' ms+ Left errors -> throwError $ ImportError errors+ Left error' -> throwError error' where excludeFailedParse :: ModulePath- -> Either ParseError Mod.Module- -> Either PackageError (M.Map ModulePath Mod.Module)- -> Either PackageError (M.Map ModulePath Mod.Module)+ -> Either ParseError Module+ -> Either PackageError (M.Map ModulePath Module)+ -> Either PackageError (M.Map ModulePath Module) excludeFailedParse _ _ (Left error') = Left error' excludeFailedParse path (Left error') _ = Left $ ParseError path error' excludeFailedParse path (Right module') (Right map') = Right (M.insert path module' map')+ catch :: IO a -> (IOError -> e) -> ExceptT e IO a+ catch op onError = do+ result <- liftIO $ catchIOError (fmap Right op)+ (return . Left . onError)+ case result of+ Left err -> throwError err+ Right val -> return val -- | Scan the given path recursively, and then return the map of -- detected module paths.@@ -148,7 +84,7 @@ return $ M.fromList files where isNotHidden :: FilePath -> Bool- isNotHidden ('.':_) = False+ isNotHidden ('.' : _) = False isNotHidden _ = True scanFiles :: FilePath -> IO [(ModulePath, FilePath)] scanFiles path = do@@ -166,44 +102,3 @@ realPath = case path of [] -> packagePath p -> packagePath </> p--data BoundModule = BoundModule { boundPackage :: Package- , modulePath :: ModulePath- } deriving (Eq, Ord, Show)--findInBoundModule :: (Mod.Module -> a) -> a -> BoundModule -> a-findInBoundModule valueWhenExist valueWhenNotExist- BoundModule { boundPackage = Package { modules = ms }- , modulePath = path- } =- case M.lookup path ms of- Nothing -> valueWhenNotExist- Just mod' -> valueWhenExist mod'--types :: BoundModule -> DS.DeclarationSet TypeDeclaration-types = findInBoundModule Mod.types DS.empty--docs :: BoundModule -> Maybe Docs-docs = findInBoundModule Mod.docs Nothing--data TypeLookup = Missing- | Local Type- | Imported ModulePath Type- deriving (Eq, Ord, Show)--lookupType :: Identifier -> BoundModule -> TypeLookup-lookupType identifier boundModule =- case DS.lookup identifier (types boundModule) of- Nothing -> toType Mod.coreModulePath- (DS.lookup identifier $ Mod.types Mod.coreModule)- Just TypeDeclaration { type' = t } -> Local t- Just (Import path _ _) ->- case resolveModule path (boundPackage boundModule) of- Nothing -> Missing- Just (Mod.Module decls _) ->- toType path (DS.lookup identifier decls)- Just ServiceDeclaration {} -> Missing- where- toType :: ModulePath -> Maybe TypeDeclaration -> TypeLookup- toType mp (Just TypeDeclaration { type' = t }) = Imported mp t- toType _ _ = Missing
+ src/Nirum/Package/Metadata.hs view
@@ -0,0 +1,348 @@+{-# LANGUAGE GADTs, QuasiQuotes, RankNTypes, ScopedTypeVariables,+ StandaloneDeriving, TypeFamilies #-}+module Nirum.Package.Metadata ( Author (Author, email, name, uri)+ , Metadata ( Metadata+ , authors+ , target+ , version+ , description+ , license+ , keywords+ )+ , MetadataError ( FieldError+ , FieldTypeError+ , FieldValueError+ , FormatError+ )+ , MetadataField+ , MetadataFieldType+ , Node ( VArray+ , VBoolean+ , VDatetime+ , VFloat+ , VInteger+ , VString+ , VTable+ , VTArray+ )+ , Package (Package, metadata, modules)+ , Table+ , Target ( CompileError+ , CompileResult+ , compilePackage+ , parseTarget+ , showCompileError+ , targetName+ , toByteString+ )+ , TargetName+ , VTArray+ , fieldType+ , metadataFilename+ , metadataPath+ , parseMetadata+ , packageTarget+ , prependMetadataErrorField+ , readFromPackage+ , readMetadata+ , stringField+ , tableField+ , versionField+ ) where++import Data.Proxy (Proxy (Proxy))+import Data.Typeable (Typeable)+import GHC.Exts (IsList (fromList, toList))++import Data.ByteString (ByteString)+import qualified Data.HashMap.Strict as HM+import Data.Map.Strict (Map)+import qualified Data.SemVer as SV+import Data.Text (Text, append, snoc, unpack)+import Data.Text.Encoding (encodeUtf8)+import qualified Data.Text.IO as TIO+import System.FilePath ((</>))+import Text.Email.Parser (EmailAddress)+import qualified Text.Email.Validate as EV+import Text.InterpolatedString.Perl6 (qq)+import Text.Parsec.Error (ParseError)+import Text.Toml (parseTomlDoc)+import Text.Toml.Types (Node ( VArray+ , VBoolean+ , VDatetime+ , VFloat+ , VInteger+ , VString+ , VTable+ , VTArray+ )+ , Table+ , VTArray+ , VArray+ )+import Text.URI (URI, parseURI)++import Nirum.Package.ModuleSet (ModuleSet)++-- | The filename of Nirum package metadata.+metadataFilename :: FilePath+metadataFilename = "package.toml"++-- | Represents a package which consists of modules.+data Package t =+ Package { metadata :: (Eq t, Ord t, Show t, Target t) => Metadata t+ , modules :: ModuleSet+ }++deriving instance (Eq t, Target t) => Eq (Package t)+deriving instance (Ord t, Target t) => Ord (Package t)+deriving instance (Show t, Target t) => Show (Package t)++packageTarget :: Target t => Package t -> t+packageTarget Package { metadata = Metadata { target = t } } = t++data Metadata t =+ Metadata { version :: SV.Version+ , description :: Maybe Text+ , license :: Maybe Text+ , keywords :: [Text]+ , authors :: [Author]+ , target :: (Eq t, Ord t, Show t, Target t) => t+ }+-- TODO: uri, dependencies++deriving instance (Eq t, Target t) => Eq (Metadata t)+deriving instance (Ord t, Target t) => Ord (Metadata t)+deriving instance (Show t, Target t) => Show (Metadata t)++data Author = Author { name :: Text+ , email :: Maybe EmailAddress+ , uri :: Maybe URI+ } deriving (Eq, Ord, Show)++type TargetName = Text++class (Eq t, Ord t, Show t, Typeable t) => Target t where+ type family CompileResult t :: *+ type family CompileError t :: *++ -- | The name of the given target e.g. @"python"@.+ targetName :: Proxy t -> TargetName++ -- | Parse the target metadata.+ parseTarget :: Table -> Either MetadataError t++ -- | Compile the package to a source tree of the target.+ compilePackage :: Package t+ -> Map FilePath (Either (CompileError t) (CompileResult t))++ -- | Show a human-readable message from the given 'CompileError'.+ showCompileError :: t -> CompileError t -> Text++ -- | Encode the given 'CompileResult' to a 'ByteString'+ toByteString :: t -> CompileResult t -> ByteString++-- | Name of package.toml field.+type MetadataField = Text++-- | Typename of package.toml field e.g. @"string"@, @"array of 3 values"@.+type MetadataFieldType = Text++-- | Error related to parsing package.toml.+data MetadataError+ -- | A required field is missing.+ = FieldError MetadataField+ -- | A field has a value of incorrect type e.g. array for @version@ field.+ | FieldTypeError MetadataField MetadataFieldType MetadataFieldType+ -- | A field has a value of invalid format+ -- e.g. @"1/2/3"@ for @version@ field.+ | FieldValueError MetadataField String+ -- | The given package.toml file is not a valid TOML.+ | FormatError ParseError+ deriving (Eq, Show)++-- | Prepend the given prefix to a 'MetadataError' value's field information.+-- Note that a period is automatically inserted right after the given prefix.+-- It's useful for handling of accessing nested tables.+prependMetadataErrorField :: MetadataField -> MetadataError -> MetadataError+prependMetadataErrorField prefix e =+ case e of+ FieldError f -> FieldError $ prepend f+ FieldTypeError f e' a -> FieldTypeError (prepend f) e' a+ FieldValueError f m -> FieldValueError (prepend f) m+ e'@(FormatError _) -> e'+ where+ prepend :: MetadataField -> MetadataField+ prepend = (prefix `snoc` '.' `append`)++parseMetadata :: forall t . Target t+ => FilePath -> Text -> Either MetadataError (Metadata t)+parseMetadata metadataPath' tomlText = do+ table <- case parseTomlDoc metadataPath' tomlText of+ Left e -> Left $ FormatError e+ Right t -> Right t+ -- NOTE: When a new field is added please write docs about it in+ -- docs/package.md file.+ version' <- versionField "version" table+ authors' <- authorsField "authors" table+ description' <- optional $ stringField "description" table+ license' <- optional $ stringField "license" table+ keywords' <- textArrayField "keywords" table+ targets <- case tableField "targets" table of+ Left (FieldError _) -> Right HM.empty+ otherwise' -> otherwise'+ targetTable <- case tableField targetName' targets of+ Left (FieldError _) -> Right HM.empty+ Left e -> Left $ prependMetadataErrorField "targets" e+ otherwise' -> otherwise'+ target' <- case parseTarget targetTable of+ Left e -> Left $ prependMetadataErrorField "targets"+ $ prependMetadataErrorField targetName' e+ otherwise' -> otherwise'+ return Metadata { version = version'+ , description = description'+ , license = license'+ , keywords = keywords'+ , authors = authors'+ , target = target'+ }+ where+ targetName' :: Text+ targetName' = targetName (Proxy :: Proxy t)++readMetadata :: Target t => FilePath -> IO (Either MetadataError (Metadata t))+readMetadata metadataPath' = do+ tomlText <- TIO.readFile metadataPath'+ return $ parseMetadata metadataPath' tomlText++metadataPath :: FilePath -> FilePath+metadataPath = (</> metadataFilename)++readFromPackage :: Target t+ => FilePath -> IO (Either MetadataError (Metadata t))+readFromPackage = readMetadata . metadataPath++-- | Show the typename of the given 'Node'.+fieldType :: Node -> MetadataFieldType+fieldType (VTable t) = if length t == 1+ then "table of an item"+ else [qq|table of {length t} items|]+fieldType (VTArray a) = [qq|array of {length a} tables|]+fieldType (VString s) = [qq|string ($s)|]+fieldType (VInteger i) = [qq|integer ($i)|]+fieldType (VFloat f) = [qq|float ($f)|]+fieldType (VBoolean True) = "boolean (true)"+fieldType (VBoolean False) = "boolean (false)"+fieldType (VDatetime d) = [qq|datetime ($d)|]+fieldType (VArray a) = if length a == 1+ then "array of a value"+ else [qq|array of {length a} values|]++field :: MetadataField -> Table -> Either MetadataError Node+field field' table =+ case HM.lookup field' table of+ Just node -> return node+ Nothing -> Left $ FieldError field'++typedField :: MetadataFieldType+ -> (Node -> Maybe v)+ -> MetadataField+ -> Table+ -> Either MetadataError v+typedField typename match field' table = do+ node <- field field' table+ case match node of+ Just value -> return value+ Nothing -> Left $ FieldTypeError field' typename $ fieldType node++optional :: Either MetadataError a -> Either MetadataError (Maybe a)+optional (Right value) = Right $ Just value+optional (Left (FieldError _)) = Right Nothing+optional (Left error') = Left error'++tableField :: MetadataField -> Table -> Either MetadataError Table+tableField = typedField "table" $ \ n -> case n of+ VTable t -> Just t+ _ -> Nothing++stringField :: MetadataField -> Table -> Either MetadataError Text+stringField = typedField "string" $ \ n -> case n of+ VString s -> Just s+ _ -> Nothing++arrayField :: MetadataField -> Table -> Either MetadataError VArray+arrayField f t =+ case arrayF f t of+ Right vector -> Right vector+ Left (FieldError _) -> Right $ fromList []+ Left error' -> Left error'+ where+ arrayF :: MetadataField -> Table -> Either MetadataError VArray+ arrayF = typedField "array" $ \ node ->+ case node of+ VArray array -> Just array+ _ -> Nothing+++tableArrayField :: MetadataField -> Table -> Either MetadataError VTArray+tableArrayField f t =+ case arrayF f t of+ Right vector -> Right vector+ Left (FieldError _) -> Right $ fromList []+ Left error' -> Left error'+ where+ arrayF :: MetadataField -> Table -> Either MetadataError VTArray+ arrayF = typedField "array of tables" $ \ node ->+ case node of+ VTArray array -> Just array+ _ -> Nothing++uriField :: MetadataField -> Table -> Either MetadataError URI+uriField field' table = do+ s <- stringField field' table+ case parseURI (unpack s) of+ Just uri' -> Right uri'+ Nothing -> Left $ FieldValueError field'+ [qq|expected a URI string, not $s|]++emailField :: MetadataField -> Table -> Either MetadataError EmailAddress+emailField field' table = do+ s <- stringField field' table+ case EV.validate (encodeUtf8 s) of+ Right emailAddress -> Right emailAddress+ Left e -> Left $+ FieldValueError field' [qq|expected an email address, not $s; $e|]++versionField :: MetadataField -> Table -> Either MetadataError SV.Version+versionField field' table = do+ s <- stringField field' table+ case SV.fromText s of+ Right v -> return v+ Left _ -> Left $ FieldValueError field' $+ "expected a semver string (e.g. \"1.2.3\"), not " ++ show s++textArrayField :: MetadataField -> Table -> Either MetadataError [Text]+textArrayField field' table = do+ array <- arrayField field' table+ textArray' <- mapM parseText array+ return $ toList textArray'+ where+ parseText :: Node -> Either MetadataError Text+ parseText (VString s) = Right s+ parseText a = Left $ FieldTypeError field' "array" $ fieldType a++authorsField :: MetadataField -> Table -> Either MetadataError [Author]+authorsField field' table = do+ array <- tableArrayField field' table+ authors' <- mapM parseAuthor array+ return $ toList authors'+ where+ parseAuthor :: Table -> Either MetadataError Author+ parseAuthor t = do+ name' <- stringField "name" t+ email' <- optional $ emailField "email" t+ uri' <- optional $ uriField "uri" t+ return Author { name = name'+ , email = email'+ , uri = uri'+ }
+ src/Nirum/Package/ModuleSet.hs view
@@ -0,0 +1,124 @@+module Nirum.Package.ModuleSet ( ImportError ( CircularImportError+ , MissingImportError+ , MissingModulePathError+ )+ , ModuleSet+ , fromList+ , fromMap+ , keys+ , keysSet+ , length+ , lookup+ , null+ , toAscList+ , toList+ , toMap+ ) where++import qualified Data.Map.Strict as M+import qualified Data.Set as S+import Prelude hiding (length, lookup, null)++import qualified Nirum.Constructs.DeclarationSet as DS+import Nirum.Constructs.Identifier (Identifier)+import Nirum.Constructs.Module (Module (Module), imports)+import Nirum.Constructs.ModulePath (ModulePath)+import Nirum.Constructs.TypeDeclaration ( TypeDeclaration ( Import+ , ServiceDeclaration+ , TypeDeclaration+ )+ )++data ImportError = CircularImportError [ModulePath]+ | MissingModulePathError ModulePath ModulePath+ | MissingImportError ModulePath ModulePath Identifier+ deriving (Eq, Ord, Show)++-- | The set of 'Module' values. It can be looked up by its 'ModulePath'.+newtype ModuleSet = ModuleSet (M.Map ModulePath Module) deriving (Eq, Ord, Show)++fromMap :: M.Map ModulePath Module -> Either (S.Set ImportError) ModuleSet+fromMap ms+ | S.null importErrors = Right moduleSet+ | otherwise = Left importErrors+ where+ moduleSet :: ModuleSet+ moduleSet = ModuleSet ms+ importErrors :: S.Set ImportError+ importErrors = detectImportErrors moduleSet++fromList :: [(ModulePath, Module)] -> Either (S.Set ImportError) ModuleSet+fromList = fromMap . M.fromList++toMap :: ModuleSet -> M.Map ModulePath Module+toMap (ModuleSet ms) = ms++toList :: ModuleSet -> [(ModulePath, Module)]+toList = M.toList . toMap++toAscList :: ModuleSet -> [(ModulePath, Module)]+toAscList = M.toAscList . toMap++length :: ModuleSet -> Int+length = M.size . toMap++null :: ModuleSet -> Bool+null = M.null . toMap++keys :: ModuleSet -> [ModulePath]+keys = M.keys . toMap++keysSet :: ModuleSet -> S.Set ModulePath+keysSet = M.keysSet . toMap++lookup :: ModulePath -> ModuleSet -> Maybe Module+lookup path = M.lookup path . toMap++detectImportErrors :: ModuleSet -> S.Set ImportError+detectImportErrors moduleSet = detectMissingImports moduleSet `S.union`+ detectCircularImports moduleSet++detectMissingImports :: ModuleSet -> S.Set ImportError+detectMissingImports moduleSet =+ S.fromList [e | (path, mod') <- toList moduleSet, e <- detect path mod']+ where+ detect :: ModulePath -> Module -> [ImportError]+ detect path module' =+ [ e+ | (path', idents) <- M.toList (imports module')+ , e <- case lookup path' moduleSet of+ Nothing -> [MissingModulePathError path path']+ Just (Module decls _) ->+ [ e+ | i <- S.toList idents+ , e <- case DS.lookup i decls of+ Just TypeDeclaration {} -> []+ Just ServiceDeclaration {} -> []+ Just Import {} -> [MissingImportError path path' i]+ Nothing -> [MissingImportError path path' i]+ ]+ ]++detectCircularImports :: ModuleSet -> S.Set ImportError+detectCircularImports (ModuleSet ms) =+ S.fromList [e | path <- M.keys ms, e <- detect path []]+ where+ moduleImports :: M.Map ModulePath (S.Set ModulePath)+ moduleImports =+ M.fromList [ (path, M.keysSet $ imports module')+ | (path, module') <- M.toList ms+ ]+ detect :: ModulePath -> [ModulePath] -> [ImportError]+ detect path reversedCycle+ | path `elem` reversedCycle =+ [CircularImportError $ reverse reversedCycle']+ | otherwise =+ case M.lookup path moduleImports of+ Just paths -> [ e+ | path' <- S.toList paths+ , e <- detect path' reversedCycle'+ ]+ Nothing -> []+ where+ reversedCycle' :: [ModulePath]+ reversedCycle' = path : reversedCycle
src/Nirum/Parser.hs view
@@ -31,32 +31,14 @@ , unionTypeDeclaration ) where -import Control.Applicative ((<$>))-import Control.Monad (join, void)-import Data.List (foldl1')-import Prelude hiding (readFile)+import Control.Monad (void)+import qualified System.IO as SIO -import Data.Set (elems)+import Data.Map.Strict as Map hiding (foldl)+import Data.Set hiding (empty, foldl, fromList, map) import qualified Data.Text as T-import Data.Text.IO (readFile)-import Text.Megaparsec ( Token- , choice- , eof- , many- , manyTill- , notFollowedBy- , option- , optional- , runParser- , sepBy1- , sepEndBy- , sepEndBy1- , skipMany- , skipSome- , try- , (<|>)- , (<?>)- )+import qualified Data.Text.IO as TIO+import Text.Megaparsec hiding (ParseError, parse) import Text.Megaparsec.Char ( char , eol , noneOf@@ -70,48 +52,42 @@ import qualified Nirum.Constructs.Annotation as A import Nirum.Constructs.Declaration (Declaration)-import Nirum.Constructs.Docs (Docs(Docs))-import Nirum.Constructs.DeclarationSet ( DeclarationSet- , NameDuplication( BehindNameDuplication- , FacialNameDuplication- )- , empty- , fromList- )+import Nirum.Constructs.Docs (Docs (Docs))+import Nirum.Constructs.DeclarationSet as DeclarationSet import Nirum.Constructs.Identifier ( Identifier , identifierRule , reservedKeywords , toString )-import Nirum.Constructs.Module (Module(Module))-import Nirum.Constructs.ModulePath (ModulePath(ModulePath, ModuleName))-import Nirum.Constructs.Name (Name(Name))-import Nirum.Constructs.Service ( Method(Method)- , Parameter(Parameter)- , Service(Service)+import Nirum.Constructs.Module (Module (Module))+import Nirum.Constructs.ModulePath (ModulePath (ModulePath, ModuleName))+import Nirum.Constructs.Name (Name (Name))+import Nirum.Constructs.Service ( Method (Method)+ , Parameter (Parameter)+ , Service (Service) )-import Nirum.Constructs.TypeDeclaration ( EnumMember(EnumMember)- , Field(Field)- , Tag(Tag)- , Type( Alias- , EnumType- , RecordType- , UnboxedType- , UnionType- )- , TypeDeclaration( Import- , ServiceDeclaration- , TypeDeclaration- , serviceAnnotations- , typeAnnotations- )+import Nirum.Constructs.TypeDeclaration ( EnumMember (EnumMember)+ , Field (Field)+ , Tag (Tag)+ , Type ( Alias+ , EnumType+ , RecordType+ , UnboxedType+ , UnionType+ )+ , TypeDeclaration ( Import+ , ServiceDeclaration+ , TypeDeclaration+ , serviceAnnotations+ , typeAnnotations+ ) )-import Nirum.Constructs.TypeExpression ( TypeExpression( ListModifier- , MapModifier- , OptionModifier- , SetModifier- , TypeIdentifier- )+import Nirum.Constructs.TypeExpression ( TypeExpression ( ListModifier+ , MapModifier+ , OptionModifier+ , SetModifier+ , TypeIdentifier+ ) ) type ParseError = E.ParseError (Token T.Text) E.Dec@@ -129,12 +105,14 @@ identifier = quotedIdentifier <|> bareIdentifier <?> "identifier" where- keywords :: Parser String- keywords = foldl1' (<|>) $ map (string' . toString) $ elems reservedKeywords bareIdentifier :: Parser Identifier- bareIdentifier = do- notFollowedBy keywords- identifierRule+ bareIdentifier = try $ do+ ident <- lookAhead identifierRule+ if ident `Data.Set.member` reservedKeywords+ then fail $ "\"" ++ toString ident ++ "\" is a reserved keyword; "+ ++ "wrap it with backquotes to use it as a normal "+ ++ "identifier (i.e. \"`" ++ toString ident ++ "`\")"+ else identifierRule quotedIdentifier :: Parser Identifier quotedIdentifier = do char '`'@@ -152,22 +130,39 @@ identifier <?> "behind name" return $ Name facialName behindName +annotationArgumentValue :: Parser T.Text+annotationArgumentValue = do+ char '"'+ value <- manyTill charLiteral (char '"')+ return $ T.pack value++annotationArgument :: Parser (Identifier, T.Text)+annotationArgument = do+ arg <- identifier <?> "annotation parameter"+ spaces+ char '='+ spaces+ value <- annotationArgumentValue <?> "annotation argument value"+ return (arg, value)+ annotation :: Parser A.Annotation annotation = do char '@' spaces name' <- identifier spaces- metadata <- optional $ do+ args' <- option Map.empty $ do char '(' spaces- m <- optional ((char '"' >> manyTill charLiteral (char '"'))- <?> "annotation metadata")+ args <- (`sepEndBy` char ',') $ do+ spaces+ a <- annotationArgument+ spaces+ return a spaces char ')'- return m- let metadata' = T.pack <$> join metadata- return $ A.Annotation name' metadata'+ return $ Map.fromList args+ return $ A.Annotation name' args' annotationSet :: Parser A.AnnotationSet annotationSet = do@@ -234,11 +229,12 @@ docs :: Parser Docs docs = do- comments <- sepEndBy1 (do { char '#'- ; void $ optional $ char ' '- ; line <- many $ noneOf ("\r\n" :: String)- ; return $ T.pack line- }) (eol >> spaces) <?> "comments"+ comments <- sepEndBy1 (do+ char '#'+ void $ optional $ char ' '+ line <- many $ noneOf ("\r\n" :: String)+ return $ T.pack line+ ) (eol >> spaces) <?> "comments" return $ Docs $ T.unlines comments annotationsWithDocs :: Monad m@@ -302,13 +298,13 @@ => String -> [a] -> (DeclarationSet a -> Parser b) -> Parser b-handleNameDuplication label declarations cont =- case fromList declarations of+handleNameDuplication label' declarations cont =+ case DeclarationSet.fromList declarations of Left (BehindNameDuplication (Name _ bname)) ->- fail ("the behind " ++ label ++ " name `" ++ toString bname +++ fail ("the behind " ++ label' ++ " name `" ++ toString bname ++ "` is duplicated") Left (FacialNameDuplication (Name fname _)) ->- fail ("the facial " ++ label ++ " name `" ++ toString fname +++ fail ("the facial " ++ label' ++ " name `" ++ toString fname ++ "` is duplicated") Right set -> cont set @@ -334,7 +330,7 @@ annotationSet'' <- annotationsWithDocs annotationSet' docs' members <- (enumMember `sepBy1` (spaces >> char '|' >> spaces)) <?> "enum members"- case fromList members of+ case DeclarationSet.fromList members of Left (BehindNameDuplication (Name _ bname)) -> fail ("the behind member name `" ++ toString bname ++ "` is duplicated")@@ -347,39 +343,39 @@ return $ TypeDeclaration typename (EnumType memberSet) annotationSet'' -fieldsOrParameters :: forall a. (String, String)+fieldsOrParameters :: forall a . (String, String) -> (Name -> TypeExpression -> A.AnnotationSet -> a) -> Parser [a]-fieldsOrParameters (label, pluralLabel) make = do- annotationSet' <- annotationSet <?> (label ++ " annotations")+fieldsOrParameters (label', pluralLabel) make = do+ annotationSet' <- annotationSet <?> (label' ++ " annotations") spaces- type' <- typeExpression <?> (label ++ " type")+ type' <- typeExpression <?> (label' ++ " type") spaces1- name' <- name <?> (label ++ " name")+ name' <- name <?> (label' ++ " name") spaces let makeWithDocs = make name' type' . A.union annotationSet' . annotationsFromDocs followedByComma makeWithDocs <|> do- d <- optional docs' <?> (label ++ " docs")+ d <- optional docs' <?> (label' ++ " docs") return [makeWithDocs d] where recur :: Parser [a]- recur = fieldsOrParameters (label, pluralLabel) make+ recur = fieldsOrParameters (label', pluralLabel) make followedByComma :: (Maybe Docs -> a) -> Parser [a] followedByComma makeWithDocs = do char ',' spaces- d <- optional docs' <?> (label ++ " docs")+ d <- optional docs' <?> (label' ++ " docs") rest <- option [] recur <?> ("rest of " ++ pluralLabel) return $ makeWithDocs d : rest docs' :: Parser Docs docs' = do- d <- docs <?> (label ++ " docs")+ d <- docs <?> (label' ++ " docs") spaces return d annotationsFromDocs :: Maybe Docs -> A.AnnotationSet- annotationsFromDocs Nothing = A.empty+ annotationsFromDocs Nothing = A.empty annotationsFromDocs (Just d) = A.singleton $ A.docs d fields :: Parser [Field]@@ -418,18 +414,26 @@ tagName <- name <?> "union tag name" spaces paren <- optional $ char '('- fields' <- case paren of- Just _ -> do { spaces- ; f <- fieldSet <?> "union tag fields"- ; spaces- ; char ')'- ; return f- }- Nothing -> return empty- docs' <- optional $ do+ spaces+ frontDocs <- optional $ do d <- docs <?> "union tag docs" spaces return d+ fields' <- case paren of+ Just _ -> do+ spaces+ f <- fieldSet <?> "union tag fields"+ spaces+ char ')'+ return f+ Nothing -> return DeclarationSet.empty+ spaces+ docs' <- case frontDocs of+ d@(Just _) -> return d+ Nothing -> optional $ do+ d <- docs <?> "union tag docs"+ spaces+ return d annotationSet'' <- annotationsWithDocs annotationSet' docs' return $ Tag tagName fields' annotationSet'' @@ -451,7 +455,7 @@ spaces char ';' annotationSet'' <- annotationsWithDocs annotationSet' docs'- handleNameDuplication "tag" tags' $ \tagSet ->+ handleNameDuplication "tag" tags' $ \ tagSet -> return $ TypeDeclaration typename (UnionType tagSet) annotationSet'' typeDeclaration :: Parser TypeDeclaration@@ -479,21 +483,26 @@ 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+ unless' (x : xs) p = notFollowedBy (string x) >> unless' xs p parameters :: Parser [Parameter] parameters = fieldsOrParameters ("parameter", "parameters") Parameter parameterSet :: Parser (DeclarationSet Parameter)-parameterSet = option empty $ try $ do+parameterSet = option DeclarationSet.empty $ try $ do params <- parameters <?> "method parameters" handleNameDuplication "parameter" params return method :: Parser Method method = do annotationSet' <- annotationSet <?> "service method annotation"- returnType <- typeExpression <?> "method return type"- spaces1++ returnType <- optional $ try $ do+ rt <- typeExpression <?> "method return type"+ spaces1+ notFollowedBy $ char '('+ return rt+ methodName <- name <?> "method name" spaces char '('@@ -574,10 +583,9 @@ spaces char '(' spaces- idents <- sepBy1 importName- (spaces >> char ',' >> spaces)- <?> "names to import"- spaces+ idents <- (importName >>= \ i -> spaces >> return i)+ `sepEndBy1` (char ',' >> spaces)+ <?> "names to import" char ')' spaces char ';'@@ -604,7 +612,7 @@ annotationSet' <- annotationSet <?> "annotations" spaces decl <- choice [ notFollowedBy (string "service") >> typeDeclaration- , serviceDeclaration <?> "service declaration"+ , serviceDeclaration <?> "service declaration" ] -- In theory, though it preconsumes annotationSet' before parsing -- decl so that decl itself has no annotations, to prepare for an@@ -620,7 +628,7 @@ spaces return typeDecl handleNameDuplication "type" (types ++ [i | l <- importLists, i <- l]) $- \typeSet -> return $ Module typeSet docs'+ \ typeSet -> return $ Module typeSet docs' file :: Parser Module file = do@@ -628,15 +636,17 @@ eof return mod' -parse :: FilePath -- | Source path (although it's only used for error message)- -> T.Text -- | Input source code+parse :: FilePath -- ^ Source path (although it's only used for error message)+ -> T.Text -- ^ Input source code -> Either ParseError Module parse = runParser file -parseFile :: FilePath -- | Source path+parseFile :: FilePath -- ^ Source path -> IO (Either ParseError Module) parseFile path = do- code <- readFile path+ code <- SIO.withFile path SIO.ReadMode $ \ h -> do+ SIO.hSetEncoding h SIO.utf8_bom+ TIO.hGetContents h return $ runParser file path code {-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}
+ src/Nirum/Targets.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE QuasiQuotes, ScopedTypeVariables, TemplateHaskell #-}+module Nirum.Targets ( BuildError (CompileError, PackageError, TargetNameError)+ , BuildResult+ , Target ( CompileError+ , CompileResult+ , compilePackage+ , parseTarget+ , showCompileError+ , targetName+ , toByteString+ )+ , TargetName+ , buildPackage+ , targetNames+ ) where++import Data.Either (partitionEithers)+import Data.Maybe (fromMaybe)+import Data.Proxy (Proxy)++import Data.ByteString (ByteString)+import Data.Set (Set)+import qualified Data.Map.Strict as M+import Data.Text (Text)++import Nirum.Package (PackageError, scanPackage)+import Nirum.Package.Metadata ( Metadata (Metadata, target)+ , Package (Package, metadata)+ , Target ( CompileError+ , CompileResult+ , compilePackage+ , parseTarget+ , showCompileError+ , targetName+ , toByteString+ )+ , TargetName+ )+import Nirum.Targets.List (targetProxyMapQ)++-- Imported targets below are automatically added to the list of targets.+-- These target names become options of `[targets.*]` sections of package.toml+-- and `-t`/`--target` of CLI as well.+--+-- CHECK: When a new target `Nirum.Targets.X` is added, write docs for it in+-- docs/target/x.md file too.+import Nirum.Targets.Docs ()+import Nirum.Targets.Python ()++data BuildError = TargetNameError TargetName+ | CompileError (M.Map FilePath Text)+ | PackageError PackageError+ deriving (Eq, Show)+type BuildResult = M.Map FilePath ByteString++packageBuilders :: M.Map TargetName+ (FilePath -> IO (Either BuildError BuildResult))+packageBuilders = M.fromList $(targetProxyMapQ [e|buildPackage'|])++targetNames :: Set TargetName+targetNames = M.keysSet packageBuilders++buildPackage :: TargetName -> FilePath -> IO (Either BuildError BuildResult)+buildPackage targetName' =+ fromMaybe (\ _ -> return $ Left $ TargetNameError targetName') $+ M.lookup targetName' packageBuilders++buildPackage' :: forall t. Target t+ => Proxy t+ -> FilePath+ -> IO (Either BuildError BuildResult)+buildPackage' _ packagePath = do+ scanResult <- scanPackage packagePath+ return $ case scanResult of+ Left e -> Left $ PackageError e+ Right (pkg :: Package t) ->+ let Package { metadata = Metadata { target = target' } } = pkg+ results = M.toList $ compilePackage pkg+ eithers = [ case result of+ Left e -> Left (f, showCompileError target' e)+ Right r -> Right (f, toByteString target' r)+ | (f, result) <- results+ ] :: [Either (FilePath, Text) (FilePath, ByteString)]+ in+ case partitionEithers eithers of+ (errors@(_ : _), _) ->+ Left $ CompileError $ M.fromList errors+ ([], outs) -> Right $ M.fromList outs
+ src/Nirum/Targets/Docs.hs view
@@ -0,0 +1,378 @@+{-# LANGUAGE QuasiQuotes, TypeFamilies #-}+module Nirum.Targets.Docs ( Docs+ , blockToHtml+ , makeFilePath+ , makeUri+ , moduleTitle+ ) where++import Data.Maybe (mapMaybe)+import GHC.Exts (IsList (fromList, toList))++import qualified Data.ByteString as BS+import Data.ByteString.Lazy (toStrict)+import qualified Text.Email.Parser as E+import Data.Map.Strict (Map, union)+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import Data.Text.Encoding (decodeUtf8, encodeUtf8)+import System.FilePath ((</>))+import Text.Blaze (ToMarkup (preEscapedToMarkup))+import Text.Blaze.Html.Renderer.Utf8 (renderHtml)+import Text.Cassius (cassius, renderCss)+import Text.Hamlet (Html, shamlet)++import Nirum.Constructs (Construct (toCode))+import Nirum.Constructs.Declaration (Documented (docsBlock))+import qualified Nirum.Constructs.Declaration as DE+import qualified Nirum.Constructs.DeclarationSet as DES+import qualified Nirum.Constructs.Docs as D+import Nirum.Constructs.Identifier ( Identifier+ , toNormalizedString+ , toNormalizedText+ )+import Nirum.Constructs.Module (Module (Module, docs))+import Nirum.Constructs.ModulePath (ModulePath)+import Nirum.Constructs.Name (Name (facialName))+import qualified Nirum.Constructs.Service as S+import qualified Nirum.Constructs.TypeDeclaration as TD+import qualified Nirum.Constructs.TypeExpression as TE+import Nirum.Docs ( Block (Heading)+ , filterReferences+ )+import Nirum.Docs.Html (render, renderInlines)+import Nirum.Package+import Nirum.Package.Metadata ( Author (Author, email, name, uri)+ , Metadata (authors)+ , Target ( CompileError+ , CompileResult+ , compilePackage+ , parseTarget+ , showCompileError+ , targetName+ , toByteString+ )+ )+import qualified Nirum.Package.ModuleSet as MS+import Nirum.TypeInstance.BoundModule+import Nirum.Version (versionText)++data Docs = Docs deriving (Eq, Ord, Show)++type Error = T.Text++makeFilePath :: ModulePath -> FilePath+makeFilePath modulePath' = foldl (</>) "" $+ map toNormalizedString (toList modulePath') ++ ["index.html"]++-- FIXME: remove trailing index.html on production+makeUri :: ModulePath -> T.Text+makeUri modulePath' =+ T.intercalate "/" $+ map toNormalizedText (toList modulePath') ++ ["index.html"]++layout :: ToMarkup m => Package Docs -> Int -> m -> Html -> Html+layout Package { metadata = md } dirDepth title body = [shamlet|+$doctype 5+<html>+ <head>+ <meta charset="utf-8">+ <title>#{title}+ <meta name="generator" content="Nirum #{versionText}">+ $forall Author { name = name' } <- authors md+ <meta name="author" content="#{name'}">+ <link rel="stylesheet" href="#{T.replicate dirDepth "../"}style.css">+ <body>#{body}+|]++typeExpression :: BoundModule Docs -> TE.TypeExpression -> Html+typeExpression _ expr = [shamlet|#{typeExpr expr}|]+ where+ typeExpr :: TE.TypeExpression -> Html+ typeExpr expr' = [shamlet|+$case expr'+ $of TE.TypeIdentifier ident+ #{toCode ident}+ $of TE.OptionModifier type'+ #{typeExpr type'}?+ $of TE.SetModifier elementType+ {#{typeExpr elementType}}+ $of TE.ListModifier elementType+ [#{typeExpr elementType}]+ $of TE.MapModifier keyType valueType+ {#{typeExpr keyType}: #{typeExpr valueType}}+|]++module' :: BoundModule Docs -> Html+module' docsModule = layout pkg depth path $ [shamlet|+ $maybe tit <- title+ <h1><code>#{path}</code>+ <p>#{tit}+ $nothing+ <h1><code>#{path}</code>+ $forall (ident, decl) <- types'+ <div class="#{showKind decl}" id="#{toNormalizedText ident}">+ #{typeDecl docsModule ident decl}+|]+ where+ docsModulePath :: ModulePath+ docsModulePath = modulePath docsModule+ pkg :: Package Docs+ pkg = boundPackage docsModule+ path :: T.Text+ path = toCode docsModulePath+ types' :: [(Identifier, TD.TypeDeclaration)]+ types' = [ (facialName $ DE.name decl, decl)+ | decl <- DES.toList $ boundTypes docsModule+ , case decl of+ TD.Import {} -> False+ _ -> True+ ]+ mod' :: Maybe Module+ mod' = resolveModule docsModulePath pkg+ title :: Maybe Html+ title = do+ m <- mod'+ moduleTitle m+ depth :: Int+ depth = length $ toList docsModulePath++blockToHtml :: Block -> Html+blockToHtml b = preEscapedToMarkup $ render b++typeDecl :: BoundModule Docs -> Identifier -> TD.TypeDeclaration -> Html+typeDecl mod' ident+ tc@TD.TypeDeclaration { TD.type' = TD.Alias cname } = [shamlet|+ <h2><code>type</code> #{toNormalizedText ident} = #+ <code>#{typeExpression mod' cname}</code>+ $maybe d <- docsBlock tc+ #{blockToHtml d}+|]+typeDecl mod' ident+ tc@TD.TypeDeclaration { TD.type' = TD.UnboxedType innerType } =+ [shamlet|+ <h2><code>unboxed</code> #{toNormalizedText ident}+ (<code>#{typeExpression mod' innerType}</code>)+ $maybe d <- docsBlock tc+ #{blockToHtml d}+ |]+typeDecl _ ident+ tc@TD.TypeDeclaration { TD.type' = TD.EnumType members } = [shamlet|+ <h2><code>enum</code> #{toNormalizedText ident}+ $maybe d <- docsBlock tc+ #{blockToHtml d}+ <dl class="members">+ $forall decl <- DES.toList members+ <dt class="member-name">#{nameText $ DE.name decl}+ <dd class="member-doc">+ $maybe d <- docsBlock decl+ #{blockToHtml d}+|]+typeDecl mod' ident+ tc@TD.TypeDeclaration { TD.type' = TD.RecordType fields } = [shamlet|+ <h2><code>record</code> #{toNormalizedText ident}+ $maybe d <- docsBlock tc+ #{blockToHtml d}+ <dl.fields>+ $forall fieldDecl@(TD.Field _ fieldType _) <- DES.toList fields+ <dt>+ <code>#{typeExpression mod' fieldType}+ #{nameText $ DE.name fieldDecl}+ $maybe d <- docsBlock fieldDecl+ <dd>#{blockToHtml d}+|]+typeDecl mod' ident+ tc@TD.TypeDeclaration { TD.type' = TD.UnionType tags } = [shamlet|+ <h2>union <code>#{toNormalizedText ident}</code>+ $maybe d <- docsBlock tc+ #{blockToHtml d}+ $forall tagDecl@(TD.Tag _ fields _) <- DES.toList tags+ <h3 class="tag"><code>#{nameText $ DE.name tagDecl}</code>+ $maybe d <- docsBlock tagDecl+ #{blockToHtml d}+ $forall fieldDecl@(TD.Field _ fieldType _) <- DES.toList fields+ <h4>+ <span.type>#{typeExpression mod' fieldType}+ <code>#{nameText $ DE.name fieldDecl}+ $maybe d <- docsBlock fieldDecl+ #{blockToHtml d}+|]+typeDecl _ ident+ TD.TypeDeclaration { TD.type' = TD.PrimitiveType {} } = [shamlet|+ <h2>primitive <code>#{toNormalizedText ident}</code>+|]+typeDecl mod' ident+ tc@TD.ServiceDeclaration { TD.service = S.Service methods } =+ [shamlet|+ <h2><code>service</code> #{toNormalizedText ident}+ $maybe d <- docsBlock tc+ #{blockToHtml d}+ $forall md@(S.Method _ ps ret err _) <- DES.toList methods+ <h3.method>#{nameText $ DE.name md} (+ $forall (i, pd@(S.Parameter _ pt _)) <- enumerateParams ps+ $if i > 0+ , #+ <code.type>#{typeExpression mod' pt}</code> #+ <var>#{nameText $ DE.name pd}</var>#+ )+ $maybe d <- docsBlock md+ #{blockToHtml d}+ <dl.parameters>+ $forall paramDecl@(S.Parameter _ paramType _) <- DES.toList ps+ $maybe d <- docsBlock paramDecl+ <dt>+ <code.type>#{typeExpression mod' paramType}+ <var>#{nameText $ DE.name paramDecl}</var>:+ <dd>#{blockToHtml d}+ <dl.result>+ $maybe retType <- ret+ <dt.return-label>returns:+ <dd.return-type><code>#{typeExpression mod' retType}</code>+ $maybe errType <- err+ <dt.raise-label>raises:+ <dd.raise-type><code>#{typeExpression mod' errType}</code>+|]+ where+ enumerate :: [a] -> [(Int, a)]+ enumerate = zip [0 ..]+ enumerateParams :: DES.DeclarationSet S.Parameter -> [(Int, S.Parameter)]+ enumerateParams = enumerate . DES.toList+typeDecl _ _ TD.Import {} =+ error ("It shouldn't happen; please report it to Nirum's bug tracker:\n" +++ "https://github.com/spoqa/nirum/issues")++nameText :: Name -> T.Text+nameText = toNormalizedText . facialName++showKind :: TD.TypeDeclaration -> T.Text+showKind TD.ServiceDeclaration {} = "service"+showKind TD.TypeDeclaration { TD.type' = type'' } = case type'' of+ TD.Alias {} -> "alias"+ TD.UnboxedType {} -> "unboxed"+ TD.EnumType {} -> "enum"+ TD.RecordType {} -> "record"+ TD.UnionType {} -> "union"+ TD.PrimitiveType {} -> "primitive"+showKind TD.Import {} = "import"++contents :: Package Docs -> Html+contents pkg@Package { metadata = md+ , modules = ms+ } = layout pkg 0 ("Package docs" :: T.Text) [shamlet|+<h1>Modules+$forall (modulePath', mod) <- MS.toAscList ms+ $maybe tit <- moduleTitle mod+ <h2>+ <a href="#{makeUri modulePath'}"><code>#{toCode modulePath'}</code>+ <p>#{tit}+ $nothing+ <h2>+ <a href="#{makeUri modulePath'}"><code>#{toCode modulePath'}</code>+<hr>+<dl>+ <dt.author>+ $if 1 < length (authors md)+ Authors+ $else+ Author+ $forall Author { name = n, uri = u, email = e } <- authors md+ $maybe uri' <- u+ <dd.author><a href="#{show uri'}">#{n}</a>+ $nothing+ $maybe email' <- e+ <dd.author><a href="mailto:#{emailText email'}">#{n}</a>+ $nothing+ <dd.author>#{n}+|]+ where+ emailText :: E.EmailAddress -> T.Text+ emailText = decodeUtf8 . E.toByteString++moduleTitle :: Module -> Maybe Html+moduleTitle Module { docs = docs' } = do+ d <- docs'+ t <- D.title d+ nodes <- case t of+ Heading _ inlines ->+ Just $ filterReferences inlines+ _ -> Nothing+ return $ preEscapedToMarkup $ renderInlines nodes++stylesheet :: TL.Text+stylesheet = renderCss ([cassius|+@import url(#{fontUrl})+body+ font-family: Source Sans Pro+ color: #{gray8}+code+ font-family: Source Code Pro+ font-weight: 300+ background-color: #{gray1}+pre+ padding: 16px 10px+ background-color: #{gray1}+ code+ background: none+div+ border-top: 1px solid #{gray3}+h1, h2, h3, h4, h5, h6+ code+ background-color: #{gray3}+h1, h2, h3, h4, h5, h6, dt+ font-weight: bold+ code+ font-weight: 400+a+ text-decoration: none+a:link+ color: #{indigo8}+a:visited+ color: #{graph8}+a:hover+ text-decoration: underline+dd+ p+ margin-top: 0+|] undefined)+ where+ fontUrl :: T.Text+ fontUrl = T.concat+ [ "https://fonts.googleapis.com/css"+ , "?family=Source+Code+Pro:300,400|Source+Sans+Pro"+ ]+ -- from Open Color https://yeun.github.io/open-color/+ gray1 :: T.Text+ gray1 = "#f1f3f5"+ gray3 :: T.Text+ gray3 = "#dee2e6"+ gray8 :: T.Text+ gray8 = "#343a40"+ graph8 :: T.Text+ graph8 = "#9c36b5"+ indigo8 :: T.Text+ indigo8 = "#3b5bdb"++compilePackage' :: Package Docs -> Map FilePath (Either Error BS.ByteString)+compilePackage' pkg =+ fromList [ ("style.css", Right $ encodeUtf8 $ TL.toStrict stylesheet)+ , ("index.html", Right $ toStrict $ renderHtml $ contents pkg)+ ] `union`+ (fromList [ ( makeFilePath $ modulePath m+ , Right $ toStrict $ renderHtml $ module' m+ )+ | m <- modules'+ ] :: Map FilePath (Either Error BS.ByteString))+ where+ paths' :: [ModulePath]+ paths' = MS.keys $ modules pkg+ modules' :: [BoundModule Docs]+ modules' = mapMaybe (`resolveBoundModule` pkg) paths'++instance Target Docs where+ type CompileResult Docs = BS.ByteString+ type CompileError Docs = Error+ targetName _ = "docs"+ parseTarget _ = return Docs+ compilePackage = compilePackage'+ showCompileError _ = id+ toByteString _ = id
+ src/Nirum/Targets/List.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE QuasiQuotes, TemplateHaskell #-}+module Nirum.Targets.List ( targetProxiesQ+ , targetProxyMapQ+ , targetTypesQ+ ) where++import Data.Proxy (Proxy (Proxy))+import Language.Haskell.TH ( Dec (InstanceD)+ , Exp+ , Info (ClassI)+ , Q+ , Type (AppT)+ )+import Language.Haskell.TH.Lib (listE)+import Language.Haskell.TH.Syntax (reify, sequenceQ)++import Nirum.Package.Metadata (Target)++targetTypesQ :: Q [Type]+targetTypesQ = do+ ClassI _ instances <- reify ''Target+ return [t | InstanceD _ _ (AppT _ t) _ <- instances]++targetProxiesQ :: Q [Exp]+targetProxiesQ = do+ targetTypes <- targetTypesQ+ sequenceQ [[e|(Proxy :: Proxy $(return t))|] | t <- targetTypes]++targetProxyMapQ :: Q Exp -> Q Exp+targetProxyMapQ funcQ = do+ targetProxies <- targetProxiesQ+ listE [ [e|(targetName $(return p), $funcQ $(return p))|]+ | p <- targetProxies+ ]
src/Nirum/Targets/Python.hs view
@@ -1,806 +1,1647 @@-{-# LANGUAGE ExtendedDefaultRules, OverloadedLists, QuasiQuotes,- TypeSynonymInstances, MultiParamTypeClasses #-}-module Nirum.Targets.Python ( Code- , CodeGen- , CodeGenContext ( localImports- , standardImports- , thirdPartyImports- )- , CompileError- , InstallRequires ( InstallRequires- , dependencies- , optionalDependencies- )- , Source( Source- , sourceModule- , sourcePackage- )- , addDependency- , addOptionalDependency- , compileModule- , compilePackage- , compilePrimitiveType- , compileTypeDeclaration- , compileTypeExpression- , emptyContext- , toAttributeName- , toClassName- , toImportPath- , toNamePair- , unionInstallRequires- , 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))--import qualified Data.Map.Strict as M-import qualified Data.Set as S-import qualified Data.Text as T-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- , toSnakeCaseText- , toString- )-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- , parameters- , returnType- )- , Parameter(Parameter)- , Service(Service)- )-import Nirum.Constructs.TypeDeclaration ( EnumMember(EnumMember)- , Field(Field)- , PrimitiveTypeIdentifier(..)- , Tag(Tag)- , Type( Alias- , EnumType- , PrimitiveType- , RecordType- , UnboxedType- , UnionType- )- , TypeDeclaration(..)- )-import Nirum.Constructs.TypeExpression ( TypeExpression( ListModifier- , MapModifier- , OptionModifier- , SetModifier- , TypeIdentifier- )- )-import Nirum.Package ( BoundModule- , Package(modules)- , TypeLookup(Imported, Local, Missing)- , lookupType- , resolveBoundModule- , types- )--data Source = Source { sourcePackage :: Package- , sourceModule :: BoundModule- } deriving (Eq, Ord, Show)--type Code = T.Text-type CompileError = T.Text--instance Failure CodeGenContext CompileError where- fromString = return . T.pack--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)--emptyContext :: CodeGenContext-emptyContext = CodeGenContext { standardImports = []- , thirdPartyImports = []- , localImports = []- }--type CodeGen = C.CodeGen CodeGenContext CompileError--runCodeGen :: CodeGen a -> CodeGenContext -> (Either CompileError a, CodeGenContext)-runCodeGen = C.runCodeGen--insertStandardImport :: T.Text -> CodeGen ()-insertStandardImport module' = modify insert'- where- insert' c@CodeGenContext { standardImports = si } =- c { standardImports = S.insert module' si }--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--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-keywords :: S.Set T.Text-keywords = [ "False", "None", "True"- , "and", "as", "assert", "break", "class", "continue"- , "def", "del" , "elif", "else", "except", "finally"- , "for", "from", "global", "if", "import", "in", "is"- , "lambda", "nonlocal", "not", "or", "pass", "raise"- , "return", "try", "while", "with", "yield"- ]--toClassName :: Identifier -> T.Text-toClassName identifier =- if className `S.member` keywords then className `T.snoc` '_' else className- where- className :: T.Text- className = toPascalCaseText identifier--toClassName' :: Name -> T.Text-toClassName' = toClassName . N.facialName--toAttributeName :: Identifier -> T.Text-toAttributeName identifier =- if attrName `S.member` keywords then attrName `T.snoc` '_' else attrName- where- attrName :: T.Text- attrName = toSnakeCaseText identifier--toAttributeName' :: Name -> T.Text-toAttributeName' = toAttributeName . N.facialName--toImportPath :: ModulePath -> T.Text-toImportPath = T.intercalate "." . map toAttributeName . toList--toNamePair :: Name -> T.Text-toNamePair (Name f b) = [qq|('{toAttributeName f}', '{toSnakeCaseText b}')|]--toIndentedCodes :: (a -> T.Text) -> [a] -> T.Text -> T.Text-toIndentedCodes f traversable concatenator =- T.intercalate concatenator $ map f traversable---compileUnionTag :: Source- -> Name- -> Name- -> DS.DeclarationSet Field- -> CodeGen Code-compileUnionTag source parentname typename' fields = do- typeExprCodes <- mapM (compileTypeExpression source)- [typeExpr | (Field _ typeExpr _) <- toList fields]- 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 = 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 =- toIndentedCodes (\n -> [qq|self.{n} = {n}|]) tagNames "\n "- nameMaps = toIndentedCodes- toNamePair- [name | Field name _ _ <- toList fields]- ",\n "- parentClass = toClassName' parentname- insertStandardImport "typing"- insertThirdPartyImports [ ("nirum.validate", ["validate_union_type"])- , ("nirum.constructs", ["name_dict_type"])- ]- return [qq|-class $className($parentClass):- # TODO: docstring-- __slots__ = (- $slots- )- __nirum_tag__ = $parentClass.Tag.{toAttributeName' typename'}- __nirum_tag_types__ = \{- $slotTypes- \}- __nirum_tag_names__ = name_dict_type([- $nameMaps- ])-- def __init__(self, $initialArgs) -> None:- $initialValues- validate_union_type(self)-- def __repr__(self) -> str:- return '\{0.__module__\}.\{0.__qualname__\}(\{1\})'.format(- type(self),- ', '.join('\{\}=\{\}'.format(attr, getattr(self, attr))- for attr in self.__slots__)- )-- def __eq__(self, other) -> bool:- return isinstance(other, $className) and all(- getattr(self, attr) == getattr(other, attr)- for attr in self.__slots__- )-- def __hash__(self) -> int:- return hash($hashTuple)- |]--compilePrimitiveType :: PrimitiveTypeIdentifier -> CodeGen Code-compilePrimitiveType primitiveTypeIdentifier =- case primitiveTypeIdentifier of- Bool -> return "bool"- Bigint -> return "int"- 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 -> 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-compileTypeExpression Source { sourceModule = boundModule } (TypeIdentifier i) =- case lookupType i boundModule of- Missing -> fail $ "undefined identifier: " ++ toString i- Imported _ (PrimitiveType p _) -> compilePrimitiveType p- 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- insertStandardImport "typing"- return [qq|typing.Mapping[$kExpr, $vExpr]|]-compileTypeExpression source modifier = do- expr <- compileTypeExpression source typeExpr- insertStandardImport "typing"- return [qq|typing.$className[$expr]|]- where- typeExpr :: TypeExpression- className :: T.Text- (typeExpr, className) = case modifier of- OptionModifier t' -> (t', "Optional")- SetModifier t' -> (t', "AbstractSet")- ListModifier t' -> (t', "Sequence")- TypeIdentifier _ -> undefined -- never happen!- MapModifier _ _ -> undefined -- never happen!--compileTypeDeclaration :: Source -> TypeDeclaration -> CodeGen Code-compileTypeDeclaration _ TypeDeclaration { type' = PrimitiveType { } } =- return "" -- never used-compileTypeDeclaration src TypeDeclaration { typename = typename'- , type' = Alias ctype } = do- ctypeExpr <- compileTypeExpression src ctype- return [qq|-# TODO: docstring-{toClassName' typename'} = $ctypeExpr- |]-compileTypeDeclaration src TypeDeclaration { typename = typename'- , type' = UnboxedType itype } = do- let className = toClassName' typename'- itypeExpr <- compileTypeExpression src itype- 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_inner_type__ = $itypeExpr-- def __init__(self, value: $itypeExpr) -> None:- validate_unboxed_type(value, $itypeExpr)- self.value = value # type: $itypeExpr-- def __eq__(self, other) -> bool:- return (isinstance(other, $className) and- self.value == other.value)-- def __hash__(self) -> int:- return hash(self.value)-- def __nirum_serialize__(self) -> typing.Any:- return serialize_unboxed_type(self)-- @classmethod- def __nirum_deserialize__(cls: type, value: typing.Any) -> '{className}':- 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 = typename'- , type' = EnumType members } = do- let className = toClassName' typename'- memberNames = T.intercalate- "\n "- [ [qq|{toAttributeName' memberName} = '{toSnakeCaseText bn}'|]- | EnumMember memberName@(Name _ bn) _ <- toList members- ]- insertStandardImport "enum"- return [qq|-class $className(enum.Enum):- # TODO: docstring-- $memberNames-- def __nirum_serialize__(self) -> str:- return self.value-- @classmethod- def __nirum_deserialize__(cls: type, value: str) -> '{className}':- return cls(value.replace('-', '_')) # FIXME: validate input- |]-compileTypeDeclaration src TypeDeclaration { typename = typename'- , type' = RecordType fields } = do- typeExprCodes <- mapM (compileTypeExpression src)- [typeExpr | (Field _ typeExpr _) <- toList fields]- let className = toClassName' typename'- fieldNames = map toAttributeName' [ name- | (Field name _ _) <- toList fields- ]- nameNTypes = zip fieldNames typeExprCodes- slotTypes = toIndentedCodes- (\(n, t) -> [qq|'{n}': {t}|]) nameNTypes ",\n "- slots = toIndentedCodes (\n -> [qq|'{n}'|]) fieldNames ",\n "- initialArgs = toIndentedCodes- (\(n, t) -> [qq|{n}: {t}|]) nameNTypes ", "- initialValues = toIndentedCodes- (\n -> [qq|self.{n} = {n}|]) fieldNames "\n "- nameMaps = toIndentedCodes- toNamePair- [name | Field name _ _ <- toList fields]- ",\n "- 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_field_types__ = \{- $slotTypes- \}- __nirum_field_names__ = name_dict_type([- $nameMaps- ])-- def __init__(self, $initialArgs) -> None:- $initialValues- validate_record_type(self)-- def __repr__(self) -> str:- return '\{0.__module__\}.\{0.__qualname__\}(\{1\})'.format(- type(self),- ', '.join('\{\}=\{\}'.format(attr, getattr(self, attr))- for attr in self.__slots__)- )-- def __eq__(self, other) -> bool:- return isinstance(other, $className) and all(- getattr(self, attr) == getattr(other, attr)- for attr in self.__slots__- )-- def __nirum_serialize__(self) -> typing.Mapping[str, typing.Any]:- return serialize_record_type(self)-- @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 = 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 "- 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_field_names__ = name_dict_type([- $nameMaps- ])-- class Tag(enum.Enum):- $enumMembers-- def __init__(self, *args, **kwargs):- raise NotImplementedError(- "\{0.__module__\}.\{0.__qualname__\} cannot be instantiated "- "since it is an abstract class. Instantiate a concrete subtype "- "of it instead.".format(- type(self)- )- )-- def __nirum_serialize__(self) -> typing.Mapping[str, typing.Any]:- return serialize_union_type(self)-- @classmethod- def __nirum_deserialize__(cls: type, value) -> '{className}':- return deserialize_union_type(cls, value)---$fieldCodes'- |]- where- tagNameNFields :: [(Name, DS.DeclarationSet Field)]- tagNameNFields = [ (tagName, fields)- | (Tag tagName fields _) <- toList tags- ]- enumMembers' :: [(T.Text, T.Text)]- enumMembers' = [ ( toAttributeName' tagName- , toSnakeCaseText $ N.behindName tagName- )- | (Tag tagName _ _) <- toList tags- ]- nameMaps :: T.Text- nameMaps = toIndentedCodes- toNamePair- [name | (name, _) <- tagNameNFields]- ",\n "-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- 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__ = \{- {methodMetadata'}- \}- __nirum_method_names__ = name_dict_type([- $methodNameMap- ])-- {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- className = toClassName' name- commaNl :: [T.Text] -> T.Text- commaNl = T.intercalate ",\n"- compileMethod :: Method -> CodeGen Code- compileMethod (Method mName params rtype _etype _anno) = do- let mName' = toAttributeName' mName- params' <- mapM compileParameter $ toList params- rtypeExpr <- compileTypeExpression src rtype- return [qq|- def {mName'}(self, {commaNl params'}) -> $rtypeExpr:- raise NotImplementedError('$className has to implement {mName'}()')-|]- compileParameter :: Parameter -> CodeGen Code- compileParameter (Parameter pName pType _) = do- pTypeExpr <- compileTypeExpression src pType- return [qq|{toAttributeName' pName}: $pTypeExpr|]- compileMethodMetadata :: Method -> CodeGen Code- 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- 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- pTypeExpr <- compileTypeExpression src pType- return [qq|'{pName'}': $pTypeExpr|]- methodNameMap :: T.Text- methodNameMap = toIndentedCodes- toNamePair- [mName | Method { methodName = mName } <- toList methods]- ",\n "- paramNameMap :: [Parameter] -> T.Text- paramNameMap params = toIndentedCodes- toNamePair [pName | Parameter pName _ _ <- params] ",\n "- 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-compileModuleBody src@Source { sourceModule = boundModule } = do- let types' = types boundModule- typeCodes <- mapM (compileTypeDeclaration src) $ toList types'- let moduleCode = T.intercalate "\n\n" typeCodes- return [qq|-# TODO: docs-$moduleCode- |]--data InstallRequires =- InstallRequires { dependencies :: S.Set T.Text- , optionalDependencies :: M.Map (Int, Int) (S.Set T.Text)- } deriving (Eq, Ord, Show)--addDependency :: InstallRequires -> T.Text -> InstallRequires-addDependency requires package =- requires { dependencies = S.insert package $ dependencies requires }--addOptionalDependency :: InstallRequires- -> (Int, Int) -- | Python version already stasified- -> T.Text -- | PyPI package name- -> InstallRequires-addOptionalDependency requires pyVer package =- requires { optionalDependencies = newOptDeps }- where- oldOptDeps :: M.Map (Int, Int) (S.Set T.Text)- oldOptDeps = optionalDependencies requires- newOptDeps :: M.Map (Int, Int) (S.Set T.Text)- newOptDeps = M.alter (Just . S.insert package . fromMaybe S.empty)- pyVer oldOptDeps--unionInstallRequires :: InstallRequires -> InstallRequires -> InstallRequires-unionInstallRequires a b =- a { dependencies = S.union (dependencies a) (dependencies b)- , optionalDependencies = M.unionWith S.union (optionalDependencies a)- (optionalDependencies b)- }--compileModule :: Source -> Either CompileError (InstallRequires, Code)-compileModule source =- case runCodeGen code' emptyContext of- (Left errMsg, _ ) -> Left errMsg- (Right code , context) -> codeWithDeps context $ [qq|-{imports $ standardImports context}--{fromImports $ localImports context}--{fromImports $ thirdPartyImports context}--{code}-|]- where- code' :: CodeGen T.Text- code' = compileModuleBody source- imports :: S.Set T.Text -> T.Text- imports importSet =- if S.null importSet- then ""- else "import " `T.append` T.intercalate "," (S.elems importSet)- fromImports :: M.Map T.Text (S.Set T.Text) -> T.Text- fromImports importMap =- T.intercalate "\n"- [ [qq|from $from import {T.intercalate ", " $ S.elems vars}|]- | (from, vars) <- M.assocs importMap- ]- has :: S.Set T.Text -> T.Text -> Bool- has set module' = module' `S.member` set ||- any (T.isPrefixOf $ module' `T.snoc` '.') set- 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- 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|-import sys--from setuptools import setup, __version__ as setuptools_version--install_requires = [$pInstallRequires]-polyfill_requires = \{$pPolyfillRequires}--if polyfill_requires:- # '<' operator for environment markers are supported since setuptools 17.1.- # Read PEP 496 for details of environment markers.- setup_requires = ['setuptools >= 17.1']- if tuple(map(int, setuptools_version.split('.'))) < (17, 1):- extras_require = \{}- if 'bdist_wheel' not in sys.argv:- for (major, minor), deps in polyfill_requires.items():- if sys.version_info < (major, minor):- install_requires.extend(deps)- envmarker = ":python_version=='\{0}.\{1}'"- python_versions = [(2, 6), (2, 7),- (3, 3), (3, 4), (3, 5), (3, 6)] # FIXME- for pyver in python_versions:- extras_require[envmarker.format(*pyver)] = list(\{- d- for v, vdeps in polyfill_requires.items()- if pyver < v- for d in vdeps- })- else:- extras_require = \{- ":python_version<'\{0}.\{1}'".format(*pyver): deps- for pyver, deps in polyfill_requires.items()- }-else:- setup_requires = []- extras_require = \{}--# TODO: description, long_description, url, author, author_email, license,-# keywords, classifiers-setup(- name='{pName}',- version='{pVersion}',- packages=[$pPackages],- provides=[$pPackages],- requires=[$pInstallRequires],- setup_requires=setup_requires,- install_requires=install_requires,- extras_require=extras_require,-)-|]- where- pName :: Code- pName = "TestPackage" -- FIXME- pVersion :: Code- pVersion = "0.1.0" -- FIXME- strings :: [Code] -> Code- strings values = T.intercalate ", " . L.sort $ [[qq|'{v}'|] | v <- values]- pPackages :: Code- pPackages = strings $ map toImportPath $ M.keys $ modules package- pInstallRequires :: Code- pInstallRequires = strings $ S.toList deps- pPolyfillRequires :: Code- pPolyfillRequires = T.intercalate ", "- [ [qq|($major, $minor): [{strings $ S.toList deps'}]|]- | ((major, minor), deps') <- M.toList optDeps- ]--compilePackage :: Package- -> M.Map FilePath (Either CompileError Code)-compilePackage package =- M.fromList $- initFiles ++- [ ( f- , case cd of- Left e -> Left e- Right (_, cd') -> Right cd'- )- | (f, cd) <- modules'- ] ++- [("setup.py", Right $ compilePackageMetadata package installRequires)]- where- toFilename :: ModulePath -> FilePath- toFilename mp =- joinPath $ [ T.unpack (toAttributeName i)- | i <- toList mp- ] ++ ["__init__.py"]- initFiles :: [(FilePath, Either CompileError Code)]- initFiles = [ (toFilename mp', Right "")- | mp <- M.keys (modules package)- , mp' <- S.elems (ancestors mp)- ]- modules' :: [(FilePath, Either CompileError (InstallRequires, Code))]- modules' =- [ ( toFilename modulePath'- , compileModule $ Source package boundModule- )- | (modulePath', _) <- M.assocs (modules package)- , Just boundModule <- [resolveBoundModule modulePath' package]- ]- installRequires :: InstallRequires- installRequires = foldl unionInstallRequires- (InstallRequires [] [])- [deps | (_, Right (deps, _)) <- modules']+{-# LANGUAGE DeriveDataTypeable, ExtendedDefaultRules, OverloadedLists,+ QuasiQuotes, TypeFamilies, TypeSynonymInstances,+ MultiParamTypeClasses #-}+module Nirum.Targets.Python ( Code+ , CodeGen+ , CodeGenContext ( localImports+ , standardImports+ , thirdPartyImports+ )+ , CompileError+ , InstallRequires ( InstallRequires+ , dependencies+ , optionalDependencies+ )+ , Source ( Source+ , sourceModule+ , sourcePackage+ )+ , Python (Python)+ , PythonVersion ( Python2+ , Python3+ )+ , RenameMap+ , addDependency+ , addOptionalDependency+ , compileModule+ , compilePrimitiveType+ , compileTypeDeclaration+ , compileTypeExpression+ , empty+ , insertLocalImport+ , insertStandardImport+ , insertThirdPartyImports+ , insertThirdPartyImportsA+ , localImportsMap+ , minimumRuntime+ , parseModulePath+ , renameModulePath+ , runCodeGen+ , stringLiteral+ , toAttributeName+ , toClassName+ , toImportPath+ , toImportPaths+ , toNamePair+ , unionInstallRequires+ ) where++import Control.Monad (forM)+import qualified Control.Monad.State as ST+import qualified Data.List as L+import Data.Maybe (catMaybes, fromMaybe)+import Data.Typeable (Typeable)+import GHC.Exts (IsList (toList))+import Text.Printf (printf)++import qualified Data.HashMap.Strict as HM+import qualified Data.Map.Strict as M+import qualified Data.SemVer as SV+import qualified Data.Set as S+import qualified Data.Text as T+import Data.Text.Lazy (toStrict)+import Data.Text.Encoding (decodeUtf8, encodeUtf8)+import Data.Function (on)+import System.FilePath (joinPath)+import Text.Blaze.Renderer.Text+import qualified Text.Email.Validate as E+import Text.Heterocephalus (compileText)+import Text.InterpolatedString.Perl6 (q, qq)++import qualified Nirum.CodeGen as C+import Nirum.CodeGen (Failure)+import qualified Nirum.Constructs.Annotation as A+import qualified Nirum.Constructs.DeclarationSet as DS+import qualified Nirum.Constructs.Identifier as I+import Nirum.Constructs.Declaration (Documented (docsBlock))+import Nirum.Constructs.ModulePath ( ModulePath+ , fromIdentifiers+ , hierarchy+ , hierarchies+ , replacePrefix+ )+import Nirum.Constructs.Name (Name (Name))+import qualified Nirum.Constructs.Name as N+import Nirum.Constructs.Service ( Method ( Method+ , errorType+ , methodAnnotations+ , methodName+ , parameters+ , returnType+ )+ , Parameter (Parameter)+ , Service (Service)+ )+import Nirum.Constructs.TypeDeclaration ( EnumMember (EnumMember)+ , Field (Field, fieldName)+ , PrimitiveTypeIdentifier (..)+ , Tag (Tag)+ , Type ( Alias+ , EnumType+ , PrimitiveType+ , RecordType+ , UnboxedType+ , UnionType+ , primitiveTypeIdentifier+ )+ , TypeDeclaration (..)+ )+import Nirum.Constructs.TypeExpression ( TypeExpression ( ListModifier+ , MapModifier+ , OptionModifier+ , SetModifier+ , TypeIdentifier+ )+ )+import Nirum.Docs.ReStructuredText (ReStructuredText, render)+import Nirum.Package hiding (target)+import Nirum.Package.Metadata ( Author (Author, name, email)+ , Metadata ( Metadata+ , authors+ , target+ , version+ , description+ , license+ )+ , MetadataError ( FieldError+ , FieldTypeError+ , FieldValueError+ )+ , Node (VString)+ , Target ( CompileError+ , CompileResult+ , compilePackage+ , parseTarget+ , showCompileError+ , targetName+ , toByteString+ )+ , fieldType+ , stringField+ , tableField+ , versionField+ )+import qualified Nirum.Package.ModuleSet as MS+import qualified Nirum.Package.Metadata as MD+import Nirum.TypeInstance.BoundModule++minimumRuntime :: SV.Version+minimumRuntime = SV.version 0 6 0 [] []++data Python = Python { packageName :: T.Text+ , minimumRuntimeVersion :: SV.Version+ , renames :: RenameMap+ } deriving (Eq, Ord, Show, Typeable)++type RenameMap = M.Map ModulePath ModulePath+type Package' = Package Python+type CompileError' = T.Text++data PythonVersion = Python2+ | Python3+ deriving (Eq, Ord, Show)++data Source = Source { sourcePackage :: Package'+ , sourceModule :: BoundModule Python+ } deriving (Eq, Ord, Show)++type Code = T.Text++instance Failure CodeGenContext CompileError' where+ fromString = return . T.pack++data CodeGenContext+ = CodeGenContext { standardImports :: S.Set T.Text+ , thirdPartyImports :: M.Map T.Text (M.Map T.Text T.Text)+ , localImports :: M.Map T.Text (S.Set T.Text)+ , pythonVersion :: PythonVersion+ }+ deriving (Eq, Ord, Show)++localImportsMap :: CodeGenContext -> M.Map T.Text (M.Map T.Text T.Text)+localImportsMap CodeGenContext { localImports = imports } =+ M.map (M.fromSet id) imports++sourceDirectory :: PythonVersion -> T.Text+sourceDirectory Python2 = "src-py2"+sourceDirectory Python3 = "src"++empty :: PythonVersion -> CodeGenContext+empty pythonVersion' = CodeGenContext { standardImports = []+ , thirdPartyImports = []+ , localImports = []+ , pythonVersion = pythonVersion'+ }++type CodeGen = C.CodeGen CodeGenContext CompileError'++runCodeGen :: CodeGen a+ -> CodeGenContext+ -> (Either CompileError' a, CodeGenContext)+runCodeGen = C.runCodeGen++insertStandardImport :: T.Text -> CodeGen ()+insertStandardImport module' = ST.modify insert'+ where+ insert' c@CodeGenContext { standardImports = si } =+ c { standardImports = S.insert module' si }++insertThirdPartyImports :: [(T.Text, S.Set T.Text)] -> CodeGen ()+insertThirdPartyImports imports =+ insertThirdPartyImportsA [ (from, M.fromSet id objects)+ | (from, objects) <- imports+ ]++insertThirdPartyImportsA :: [(T.Text, M.Map T.Text T.Text)] -> CodeGen ()+insertThirdPartyImportsA imports =+ ST.modify insert'+ where+ insert' c@CodeGenContext { thirdPartyImports = ti } =+ c { thirdPartyImports = L.foldl (M.unionWith M.union) ti importList }+ importList :: [M.Map T.Text (M.Map T.Text T.Text)]+ importList = [ M.singleton from objects+ | (from, objects) <- imports+ ]++insertLocalImport :: T.Text -> T.Text -> CodeGen ()+insertLocalImport module' object = ST.modify insert'+ where+ insert' c@CodeGenContext { localImports = li } =+ c { localImports = M.insertWith S.union module' [object] li }++importTypingForPython3 :: CodeGen ()+importTypingForPython3 = do+ pyVer <- getPythonVersion+ case pyVer of+ Python2 -> return ()+ Python3 -> insertStandardImport "typing"++getPythonVersion :: CodeGen PythonVersion+getPythonVersion = fmap pythonVersion ST.get++renameModulePath :: RenameMap -> ModulePath -> ModulePath+renameModulePath renameMap path' =+ rename (M.toDescList renameMap)+ -- longest paths should be processed first+ where+ rename :: [(ModulePath, ModulePath)] -> ModulePath+ rename ((from, to) : xs) = let r = replacePrefix from to path'+ in if r == path'+ then rename xs+ else r+ rename [] = path'++renameMP :: Python -> ModulePath -> ModulePath+renameMP Python { renames = table } = renameModulePath table++thd3 :: (a, b, c) -> c+thd3 (_, _, v) = v++mangleVar :: Code -> T.Text -> Code+mangleVar expr arbitrarySideName = T.concat+ [ "__nirum_"+ , (`T.map` expr) $ \ c -> if 'A' <= c && c <= 'Z' ||+ 'a' <= c && c <= 'z' || c == '_'+ then c else '_'+ , "__"+ , arbitrarySideName+ , "__"+ ]++-- | The set of Python reserved keywords.+-- See also: https://docs.python.org/3/reference/lexical_analysis.html#keywords+keywords :: S.Set T.Text+keywords = [ "False", "None", "True"+ , "and", "as", "assert", "break", "class", "continue"+ , "def", "del" , "elif", "else", "except", "finally"+ , "for", "from", "global", "if", "import", "in", "is"+ , "lambda", "nonlocal", "not", "or", "pass", "raise"+ , "return", "try", "while", "with", "yield"+ ]++toClassName :: I.Identifier -> T.Text+toClassName identifier =+ if className `S.member` keywords then className `T.snoc` '_' else className+ where+ className :: T.Text+ className = I.toPascalCaseText identifier++toClassName' :: Name -> T.Text+toClassName' = toClassName . N.facialName++toAttributeName :: I.Identifier -> T.Text+toAttributeName identifier =+ if attrName `S.member` keywords then attrName `T.snoc` '_' else attrName+ where+ attrName :: T.Text+ attrName = I.toSnakeCaseText identifier++toAttributeName' :: Name -> T.Text+toAttributeName' = toAttributeName . N.facialName++toEnumMemberName :: Name -> T.Text+toEnumMemberName name'+ | attributeName `elem` memberKeywords = attributeName `T.snoc` '_'+ | otherwise = attributeName+ where+ memberKeywords :: [T.Text]+ memberKeywords = ["mro"]+ attributeName :: T.Text+ attributeName = toAttributeName' name'++toImportPath' :: ModulePath -> T.Text+toImportPath' = T.intercalate "." . map toAttributeName . toList++toImportPath :: Python -> ModulePath -> T.Text+toImportPath target' = toImportPath' . renameMP target'++toImportPaths :: Python -> S.Set ModulePath -> [T.Text]+toImportPaths target' paths =+ S.toAscList $ S.map toImportPath' $ hierarchies renamedPaths+ where+ renamedPaths :: S.Set ModulePath+ renamedPaths = S.map (renameMP target') paths++toNamePair :: Name -> T.Text+toNamePair (Name f b) = [qq|('{toAttributeName f}', '{I.toSnakeCaseText b}')|]++stringLiteral :: T.Text -> T.Text+stringLiteral string =+ open $ T.concatMap esc string `T.snoc` '"'+ where+ open :: T.Text -> T.Text+ open = if T.any (> '\xff') string then T.append [qq|u"|] else T.cons '"'+ esc :: Char -> T.Text+ esc '"' = "\\\""+ esc '\\' = "\\\\"+ esc '\t' = "\\t"+ esc '\n' = "\\n"+ esc '\r' = "\\r"+ esc c+ | c >= '\x10000' = T.pack $ printf "\\U%08x" c+ | c >= '\xff' = T.pack $ printf "\\u%04x" c+ | c < ' ' || c >= '\x7f' = T.pack $ printf "\\x%02x" c+ | otherwise = T.singleton c++toIndentedCodes :: (a -> T.Text) -> [a] -> T.Text -> T.Text+toIndentedCodes f traversable concatenator =+ T.intercalate concatenator $ map f traversable++compileParameters :: (ParameterName -> ParameterType -> Code)+ -> [(T.Text, Code, Bool)]+ -> Code+compileParameters gen nameTypeTriples =+ toIndentedCodes+ (\ (n, t, o) -> gen n t `T.append` if o then "=None" else "")+ nameTypeTriples ", "++compileFieldInitializers :: DS.DeclarationSet Field -> Int -> CodeGen Code+compileFieldInitializers fields depth = do+ initializers <- forM (toList fields) compileFieldInitializer+ return $ T.intercalate indentSpaces initializers+ where+ indentSpaces :: T.Text+ indentSpaces = "\n" `T.append` T.replicate depth " "+ compileFieldInitializer :: Field -> CodeGen Code+ compileFieldInitializer (Field fieldName' fieldType' _) =+ case fieldType' of+ SetModifier _ ->+ return [qq|self.$attributeName = frozenset($attributeName)|]+ ListModifier _ -> do+ insertThirdPartyImportsA [ ( "nirum.datastructures"+ , [("list_type", "List")]+ )+ ]+ return [qq|self.$attributeName = list_type($attributeName)|]+ _ -> return [qq|self.$attributeName = $attributeName|]+ where+ attributeName :: Code+ attributeName = toAttributeName' fieldName'++compileDocs :: Documented a => a -> Maybe ReStructuredText+compileDocs = fmap render . docsBlock++quoteDocstring :: ReStructuredText -> Code+quoteDocstring rst = T.concat ["r'''", rst, "\n'''\n"]++compileDocstring' :: Documented a => Code -> a -> [ReStructuredText] -> Code+compileDocstring' indentSpace d extra =+ case (compileDocs d, extra) of+ (Nothing, []) -> "\n"+ (result, extra') -> indent indentSpace $ quoteDocstring $+ T.append (fromMaybe "" result) $+ T.concat ['\n' `T.cons` e `T.snoc` '\n' | e <- extra']++compileDocstring :: Documented a => Code -> a -> Code+compileDocstring indentSpace d = compileDocstring' indentSpace d []++compileDocstringWithFields :: Documented a+ => Code -> a -> DS.DeclarationSet Field -> Code+compileDocstringWithFields indentSpace decl fields =+ compileDocstring' indentSpace decl extra+ where+ extra :: [ReStructuredText]+ extra =+ [ case compileDocs f of+ Nothing -> T.concat [ ".. attribute:: "+ , toAttributeName' n+ , "\n"+ ]+ Just docs' -> T.concat [ ".. attribute:: "+ , toAttributeName' n+ , "\n\n"+ , indent " " docs'+ ]+ | f@(Field n _ _) <- toList fields+ ]++compileDocsComment :: Documented a => Code -> a -> Code+compileDocsComment indentSpace d =+ case compileDocs d of+ Nothing -> "\n"+ Just rst -> indent (indentSpace `T.append` "#: ") rst++indent :: Code -> Code -> Code+indent space =+ T.intercalate "\n" . map indentLn . T.lines+ where+ indentLn :: Code -> Code+ indentLn line+ | T.null line = T.empty+ | otherwise = space `T.append` line++typeReprCompiler :: CodeGen (Code -> Code)+typeReprCompiler = do+ ver <- getPythonVersion+ case ver of+ Python2 -> return $ \ t -> [qq|($t.__module__ + '.' + $t.__name__)|]+ Python3 -> do+ insertStandardImport "typing"+ return $ \ t -> [qq|typing._type_repr($t)|]++type ParameterName = Code+type ParameterType = Code+type ReturnType = Code++parameterCompiler :: CodeGen (ParameterName -> ParameterType -> Code)+parameterCompiler = do+ ver <- getPythonVersion+ return $ \ n t -> case ver of+ Python2 -> n+ Python3 -> [qq|$n: '{t}'|]++returnCompiler :: CodeGen (ReturnType -> Code)+returnCompiler = do+ ver <- getPythonVersion+ return $ \ r ->+ case (ver, r) of+ (Python2, _) -> ""+ (Python3, "None") -> [qq| -> None|]+ (Python3, _) -> [qq| -> '{r}'|]+++compileUnionTag :: Source -> Name -> Tag -> CodeGen Code+compileUnionTag source parentname d@(Tag typename' fields _) = do+ typeExprCodes <- mapM (compileTypeExpression source)+ [Just typeExpr | (Field _ typeExpr _) <- toList fields]+ let nameTypeTriples = L.sortBy (compare `on` thd3)+ (zip3 tagNames typeExprCodes optionFlags)+ slotTypes = toIndentedCodes+ (\ (n, t, _) -> [qq|('{n}', {t})|]) nameTypeTriples ",\n "+ insertThirdPartyImportsA+ [ ("nirum.validate", [("validate_union_type", "validate_union_type")])+ , ("nirum.constructs", [("name_dict_type", "NameDict")])+ ]+ arg <- parameterCompiler+ ret <- returnCompiler+ pyVer <- getPythonVersion+ initializers <- compileFieldInitializers fields $ case pyVer of+ Python3 -> 2+ Python2 -> 3+ let initParams = compileParameters arg nameTypeTriples+ inits = case pyVer of+ Python2 -> [qq|+ def __init__(self, **kwargs):+ def __init__($initParams):+ $initializers+ pass+ __init__(**kwargs)+ validate_union_type(self)+ |]+ Python3 -> [qq|+ def __init__(self{ if null nameTypeTriples+ then T.empty+ else ", *, " `T.append` initParams }) -> None:+ $initializers+ validate_union_type(self)+ |]+ return [qq|+class $className($parentClass):+{compileDocstringWithFields " " d fields}+ __slots__ = (+ $slots+ )+ __nirum_type__ = 'union'+ __nirum_tag__ = $parentClass.Tag.{toEnumMemberName typename'}+ __nirum_tag_names__ = name_dict_type([+ $nameMaps+ ])++ @staticmethod+ def __nirum_tag_types__():+ return [$slotTypes]++ { inits :: T.Text }++ def __nirum_serialize__(self):+ return \{+ '_type': '{behindParentTypename}',+ '_tag': '{behindTagName}',+ $fieldSerializers+ \}++ def __repr__(self){ ret "str" }:+ return (+ $parentClass.__module__ + '.$parentClass.$className(' ++ ', '.join('\{0\}=\{1!r\}'.format(attr, getattr(self, attr))+ for attr in self.__slots__) ++ ')'+ )++ def __eq__(self, other){ ret "bool" }:+ return isinstance(other, $className) and all(+ getattr(self, attr) == getattr(other, attr)+ for attr in self.__slots__+ )++ def __ne__(self, other){ ret "bool" }:+ return not self == other++ def __hash__(self){ ret "int" }:+ return hash($hashTuple)+++$parentClass.$className = $className+if hasattr($parentClass, '__qualname__'):+ $className.__qualname__ = $parentClass.__qualname__ + '.{className}'+|]+ where+ optionFlags :: [Bool]+ optionFlags = [ case typeExpr of+ OptionModifier _ -> True+ _ -> False+ | (Field _ typeExpr _) <- toList fields+ ]+ className :: T.Text+ className = toClassName' typename'+ behindParentTypename :: T.Text+ behindParentTypename = I.toSnakeCaseText $ N.behindName parentname+ tagNames :: [T.Text]+ tagNames = map (toAttributeName' . fieldName) (toList fields)+ behindTagName :: T.Text+ behindTagName = I.toSnakeCaseText $ N.behindName typename'+ slots :: Code+ slots = if length tagNames == 1+ then [qq|'{head tagNames}'|] `T.snoc` ','+ else toIndentedCodes (\ n -> [qq|'{n}'|]) tagNames ",\n "+ hashTuple :: Code+ hashTuple = if null tagNames+ then "self.__nirum_tag__"+ else [qq|({toIndentedCodes (T.append "self.") tagNames ", "},)|]+ fieldList :: [Field]+ fieldList = toList fields+ nameMaps :: Code+ nameMaps = toIndentedCodes toNamePair+ (map fieldName fieldList)+ ",\n "+ parentClass :: T.Text+ parentClass = toClassName' parentname+ fieldSerializers :: Code+ fieldSerializers = T.intercalate ",\n"+ [ T.concat [ "'", I.toSnakeCaseText (N.behindName fn), "': "+ , compileSerializer source ft+ [qq|self.{toAttributeName' fn}|]+ ]+ | Field fn ft _ <- fieldList+ ]+compilePrimitiveType :: PrimitiveTypeIdentifier -> CodeGen Code+compilePrimitiveType primitiveTypeIdentifier' = do+ pyVer <- getPythonVersion+ case (primitiveTypeIdentifier', pyVer) of+ (Bool, _) -> return "bool"+ (Bigint, _) -> return "int"+ (Decimal, _) -> do+ insertStandardImport "decimal"+ return "decimal.Decimal"+ (Int32, _) -> return "int"+ (Int64, Python2) -> do+ insertStandardImport "numbers"+ return "numbers.Integral"+ (Int64, Python3) -> return "int"+ (Float32, _) -> return "float"+ (Float64, _) -> return "float"+ (Text, Python2) -> return "unicode"+ (Text, Python3) -> return "str"+ (Binary, _) -> return "bytes"+ (Date, _) -> do+ insertStandardImport "datetime"+ return "datetime.date"+ (Datetime, _) -> do+ insertStandardImport "datetime"+ return "datetime.datetime"+ (Uuid, _) -> insertStandardImport "uuid" >> return "uuid.UUID"+ (Uri, Python2) -> return "unicode"+ (Uri, Python3) -> return "str"++compileTypeExpression :: Source -> Maybe TypeExpression -> CodeGen Code+compileTypeExpression Source { sourcePackage = Package { metadata = meta }+ , sourceModule = boundModule+ }+ (Just (TypeIdentifier i)) =+ case lookupType i boundModule of+ Missing -> fail $ "undefined identifier: " ++ I.toString i+ Imported _ (PrimitiveType p _) -> compilePrimitiveType p+ Imported m _ -> do+ insertThirdPartyImports [(toImportPath target' m, [toClassName i])]+ return $ toClassName i+ Local _ -> return $ toClassName i+ where+ target' :: Python+ target' = target meta+compileTypeExpression source (Just (MapModifier k v)) = do+ kExpr <- compileTypeExpression source (Just k)+ vExpr <- compileTypeExpression source (Just v)+ insertStandardImport "typing"+ return [qq|typing.Mapping[$kExpr, $vExpr]|]+compileTypeExpression source (Just modifier) = do+ expr <- compileTypeExpression source (Just typeExpr)+ insertStandardImport "typing"+ return [qq|typing.$className[$expr]|]+ where+ typeExpr :: TypeExpression+ className :: T.Text+ (typeExpr, className) = case modifier of+ OptionModifier t' -> (t', "Optional")+ SetModifier t' -> (t', "AbstractSet")+ ListModifier t' -> (t', "Sequence")+ TypeIdentifier _ -> undefined -- never happen!+ MapModifier _ _ -> undefined -- never happen!+compileTypeExpression _ Nothing =+ return "None"++compileSerializer :: Source -> TypeExpression -> Code -> Code+compileSerializer Source { sourceModule = boundModule } =+ compileSerializer' boundModule++compileSerializer' :: BoundModule Python -> TypeExpression -> Code -> Code+compileSerializer' mod' (OptionModifier typeExpr) pythonVar =+ [qq|(None if ($pythonVar) is None+ else ({compileSerializer' mod' typeExpr pythonVar}))|]+compileSerializer' mod' (SetModifier typeExpr) pythonVar =+ compileSerializer' mod' (ListModifier typeExpr) pythonVar+compileSerializer' mod' (ListModifier typeExpr) pythonVar =+ [qq|list(($serializer) for $elemVar in ($pythonVar))|]+ where+ elemVar :: Code+ elemVar = mangleVar pythonVar "elem"+ serializer :: Code+ serializer = compileSerializer' mod' typeExpr elemVar+compileSerializer' mod' (MapModifier kt vt) pythonVar =+ [qq|list(+ \{+ 'key': ({compileSerializer' mod' kt kVar}),+ 'value': ({compileSerializer' mod' vt vVar}),+ \}+ for $kVar, $vVar in ($pythonVar).items()+ )|]+ where+ kVar :: Code+ kVar = mangleVar pythonVar "key"+ vVar :: Code+ vVar = mangleVar pythonVar "value"+compileSerializer' mod' (TypeIdentifier typeId) pythonVar =+ case lookupType typeId mod' of+ Missing -> "None" -- must never happen+ Local (Alias t) -> compileSerializer' mod' t pythonVar+ Imported modulePath' (Alias t) ->+ case resolveBoundModule modulePath' (boundPackage mod') of+ Nothing -> "None" -- must never happen+ Just foundMod -> compileSerializer' foundMod t pythonVar+ Local PrimitiveType { primitiveTypeIdentifier = p } ->+ compilePrimitiveTypeSerializer p pythonVar+ Imported _ PrimitiveType { primitiveTypeIdentifier = p } ->+ compilePrimitiveTypeSerializer p pythonVar+ Local EnumType {} -> serializerCall+ Imported _ EnumType {} -> serializerCall+ Local RecordType {} -> serializerCall+ Imported _ RecordType {} -> serializerCall+ Local UnboxedType {} -> serializerCall+ Imported _ UnboxedType {} -> serializerCall+ Local UnionType {} -> serializerCall+ Imported _ UnionType {} -> serializerCall+ where+ serializerCall :: Code+ serializerCall = [qq|$pythonVar.__nirum_serialize__()|]++compilePrimitiveTypeSerializer :: PrimitiveTypeIdentifier -> Code -> Code+compilePrimitiveTypeSerializer Bigint var = var+compilePrimitiveTypeSerializer Decimal var = [qq|str($var)|]+compilePrimitiveTypeSerializer Int32 var = var+compilePrimitiveTypeSerializer Int64 var = var+compilePrimitiveTypeSerializer Float32 var = var+compilePrimitiveTypeSerializer Float64 var = var+compilePrimitiveTypeSerializer Text var = var+compilePrimitiveTypeSerializer Binary var =+ [qq|__import__('base64').b64encode($var).decode('ascii')|]+compilePrimitiveTypeSerializer Date var = [qq|($var).isoformat()|]+compilePrimitiveTypeSerializer Datetime var = [qq|($var).isoformat()|]+compilePrimitiveTypeSerializer Bool var = var+compilePrimitiveTypeSerializer Uuid var = [qq|str($var)|]+compilePrimitiveTypeSerializer Uri var = var++compileTypeDeclaration :: Source -> TypeDeclaration -> CodeGen Code+compileTypeDeclaration _ TypeDeclaration { type' = PrimitiveType {} } =+ return "" -- never used+compileTypeDeclaration src d@TypeDeclaration { typename = typename'+ , type' = Alias ctype+ } = do+ ctypeExpr <- compileTypeExpression src (Just ctype)+ return $ toStrict $ renderMarkup [compileText|+%{ case compileDocs d }+%{ of Just rst }+#: #{rst}+%{ of Nothing }+%{ endcase }+#{toClassName' typename'} = #{ctypeExpr}+ |]+compileTypeDeclaration src d@TypeDeclaration { typename = typename'+ , type' = UnboxedType itype+ } = do+ let className = toClassName' typename'+ itypeExpr <- compileTypeExpression src (Just itype)+ insertStandardImport "typing"+ insertThirdPartyImports+ [ ("nirum.validate", ["validate_unboxed_type"])+ , ("nirum.deserialize", ["deserialize_meta"])+ ]+ pyVer <- getPythonVersion+ return $ toStrict $ renderMarkup $ [compileText|+class #{className}(object):+#{compileDocstring " " d}++ __nirum_type__ = 'unboxed'++ @staticmethod+ def __nirum_get_inner_type__():+ return #{itypeExpr}++%{ case pyVer }+%{ of Python2 }+ def __init__(self, value):+%{ of Python3 }+ def __init__(self, value: '#{itypeExpr}') -> None:+%{ endcase }+ validate_unboxed_type(value, #{itypeExpr})+ self.value = value # type: #{itypeExpr}++%{ case pyVer }+%{ of Python2 }+ def __ne__(self, other):+ return not self == other++ def __eq__(self, other):+%{ of Python3 }+ def __eq__(self, other) -> bool:+%{ endcase }+ return (isinstance(other, #{className}) and+ self.value == other.value)++%{ case pyVer }+%{ of Python2 }+ def __hash__(self):+%{ of Python3 }+ def __hash__(self) -> int:+%{ endcase }+ return hash(self.value)++ def __nirum_serialize__(self):+ return (#{compileSerializer src itype "self.value"})++ @classmethod+%{ case pyVer }+%{ of Python2 }+ def __nirum_deserialize__(cls, value):+%{ of Python3 }+ def __nirum_deserialize__(cls: type, value: typing.Any) -> '#{className}':+%{ endcase }+ inner_type = cls.__nirum_get_inner_type__()+ deserializer = getattr(inner_type, '__nirum_deserialize__', None)+ if deserializer:+ value = deserializer(value)+ else:+ value = deserialize_meta(inner_type, value)+ return cls(value=value)++%{ case pyVer }+%{ of Python2 }+ def __repr__(self):+ return '{0.__module__}.{0.__name__}({1!r})'.format(+ type(self), self.value+ )+%{ of Python3 }+ def __repr__(self) -> str:+ return '{0}({1!r})'.format(typing._type_repr(type(self)), self.value)+%{ endcase }++%{ case pyVer }+%{ of Python2 }+ def __hash__(self):+%{ of Python3 }+ def __hash__(self) -> int:+%{ endcase }+ return hash(self.value)+|]+compileTypeDeclaration _ d@TypeDeclaration { typename = typename'+ , type' = EnumType members+ } = do+ let className = toClassName' typename'+ insertStandardImport "enum"+ pyVer <- getPythonVersion+ return $ toStrict $ renderMarkup [compileText|+class #{className}(enum.Enum):+#{compileDocstring " " d}++%{ forall member@(EnumMember memberName@(Name _ behind) _) <- toList members }+#{compileDocsComment " " member}+ #{toEnumMemberName memberName} = '#{I.toSnakeCaseText behind}'+%{ endforall }++%{ case pyVer }+%{ of Python2 }+ def __nirum_serialize__(self):+%{ of Python3 }+ def __nirum_serialize__(self) -> str:+%{ endcase }+ return self.value++ @classmethod+%{ case pyVer }+%{ of Python2 }+ def __nirum_deserialize__(cls, value):+%{ of Python3 }+ def __nirum_deserialize__(cls: type, value: str) -> '#{className}':+%{ endcase }+ return cls(value.replace('-', '_')) # FIXME: validate input+++# Since enum.Enum doesn't allow to define non-member when the class is defined,+# __nirum_type__ should be defined after the class is defined.+#{className}.__nirum_type__ = 'enum'+|]+compileTypeDeclaration src d@TypeDeclaration { typename = typename'+ , type' = RecordType fields+ } = do+ typeExprCodes <- mapM (compileTypeExpression src)+ [Just typeExpr | (Field _ typeExpr _) <- fieldList]+ let nameTypeTriples = L.sortBy (compare `on` thd3)+ (zip3 fieldNames typeExprCodes optionFlags)+ slotTypes = toIndentedCodes+ (\ (n, t, _) -> [qq|'{n}': {t}|]) nameTypeTriples ",\n "+ importTypingForPython3+ insertThirdPartyImports [ ("nirum.validate", ["validate_record_type"])+ , ("nirum.deserialize", ["deserialize_meta"])+ ]+ insertThirdPartyImportsA [ ( "nirum.constructs"+ , [("name_dict_type", "NameDict")]+ )+ ]+ arg <- parameterCompiler+ ret <- returnCompiler+ typeRepr <- typeReprCompiler+ pyVer <- getPythonVersion+ initializers <- compileFieldInitializers fields $ case pyVer of+ Python3 -> 2+ Python2 -> 3+ let initParams = compileParameters arg nameTypeTriples+ inits = case pyVer of+ Python2 -> [qq|+ def __init__(self, **kwargs):+ def __init__($initParams):+ $initializers+ pass+ __init__(**kwargs)+ validate_record_type(self)+ |]+ Python3 -> [qq|+ def __init__(self{ if null nameTypeTriples+ then T.empty+ else ", *, " `T.append` initParams }) -> None:+ $initializers+ validate_record_type(self)+ |]+ let clsType = arg "cls" "type"+ return [qq|+class $className(object):+{compileDocstringWithFields " " d fields}+ __slots__ = (+ $slots,+ )+ __nirum_type__ = 'record'+ __nirum_record_behind_name__ = '{behindTypename}'+ __nirum_field_names__ = name_dict_type([$nameMaps])++ @staticmethod+ def __nirum_field_types__():+ return \{$slotTypes\}++ {inits :: T.Text}++ def __repr__(self){ret "bool"}:+ return '\{0\}(\{1\})'.format(+ {typeRepr "type(self)"},+ ', '.join('\{\}=\{\}'.format(attr, getattr(self, attr))+ for attr in self.__slots__)+ )++ def __eq__(self, other){ret "bool"}:+ return isinstance(other, $className) and all(+ getattr(self, attr) == getattr(other, attr)+ for attr in self.__slots__+ )++ def __ne__(self, other){ ret "bool" }:+ return not self == other++ def __nirum_serialize__(self):+ return \{+ '_type': '{behindTypename}',+ $fieldSerializers+ \}++ @classmethod+ def __nirum_deserialize__($clsType, value){ ret className }:+ if '_type' not in value:+ raise ValueError('"_type" field is missing.')+ if not cls.__nirum_record_behind_name__ == value['_type']:+ raise ValueError(+ '%s expect "_type" equal to "%s"'+ ', but found %s.' % (+ typing._type_repr(cls),+ cls.__nirum_record_behind_name__,+ value['_type']+ )+ )+ args = dict()+ behind_names = cls.__nirum_field_names__.behind_names+ field_types = cls.__nirum_field_types__+ if callable(field_types):+ field_types = field_types()+ # old compiler could generate non-callable dictionary+ errors = set()+ for attribute_name, item in value.items():+ if attribute_name == '_type':+ continue+ if attribute_name in behind_names:+ name = behind_names[attribute_name]+ else:+ name = attribute_name+ try:+ args[name] = deserialize_meta(field_types[name], item)+ except ValueError as e:+ errors.add('%s: %s' % (attribute_name, str(e)))+ if errors:+ raise ValueError('\\n'.join(sorted(errors)))+ return cls(**args)++ def __hash__(self){ret "int"}:+ return hash(($hashText,))+|]+ where+ className :: T.Text+ className = toClassName' typename'+ fieldList :: [Field]+ fieldList = toList fields+ behindTypename :: T.Text+ behindTypename = I.toSnakeCaseText $ N.behindName typename'+ optionFlags :: [Bool]+ optionFlags = [ case typeExpr of+ OptionModifier _ -> True+ _ -> False+ | (Field _ typeExpr _) <- fieldList+ ]+ fieldNames :: [T.Text]+ fieldNames = [toAttributeName' name' | Field name' _ _ <- fieldList]+ slots :: Code+ slots = toIndentedCodes (\ n -> [qq|'{n}'|]) fieldNames ",\n "+ nameMaps :: Code+ nameMaps = toIndentedCodes+ toNamePair+ (map fieldName $ toList fields)+ ",\n "+ hashText :: Code+ hashText = toIndentedCodes (\ n -> [qq|self.{n}|]) fieldNames ", "+ fieldSerializers :: Code+ fieldSerializers = T.intercalate ",\n"+ [ T.concat [ "'", I.toSnakeCaseText (N.behindName fn), "': "+ , compileSerializer src ft [qq|self.{ toAttributeName' fn}|]+ ]+ | Field fn ft _ <- fieldList+ ]+compileTypeDeclaration src+ d@TypeDeclaration { typename = typename'+ , type' = UnionType tags+ , typeAnnotations = annotations+ } = do+ tagCodes <- mapM (compileUnionTag src typename') $ toList tags+ let className = toClassName' typename'+ tagCodes' = T.intercalate "\n\n" tagCodes+ tagClasses = T.intercalate ", " [ toClassName' tagName+ | Tag tagName _ _ <- toList tags+ ]+ enumMembers = toIndentedCodes+ (\ (t, b) -> [qq|$t = '{b}'|]) enumMembers' "\n "+ importTypingForPython3+ insertStandardImport "enum"+ insertThirdPartyImports [ ("nirum.deserialize", ["deserialize_meta"])+ ]+ insertThirdPartyImportsA [ ( "nirum.constructs"+ , [("name_dict_type", "NameDict")]+ )+ ]+ insertThirdPartyImportsA [ ( "nirum.datastructures"+ , [("map_type", "Map")]+ )+ ]+ typeRepr <- typeReprCompiler+ ret <- returnCompiler+ arg <- parameterCompiler+ return [qq|+class $className({T.intercalate "," $ compileExtendClasses annotations}):+{compileDocstring " " d}++ __nirum_type__ = 'union'+ __nirum_union_behind_name__ = '{I.toSnakeCaseText $ N.behindName typename'}'+ __nirum_field_names__ = name_dict_type([$nameMaps])++ class Tag(enum.Enum):+ $enumMembers++ def __init__(self, *args, **kwargs):+ raise NotImplementedError(+ "\{0\} cannot be instantiated "+ "since it is an abstract class. Instantiate a concrete subtype "+ "of it instead.".format({typeRepr "type(self)"})+ )++ def __nirum_serialize__(self):+ raise NotImplementedError(+ "\{0\} cannot be instantiated "+ "since it is an abstract class. Instantiate a concrete subtype "+ "of it instead.".format({typeRepr "type(self)"})+ )++ @classmethod+ def __nirum_deserialize__(+ {arg "cls" "type"}, value+ ){ ret className }:+ if '_type' not in value:+ raise ValueError('"_type" field is missing.')+ if '_tag' not in value:+ raise ValueError('"_tag" field is missing.')+ if not hasattr(cls, '__nirum_tag__'):+ for sub_cls in cls.__subclasses__():+ if sub_cls.__nirum_tag__.value == value['_tag']:+ cls = sub_cls+ break+ else:+ raise ValueError(+ '%r is not deserialzable tag of `%s`' % (+ value, typing._type_repr(cls)+ )+ )+ if not cls.__nirum_union_behind_name__ == value['_type']:+ raise ValueError(+ '%s expect "_type" equal to "%s", but found %s' % (+ typing._type_repr(cls),+ cls.__nirum_union_behind_name__,+ value['_type']+ )+ )+ if not cls.__nirum_tag__.value == value['_tag']:+ raise ValueError(+ '%s expect "_tag" equal to "%s", but found %s' % (+ typing._type_repr(cls),+ cls.__nirum_tag__.value,+ cls+ )+ )+ args = dict()+ behind_names = cls.__nirum_tag_names__.behind_names+ errors = set()+ for attribute_name, item in value.items():+ if attribute_name in ('_type', '_tag'):+ continue+ if attribute_name in behind_names:+ name = behind_names[attribute_name]+ else:+ name = attribute_name+ tag_types = dict(cls.__nirum_tag_types__())+ try:+ args[name] = deserialize_meta(tag_types[name], item)+ except ValueError as e:+ errors.add('%s: %s' % (attribute_name, str(e)))+ if errors:+ raise ValueError('\\n'.join(sorted(errors)))+ return cls(**args)+++$tagCodes'++$className.__nirum_tag_classes__ = map_type(+ (tcls.__nirum_tag__, tcls)+ for tcls in [$tagClasses]+)+ |]+ where+ enumMembers' :: [(T.Text, T.Text)]+ enumMembers' = [ ( toEnumMemberName tagName+ , I.toSnakeCaseText $ N.behindName tagName+ )+ | (Tag tagName _ _) <- toList tags+ ]+ nameMaps :: T.Text+ nameMaps = toIndentedCodes+ toNamePair+ [name' | Tag name' _ _ <- toList tags]+ ",\n "+ compileExtendClasses :: A.AnnotationSet -> [Code]+ compileExtendClasses annotations' =+ if null extendClasses+ then ["object"]+ else extendClasses+ where+ extendsClassMap :: M.Map I.Identifier Code+ extendsClassMap = [("error", "Exception")]+ extendClasses :: [Code]+ extendClasses = catMaybes+ [ M.lookup annotationName extendsClassMap+ | (A.Annotation annotationName _) <- A.toList annotations'+ ]+compileTypeDeclaration+ src@Source { sourcePackage = Package { metadata = metadata' } }+ d@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'+ methodErrorTypes <- mapM compileErrorType methods'+ let dummyMethods' = T.intercalate "\n\n" dummyMethods+ clientMethods' = T.intercalate "\n\n" clientMethods+ methodErrorTypes' =+ T.intercalate "," $ catMaybes methodErrorTypes+ param <- parameterCompiler+ ret <- returnCompiler+ insertStandardImport "json"+ insertThirdPartyImports [ ("nirum.deserialize", ["deserialize_meta"])+ ]+ insertThirdPartyImportsA+ [ ("nirum.constructs", [("name_dict_type", "NameDict")])+ , ("nirum.datastructures", [(nirumMapName, "Map")])+ , ("nirum.service", [("service_type", "Service")])+ , ("nirum.transport", [("transport_type", "Transport")])+ ]+ return [qq|+class $className(service_type):+{compileDocstring " " d}+ __nirum_type__ = 'service'+ __nirum_schema_version__ = \'{SV.toText $ version metadata'}\'+ __nirum_service_methods__ = \{+ {methodMetadata'}+ \}+ __nirum_method_names__ = name_dict_type([+ $methodNameMap+ ])+ __nirum_method_annotations__ = $methodAnnotations'++ @staticmethod+ def __nirum_method_error_types__(k, d=None):+ return dict([+ $methodErrorTypes'+ ]).get(k, d)++ {dummyMethods'}+++# FIXME client MUST be generated & saved on diffrent module+# where service isn't included.+class {className}_Client($className):+ """The client object of :class:`{className}`."""++ def __init__(self,+ { param "transport" "transport_type" }){ ret "None" }:+ if not isinstance(transport, transport_type):+ raise TypeError(+ 'expected an instance of \{0.__module__\}.\{0.__name__\}, not '+ '\{1!r\}'.format(transport_type, transport)+ )+ self.__nirum_transport__ = transport # type: transport_type++ {clientMethods'}++{className}.Client = {className}_Client+{className}.Client.__name__ = 'Client'+if hasattr({className}.Client, '__qualname__'):+ {className}.Client.__qualname__ = '{className}.Client'+|]+ where+ nirumMapName :: T.Text+ nirumMapName = "map_type"+ className :: T.Text+ className = toClassName' name'+ commaNl :: [T.Text] -> T.Text+ commaNl = T.intercalate ",\n"+ compileErrorType :: Method -> CodeGen (Maybe Code)+ compileErrorType (Method mn _ _ me _) =+ case me of+ Just errorTypeExpression -> do+ et <- compileTypeExpression src (Just errorTypeExpression)+ return $ Just [qq|('{toAttributeName' mn}', $et)|]+ Nothing -> return Nothing+ compileMethod :: Method -> CodeGen Code+ compileMethod m@(Method mName params rtype _etype _anno) = do+ let mName' = toAttributeName' mName+ params' <- mapM compileMethodParameter $ toList params+ let paramDocs = [ T.concat [ ":param "+ , toAttributeName' pName+ , maybe "" (T.append ": ") $ compileDocs p+ -- TODO: types+ ]+ | p@(Parameter pName _ _) <- toList params+ ]+ rtypeExpr <- compileTypeExpression src rtype+ ret <- returnCompiler+ return [qq|+ def {mName'}(self, {commaNl params'}){ ret rtypeExpr }:+{compileDocstring' " " m paramDocs}+ raise NotImplementedError('$className has to implement {mName'}()')+|]+ compileMethodParameter :: Parameter -> CodeGen Code+ compileMethodParameter (Parameter pName pType _) = do+ pTypeExpr <- compileTypeExpression src (Just pType)+ arg <- parameterCompiler+ return [qq|{arg (toAttributeName' pName) pTypeExpr}|]+ compileMethodMetadata :: Method -> CodeGen Code+ 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+ insertThirdPartyImportsA+ [("nirum.constructs", [("name_dict_type", "NameDict")])]+ return [qq|'{toAttributeName' mName}': \{+ '_v': 2,+ '_return': lambda: $rtypeExpr,+ '_names': name_dict_type([{paramNameMap params'}]),+ {paramMetadata'}+ \}|]+ methodList :: [Method]+ methodList = toList methods+ compileParameterMetadata :: Parameter -> CodeGen Code+ compileParameterMetadata (Parameter pName pType _) = do+ let pName' = toAttributeName' pName+ pTypeExpr <- compileTypeExpression src (Just pType)+ return [qq|'{pName'}': lambda: $pTypeExpr|]+ methodNameMap :: T.Text+ methodNameMap = toIndentedCodes+ toNamePair+ [mName | Method { methodName = mName } <- methodList]+ ",\n "+ paramNameMap :: [Parameter] -> T.Text+ paramNameMap params = toIndentedCodes+ toNamePair [pName | Parameter pName _ _ <- params] ",\n "+ compileClientPayload :: Parameter -> CodeGen Code+ compileClientPayload (Parameter pName pt _) = do+ let pName' = toAttributeName' pName+ return [qq|'{I.toSnakeCaseText $ N.behindName pName}':+ ({compileSerializer src pt pName'})|]+ compileClientMethod :: Method -> CodeGen Code+ compileClientMethod Method { methodName = mName+ , parameters = params+ , returnType = rtype+ , errorType = etypeM+ } = do+ let clientMethodName' = toAttributeName' mName+ params' <- mapM compileMethodParameter $ toList params+ rtypeExpr <- compileTypeExpression src rtype+ errorCode <- case etypeM of+ Just e -> do+ e' <- compileTypeExpression src (Just e)+ return $ "result_type = " `T.append` e'+ Nothing ->+ return "raise UnexpectedNirumResponseError(serialized)"+ payloadArguments <- mapM compileClientPayload $ toList params+ ret <- returnCompiler+ return [qq|+ def {clientMethodName'}(self, {commaNl params'}){ret rtypeExpr}:+ successful, serialized = self.__nirum_transport__(+ '{I.toSnakeCaseText $ N.behindName mName}',+ payload=\{{commaNl payloadArguments}\},+ # FIXME Give annotations.+ service_annotations=\{\},+ method_annotations=self.__nirum_method_annotations__,+ parameter_annotations=\{\}+ )+ if successful:+ result_type = $rtypeExpr+ else:+ $errorCode+ if result_type is None:+ result = None+ else:+ result = deserialize_meta(result_type, serialized)+ if successful:+ return result+ raise result+|]+ toKeyItem :: I.Identifier -> T.Text -> T.Text+ toKeyItem ident v = [qq|'{toAttributeName ident}': {v}|]+ wrapMap :: T.Text -> T.Text+ wrapMap items = [qq|$nirumMapName(\{$items\})|]+ compileAnnotation :: I.Identifier -> A.AnnotationArgumentSet -> T.Text+ compileAnnotation ident annoArgument =+ toKeyItem ident $+ wrapMap $ T.intercalate ","+ [ toKeyStr ident' value :: T.Text+ | (ident', value) <- M.toList annoArgument+ ]+ where+ escapeSingle :: T.Text -> T.Text+ escapeSingle = T.strip . T.replace "'" "\\'"+ toKeyStr :: I.Identifier -> T.Text -> T.Text+ toKeyStr k v =+ [qq|'{toAttributeName k}': u'''{escapeSingle v}'''|]+ compileMethodAnnotation :: Method -> T.Text+ compileMethodAnnotation Method { methodName = mName+ , methodAnnotations = annoSet+ } =+ toKeyItem (N.facialName mName) $ wrapMap annotationDict+ where+ annotationDict :: T.Text+ annotationDict = T.intercalate ","+ [ compileAnnotation ident annoArgSet :: T.Text+ | (ident, annoArgSet) <- M.toList $ A.annotations annoSet+ ]+ methodAnnotations' :: T.Text+ methodAnnotations' = wrapMap $ commaNl $ map compileMethodAnnotation+ methodList++compileTypeDeclaration _ Import {} =+ return "" -- Nothing to compile++compileModuleBody :: Source -> CodeGen Code+compileModuleBody src@Source { sourceModule = boundModule } = do+ let types' = boundTypes boundModule+ typeCodes <- mapM (compileTypeDeclaration src) $ toList types'+ return $ T.intercalate "\n\n" typeCodes++data InstallRequires =+ InstallRequires { dependencies :: S.Set T.Text+ , optionalDependencies :: M.Map (Int, Int) (S.Set T.Text)+ } deriving (Eq, Ord, Show)++addDependency :: InstallRequires -> T.Text -> InstallRequires+addDependency requires package =+ requires { dependencies = S.insert package $ dependencies requires }++addOptionalDependency :: InstallRequires+ -> (Int, Int) -- ^ Python version already stasified+ -> T.Text -- ^ PyPI package name+ -> InstallRequires+addOptionalDependency requires pyVer package =+ requires { optionalDependencies = newOptDeps }+ where+ oldOptDeps :: M.Map (Int, Int) (S.Set T.Text)+ oldOptDeps = optionalDependencies requires+ newOptDeps :: M.Map (Int, Int) (S.Set T.Text)+ newOptDeps = M.alter (Just . S.insert package . fromMaybe S.empty)+ pyVer oldOptDeps++unionInstallRequires :: InstallRequires -> InstallRequires -> InstallRequires+unionInstallRequires a b =+ a { dependencies = S.union (dependencies a) (dependencies b)+ , optionalDependencies = M.unionWith S.union (optionalDependencies a)+ (optionalDependencies b)+ }++compileModule :: PythonVersion+ -> Source+ -> Either CompileError' (InstallRequires, Code)+compileModule pythonVersion' source = do+ let (result, context) = runCodeGen (compileModuleBody source)+ (empty pythonVersion')+ let deps = require "nirum" "nirum" $ M.keysSet $ thirdPartyImports context+ let optDeps =+ [ ((3, 4), require "enum34" "enum" $ standardImports context)+ , ((3, 5), require "typing" "typing" $ standardImports context)+ ]+ let installRequires = InstallRequires deps optDeps+ let fromImports = M.assocs (localImportsMap context) +++ M.assocs (thirdPartyImports context)+ code <- result+ return $ (,) installRequires $ toStrict $ renderMarkup $+ [compileText|# -*- coding: utf-8 -*-+#{compileDocstring "" $ sourceModule source}+%{ forall i <- S.elems (standardImports context) }+import #{i}+%{ endforall }++%{ forall (from, nameMap) <- fromImports }+from #{from} import (+%{ forall (alias, name) <- M.assocs nameMap }+%{ if (alias == name) }+ #{name},+%{ else }+ #{name} as #{alias},+%{ endif }+%{ endforall }+)+%{ endforall }++#{code}+|]+ where+ has :: S.Set T.Text -> T.Text -> Bool+ has set module' = module' `S.member` set ||+ any (T.isPrefixOf $ module' `T.snoc` '.') set+ 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++compilePackageMetadata :: Package' -> InstallRequires -> Code+compilePackageMetadata Package+ { metadata = Metadata+ { authors = authors'+ , version = version'+ , description = description'+ , license = license'+ , MD.keywords = keywords'+ , target = target'@Python+ { packageName = packageName'+ , minimumRuntimeVersion = minRuntimeVer+ }+ }+ , modules = modules'+ }+ (InstallRequires deps optDeps) =+ toStrict $ renderMarkup [compileText|# -*- coding: utf-8 -*-+import sys++from setuptools import setup, __version__ as setuptools_version++install_requires = [+%{ forall p <- S.toList deps }+%{ if (p == "nirum") }+ 'nirum >= #{SV.toText minRuntimeVer}',+%{ else }+ (#{stringLiteral p}),+%{ endif }+%{ endforall }+]+polyfill_requires = {+%{ forall ((major, minor), deps') <- M.toList optDeps }+ (#{major}, #{minor}): [+%{ forall dep' <- S.toList deps' }+ (#{stringLiteral dep'}),+%{ endforall }+ ],+%{ endforall }+}++%{ if (not $ M.null optDeps) }+# '<' operator for environment markers are supported since setuptools 17.1.+# Read PEP 496 for details of environment markers.+setup_requires = ['setuptools >= 17.1']+if tuple(map(int, setuptools_version.split('.'))) < (17, 1):+ extras_require = {}+ if 'bdist_wheel' not in sys.argv:+ for (major, minor), deps in polyfill_requires.items():+ if sys.version_info < (major, minor):+ install_requires.extend(deps)+ envmarker = ":python_version=='{0}.{1}'"+ python_versions = [(2, 6), (2, 7),+ (3, 3), (3, 4), (3, 5), (3, 6)] # FIXME+ for pyver in python_versions:+ extras_require[envmarker.format(*pyver)] = list({+ d+ for v, vdeps in polyfill_requires.items()+ if pyver < v+ for d in vdeps+ })+else:+ extras_require = {+ ":python_version<'{0}.{1}'".format(*pyver): deps+ for pyver, deps in polyfill_requires.items()+ }+%{ else }+setup_requires = []+extras_require = {}+%{ endif }+++SOURCE_ROOT = #{stringLiteral $ sourceDirectory Python3}++if sys.version_info < (3, 0):+ SOURCE_ROOT = #{stringLiteral $ sourceDirectory Python2}++# TODO: long_description, url, classifiers+setup(+ name=#{stringLiteral packageName'},+ version=#{stringLiteral $ SV.toText version'},+ description=#{nStringLiteral description'},+ license=#{nStringLiteral license'},+ keywords=#{stringLiteral $ T.intercalate " " keywords'},+ author=', '.join([+%{ forall Author { name = name } <- authors' }+ (#{stringLiteral name}),+%{ endforall }+ ]),+ author_email=', '.join([+%{ forall Author { email = email' } <- authors' }+%{ case email' }+%{ of Just authorEmail }+ (#{stringLiteral $ decodeUtf8 $ E.toByteString authorEmail}),+%{ of Nothing }+%{ endcase }+%{ endforall }+ ]),+ package_dir={'': SOURCE_ROOT},+ packages=[#{strings $ toImportPaths target' $ MS.keysSet modules'}],+ provides=[#{strings $ toImportPaths target' $ MS.keysSet modules'}],+ requires=[#{strings $ S.toList deps}],+ setup_requires=setup_requires,+ install_requires=install_requires,+ extras_require=extras_require,+)+|]+ where+ nStringLiteral :: Maybe T.Text -> T.Text+ nStringLiteral (Just value) = stringLiteral value+ nStringLiteral Nothing = "None"+ strings :: [Code] -> Code+ strings values = T.intercalate ", " $ map stringLiteral (L.sort values)++manifestIn :: Code+manifestIn = [q|recursive-include src *.py+recursive-include src-py2 *.py+|]++compilePackage' :: Package'+ -> M.Map FilePath (Either CompileError' Code)+compilePackage' package@Package { metadata = Metadata { target = target' } } =+ M.fromList $+ initFiles +++ [ ( f+ , case cd of+ Left e -> Left e+ Right (_, cd') -> Right cd'+ )+ | (f, cd) <- modules'+ ] +++ [ ("setup.py", Right $ compilePackageMetadata package installRequires)+ , ("MANIFEST.in", Right manifestIn)+ ]+ where+ toPythonFilename :: ModulePath -> [FilePath]+ toPythonFilename mp = [ T.unpack (toAttributeName i)+ | i <- toList $ renameMP target' mp+ ] ++ ["__init__.py"]+ versions :: [PythonVersion]+ versions = [Python2, Python3]+ toFilename :: T.Text -> ModulePath -> FilePath+ toFilename sourceRootDirectory mp =+ joinPath $ T.unpack sourceRootDirectory : toPythonFilename mp+ initFiles :: [(FilePath, Either CompileError' Code)]+ initFiles = [ (toFilename (sourceDirectory ver) mp', Right "")+ | mp <- MS.keys (modules package)+ , mp' <- S.elems (hierarchy mp)+ , ver <- versions+ ]+ modules' :: [(FilePath, Either CompileError' (InstallRequires, Code))]+ modules' =+ [ ( toFilename (sourceDirectory ver) modulePath'+ , compileModule ver $ Source package boundModule+ )+ | (modulePath', _) <- MS.toAscList (modules package)+ , Just boundModule <- [resolveBoundModule modulePath' package]+ , ver <- versions+ ]+ installRequires :: InstallRequires+ installRequires = foldl unionInstallRequires+ (InstallRequires [] [])+ [deps | (_, Right (deps, _)) <- modules']++parseModulePath :: T.Text -> Maybe ModulePath+parseModulePath string =+ mapM I.fromText identTexts >>= fromIdentifiers+ where+ identTexts :: [T.Text]+ identTexts = T.split (== '.') string++instance Target Python where+ type CompileResult Python = Code+ type CompileError Python = CompileError'+ targetName _ = "python"+ parseTarget table = do+ name' <- stringField "name" table+ minRuntime <- case versionField "minimum_runtime" table of+ Left (FieldError _) -> Right minimumRuntime+ otherwise' -> otherwise'+ renameTable <- case tableField "renames" table of+ Right t -> Right t+ Left (FieldError _) -> Right HM.empty+ otherwise' -> otherwise'+ renamePairs <- sequence+ [ case (parseModulePath k, v) of+ (Just modulePath', VString v') -> case parseModulePath v' of+ Just altPath -> Right (modulePath', altPath)+ Nothing -> Left $ FieldValueError [qq|renames.$k|]+ [qq|expected a module path, not "$v'"|]+ (Nothing, _) -> Left $ FieldValueError [qq|renams.$k|]+ [qq|expected a module path as a key, not "$k"|]+ _ -> Left $ FieldTypeError [qq|renames.$k|] "string" $+ fieldType v+ | (k, v) <- HM.toList renameTable+ ]+ return Python { packageName = name'+ , minimumRuntimeVersion = max minRuntime minimumRuntime+ , renames = M.fromList renamePairs+ }+ compilePackage = compilePackage'+ showCompileError _ e = e+ toByteString _ = encodeUtf8
+ src/Nirum/TypeInstance/BoundModule.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE RankNTypes, StandaloneDeriving #-}+module Nirum.TypeInstance.BoundModule+ ( BoundModule (boundPackage, modulePath)+ , TypeLookup (..)+ , boundTypes+ , findInBoundModule+ , lookupType+ , resolveBoundModule+ ) where++import Nirum.Constructs.Declaration+import Nirum.Constructs.DeclarationSet as DS+import Nirum.Constructs.Identifier+import Nirum.Constructs.Module+import Nirum.Constructs.ModulePath+import Nirum.Constructs.TypeDeclaration as TypeDeclaration hiding (modulePath)+import Nirum.Package+import Nirum.Package.Metadata+import qualified Nirum.Package.ModuleSet as ModuleSet++data BoundModule t = BoundModule+ { boundPackage :: Target t => Package t+ , modulePath :: ModulePath+ }++deriving instance (Eq t, Target t) => Eq (BoundModule t)+deriving instance (Ord t, Target t) => Ord (BoundModule t)+deriving instance (Show t, Target t) => Show (BoundModule t)++resolveBoundModule :: ModulePath -> Package t -> Maybe (BoundModule t)+resolveBoundModule path' package =+ case resolveModule path' package of+ Just _ -> Just $ BoundModule package path'+ Nothing -> Nothing++findInBoundModule :: Target t => (Module -> a) -> a -> BoundModule t -> a+findInBoundModule valueWhenExist valueWhenNotExist+ BoundModule { boundPackage = Package { modules = ms }+ , modulePath = path'+ } =+ case ModuleSet.lookup path' ms of+ Nothing -> valueWhenNotExist+ Just mod' -> valueWhenExist mod'++boundTypes :: Target t => BoundModule t -> DeclarationSet TypeDeclaration+boundTypes = findInBoundModule types DS.empty++data TypeLookup = Missing+ | Local Type+ | Imported ModulePath Type+ deriving (Eq, Ord, Show)++lookupType :: Target t => Identifier -> BoundModule t -> TypeLookup+lookupType identifier boundModule =+ case DS.lookup identifier (boundTypes boundModule) of+ Nothing -> toType coreModulePath+ (DS.lookup identifier $ types coreModule)+ Just TypeDeclaration { type' = t } -> Local t+ Just (Import path' _ _) ->+ case resolveModule path' (boundPackage boundModule) of+ Nothing -> Missing+ Just (Module decls _) ->+ toType path' (DS.lookup identifier decls)+ Just ServiceDeclaration {} -> Missing+ where+ toType :: ModulePath -> Maybe TypeDeclaration -> TypeLookup+ toType mp (Just TypeDeclaration { type' = t }) = Imported mp t+ toType _ _ = Missing++instance Target t => Documented (BoundModule t) where+ docs = findInBoundModule Nirum.Constructs.Module.docs Nothing
test/Nirum/CliSpec.hs view
@@ -3,10 +3,9 @@ import Control.Monad (forM_) +import qualified Data.ByteString as B import qualified Data.Map.Strict as M import Data.List (sort)-import Data.Text (Text)-import qualified Data.Text.IO as TI import System.Directory (listDirectory) import System.FilePath ((</>)) import System.IO.Temp (withSystemTempDirectory)@@ -14,11 +13,11 @@ import Nirum.Cli (writeFiles) -expectWriteFiles :: FilePath -> [(FilePath, Text)] -> IO [FilePath]+expectWriteFiles :: FilePath -> [(FilePath, B.ByteString)] -> IO [FilePath] expectWriteFiles tmpDir files = do- writeFiles tmpDir $ M.fromList [(f, Right c) | (f, c) <- files]- forM_ files $ \(f, expectedContent) -> do- content <- TI.readFile (tmpDir </> f)+ writeFiles tmpDir $ M.fromList files+ forM_ files $ \ (f, expectedContent) -> do+ content <- B.readFile (tmpDir </> f) content `shouldBe` expectedContent fileList <- listDirectory tmpDir return $ sort fileList@@ -27,14 +26,14 @@ spec = describe "writeFiles" $ do it "writes root files" $- withSystemTempDirectory "writeFiles-rootFiles" $ \tmpDir -> do+ withSystemTempDirectory "writeFiles-rootFiles" $ \ tmpDir -> do let files = [ ("a.txt", "content A") , ("b.txt", "content B") ] fileList <- expectWriteFiles tmpDir files fileList `shouldBe` sort [f | (f, _) <- files] it "makes directories if necessary" $- withSystemTempDirectory "writeFiles-directories" $ \tmpDir -> do+ withSystemTempDirectory "writeFiles-directories" $ \ tmpDir -> do let files = [ ("a.txt", "content A") , ("b.txt", "content B") , ("d/a.txt", "content d/a")
+ test/Nirum/CodeBuilderSpec.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE OverloadedLists, TypeFamilies #-}+module Nirum.CodeBuilderSpec where++import Control.Monad (forM_)+import Data.Map.Strict as M+import qualified Data.SemVer as SV+import qualified Data.Text as T+import Data.Text.Encoding (encodeUtf8)+import qualified Data.Text.Lazy as L+import qualified Data.Text.Lazy.Builder as B+import Test.Hspec.Meta+import qualified Text.PrettyPrint as P++import Nirum.CodeBuilder+import qualified Nirum.Constructs.DeclarationSet as DS+import Nirum.Constructs.Module (Module (..))+import Nirum.Constructs.ModulePath (ModulePath (..))+import qualified Nirum.Constructs.TypeDeclaration as TD+import Nirum.Package.Metadata (Metadata (..), Package (..), Target (..))+import qualified Nirum.Package.ModuleSet as MS+import Nirum.TypeInstance.BoundModule hiding (lookupType)+++emptyModule :: Module+emptyModule = Module { types = DS.empty, docs = Nothing }++modules' :: MS.ModuleSet+modules' = case m of+ Right m' -> m'+ _ -> error "unreachable"+ where+ m = MS.fromList [ (["fruits"], emptyModule)+ , (["imported-commons"], emptyModule)+ , (["transports", "truck"], emptyModule)+ , (["transports", "container"], emptyModule)+ ]++package :: Package DummyTarget+package = Package { metadata = Metadata { version = SV.version 0 0 1 [] []+ , authors = []+ , description = Nothing+ , license = Nothing+ , keywords = []+ , target = DummyTarget+ }+ , modules = modules'+ }++run :: CodeBuilder DummyTarget () a -> L.Text+run = B.toLazyText . snd . runBuilder package ["fruits"] ()+++spec = do+ specify "writeLine" $ do+ let w = do+ writeLine "a"+ writeLine "b"+ run w `shouldBe` "a\nb\n"+ specify "writeLine 2" $ do+ let w = forM_ ([1 .. 10] :: [Integer]) $ \ i ->+ writeLine $ P.text $ show i+ run w `shouldBe` "1\n2\n3\n4\n5\n6\n7\n8\n9\n10\n"+ describe "nest" $ do+ it "should indent its own context" $ do+ let w = do+ writeLine "a"+ nest 4 $ writeLine "b"+ run w `shouldBe` "a\n b\n"+ it "should indent its own context (2)" $ do+ let w = do+ writeLine "a"+ nest 4 $ do+ writeLine "b"+ writeLine "cd"+ writeLine "eee"+ run w `shouldBe` "a\n b\n cd\neee\n"+ describe "lookupType" $+ specify "primitives" $ do+ let run' = fst . runBuilder package ["fruits"] ()+ let core = ModuleName "core"+ run' (lookupType "text") `shouldBe`+ Imported core (TD.PrimitiveType TD.Text TD.String)+ run' (lookupType "int32") `shouldBe`+ Imported core (TD.PrimitiveType TD.Int32 TD.Number)+++data DummyTarget = DummyTarget deriving (Eq, Ord, Show)++instance Target DummyTarget where+ type CompileResult DummyTarget = T.Text+ type CompileError DummyTarget = T.Text+ targetName _ = "dummy"+ parseTarget _ = return DummyTarget+ compilePackage _ = M.empty+ showCompileError _ e = e+ toByteString _ = encodeUtf8
test/Nirum/CodeGenSpec.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE FlexibleInstances, ScopedTypeVariables, RankNTypes, MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances, ScopedTypeVariables, RankNTypes,+ MultiParamTypeClasses #-} module Nirum.CodeGenSpec where import Control.Monad.Except (throwError)@@ -10,10 +11,9 @@ import Nirum.CodeGen (CodeGen, Failure, fromString, runCodeGen) -data SampleError = SampleError Text- deriving (Eq, Ord, Show)+newtype SampleError = SampleError Text deriving (Eq, Ord, Show) -instance forall s. Failure s SampleError where+instance forall s . Failure s SampleError where fromString = return . SampleError . T.pack @@ -21,19 +21,19 @@ spec = parallel $ do specify "fail" $ do let codeGen' :: CodeGen Integer SampleError () = do- modify (+1)- modify (+1)+ modify (+ 1)+ modify (+ 1) fail "test" runCodeGen codeGen' 0 `shouldBe` (Left (SampleError "test"), 2) let codeGen'' :: CodeGen Integer SampleError Integer = do- modify (+1)+ modify (+ 1) _ <- fail "test"- modify (+1)+ modify (+ 1) return 42 runCodeGen codeGen'' 0 `shouldBe` (Left (SampleError "test"), 1) specify "throwError" $ do let codeGen' :: CodeGen Integer SampleError () = do- modify (+1)+ modify (+ 1) _ <- throwError $ SampleError "test"- modify (+2)+ modify (+ 2) runCodeGen codeGen' 0 `shouldBe` (Left (SampleError "test"), 1)
test/Nirum/Constructs/AnnotationSpec.hs view
@@ -1,52 +1,44 @@ {-# LANGUAGE OverloadedLists #-} module Nirum.Constructs.AnnotationSpec where +import Prelude hiding (null)+ import Test.Hspec.Meta import qualified Data.Map.Strict as M import Nirum.Constructs.Annotation as A- ( Annotation (Annotation)- , 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")- escapeCharAnno = Annotation "quote" (Just "\"")- longNameAnno = Annotation "long-cat-is-long" (Just "nyancat")+ let annotation = Annotation "foo" M.empty+ loremAnno = Annotation "lorem" [("arg", "ipsum")]+ escapeCharAnno = Annotation "quote" [("arg", "\"")]+ longNameAnno = Annotation "long-cat-is-long" [("long", "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 escapeCharAnno `shouldBe` "@quote(\"\\\"\")"+ toCode loremAnno `shouldBe` "@lorem(arg = \"ipsum\")"+ toCode escapeCharAnno `shouldBe` "@quote(arg = \"\\\"\")" specify "docs" $- docsAnno `shouldBe` Annotation "docs" (Just "Description\n")+ docsAnno `shouldBe`+ Annotation "docs" [("docs", "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")]+ specify "empty" $+ empty `shouldSatisfy` null+ specify "singleton" $ do+ singleton (Annotation "foo" []) `shouldBe`+ AnnotationSet [("foo", [])]+ singleton (Annotation "bar" [("arg", "baz")]) `shouldBe`+ AnnotationSet [("bar", [("arg", "baz")])] describe "fromList" $ do it "success" $ do- fromList [] `shouldBe` Right (AnnotationSet M.empty)- fromList [annotation] `shouldBe` Right- (AnnotationSet $ M.fromList [("foo", Nothing)])+ let Right empty' = fromList []+ empty' `shouldSatisfy` null+ fromList [annotation] `shouldBe`+ Right (AnnotationSet [("foo", [])]) it "name duplication" $ do let duplicationAnnotations = fromList [ annotation , loremAnno@@ -57,12 +49,13 @@ 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")- ]+ let c = AnnotationSet [("foo", [("arg", "bar")])]+ A.union a b `shouldBe`+ AnnotationSet [ ("foo", [])+ , ("lorem", [("arg", "ipsum")])+ , ("quote", [("arg", "\"")])+ , ("docs", [("docs", "Description\n")])+ ] A.union a c `shouldBe` a let Right annotationSet = fromList [ annotation , loremAnno@@ -78,8 +71,10 @@ 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 "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@@ -90,6 +85,6 @@ describe "insertDocs" $ do it "should insert the doc comment as an annotation" $ A.insertDocs "yay" empty `shouldReturn`- AnnotationSet [("docs", Just "yay\n")]+ AnnotationSet [("docs", [("docs", "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,17 +1,17 @@ {-# LANGUAGE OverloadedLists #-}-module Nirum.Constructs.DeclarationSetSpec (SampleDecl(..), spec) where+module Nirum.Constructs.DeclarationSetSpec (SampleDecl (..), spec) where import Control.Exception.Base (evaluate)-import Data.String (IsString(..))+import Data.String (IsString (..)) import Test.Hspec.Meta -import Nirum.Constructs (Construct(..))+import Nirum.Constructs (Construct (..)) import qualified Nirum.Constructs.Annotation as A import Nirum.Constructs.Annotation (AnnotationSet)-import Nirum.Constructs.Declaration (Declaration(..))+import Nirum.Constructs.Declaration (Declaration (..), Documented) import Nirum.Constructs.DeclarationSet ( DeclarationSet- , NameDuplication(..)+ , NameDuplication (..) , empty , fromList , lookup'@@ -21,12 +21,14 @@ , union , (!) )-import Nirum.Constructs.Name (Name(Name))+import Nirum.Constructs.Name (Name (Name)) data SampleDecl = SampleDecl Name AnnotationSet deriving (Eq, Ord, Show) instance Construct SampleDecl where toCode _ = "(do not impl)"++instance Documented SampleDecl instance Declaration SampleDecl where name (SampleDecl name' _) = name'
test/Nirum/Constructs/DocsSpec.hs view
@@ -2,12 +2,39 @@ import Test.Hspec.Meta -import Nirum.Constructs (Construct(..))-import Nirum.Constructs.Docs (Docs(Docs), toCodeWithPrefix)+import Nirum.Constructs (Construct (..))+import Nirum.Constructs.Docs (Docs (Docs), title, toBlock, toCodeWithPrefix)+import Nirum.Docs ( Block (Document, Heading, Paragraph)+ , HeadingLevel (H1, H2)+ , Inline (Code, Emphasis, Text)+ ) spec :: Spec spec = describe "Docs" $ do+ specify "toBlock" $+ toBlock (Docs "This is a *docs* `Block`.") `shouldBe`+ Document [ Paragraph [ Text "This is a "+ , Emphasis [Text "docs"]+ , Text " "+ , Code "Block"+ , Text "."+ ]+ ]+ context "title" $ do+ it "returns Nothing if it doesn't have any heading blocks" $+ title (Docs "This doesn't have any title.") `shouldBe` Nothing+ it "returns Nothing if its first block is not a heading" $+ title (Docs "Its first block is...\n\n# Not a Heading\n")+ `shouldBe` Nothing+ it "returns Just Heading if its first block is a heading" $ do+ title (Docs "# H1\n\nis its first block!") `shouldBe`+ Just (Heading H1 [Text "H1"])+ title (Docs "## Not have to be H1\n\nAny lebel can be a title.")+ `shouldBe` Just (Heading H2 [Text "Not have to be H1"])+ specify "title block can other Inlines than Text" $+ title (Docs "# `<code>`\n\nThe title can consist of.")+ `shouldBe` Just (Heading H1 [Code "<code>"]) context "toCode" $ do it "has leading sharps every line" $ do toCode (Docs "test") `shouldBe` "# test"
test/Nirum/Constructs/IdentifierSpec.hs view
@@ -51,8 +51,8 @@ `shouldBe` Nothing fromText "identifier_cannot_have_two__or_more_continued_underscores" `shouldBe` Nothing- fromText "무효한-식별자" `shouldBe` Nothing- fromText "invalid-식별자" `shouldBe` Nothing+ fromText "\xbb34\xd6a8\xd55c-\xc2dd\xbcc4\xc790" `shouldBe` Nothing+ fromText "invalid-\xc2dd\xbcc4\xc790" `shouldBe` Nothing fromText "identifier cannot contain whitepsaces" `shouldBe` Nothing it "returns Just Identifier if nothing goes wrong" $ do toText "datetime" `shouldBe` "datetime"@@ -109,7 +109,7 @@ let normalizers = [ toNormalizedText , toLispCaseText ] :: [Identifier -> Text]- forM_ normalizers $ \normalizer -> do+ forM_ normalizers $ \ normalizer -> do it "returns lowercased identifier text" $ do normalizer "IDENTIFIER" `shouldBe` "identifier" normalizer "Identifier" `shouldBe` "identifier"
test/Nirum/Constructs/ModulePathSpec.hs view
@@ -2,16 +2,19 @@ module Nirum.Constructs.ModulePathSpec where import Control.Exception (evaluate)-import GHC.Exts (IsList(fromList, toList))+import Data.List (sort)+import GHC.Exts (IsList (fromList, toList)) import System.FilePath ((</>)) import Test.Hspec.Meta -import Nirum.Constructs (Construct(toCode))-import Nirum.Constructs.ModulePath ( ModulePath(ModuleName, ModulePath)- , ancestors+import Nirum.Constructs (Construct (toCode))+import Nirum.Constructs.ModulePath ( ModulePath (ModuleName, ModulePath)+ , hierarchy+ , hierarchies , fromFilePath , fromIdentifiers+ , replacePrefix ) spec :: Spec@@ -44,13 +47,40 @@ Just fooBarBaz fromFilePath ("foo" </> "bar-baz2.nrm") `shouldBe` Just fooBarBaz2 fromFilePath ("foo" </> "bar_baz2.NRM") `shouldBe` Just fooBarBaz2- specify "ancestors" $ do- ancestors ["foo", "bar", "baz"] `shouldBe`+ specify "hierarchy" $ do+ hierarchy ["foo", "bar", "baz"] `shouldBe` [ ["foo"] , ["foo", "bar"] , ["foo", "bar", "baz"] ]- ancestors ["foo"] `shouldBe` [["foo"]]+ hierarchy ["foo"] `shouldBe` [["foo"]]+ specify "hierarchies" $+ hierarchies [ ["foo", "bar", "baz"], ["tar", "gz"] ] `shouldBe`+ [ ["foo"]+ , ["foo", "bar"]+ , ["foo", "bar", "baz"]+ , ["tar"]+ , ["tar", "gz"]+ ]+ specify "replacePrefix" $ do+ replacePrefix ["foo"] ["qux"] ["foo"] `shouldBe` ["qux"]+ replacePrefix ["foo"] ["qux"] ["foo", "bar"] `shouldBe`+ ["qux", "bar"]+ replacePrefix ["foo"] ["qux"] ["bar", "foo"] `shouldBe`+ ["bar", "foo"]+ replacePrefix ["foo"] ["qux", "quz"] ["foo"] `shouldBe`+ ["qux", "quz"]+ replacePrefix ["foo"] ["qux", "quz"] ["foo", "bar"] `shouldBe`+ ["qux", "quz", "bar"]+ replacePrefix ["foo"] ["qux", "quz"] ["bar", "foo"] `shouldBe`+ ["bar", "foo"]+ replacePrefix ["foo", "bar"] ["qux"] ["foo"] `shouldBe` ["foo"]+ replacePrefix ["foo", "bar"] ["qux"] ["foo", "bar"] `shouldBe`+ ["qux"]+ replacePrefix ["foo", "bar"] ["qux"] ["foo", "bar", "baz"]+ `shouldBe` ["qux", "baz"]+ replacePrefix ["foo", "bar"] ["qux"] ["bar", "foo"] `shouldBe`+ ["bar", "foo"] context "Construct" $ specify "toCode" $ do toCode foo `shouldBe` "foo"@@ -70,3 +100,14 @@ toList fooBar `shouldBe` ["foo", "bar"] toList fooBarBaz `shouldBe` ["foo", "bar", "baz"] toList fooBarBaz2 `shouldBe` ["foo", "bar-baz2"]+ context "Ord" $+ specify "<=" $ do+ ["abc"] `shouldSatisfy` (<= foo)+ foo `shouldSatisfy` (<= fooBar)+ fooBar `shouldNotSatisfy` (<= foo)+ fooBar `shouldSatisfy` (<= fooBarBaz)+ fooBarBaz `shouldNotSatisfy` (<= fooBar)+ fooBarBaz `shouldSatisfy` (<= fooBarBaz2)+ fooBarBaz2 `shouldNotSatisfy` (<= fooBarBaz)+ sort [["abc"], foo, fooBar, fooBarBaz, fooBarBaz2]+ `shouldBe` [["abc"], foo, fooBar, fooBarBaz, fooBarBaz2]
test/Nirum/Constructs/ModuleSpec.hs view
@@ -4,14 +4,14 @@ import Test.Hspec.Meta import Text.InterpolatedString.Perl6 (q) -import Nirum.Constructs (Construct(toCode))+import Nirum.Constructs (Construct (toCode)) 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(..)- , TypeDeclaration( Import- , TypeDeclaration- )+import Nirum.Constructs.Module (Module (..), imports)+import Nirum.Constructs.TypeDeclaration ( Type (..)+ , TypeDeclaration ( Import+ , TypeDeclaration+ ) ) spec :: Spec
test/Nirum/Constructs/NameSpec.hs view
@@ -2,7 +2,7 @@ import Test.Hspec.Meta -import Nirum.Constructs.Name (Name(Name), isComplex, isSimple, toCode)+import Nirum.Constructs.Name (Name (Name), isComplex, isSimple, toCode) spec :: Spec spec =
test/Nirum/Constructs/ServiceSpec.hs view
@@ -1,15 +1,13 @@-{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedLists, QuasiQuotes #-} module Nirum.Constructs.ServiceSpec where +import Data.String.QQ (s)+import Data.Map.Strict as Map (fromList) import Test.Hspec.Meta -import Nirum.Constructs.Annotation (Annotation (Annotation)- , empty- , fromList- , union- )+import Nirum.Constructs.Annotation import Nirum.Constructs.Docs (toCode)-import Nirum.Constructs.Service (Method(Method), Parameter(Parameter))+import Nirum.Constructs.Service (Method (Method), Parameter (Parameter)) import Nirum.Constructs.TypeExpression ( TypeExpression ( ListModifier , OptionModifier )@@ -19,7 +17,10 @@ spec :: Spec spec = do- let Right methodAnno = fromList [Annotation "http-get" (Just "/ping/")]+ let methodAnno = singleton $ Annotation "http" $ Map.fromList+ [ ("method", "GET")+ , ("path", "/ping/")+ ] let docsAnno = singleDocs "docs..." describe "Parameter" $ specify "toCode" $ do@@ -28,101 +29,106 @@ "date dob,\n# docs..." describe "Method" $ specify "toCode" $ do- toCode (Method "ping" [] "bool"+ toCode (Method "ping" [] (Just "bool") Nothing empty) `shouldBe` "bool ping (),"- toCode (Method "ping" [] "bool"+ toCode (Method "ping" [] (Just "bool") Nothing methodAnno) `shouldBe`- "@http-get(\"/ping/\")\nbool ping (),"- toCode (Method "ping" [] "bool"+ "@http(method = \"GET\", path = \"/ping/\")\nbool ping (),"+ toCode (Method "ping" [] (Just "bool") Nothing docsAnno) `shouldBe` "bool ping (\n # docs...\n),"- toCode (Method "ping" [] "bool"+ toCode (Method "ping" [] (Just "bool") (Just "ping-error") empty) `shouldBe` "bool ping () throws ping-error,"- toCode (Method "ping" [] "bool"+ toCode (Method "ping" [] (Just "bool") (Just "ping-error") docsAnno) `shouldBe` "bool ping (\n # docs...\n) throws ping-error,"- toCode (Method "ping" [] "bool"+ toCode (Method "ping" [] (Just "bool") Nothing methodAnno) `shouldBe`- "@http-get(\"/ping/\")\nbool ping (),"- toCode (Method "ping" [] "bool"+ "@http(method = \"GET\", path = \"/ping/\")\nbool ping (),"+ toCode (Method "ping" [] (Just "bool") (Just "ping-error") methodAnno) `shouldBe`- "@http-get(\"/ping/\")\nbool ping () throws ping-error,"+ "@http(method = \"GET\", path = \"/ping/\")\n\+ \bool ping () throws ping-error," toCode (Method "get-user" [Parameter "user-id" "uuid" empty]- (OptionModifier "user")+ (Just $ OptionModifier "user") Nothing empty) `shouldBe` "user? get-user (uuid user-id)," toCode (Method "get-user" [Parameter "user-id" "uuid" empty]- (OptionModifier "user")+ (Just $ 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 $ 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 $ OptionModifier "user") (Just "get-user-error")- docsAnno) `shouldBe`- "user? get-user (\n\- \ # docs...\n\- \ uuid user-id,\n\- \) throws get-user-error,"+ docsAnno) `shouldBe` [s|+user? get-user (+ # docs...+ uuid user-id,+) throws get-user-error,|] toCode (Method "get-user"- [Parameter "user-id" "uuid" $ singleDocs "param docs..."]- (OptionModifier "user")+ [Parameter "user-id" "uuid" $+ singleDocs "param docs..."]+ (Just $ 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")+ [Parameter "user-id" "uuid" $+ singleDocs "param docs..."]+ (Just $ OptionModifier "user") Nothing- docsAnno) `shouldBe`- "user? get-user (\n\- \ # docs...\n\- \ uuid user-id,\n\- \ # param docs...\n\- \),"+ docsAnno) `shouldBe` [s|+user? get-user (+ # docs...+ uuid user-id,+ # param docs...+),|] toCode (Method "get-user"- [Parameter "user-id" "uuid" $ singleDocs "param docs..."]- (OptionModifier "user")+ [Parameter "user-id" "uuid" $+ singleDocs "param docs..."]+ (Just $ OptionModifier "user") (Just "get-user-error")- empty) `shouldBe`- "user? get-user (\n\- \ uuid user-id,\n\- \ # param docs...\n\- \) throws get-user-error,"+ empty) `shouldBe` [s|+user? get-user (+ uuid user-id,+ # param docs...+) throws get-user-error,|] toCode (Method "get-user"- [Parameter "user-id" "uuid" $ singleDocs "param docs..."]- (OptionModifier "user")+ [Parameter "user-id" "uuid" $+ singleDocs "param docs..."]+ (Just $ 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,"+ docsAnno) `shouldBe` [s|+user? get-user (+ # docs...+ uuid user-id,+ # param docs...+) throws get-user-error,|] toCode (Method "search-posts" [ Parameter "blog-id" "uuid" empty , Parameter "keyword" "text" empty ]- (ListModifier "post")+ (Just $ ListModifier "post") Nothing empty) `shouldBe` "[post] search-posts (\n uuid blog-id,\n text keyword,\n),"@@ -130,103 +136,113 @@ [ Parameter "blog-id" "uuid" empty , Parameter "keyword" "text" empty ]- (ListModifier "post")+ (Just $ ListModifier "post") Nothing- docsAnno) `shouldBe`- "[post] search-posts (\n\- \ # docs...\n\- \ uuid blog-id,\n\- \ text keyword,\n\- \),"+ docsAnno) `shouldBe` [s|+[post] search-posts (+ # docs...+ uuid blog-id,+ text keyword,+),|] toCode (Method "search-posts" [ Parameter "blog-id" "uuid" empty , Parameter "keyword" "text" empty ]- (ListModifier "post")+ (Just $ ListModifier "post") (Just "search-posts-error")- empty) `shouldBe`- "[post] search-posts (\n\- \ uuid blog-id,\n\- \ text keyword,\n\- \) throws search-posts-error,"+ empty) `shouldBe` [s|+[post] search-posts (+ uuid blog-id,+ text keyword,+) throws search-posts-error,|] toCode (Method "search-posts" [ Parameter "blog-id" "uuid" empty , Parameter "keyword" "text" empty ]- (ListModifier "post")+ (Just $ 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,"+ docsAnno) `shouldBe` [s|+[post] search-posts (+ # docs...+ uuid blog-id,+ text keyword,+) throws search-posts-error,|] toCode (Method "search-posts"- [ Parameter "blog-id" "uuid" $ singleDocs "blog id..."- , Parameter "keyword" "text" $ singleDocs "keyword..."+ [ Parameter "blog-id" "uuid" $+ singleDocs "blog id..."+ , Parameter "keyword" "text" $+ singleDocs "keyword..." ]- (ListModifier "post")+ (Just $ ListModifier "post") Nothing- empty) `shouldBe`- "[post] search-posts (\n\- \ uuid blog-id,\n\- \ # blog id...\n\- \ text keyword,\n\- \ # keyword...\n\- \),"+ empty) `shouldBe` [s|+[post] search-posts (+ uuid blog-id,+ # blog id...+ text keyword,+ # keyword...+),|] toCode (Method "search-posts"- [ Parameter "blog-id" "uuid" $ singleDocs "blog id..."- , Parameter "keyword" "text" $ singleDocs "keyword..."+ [ Parameter "blog-id" "uuid" $+ singleDocs "blog id..."+ , Parameter "keyword" "text" $+ singleDocs "keyword..." ]- (ListModifier "post")+ (Just $ ListModifier "post") Nothing- docsAnno) `shouldBe`- "[post] search-posts (\n\- \ # docs...\n\- \ uuid blog-id,\n\- \ # blog id...\n\- \ text keyword,\n\- \ # keyword...\n\- \),"+ docsAnno) `shouldBe` [s|+[post] search-posts (+ # docs...+ uuid blog-id,+ # blog id...+ text keyword,+ # keyword...+),|] toCode (Method "search-posts"- [ Parameter "blog-id" "uuid" $ singleDocs "blog id..."- , Parameter "keyword" "text" $ singleDocs "keyword..."+ [ Parameter "blog-id" "uuid" $+ singleDocs "blog id..."+ , Parameter "keyword" "text" $+ singleDocs "keyword..." ]- (ListModifier "post")+ (Just $ 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,"+ empty) `shouldBe` [s|+[post] search-posts (+ uuid blog-id,+ # blog id...+ text keyword,+ # keyword...+) throws search-posts-error,|] toCode (Method "search-posts"- [ Parameter "blog-id" "uuid" $ singleDocs "blog id..."- , Parameter "keyword" "text" $ singleDocs "keyword..."+ [ Parameter "blog-id" "uuid" $+ singleDocs "blog id..."+ , Parameter "keyword" "text" $+ singleDocs "keyword..." ]- (ListModifier "post")+ (Just $ 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,"+ docsAnno) `shouldBe` [s|+[post] search-posts (+ # docs...+ uuid blog-id,+ # blog id...+ text keyword,+ # keyword...+) throws search-posts-error,|] toCode (Method "search-posts"- [ Parameter "blog-id" "uuid" $ singleDocs "blog id..."- , Parameter "keyword" "text" $ singleDocs "keyword..."+ [ Parameter "blog-id" "uuid" $+ singleDocs "blog id..."+ , Parameter "keyword" "text" $+ singleDocs "keyword..." ]- (ListModifier "post")+ (Just $ 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,"+ (docsAnno `union` methodAnno)) `shouldBe` [s|+@http(method = "GET", path = "/ping/")+[post] search-posts (+ # docs...+ uuid blog-id,+ # blog id...+ text keyword,+ # keyword...+) throws search-posts-error,|]
test/Nirum/Constructs/TypeDeclarationSpec.hs view
@@ -1,31 +1,28 @@-{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedLists, QuasiQuotes #-} module Nirum.Constructs.TypeDeclarationSpec where -import Data.Either (rights)++import Data.String.QQ (s) import qualified Data.Text as T import Test.Hspec.Meta -import Nirum.Constructs (Construct(toCode))-import Nirum.Constructs.Annotation ( Annotation (Annotation)- , AnnotationSet- , fromList- , empty- )-import Nirum.Constructs.Declaration (Declaration(name), docs)+import Nirum.Constructs (Construct (toCode))+import Nirum.Constructs.Annotation hiding (docs, name)+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)- , Field(Field)- , JsonType(String)- , PrimitiveTypeIdentifier(Text)- , Tag(Tag)- , Type(..)- , TypeDeclaration(..)+import Nirum.Constructs.Service (Method (Method), Service (Service))+import Nirum.Constructs.TypeDeclaration ( EnumMember (EnumMember)+ , Field (Field)+ , JsonType (String)+ , PrimitiveTypeIdentifier (Text)+ , Tag (Tag)+ , Type (..)+ , TypeDeclaration (..) ) import Util (singleDocs) barAnnotationSet :: AnnotationSet-barAnnotationSet = head $ rights [fromList [Annotation "bar" (Just "baz")]]+barAnnotationSet = singleton $ Annotation "bar" [("val", "baz")] spec :: Spec spec = do@@ -74,21 +71,23 @@ } b = a { typeAnnotations = singleDocs "country codes" } specify "toCode" $ do- toCode a `shouldBe` "enum country\n\- \ = kr\n\- \ | jp\n\- \ # Japan\n\- \ | us\n\- \ # United States\n\- \ ;"- toCode b `shouldBe` "enum country\n\- \ # country codes\n\- \ = kr\n\- \ | jp\n\- \ # Japan\n\- \ | us\n\- \ # United States\n\- \ ;"+ toCode a `shouldBe` [s|+enum country+ = kr+ | jp+ # Japan+ | us+ # United States+ ;|]+ toCode b `shouldBe` [s|+enum country+ # country codes+ = kr+ | jp+ # Japan+ | us+ # United States+ ;|] context "RecordType" $ do let fields' = [ Field "name" "text" empty , Field "dob" "date" (singleDocs "date of birth")@@ -101,19 +100,22 @@ } b = a { typeAnnotations = singleDocs "person record type" } specify "toCode" $ do- toCode a `shouldBe` "record person (\n\- \ text name,\n\- \ date dob,\n\- \ # date of birth\n\- \ gender gender,\n\- \);"- toCode b `shouldBe` "record person (\n\- \ # person record type\n\n\- \ text name,\n\- \ date dob,\n\- \ # date of birth\n\- \ gender gender,\n\- \);"+ toCode a `shouldBe` [s|+record person (+ text name,+ date dob,+ # date of birth+ gender gender,+);|]+ toCode b `shouldBe` [s|+record person (+ # person record type++ text name,+ date dob,+ # date of birth+ gender gender,+);|] context "UnionType" $ do let circleFields = [ Field "origin" "point" empty , Field "radius" "offset" empty@@ -125,28 +127,26 @@ , Tag "rectangle" rectangleFields empty , Tag "none" [] empty ]- union = UnionType tags'+ union' = UnionType tags' a = TypeDeclaration { typename = "shape"- , type' = union+ , type' = union' , typeAnnotations = empty } b = a { typeAnnotations = singleDocs "shape type" } specify "toCode" $ do- toCode a `shouldBe` "union shape\n\- \ = circle (point origin, \- \offset radius,)\n\- \ | rectangle (point upper-left, \- \point lower-right,)\n\- \ | none\n\- \ ;"- toCode b `shouldBe` "union shape\n\- \ # shape type\n\- \ = circle (point origin, \- \offset radius,)\n\- \ | rectangle (point upper-left, \- \point lower-right,)\n\- \ | none\n\- \ ;"+ toCode a `shouldBe` [s|+union shape+ = circle (point origin, offset radius,)+ | rectangle (point upper-left, point lower-right,)+ | none+ ;|]+ toCode b `shouldBe` [s|+union shape+ # shape type+ = circle (point origin, offset radius,)+ | rectangle (point upper-left, point lower-right,)+ | none+ ;|] context "PrimitiveType" $ do let primitiveType = PrimitiveType Text String decl = TypeDeclaration "text" primitiveType empty@@ -159,7 +159,8 @@ nullDecl' = ServiceDeclaration "null-service" nullService (singleDocs "Null service declaration.")- pingService = Service [ Method "ping" [] "bool" Nothing empty ]+ pingService = Service+ [Method "ping" [] (Just "bool") Nothing empty] pingDecl = ServiceDeclaration "ping-service" pingService empty pingDecl' = ServiceDeclaration "ping-service" pingService@@ -168,19 +169,19 @@ barAnnotationSet specify "toCode" $ do toCode nullDecl `shouldBe` "service null-service ();"- toCode nullDecl' `shouldBe` "service null-service (\n\- \ # Null service declaration.\n\- \);"+ toCode nullDecl' `shouldBe` [s|+service null-service (+ # Null service declaration.+);|] toCode pingDecl `shouldBe` "service ping-service (bool ping ());"- toCode pingDecl' `shouldBe`- "service ping-service (\n\- \ # Ping service declaration.\n\- \ bool ping ()\n\- \);"+ toCode pingDecl' `shouldBe` [s|+service ping-service (+ # Ping service declaration.+ bool ping ()+);|] toCode annoDecl `shouldBe`- "@bar(\"baz\")\n\- \service anno-service (bool ping ());"+ "@bar(val = \"baz\")\nservice anno-service (bool ping ());" -- TODO: more tests context "Import" $ do let import' = Import ["foo", "bar"] "baz" empty
test/Nirum/Constructs/TypeExpressionSpec.hs view
@@ -2,7 +2,7 @@ import Test.Hspec.Meta -import Nirum.Constructs.TypeExpression (TypeExpression(..), toCode)+import Nirum.Constructs.TypeExpression (TypeExpression (..), toCode) spec :: Spec spec =
+ test/Nirum/Docs/HtmlSpec.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE QuasiQuotes #-}+module Nirum.Docs.HtmlSpec where++import Test.Hspec.Meta+import Text.InterpolatedString.Perl6 (q)++import Nirum.Docs (Html)+import Nirum.Docs.Html (render)+import Nirum.DocsSpec (sampleDocument)++expectedHtml :: Html+expectedHtml = [q|<h1>Hello</h1>+<p>Tight list:</p>+<ul>+<li>List test</li>+<li>test2</li>+</ul>+<p>Loose list:</p>+<ol>+<li><p>a</p></li>+<li><p>b</p></li>+</ol>+<p>A <a href="http://nirum.org/" title="Nirum">complex <em>link</em></a>.</p>+|]++spec :: Spec+spec =+ describe "Docs.Html" $+ specify "render" $+ render sampleDocument `shouldBe` expectedHtml
+ test/Nirum/Docs/ReStructuredTextSpec.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE QuasiQuotes #-}+module Nirum.Docs.ReStructuredTextSpec where++import Test.Hspec.Meta+import Text.InterpolatedString.Perl6 (q)++import Nirum.Docs.ReStructuredText (ReStructuredText, render)+import Nirum.DocsSpec (sampleDocument)++expectedRst :: ReStructuredText+expectedRst = [q|Hello+=====++Tight list\:++- List test+- test2++Loose list\:++1. a++2. b++A `complex link <http://nirum.org/>`_\.+|]++spec :: Spec+spec =+ describe "Docs.ReStructuredText" $+ specify "render" $+ render sampleDocument `shouldBe` expectedRst
+ test/Nirum/DocsSpec.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE ExtendedDefaultRules, OverloadedStrings, QuasiQuotes #-}+module Nirum.DocsSpec where++import Data.Text (Text)+import Test.Hspec.Meta+import Text.InterpolatedString.Perl6 (q)++import Nirum.Docs ( Block (..)+ , HeadingLevel (..)+ , Inline (..)+ , ItemList (..)+ , ListDelimiter (..)+ , ListType (..)+ , filterReferences+ , headingLevelFromInt+ , parse+ )++sampleSource :: Text+sampleSource = [q|+Hello+=====++Tight list:++- List test+- test2++Loose list:++1. a++2. b++A [complex *link*][1].++[1]: http://nirum.org/ "Nirum"++|]++sampleDocument :: Block+sampleDocument =+ Document+ [ Heading H1 ["Hello"]+ , Paragraph ["Tight list:"]+ , List BulletList $ TightItemList [ ["List test"]+ , ["test2"]+ ]+ , Paragraph ["Loose list:"]+ , List (OrderedList 1 Period) $+ LooseItemList [ [Paragraph ["a"]]+ , [Paragraph ["b"]]+ ]+ , Paragraph+ [ "A "+ , Link "http://nirum.org/" "Nirum"+ ["complex ", Emphasis ["link"]]+ , "."+ ]+ ]++spec :: Spec+spec = do+ describe "HeadingLevel" $+ specify "headingLevelFromInt" $ do+ headingLevelFromInt (-1) `shouldBe` H1+ headingLevelFromInt 0 `shouldBe` H1+ headingLevelFromInt 1 `shouldBe` H1+ headingLevelFromInt 2 `shouldBe` H2+ headingLevelFromInt 3 `shouldBe` H3+ headingLevelFromInt 4 `shouldBe` H4+ headingLevelFromInt 5 `shouldBe` H5+ headingLevelFromInt 6 `shouldBe` H6+ headingLevelFromInt 7 `shouldBe` H6+ headingLevelFromInt 99 `shouldBe` H6+ specify "parse" $+ parse sampleSource `shouldBe` sampleDocument+ specify "filterReferences" $+ filterReferences [ "A paragraph that consists of a "+ , Link "http://nirum.org/" ""+ [ Emphasis ["hyper"], " link" ]+ , " and an "+ , Image "./img.png" "image"+ , "."+ ]+ `shouldBe`+ [ "A paragraph that consists of a "+ , Emphasis ["hyper"]+ , " link"+ , " and an "+ , "image"+ , "."+ ]
+ test/Nirum/Package/MetadataSpec.hs view
@@ -0,0 +1,267 @@+{-# LANGUAGE QuasiQuotes, TypeFamilies #-}+module Nirum.Package.MetadataSpec where++import Control.Monad (forM_)+import Data.Char (isSpace)+import Data.Either (isRight)+import Data.Maybe (fromJust)++import qualified Data.HashMap.Strict as HM+import qualified Data.Map.Strict as M+import qualified Data.SemVer as SV+import Data.Text (Text)+import Data.Text.Encoding (encodeUtf8)+import System.FilePath ((</>))+import Test.Hspec.Meta+import Text.InterpolatedString.Perl6 (q)+import qualified Text.Parsec.Error as PE+import Text.Parsec.Pos (sourceColumn, sourceLine)+import Text.Toml (parseTomlDoc)++import Nirum.Package.Metadata ( Metadata (Metadata, version)+ , MetadataError ( FieldError+ , FieldTypeError+ , FieldValueError+ , FormatError+ )+ , Target ( CompileError+ , CompileResult+ , compilePackage+ , parseTarget+ , showCompileError+ , targetName+ , toByteString+ )+ , fieldType+ , metadataFilename+ , metadataPath+ , parseMetadata+ , prependMetadataErrorField+ , readFromPackage+ , readMetadata+ , stringField+ , versionField+ )++stripPrefix :: String -> String+stripPrefix = dropWhile isSpace+ignoreLines :: String -> String+ignoreLines = concatMap stripPrefix . lines++spec :: Spec+spec =+ describe "Metadata" $ do+ specify "prependMetadataErrorField" $ do+ prependMetadataErrorField "targets" (FieldError "python")+ `shouldBe` FieldError "targets.python"+ prependMetadataErrorField "targets"+ (FieldTypeError "python" "table" "string")+ `shouldBe` FieldTypeError "targets.python" "table" "string"+ prependMetadataErrorField "prefix" (FieldValueError "version" "1a")+ `shouldBe` FieldValueError "prefix.version" "1a"+ describe "parseMetadata" $ do+ it "returns Metadata if the package.toml is valid" $ do+ let parsed = parse [q|version = "1.2.3"+ [targets.dummy]|]+ parsed `shouldSatisfy` isRight+ let Right metadata = parsed+ Metadata { version = v } = metadata+ v `shouldBe` SV.version 1 2 3 [] []+ it ("returns MetadataError (FormatError) if the package.toml is " +++ "not a valid TOML file") $ do+ let Left (FormatError e) = parse "version = 0.3.0"+ sourceLine (PE.errorPos e) `shouldBe` 1+ sourceColumn (PE.errorPos e) `shouldBe` 14+ it ("returns MetadataError (FieldError) if the package.toml " +++ "lacks any required fields") $ do+ let Left (FieldError field) = parse ""+ field `shouldBe` "version"+ it ("returns MetadataError (FieldTypeError) if some fields of " +++ "the package.toml has a value of unexpected type") $+ forM_ [ ( "version = 123"+ , "version"+ , "string"+ , "integer (123)"+ )+ , ( [q|version = "1.2.3"+ [authors]+ name = "John Doe"+ |]+ , "authors"+ , "array of tables"+ , "table of an item"+ )+ , ( [q|version = "1.2.3"+ [[authors]]+ name = 123+ |]+ , "name"+ , "string"+ , "integer (123)"+ )+ , ( [q|version = "1.2.3"+ [[authors]]+ name = "John Doe"+ [[authors]]+ name = 456+ |]+ , "name"+ , "string"+ , "integer (456)"+ )+ , ( [q|version = "1.2.3"+ [[authors]]+ name = "John Doe"+ email = "john@example.com"+ [[authors]]+ name = "Hong Minhee"+ email = []+ |]+ , "email"+ , "string"+ , "array of 0 values"+ )+ , ( [q|version = "1.2.3"+ description = 123+ |]+ , "description"+ , "string"+ , "integer (123)"+ )+ , ( [q|version = "1.2.3"+ license = 123+ |]+ , "license"+ , "string"+ , "integer (123)"+ )+ , ( [q|version = "1.2.3"+ keywords = "sample example nirum"+ |]+ , "keywords"+ , "array"+ , "string (sample example nirum)"+ )+ ] $ \ (toml, field, expected, actual) -> do+ let Left e = parse toml+ FieldTypeError field' expected' actual' = e+ field' `shouldBe` field+ expected' `shouldBe` expected+ actual' `shouldBe` actual+ it ("returns MetadataError (FieldValueError) if some fields of " +++ "the package.toml has an invalid/malformed value") $+ forM_ [ ( [q|version = "0/3/0"|]+ , "version"+ , [q|expected a semver string (e.g. "1.2.3")+ , not "0/3/0"|]+ )+ , ( [q|version = "1.2.3"+ [[authors]]+ name = "John Doe"+ email = "invalid#email"+ |]+ , "email"+ , [q|expected an email address, not invalid#email+ ; at sign > @: not enough input|]+ )+ ] $ \ (toml, field, msg) -> do+ let Left e = parse toml+ FieldValueError field' msg' = e+ field' `shouldBe` field+ msg' `shouldBe` ignoreLines msg+ let examplePackagePath = "." </> "examples"+ samplePackagePath = "." </> "test" </> "metadata_error"+ readMetadata' = readMetadata+ :: FilePath -> IO (Either MetadataError (Metadata DummyTarget))+ describe "readMetadata" $ do+ it "returns Metadata if the package.toml is valid" $ do+ readResult <- readMetadata' $ metadataPath examplePackagePath+ readResult `shouldSatisfy` isRight+ let Right metadata = readResult+ Metadata { version = v } = metadata+ v `shouldBe` SV.version 0 3 0 [] []+ it "returns MetadataError if the package.toml is invalid" $ do+ r <- readMetadata' $ metadataPath samplePackagePath+ let Left (FormatError e) = r+ sourceLine (PE.errorPos e) `shouldBe` 3+ sourceColumn (PE.errorPos e) `shouldBe` 14+ specify "metadataPath" $+ metadataPath "asdf" `shouldBe` "asdf" </> metadataFilename+ specify "readFromPackage" $+ forM_ [examplePackagePath, samplePackagePath] $ \ pkgPath -> do+ r <- readFromPackage pkgPath+ r' <- readMetadata' $ metadataPath pkgPath+ r `shouldBe` r'+ specify "stringField" $ do+ let Right table = parseTomlDoc "<string>" [q|foo = "success"+ bar = 1|]+ stringField "foo" table `shouldBe` Right "success"+ stringField "bar" table `shouldBe`+ Left (FieldTypeError "bar" "string" "integer (1)")+ stringField "qux" table `shouldBe` Left (FieldError "qux")+ specify "versionField" $ do+ let Right table = parseTomlDoc "<string>"+ [q|a = "1.0.0"+ b = "1.2.3"+ c = "1.0"+ d = 1.0+ e = "1.2.3.4"|]+ versionField "a" table `shouldBe` Right (SV.version 1 0 0 [] [])+ versionField "b" table `shouldBe` Right (SV.version 1 2 3 [] [])+ versionField "c" table `shouldBe` Left (FieldValueError "c"+ "expected a semver string (e.g. \"1.2.3\"), not \"1.0\"")+ versionField "d" table `shouldBe`+ Left (FieldTypeError "d" "string" "float (1.0)")+ versionField "e" table `shouldBe` Left (FieldValueError "e"+ "expected a semver string (e.g. \"1.2.3\"), not \"1.2.3.4\"")+ specify "fieldType" $ do+ let Right table = parseTomlDoc "<string>"+ [q|s = "foobar"+ i = 123+ f = 3.14+ bt = true+ bf = false+ d = 2017-03-16T10:56:30Z+ a0 = []+ a1 = ["foobar"]+ a3 = ["foo", "bar", "baz"]+ t0 = {}+ t1 = { a = 1 }+ [t2]+ a = 1+ b = 2+ [[ta]]+ a = 1+ b = 2+ [[ta]]+ c = 3+ d = 4|]+ get = fromJust . (`HM.lookup` table)+ fieldType (get "s") `shouldBe` "string (foobar)"+ fieldType (get "i") `shouldBe` "integer (123)"+ fieldType (get "f") `shouldBe` "float (3.14)"+ fieldType (get "bt") `shouldBe` "boolean (true)"+ fieldType (get "bf") `shouldBe` "boolean (false)"+ fieldType (get "d") `shouldBe` "datetime (2017-03-16 10:56:30 UTC)"+ fieldType (get "a0") `shouldBe` "array of 0 values"+ fieldType (get "a1") `shouldBe` "array of a value"+ fieldType (get "a3") `shouldBe` "array of 3 values"+ fieldType (get "t0") `shouldBe` "table of 0 items"+ fieldType (get "t1") `shouldBe` "table of an item"+ fieldType (get "t2") `shouldBe` "table of 2 items"+ fieldType (get "ta") `shouldBe` "array of 2 tables"+ where+ parse :: Text -> Either MetadataError (Metadata DummyTarget)+ parse = parseMetadata "<string>"+++data DummyTarget = DummyTarget deriving (Eq, Ord, Show)++instance Target DummyTarget where+ type CompileResult DummyTarget = Text+ type CompileError DummyTarget = Text+ targetName _ = "dummy"+ parseTarget _ = return DummyTarget+ compilePackage _ = M.empty+ showCompileError _ e = e+ toByteString _ = encodeUtf8
+ test/Nirum/Package/ModuleSetSpec.hs view
@@ -0,0 +1,152 @@+{-# LANGUAGE OverloadedLists, TypeFamilies #-}+module Nirum.Package.ModuleSetSpec where++import Data.List (sort, sortOn)+import Data.Maybe (isNothing)+import Prelude hiding (length, lookup, null)++import qualified Data.Map.Strict as M+import qualified Data.Set as S+import Test.Hspec.Meta++import Nirum.Constructs.Annotation (empty)+import Nirum.Constructs.ModulePath (ModulePath)+import Nirum.Constructs.Module (Module (Module))+import Nirum.Constructs.TypeDeclaration ( Type (Alias)+ , TypeDeclaration ( Import+ , TypeDeclaration+ )+ )+import Nirum.Package.ModuleSet ( ImportError ( CircularImportError+ , MissingImportError+ , MissingModulePathError+ )+ , fromList+ , fromMap+ , keys+ , keysSet+ , length+ , lookup+ , null+ , toAscList+ , toList+ , toMap+ )++fooBarModule :: Module+fooBarModule = Module [] $ Just "foo.bar"++validModules :: [(ModulePath, Module)]+validModules =+ [ ( ["abc"]+ , Module [TypeDeclaration "a" (Alias "text") empty]+ Nothing+ )+ , (["foo"], Module [] $ Just "foo")+ , (["foo", "bar"], fooBarModule)+ , (["foo", "baz"], Module [] $ Just "foo.baz")+ , (["qux"], Module [] $ Just "qux")+ , ( ["xyz"]+ , Module [ Import ["abc"] "a" empty+ , TypeDeclaration "x" (Alias "text") empty+ ] Nothing+ )+ ]++missingImportsModules :: [(ModulePath, Module)]+missingImportsModules =+ [ ( ["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") empty ] Nothing+ )+ , (["qux"], Module [ Import ["foo"] "abc" empty -- MissingImportError+ , Import ["foo"] "def" empty -- MissingImportError+ ] Nothing)+ ]++circularImportsModules :: [(ModulePath, Module)]+circularImportsModules =+ [ (["asdf"], Module [ Import ["asdf"] "foo" empty+ , TypeDeclaration "bar" (Alias "text") empty+ ] Nothing)+ , (["abc", "def"], Module [ Import ["abc", "ghi"] "bar" empty+ , TypeDeclaration+ "foo" (Alias "text") empty+ ] Nothing)+ , (["abc", "ghi"], Module [ Import ["abc", "xyz"] "baz" empty+ , TypeDeclaration+ "bar" (Alias "text") empty+ ] Nothing)+ , (["abc", "xyz"], Module [ Import ["abc", "def"] "foo" empty+ , TypeDeclaration+ "baz" (Alias "text") empty+ ] Nothing)+ ]++spec :: Spec+spec =+ describe "ModuleSet" $ do+ context "(Map ModulePath Module)" $+ testImportErrors (fromMap . M.fromList)+ context "(Map ModulePath Module)" $+ testImportErrors fromList+ specify "fromMap" $ do+ let Right moduleSet = fromMap $ M.fromList validModules+ toAscList moduleSet `shouldBe` validModules+ specify "fromList" $ do+ let Right moduleSet = fromList validModules+ toAscList moduleSet `shouldBe` validModules+ let Right validModuleSet = fromList validModules+ specify "toMap" $+ toMap validModuleSet `shouldBe` M.fromList validModules+ specify "toList" $+ sortOn fst (toList validModuleSet) `shouldBe` validModules+ specify "toAscList" $+ toAscList validModuleSet `shouldBe` validModules+ specify "keys" $+ sort (keys validModuleSet) `shouldBe`+ sort [path | (path, _) <- validModules]+ specify "keysSet" $+ keysSet validModuleSet `shouldBe`+ S.fromList [p | (p, _) <- validModules]+ specify "lookup" $ do+ let Just mod' = lookup ["foo", "bar"] validModuleSet+ mod' `shouldBe` fooBarModule+ lookup ["wrong", "path"] validModuleSet `shouldSatisfy` isNothing+ specify "length" $+ length validModuleSet `shouldBe` 6+ specify "null" $+ validModuleSet `shouldNotSatisfy` null+ where+ testImportErrors makeModuleSet = do+ specify "detectMissingImports" $+ makeModuleSet missingImportsModules `shouldBe`+ Left [ MissingModulePathError ["foo"] ["foo", "bar"]+ , MissingImportError ["qux"] ["foo"] "abc"+ , MissingImportError ["qux"] ["foo"] "def"+ ]+ specify "detectCircularImports" $+ makeModuleSet circularImportsModules `shouldBe`+ Left [ CircularImportError [["asdf"], ["asdf"]]+ , MissingImportError ["asdf"] ["asdf"] "foo"+ , CircularImportError [ ["abc", "def"]+ , ["abc", "ghi"]+ , ["abc", "xyz"]+ , ["abc", "def"]+ ]+ , CircularImportError [ ["abc", "ghi"]+ , ["abc", "xyz"]+ , ["abc", "def"]+ , ["abc", "ghi"]+ ]+ , CircularImportError [ ["abc", "xyz"]+ , ["abc", "def"]+ , ["abc", "ghi"]+ , ["abc", "xyz"]+ ]+ ]
test/Nirum/PackageSpec.hs view
@@ -1,101 +1,65 @@-{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedLists, OverloadedStrings, QuasiQuotes,+ ScopedTypeVariables #-} module Nirum.PackageSpec where -import Data.Either (isRight)-import qualified Data.Map.Strict as M+import Data.Either (isLeft, isRight)+import Data.Proxy (Proxy (Proxy))+import System.IO.Error (isDoesNotExistError)++import qualified Data.SemVer as SV import System.FilePath ((</>)) import Test.Hspec.Meta+import Text.InterpolatedString.Perl6 (qq)+import qualified Text.Parsec.Error as PE+import Text.Parsec.Pos (sourceColumn, sourceLine) -import Nirum.Constructs.Annotation (empty)-import Nirum.Constructs.Module (Module(Module), coreModulePath)+import Nirum.Constructs.Module import Nirum.Constructs.ModulePath (ModulePath)-import Nirum.Constructs.TypeDeclaration ( JsonType(String)- , PrimitiveTypeIdentifier(Text)- , Type(Alias, PrimitiveType)- , TypeDeclaration ( Import- , TypeDeclaration- )- )-import Nirum.Package ( BoundModule(boundPackage, modulePath)- , ImportError ( CircularImportError- , MissingImportError- , MissingModulePathError- )- , Package- , PackageError (ImportError)- , TypeLookup(Imported, Local, Missing)- , docs- , lookupType- , makePackage- , resolveBoundModule- , resolveModule- , scanModules- , scanPackage- , types- )+import Nirum.Package hiding (modules, target)+import Nirum.Package.Metadata ( Metadata ( Metadata+ , authors+ , target+ , version+ , description+ , license+ , keywords+ )+ , MetadataError (FormatError)+ , Target (targetName)+ )+import Nirum.Package.MetadataSpec (DummyTarget (DummyTarget))+import Nirum.Package.ModuleSet ( ImportError (MissingModulePathError)+ , fromList+ )+import Nirum.Package.ModuleSetSpec (validModules) import Nirum.Parser (parseFile)+import Nirum.Targets.Python (Python (Python), minimumRuntime) -createPackage :: M.Map ModulePath Module -> Package-createPackage modules' =- case makePackage modules' of- Right pkg -> pkg+createPackage :: Metadata t -> [(ModulePath, Module)] -> Package t+createPackage metadata' modules' =+ case fromList modules' of+ Right ms -> Package metadata' ms Left e -> error $ "errored: " ++ show e -validPackage :: Package-validPackage =- createPackage [ (["foo", "bar"], Module [] $ Just "foo.bar")- , (["foo", "baz"], Module [] $ Just "foo.baz")- , (["foo"], Module [] $ Just "foo")- , (["qux"], Module [] $ Just "qux")- , ( ["abc"]- , Module [TypeDeclaration "a" (Alias "text") empty]- Nothing- )- , ( ["xyz"]- , Module [ Import ["abc"] "a" empty- , TypeDeclaration "x" (Alias "text") empty- ] Nothing- )- ]--missingImportsModules :: M.Map ModulePath Module-missingImportsModules =- [ ( ["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") empty ] Nothing- )- , (["qux"], Module [ Import ["foo"] "abc" empty -- MissingImportError- , Import ["foo"] "def" empty -- MissingImportError- ] Nothing)- ]--circularImportsModules :: M.Map ModulePath Module-circularImportsModules =- [ (["asdf"], Module [ Import ["asdf"] "foo" empty- , TypeDeclaration "bar" (Alias "text") empty- ] Nothing)- , (["abc", "def"], Module [ Import ["abc", "ghi"] "bar" empty- , TypeDeclaration- "foo" (Alias "text") empty- ] Nothing)- , (["abc", "ghi"], Module [ Import ["abc", "xyz"] "baz" empty- , TypeDeclaration- "bar" (Alias "text") empty- ] Nothing)- , (["abc", "xyz"], Module [ Import ["abc", "def"] "foo" empty- , TypeDeclaration- "baz" (Alias "text") empty- ] Nothing)- ]+createValidPackage :: t -> Package t+createValidPackage t = createPackage Metadata { version = SV.initial+ , authors = []+ , description = Nothing+ , license = Nothing+ , keywords = []+ , target = t+ } validModules spec :: Spec spec = do- describe "Package" $ do+ testPackage (Python "nirum-examples" minimumRuntime [])+ testPackage DummyTarget++testPackage :: forall t . Target t => t -> Spec+testPackage target' = do+ let targetName' = targetName (Proxy :: Proxy t)+ validPackage = createValidPackage target'+ describe [qq|Package (target: $targetName')|] $ do specify "resolveModule" $ do resolveModule ["foo"] validPackage `shouldBe` Just (Module [] $ Just "foo")@@ -104,103 +68,65 @@ resolveModule ["qux"] validPackage `shouldBe` Just (Module [] $ Just "qux") resolveModule ["baz"] validPackage `shouldBe` Nothing- specify "resolveBoundModule" $ do- let Just bm = resolveBoundModule ["foo"] validPackage- boundPackage bm `shouldBe` validPackage- modulePath bm `shouldBe` ["foo"]- resolveBoundModule ["baz"] validPackage `shouldBe` Nothing- specify "detectMissingImports" $- makePackage missingImportsModules `shouldBe`- Left [ MissingModulePathError ["foo"] ["foo", "bar"]- , MissingImportError ["qux"] ["foo"] "abc"- , MissingImportError ["qux"] ["foo"] "def"- ]- specify "detectCircularImports" $- makePackage circularImportsModules `shouldBe`- Left [ CircularImportError [["asdf"], ["asdf"]]- , MissingImportError ["asdf"] ["asdf"] "foo"- , CircularImportError [ ["abc", "def"]- , ["abc", "ghi"]- , ["abc", "xyz"]- , ["abc", "def"]- ]- , CircularImportError [ ["abc", "ghi"]- , ["abc", "xyz"]- , ["abc", "def"]- , ["abc", "ghi"]- ]- , CircularImportError [ ["abc", "xyz"]- , ["abc", "def"]- , ["abc", "ghi"]- , ["abc", "xyz"]- ]- ]- specify "scanPackage" $ do- let path = "." </> "examples"- 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")- Right countriesM <- parseFile (path </> "countries.nrm")- Right addressM <- parseFile (path </> "address.nrm")- Right pdfServiceM <- parseFile (path </> "pdf-service.nrm")- let modules = [ (["builtins"], builtinsM)- , (["product"], productM)- , (["shapes"], shapesM)- , (["countries"], countriesM)- , (["address"], addressM)- , (["pdf-service"], pdfServiceM)- ] :: M.Map ModulePath Module- package `shouldBe` createPackage modules- Left error' <- scanPackage $ "." </> "test" </> "import_error"- error' `shouldBe`- ImportError [MissingModulePathError ["import_error"] ["foo"]]+ describe "scanPackage" $ do+ it "returns Package value when all is well" $ do+ let path = "." </> "examples"+ package' <- scanPackage' path+ package' `shouldSatisfy` isRight+ let Right package = package'+ Right blockchainM <- parseFile (path </> "blockchain.nrm")+ Right builtinsM <- parseFile (path </> "builtins.nrm")+ Right productM <- parseFile (path </> "product.nrm")+ Right shapesM <- parseFile (path </> "shapes.nrm")+ Right countriesM <- parseFile (path </> "countries.nrm")+ Right addressM <- parseFile (path </> "address.nrm")+ Right pdfServiceM <- parseFile (path </> "pdf-service.nrm")+ let modules = [ (["blockchain"], blockchainM)+ , (["builtins"], builtinsM)+ , (["product"], productM)+ , (["shapes"], shapesM)+ , (["countries"], countriesM)+ , (["address"], addressM)+ , (["pdf-service"], pdfServiceM)+ ] :: [(ModulePath, Module)]+ metadata' = Metadata { version = SV.version 0 3 0 [] []+ , authors = []+ , description = Nothing+ , license = Nothing+ , keywords = []+ , target = target'+ }+ metadata package `shouldBe` metadata'+ package `shouldBe` createPackage metadata' modules+ let testDir = "." </> "test"+ it "returns ScanError if the directory lacks package.toml" $ do+ scanResult <- scanPackage' $ testDir </> "scan_error"+ scanResult `shouldSatisfy` isLeft+ let Left (ScanError filePath ioError') = scanResult+ filePath `shouldBe` testDir </> "scan_error" </> "package.toml"+ ioError' `shouldSatisfy` isDoesNotExistError+ it "returns MetadataError if the package.toml is invalid" $ do+ scanResult <- scanPackage' $ testDir </> "metadata_error"+ scanResult `shouldSatisfy` isLeft+ let Left (MetadataError (FormatError e)) = scanResult+ sourceLine (PE.errorPos e) `shouldBe` 3+ sourceColumn (PE.errorPos e) `shouldBe` 14+ it "returns ImportError if a module imports an absent module" $ do+ scanResult <- scanPackage' $ testDir </> "import_error"+ scanResult `shouldSatisfy` isLeft+ let Left (ImportError l) = scanResult+ l `shouldBe` [MissingModulePathError ["import_error"] ["foo"]] specify "scanModules" $ do let path = "." </> "examples"- mods <- scanModules "."- mods `shouldBe`- [ (["examples", "builtins"], path </> "builtins.nrm")- , (["examples", "product"], path </> "product.nrm")- , (["examples", "shapes"], path </> "shapes.nrm")- , (["examples", "countries"], path </> "countries.nrm")- , (["examples", "address"], path </> "address.nrm")- , (["examples", "pdf-service"], path </> "pdf-service.nrm")- , ( ["test", "import_error", "import_error"]- , "." </> "test" </> "import_error" </> "import_error.nrm"- )- ] mods' <- scanModules path- mods' `shouldBe` [ (["builtins"], path </> "builtins.nrm")+ mods' `shouldBe` [ (["blockchain"], path </> "blockchain.nrm")+ , (["builtins"], path </> "builtins.nrm") , (["product"], path </> "product.nrm") , (["shapes"], path </> "shapes.nrm") , (["countries"], path </> "countries.nrm") , (["address"], path </> "address.nrm") , (["pdf-service"], path </> "pdf-service.nrm") ]- describe "BoundModule" $ do- let Just bm = resolveBoundModule ["foo", "bar"] validPackage- Just abc = resolveBoundModule ["abc"] validPackage- Just xyz = resolveBoundModule ["xyz"] validPackage- specify "docs" $ do- docs bm `shouldBe` Just "foo.bar"- let Just bm' = resolveBoundModule ["foo"] validPackage- docs bm' `shouldBe` Just "foo"- specify "types" $ do- types bm `shouldBe` []- 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- lookupType "a" abc `shouldBe` Local (Alias "text")- lookupType "a" xyz `shouldBe` Imported ["abc"] (Alias "text")- lookupType "x" bm `shouldBe` Missing- lookupType "x" abc `shouldBe` Missing- lookupType "x" xyz `shouldBe` Local (Alias "text")- lookupType "text" bm `shouldBe`- Imported coreModulePath (PrimitiveType Text String)- lookupType "text" abc `shouldBe` lookupType "text" bm- lookupType "text" xyz `shouldBe` lookupType "text" bm+ where+ scanPackage' :: FilePath -> IO (Either PackageError (Package t))+ scanPackage' = scanPackage
test/Nirum/ParserSpec.hs view
@@ -1,44 +1,40 @@-{-# LANGUAGE OverloadedLists, TypeFamilies #-}+{-# LANGUAGE OverloadedLists, QuasiQuotes, TypeFamilies #-} module Nirum.ParserSpec where import Control.Monad (forM_)-import Data.Either (isLeft, isRight, lefts, rights)+import Data.Either import Data.List (isSuffixOf) import Data.Maybe (fromJust)-import Prelude hiding (readFile) import System.Directory (getDirectoryContents) +import qualified Data.ByteString as B import qualified Data.List.NonEmpty as NE+import Data.String.QQ (s) import qualified Data.Text as T-import Data.Text.IO (readFile)+import qualified Data.Text.Encoding as E import Test.Hspec.Meta import Text.Megaparsec (eof, runParser) import Text.Megaparsec.Char (string) import Text.Megaparsec.Error (errorPos, parseErrorPretty)-import Text.Megaparsec.Pos (Pos, SourcePos(sourceColumn, sourceLine), mkPos)+import Text.Megaparsec.Pos (Pos, SourcePos (sourceColumn, sourceLine), mkPos) import Text.Megaparsec.Text (Parser) import qualified Nirum.Parser as P import Nirum.Constructs (Construct (toCode))-import Nirum.Constructs.Annotation as A ( Annotation (Annotation)- , AnnotationSet- , empty- , fromList- , union- )+import Nirum.Constructs.Annotation as A import Nirum.Constructs.Docs (Docs (Docs)) import Nirum.Constructs.DeclarationSet (DeclarationSet)-import Nirum.Constructs.DeclarationSetSpec (SampleDecl(..))+import Nirum.Constructs.DeclarationSetSpec (SampleDecl (..)) import Nirum.Constructs.Identifier (fromText) import Nirum.Constructs.Module (Module (Module))-import Nirum.Constructs.Name (Name(..))+import Nirum.Constructs.Name (Name (..)) import Nirum.Constructs.Service ( Method (Method) , Parameter (Parameter) , Service (Service) ) import Nirum.Constructs.TypeDeclaration ( EnumMember (EnumMember) , Field (Field, fieldAnnotations)- , Tag (Tag, tagFields)+ , Tag (Tag, tagAnnotations, tagFields) , Type (..) , TypeDeclaration (..) )@@ -86,10 +82,10 @@ fooAnnotationSet :: AnnotationSet-fooAnnotationSet = head $ rights [fromList [Annotation "foo" (Just "bar")]]+fooAnnotationSet = A.singleton $ Annotation "foo" [("v", "bar")] bazAnnotationSet :: AnnotationSet-bazAnnotationSet = head $ rights [fromList [Annotation "baz" Nothing]]+bazAnnotationSet = A.singleton $ Annotation "baz" [] spec :: Spec@@ -118,13 +114,13 @@ expectError "ident-_ifier" 1 7 expectError "ident_-ifier" 1 7 it "fails to parse an identifier containing disallowed chars" $ do- expectError "무효한-식별자" 1 1- expectError "invalid-식별자" 1 9+ expectError "\xbb34\xd6a8\xd55c-\xc2dd\xbcc4\xc790" 1 1+ expectError "invalid-\xc2dd\xbcc4\xc790" 1 9 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 ->+ forM_ keywords $ \ kwd -> expectError kwd 1 1 let identifier' = fromJust . fromText it "emits Identifier if succeeded to parse" $ do@@ -133,8 +129,11 @@ identifier' "valid-identifier" parse' "valid_identifier" `shouldBeRight` identifier' "valid_identifier"+ it "can parse even if a keyword is a prefix of identifier" $ do+ parse' "enumeration" `shouldBeRight` identifier' "enumeration"+ parse' "types" `shouldBeRight` identifier' "types" it "can parse reserved keywords iff they are quoted" $- forM_ keywords $ \kwd ->+ forM_ keywords $ \ kwd -> parse' ('`' `T.cons` kwd `T.snoc` '`') `shouldBeRight` identifier' kwd @@ -149,8 +148,8 @@ expectError "ident-ifier-" 1 13 expectError "ident--ifier" 1 7 expectError "ident__ifier" 1 7- expectError "무효한-식별자" 1 1- expectError "invalid-식별자" 1 9+ expectError "\xbb34\xd6a8\xd55c-\xc2dd\xbcc4\xc790" 1 1+ expectError "invalid-\xc2dd\xbcc4\xc790" 1 9 it "fails to parse if the facial name is not a valid identifier" $ do expectError "-ident/valid" 1 1 expectError "-ident-ifier/valid" 1 1@@ -158,8 +157,8 @@ expectError "ident-ifier-/valid" 1 13 expectError "ident--ifier/valid" 1 7 expectError "ident__ifier/valid" 1 7- expectError "무효한-식별자/valid" 1 1- expectError "invalid-식별자/valid" 1 9+ expectError "\xbb34\xd6a8\xd55c-\xc2dd\xbcc4\xc790/valid" 1 1+ expectError "invalid-\xc2dd\xbcc4\xc790/valid" 1 9 it "fails to parse if the behind name is not a valid identifier" $ do expectError "valid/-ident" 1 6 expectError "valid/-ident-ifier" 1 6@@ -167,8 +166,8 @@ expectError "valid/ident-ifier-" 1 6 expectError "valid/ident--ifier" 1 6 expectError "valid/ident__ifier" 1 6- expectError "valid/무효한-식별자" 1 6- expectError "valid/invalid-식별자" 1 6+ expectError "valid/\xbb34\xd6a8\xd55c-\xc2dd\xbcc4\xc790" 1 6+ expectError "valid/invalid-\xc2dd\xbcc4\xc790" 1 6 it "emits Name if succeeded to parse" $ do parse' "name" `shouldBeRight` Name "name" "name" parse' "`enum`" `shouldBeRight` Name "enum" "enum"@@ -180,26 +179,33 @@ describe "annotation" $ do let (parse', expectError) = helperFuncs P.annotation context "with single argument" $ do- let rightAnnotaiton = Annotation "name-abc" (Just "wo\"rld")+ let rightAnnotaiton = Annotation "name-abc" [("foo", "wo\"rld")] it "success" $ do- parse' "@name-abc(\"wo\\\"rld\")" `shouldBeRight` rightAnnotaiton- parse' "@name-abc( \"wo\\\"rld\")" `shouldBeRight` rightAnnotaiton- parse' "@name-abc(\"wo\\\"rld\" )" `shouldBeRight` rightAnnotaiton- parse' "@name-abc( \"wo\\\"rld\" )" `shouldBeRight` rightAnnotaiton- 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")+ parse' "@name-abc(foo=\"wo\\\"rld\")"+ `shouldBeRight` rightAnnotaiton+ parse' "@name-abc( foo=\"wo\\\"rld\")"+ `shouldBeRight` rightAnnotaiton+ parse' "@name-abc(foo=\"wo\\\"rld\" )"+ `shouldBeRight` rightAnnotaiton+ parse' "@name-abc( foo=\"wo\\\"rld\" )"+ `shouldBeRight` rightAnnotaiton+ parse' "@ name-abc ( foo=\"wo\\\"rld\")"+ `shouldBeRight` rightAnnotaiton+ parse' "@name-abc ( foo=\"wo\\\"rld\")"+ `shouldBeRight` rightAnnotaiton+ parse' "@name-abc(foo=\"wo\\\"rld\\n\")" `shouldBeRight`+ Annotation "name-abc" [("foo", "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+ expectError "@-abc(v=\"helloworld\")" 1 2+ expectError "@-abc-d(v = \"helloworld\")" 1 2 it "fails to parse without parentheses" $ expectError "@foobar \"helloworld\"" 1 9- it "fails to parse without double quotes" $- expectError "@foobar(helloworld)" 1 9+ it "fails to parse arguments without names" $+ expectError "@foobar(\"helloworld\")" 1 9+ it "fails to parse arguments without double quotes" $+ expectError "@foobar(v=helloworld)" 1 11 context "without arguments" $ do- let rightAnnotaiton = Annotation "name-abc" Nothing+ let rightAnnotaiton = Annotation "name-abc" [] it "success" $ do parse' "@name-abc" `shouldBeRight` rightAnnotaiton parse' "@name-abc " `shouldBeRight` rightAnnotaiton@@ -213,16 +219,16 @@ describe "annotationSet" $ do let (parse', expectError) = helperFuncs P.annotationSet- annotationSet = head $ rights [fromList [ Annotation "a" (Just "b")- , Annotation "c" Nothing- ]- ]+ Right annotationSet = fromList+ [ Annotation "a" [("arg", "b")]+ , Annotation "c" []+ ] it "success" $ do- parse' "@a(\"b\")@c" `shouldBeRight` annotationSet- parse' "@a(\"b\") @c" `shouldBeRight` annotationSet- parse' "@a(\"b\") @c() " `shouldBeRight` annotationSet+ parse' "@a(arg=\"b\")@c" `shouldBeRight` annotationSet+ parse' "@a(arg=\"b\") @c" `shouldBeRight` annotationSet+ parse' "@a(arg=\"b\") @c() " `shouldBeRight` annotationSet it "fails to parse if has duplicated name" $- expectError "@a(\"b\")@a" 1 10+ expectError "@a(arg=\"b\")@a" 1 14 describe "typeIdentifier" $ do let (parse', expectError) = helperFuncs P.typeIdentifier@@ -239,7 +245,7 @@ let parsers = [ P.optionModifier , P.typeExpression ] :: [Parser TypeExpression]- forM_ parsers $ \parser' -> do+ forM_ parsers $ \ parser' -> do let (parse', expectError) = helperFuncs parser' it "cannot append two or more option modifiers" $ do expectError "text??" 1 6@@ -260,7 +266,7 @@ let parsers = [ (1, P.setModifier) , (29, P.typeExpression) ] :: [(Int, Parser TypeExpression)]- forM_ parsers $ \(beginErrorPos, parser') -> do+ forM_ parsers $ \ (beginErrorPos, parser') -> do let (parse', expectError) = helperFuncs parser' it "fails to parse if input doesn't start with a curly bracket" $ expectError "not-start-with-curly-bracket}" 1 beginErrorPos@@ -284,7 +290,7 @@ let parsers = [ (1, P.listModifier) , (30, P.typeExpression) ] :: [(Int, Parser TypeExpression)]- forM_ parsers $ \(beginErrorPos, parser') -> do+ forM_ parsers $ \ (beginErrorPos, parser') -> do let (parse', expectError) = helperFuncs parser' it "fails to parse if input doesn't start with a square bracket" $ expectError "not-start-with-square-bracket]" 1 beginErrorPos@@ -308,7 +314,7 @@ let parsers = [ (1, P.mapModifier) , (15, P.typeExpression) ] :: [(Int, Parser TypeExpression)]- forM_ parsers $ \(beginErrorPos, parser') -> do+ forM_ parsers $ \ (beginErrorPos, parser') -> do let (parse', expectError) = helperFuncs parser' it "fails to parse if input doesn't start with a curly bracket" $ expectError "not-start-with: curly-bracket}" 1 beginErrorPos@@ -357,13 +363,14 @@ let parsers = [ (label, parser) , (label ++ " (typeDescription)", P.typeDeclaration) ] :: [(String, Parser TypeDeclaration)]- in forM_ parsers $ \(label', parser') ->+ in forM_ parsers $ \ (label', parser') -> describe label' $ spec' $ helperFuncs parser' describe "handleNameDuplication" $ do- let cont dset = do _ <- string "a"- return dset :: Parser (DeclarationSet SampleDecl)+ let cont dset = do+ _ <- string "a"+ return dset :: Parser (DeclarationSet SampleDecl) it "fails if there are any duplication on facial names" $ do let ds = [ "a" , "b"@@ -393,7 +400,7 @@ parse' "a" `shouldBeRight` (["a", "b", "c"] :: DeclarationSet SampleDecl) - descTypeDecl "aliasTypeDeclaration" P.aliasTypeDeclaration $ \helpers -> do+ descTypeDecl "aliasTypeDeclaration" P.aliasTypeDeclaration $ \ helpers -> do let (parse', expectError) = helpers it "emits (TypeDeclaration (Alias ...)) if succeeded to parse" $ do parse' "type path = text;" `shouldBeRight`@@ -404,7 +411,7 @@ parse' "type path = text;\n# docs\n# docs..." `shouldBeRight` TypeDeclaration "path" (Alias "text") (singleDocs "docs\ndocs...\n")- parse' "@foo ( \"bar\" ) type path = text;\n# docs\n# docs..."+ parse' "@foo ( v = \"bar\" ) type path = text;\n# docs\n# docs..." `shouldBeRight` TypeDeclaration "path" (Alias "text") (A.union (singleDocs "docs\ndocs...\n")@@ -414,8 +421,8 @@ TypeDeclaration "path" (Alias "text") (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" $+ 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'@@ -423,7 +430,8 @@ 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 "unboxedTypeDeclaration" P.unboxedTypeDeclaration $ \funs -> do+ descTypeDecl "unboxedTypeDeclaration"+ P.unboxedTypeDeclaration $ \ funs -> do let (parse', expectError) = funs it "emits (TypeDeclaration (UnboxedType ..)) if succeeded to parse" $ do parse' "unboxed offset (float64);" `shouldBeRight`@@ -431,12 +439,14 @@ 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..."+ parse' "unboxed offset (float64);\n# docs\n# docs..." `shouldBeRight` TypeDeclaration "offset" (UnboxedType "float64")+ (singleDocs "docs\ndocs...\n")+ parse' "@foo(v=\"bar\")\nunboxed offset (float64);\n# docs\n\+ \# docs..."+ `shouldBeRight`+ TypeDeclaration "offset" (UnboxedType "float64") (A.union (singleDocs "docs\ndocs...\n") fooAnnotationSet) parse' "@baz\nunboxed offset (float64);\n# docs\n# docs..."@@ -452,7 +462,7 @@ 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+ descTypeDecl "enumTypeDeclaration" P.enumTypeDeclaration $ \ helpers -> do let (parse', expectError) = helpers it "emits (TypeDeclaration (EnumType ...)) if succeeded to parse" $ do let members' = [ "male"@@ -473,15 +483,17 @@ 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 { typeAnnotations = singleDocs "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 { typeAnnotations = singleDocs "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) empty- parse' "@foo (\"bar\")\nenum gender=male|female|unknown;"+ parse' "@foo (v = \"bar\")\nenum gender=male|female|unknown;" `shouldBeRight` TypeDeclaration "gender" (EnumType members') fooAnnotationSet@@ -489,27 +501,30 @@ `shouldBeRight` TypeDeclaration "gender" (EnumType members') bazAnnotationSet- parse' "@baz\nenum gender=\n@foo (\"bar\")\nmale|female|unknown;"+ parse' "@baz\nenum gender=\n@foo (v=\"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\- \ | a/d\n\- \ ;" 4 10+ expectError [s|+enum dup = a/b+ | b/c+ | a/d+ ;|] 4 10 it "fails to parse if there are duplicated behind names" $- expectError "enum dup = a/b\n\- \ | b/c\n\- \ | c/b\n\- \ ;" 4 10+ expectError [s|+enum dup = a/b+ | b/c+ | c/b+ ;|] 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+ descTypeDecl "recordTypeDeclaration"+ P.recordTypeDeclaration $ \ helpers -> do let (parse', expectError) = helpers it "emits (TypeDeclaration (RecordType ...)) if succeeded to parse" $ do let nameF = Field "name" "text" empty@@ -520,82 +535,89 @@ 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\- \ date dob,\n\- \ # date of birth\n\- \ gender gender,\n\- \);" `shouldBeRight` a+ parse' [s|+record person (+ text name,+ date dob,+ # date of birth+ gender gender,+);|] `shouldBeRight` a -- without docs, last field without trailing comma- parse' "record person (\n\- \ text name,\n\- \ date dob,\n\- \ # date of birth\n\- \ gender gender\n\- \);" `shouldBeRight` a+ parse' [s|+record person (+ text name,+ date dob,+ # date of birth+ gender gender+);|] `shouldBeRight` a -- with docs, last field with trailing comma- parse' "record person (\n\- \ # person record type\n\n\- \ text name,\n\- \ date dob,\n\- \ # date of birth\n\- \ gender gender,\n\- \);" `shouldBeRight` b+ parse' [s|+record person (+ # person record type++ text name,+ date dob,+ # date of birth+ gender gender,+);|] `shouldBeRight` b -- with docs, last field without trailing comma- parse' "record person (\n\- \ # person record type\n\n\- \ text name,\n\- \ date dob,\n\- \ # date of birth\n\- \ gender gender\n\- \);" `shouldBeRight` b+ parse' [s|+record person (+ # person record type++ text name,+ date dob,+ # date of birth+ gender gender+);|] `shouldBeRight` b -- without docs, last field with trailing comma, -- with annotation with single argument- parse' "@foo(\"bar\")\n\- \record person (\n\- \ text name,\n\- \ date dob,\n\- \ # date of birth\n\- \ gender gender,\n\- \);"- `shouldBeRight`+ parse' [s|+@foo(v = "bar")+record person (+ text name,+ date dob,+ # date of birth+ gender gender,+);|] `shouldBeRight` TypeDeclaration "person" record fooAnnotationSet -- without docs, last field with trailing comma, -- with annotation without arguments- parse' "@baz\n\- \record person (\n\- \ text name,\n\- \ date dob,\n\- \ # date of birth\n\- \ gender gender,\n\- \);"- `shouldBeRight`+ parse' [s|+@baz+record person (+ text name,+ date dob,+ # date of birth+ gender gender,+);|] `shouldBeRight` 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`+ parse' [s|+@baz+record person (+ # person record type++ text name,+ date dob,+ # date of birth+ gender gender,+);|] `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`+ parse' [s|+record person (+ text name,+ @foo (v = "bar")+ date dob,+ # date of birth+ @baz+ gender gender,+);|] `shouldBeRight` TypeDeclaration "person" (RecordType [ nameF , dobF { fieldAnnotations = union fooAnnotationSet $@@ -607,20 +629,22 @@ expectError "record unit ();" 1 14 expectError "record unit (\n# docs\n);" 3 1 it "fails to parse if there are duplicated facial names" $- expectError "record dup (\n\- \ text a/b,\n\- \ text b/c,\n\- \ text a/d,\n\- \);" 5 1+ expectError [s|+record dup (+ text a/b,+ text b/c,+ text a/d,+);|] 5 1 it "fails to parse if there are duplicated behind names" $- expectError "record dup (\n\- \ text a/b,\n\- \ text b/c,\n\- \ text c/b,\n\- \);" 5 1+ expectError [s|+record dup (+ text a/b,+ text b/c,+ text c/b,+);|] 5 1 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+ expectError "record a (texta);" 1 16+ expectError "record a (textb\n#docs\n);" 2 1 it "fails to parse if trailing semicolon is missing" $ do let (_, expectErr) = helperFuncs P.module' expectErr@@ -630,7 +654,7 @@ expectErr "record a (text x);\ntype b = text\nrecord c (text y);" 3 1 - descTypeDecl "unionTypeDeclaration" P.unionTypeDeclaration $ \helpers -> do+ descTypeDecl "unionTypeDeclaration" P.unionTypeDeclaration $ \ helpers -> do let (parse', expectError) = helpers it "emits (TypeDeclaration (UnionType ...)) if succeeded to parse" $ do let cOriginF = Field "origin" "point" empty@@ -646,66 +670,94 @@ union' = UnionType tags' a = TypeDeclaration "shape" union' empty b = a { typeAnnotations = singleDocs "shape type" }- parse' "union shape\n\- \ = circle (point origin, \- \offset radius,)\n\- \ | rectangle (point upper-left, \- \point lower-right,)\n\- \ | 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\- \ | rectangle (point upper-left, \- \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`+ parse' [s|+union shape+ = circle (point origin, offset radius,)+ | rectangle (point upper-left, point lower-right,)+ | none+ ;|] `shouldBeRight` a+ parse' [s|+union shape+ = circle (+ point origin,+ offset radius,+ )+ | rectangle (+ point upper-left,+ point lower-right,+ )+ | none+ ;|] `shouldBeRight` a+ parse' [s|+union shape+ # shape type+ = circle (point origin, offset radius,)+ | rectangle (point upper-left, point lower-right,)+ | none+ ;|] `shouldBeRight` b+ parse' [s|+@docs (docs = "shape type\n")+union shape+ = circle (point origin, offset radius,)+ | rectangle (point upper-left, point lower-right,)+ | none+ ;|] `shouldBeRight` b+ parse' [s|+union shape+ = circle (point origin, offset radius,)+ | rectangle (point upper-left, point lower-right,)+ | @foo (v = "bar") none+ ;|] `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`+ parse' [s|+union shape+ = circle (point origin, offset radius,)+ # tag docs+ | rectangle (+ # front docs+ point upper-left, point lower-right,+ )+ | none+ ;|] `shouldBeRight` a { type' = union' { tags = [ circleTag+ { tagAnnotations = singleDocs "tag docs"+ }+ , rectTag+ { tagAnnotations =+ singleDocs "front docs"+ }+ , noneTag+ ]+ }+ }+ parse' [s|+union shape+ = circle (point origin, offset radius,)+ | rectangle (point upper-left, point lower-right,)+ | none # tag docs+ ;|] `shouldBeRight`+ a { type' = union'+ { tags = [ circleTag, rectTag+ , noneTag+ { tagAnnotations = singleDocs "tag docs"+ }+ ]+ }+ }+ parse' [s|+union shape+ = circle (point origin, @baz offset radius,)+ | rectangle (point upper-left, @foo (v = "bar") point lower-right,)+ | none+ ;|] `shouldBeRight`+ a { type' = union'+ { tags = [ circleTag { tagFields = [ cOriginF , cRadiusF { fieldAnnotations =@@ -725,25 +777,29 @@ } } it "fails to parse if there are duplicated facial names" $ do- expectError "union dup\n\- \ = a/b\n\- \ | b/c\n\- \ | a/d\n\- \ ;" 5 6- expectError "union dup\n\- \ = a (text a/b, text b/c, text a/d)\n\- \ | b\n\- \ ;" 2 38+ expectError [s|+union dup+ = a/b+ | b/c+ | a/d+ ;|] 5 6+ expectError [s|+union dup+ = a (text a/b, text b/c, text a/d)+ | b+ ;|] 2 38 it "fails to parse if there are duplicated behind names" $ do- expectError "union dup\n\- \ = a/b\n\- \ | b/c\n\- \ | c/b\n\- \ ;" 5 6- expectError "union dup\n\- \ = a (text a/b, text b/c, text c/b)\n\- \ | b\n\- \ ;" 2 38+ expectError [s|+union dup+ = a/b+ | b/c+ | c/b+ ;|] 5 6+ expectError [s|+union dup+ = a (text a/b, text b/c, text c/b)+ | b+ ;|] 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@@ -753,91 +809,108 @@ describe "method" $ do let (parse', expectError) = helperFuncs P.method- httpGetAnnotation =- head $ rights [fromList [Annotation "http-get" (Just "/get-name/")]]+ httpGetAnnotation = singleton $ Annotation "http"+ [ ("method", "GET")+ , ("path", "/get-name/")+ ] it "emits Method if succeeded to parse" $ do parse' "text get-name()" `shouldBeRight`- Method "get-name" [] "text" Nothing empty+ Method "get-name" [] (Just "text") Nothing empty parse' "text get-name (person user)" `shouldBeRight` Method "get-name" [Parameter "user" "person" empty]- "text" Nothing empty+ (Just "text") Nothing empty parse' "text get-name ( person user,text default )" `shouldBeRight` Method "get-name" [ Parameter "user" "person" empty , Parameter "default" "text" empty ]- "text" Nothing empty- parse' "@http-get(\"/get-name/\") text get-name ( person user,text default )" `shouldBeRight`+ (Just "text") Nothing empty+ parse' "@http(method = \"GET\", path = \"/get-name/\") \+ \text get-name ( person user,text default )" `shouldBeRight` Method "get-name" [ Parameter "user" "person" empty , Parameter "default" "text" empty ]- "text" Nothing httpGetAnnotation+ (Just "text") Nothing httpGetAnnotation parse' "text get-name() throws name-error" `shouldBeRight`- 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" [] (Just "text") (Just "name-error") empty+ parse' [s|+text get-name ( person user,text default )+ throws get-name-error|] `shouldBeRight` Method "get-name" [ Parameter "user" "person" empty , Parameter "default" "text" 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`+ (Just "text") (Just "get-name-error") empty+ parse' [s|+@http(method = "GET", path = "/get-name/")+text get-name ( person user,text default )+ throws get-name-error|] `shouldBeRight` Method "get-name" [ Parameter "user" "person" empty , Parameter "default" "text" empty ]- "text" (Just "get-name-error")+ (Just "text") (Just "get-name-error") httpGetAnnotation+ parse' "get-name()" `shouldBeRight`+ Method "get-name" [] Nothing Nothing empty+ parse' "get-name() throws name-error" `shouldBeRight`+ Method "get-name" [] Nothing (Just "name-error") empty it "can have docs" $ do- parse' "text get-name (\n\- \ # Gets the name.\n\- \)" `shouldBeRight`- Method "get-name" [] "text"+ parse' [s|+text get-name (+ # Gets the name.+)|] `shouldBeRight`+ Method "get-name" [] (Just "text") Nothing (singleDocs "Gets the name.")- parse' "text get-name (\n\- \ # Gets the name.\n\- \)throws name-error " `shouldBeRight`- Method "get-name" [] "text"+ parse' [s|+text get-name (+ # Gets the name.+)throws name-error |] `shouldBeRight`+ Method "get-name" [] (Just "text") (Just "name-error") (singleDocs "Gets the name.")- parse' "text get-name (\n\- \ # Gets the name of the user.\n\- \ person user,\n\- \)" `shouldBeRight`+ parse' [s|+text get-name (+ # Gets the name of the user.+ person user,+)|] `shouldBeRight` Method "get-name" [Parameter "user" "person" empty]- "text"+ (Just "text") Nothing (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`+ parse' [s|+text get-name (+ # Gets the name of the user.+ person user,+) throws get-name-error|] `shouldBeRight` Method "get-name" [Parameter "user" "person" empty]- "text"+ (Just "text") (Just "get-name-error") (singleDocs "Gets the name of the user.")- parse' "text get-name (\n\- \ # Gets the name of the user.\n\- \ person user,\n\- \ # The person to find their name.\n\- \ text default\n\- \ # The default name used when the user has no name.\n\- \)" `shouldBeRight`- Method "get-name"- [ Parameter "user" "person" $- singleDocs "The person to find their name."- , Parameter "default" "text" $- singleDocs "The default name used when \- \the user has no name."- ]- "text"- Nothing- (singleDocs "Gets the name of the user.")+ let expectedUserPDocs = "The person to find their name."+ expectedDefaultPDocs =+ "The default name used when the user has no name."+ expectedMethod =+ Method "get-name"+ [ Parameter "user" "person" $+ singleDocs expectedUserPDocs+ , Parameter "default" "text" $+ singleDocs expectedDefaultPDocs+ ]+ (Just "text")+ Nothing+ (singleDocs "Gets the name of the user.")+ parse' [s|+text get-name (+ # Gets the name of the user.+ person user,+ # The person to find their name.+ text default+ # The default name used when the user has no name.+)|] `shouldBeRight` expectedMethod 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@@ -858,145 +931,159 @@ it "emits ServiceDeclaration if succeeded to parse" $ do parse' "service null-service();" `shouldBeRight` ServiceDeclaration "null-service" (Service []) empty- parse' "service null-service (\n\- \ # Service having no methods.\n\- \);" `shouldBeRight`+ parse' [s|+service null-service (+ # Service having no methods.+);|] `shouldBeRight` ServiceDeclaration "null-service" (Service []) noMethodsD- parse' "service one-method-service(\n\- \ user get-user(uuid user-id)\n\- \);" `shouldBeRight`+ parse' [s|+service one-method-service(+ user get-user(uuid user-id)+);|] `shouldBeRight` ServiceDeclaration "one-method-service" (Service [ Method "get-user" [Parameter "user-id" "uuid" empty]- "user"+ (Just "user") Nothing empty ]) empty- parse' "service one-method-service (\n\- \ # Service having only one method.\n\- \ user get-user (\n\- \ # Gets an user by its id.\n\- \ uuid user-id\n\- \ ) throws get-user-error,\n\- \);" `shouldBeRight`+ parse' [s|+service one-method-service (+ # Service having only one method.+ user get-user (+ # Gets an user by its id.+ uuid user-id+ ) throws get-user-error,+);|] `shouldBeRight` ServiceDeclaration "one-method-service" (Service [ Method "get-user" [Parameter "user-id" "uuid" empty]- "user"+ (Just "user") (Just "get-user-error") getUserD ]) oneMethodD- parse' "service user-service (\n\- \ # Service having multiple methods.\n\- \ user create-user (\n\- \ # Creates a new user\n\- \ user user\n\- \ ),\n\- \ user get-user (\n\- \ # Gets an user by its id.\n\- \ uuid user-id\n\- \ ),\n\- \);" `shouldBeRight`+ parse' [s|+service user-service (+ # Service having multiple methods.+ user create-user (+ # Creates a new user+ user user+ ),+ user get-user (+ # Gets an user by its id.+ uuid user-id+ ),+);|] `shouldBeRight` ServiceDeclaration "user-service" (Service [ Method "create-user" [Parameter "user" "user" empty]- "user"+ (Just "user") Nothing createUserD , Method "get-user" [Parameter "user-id" "uuid" empty]- "user"+ (Just "user") Nothing getUserD ]) multiMethodsD- parse' "@foo(\"bar\")\n\- \service null-service (\n\- \ # Service having no methods.\n\- \);" `shouldBeRight`+ parse' [s|+@foo(v = "bar")+service null-service (+ # Service having no methods.+);|] `shouldBeRight` ServiceDeclaration "null-service" (Service []) (A.union noMethodsD fooAnnotationSet)- parse' "@baz\n\- \service null-service (\n\- \ # Service having no methods.\n\- \);" `shouldBeRight`+ parse' [s|+@baz+service null-service (+ # Service having no methods.+);|] `shouldBeRight` ServiceDeclaration "null-service" (Service []) (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`+ parse' [s|+service user-service (+ @docs (docs = "Creates a new user\n")+ user create-user (+ user user+ ),+ @docs (docs = "Gets an user by its id.\n")+ user get-user (+ uuid user-id+ ),+);|] `shouldBeRight` ServiceDeclaration "user-service" (Service [ Method "create-user" [Parameter "user" "user" empty]- "user"+ (Just "user") Nothing createUserD , Method "get-user" [Parameter "user-id" "uuid" empty]- "user"+ (Just "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`+ parse' [s|+service user-service (+ user get-user (+ @baz+ uuid user-id+ # The unique user identifier.+ ),+);|] `shouldBeRight` ServiceDeclaration "user-service" (Service [ Method "get-user" [ Parameter "user-id" "uuid" $ A.union bazAnnotationSet userIdD ]- "user"+ (Just "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\- \ text same-name (uuid id)\n\- \);" 3 3- expectError "service method-dups (\n\- \ bool same-name ()\n\- \ text same-name/different-behind-name (uuid id)\n\- \);" 3 3- expectError "service method-dups (\n\- \ bool same-name/unique-behind-name ()\n\- \ text same-name/different-behind-name (uuid id)\n\- \);" 3 3+ expectError [s|+service method-dups (+ bool same-name ()+ text same-name (uuid id)+);|] 3 3+ expectError [s|+service method-dups (+ bool same-name ()+ text same-name/different-behind-name (uuid id)+);|] 3 3+ expectError [s|+service method-dups (+ bool same-name/unique-behind-name ()+ text same-name/different-behind-name (uuid id)+);|] 3 3 it "fails to parse if there are methods of the same behind name" $ do- expectError "service method-dups (\n\- \ bool same-name ()\n\- \ text same-name (uuid id)\n\- \);" 3 3- expectError "service method-dups (\n\- \ bool same-name ()\n\- \ text unique-name/same-name (uuid id)\n\- \);" 3 3- expectError "service method-dups (\n\- \ bool unique-name/same-name ()\n\- \ text different-facial-name/same-name (uuid id)\n\- \);" 3 3+ expectError [s|+service method-dups (+ bool same-name ()+ text same-name (uuid id)+);|] 3 3+ expectError [s|+service method-dups (+ bool same-name ()+ text unique-name/same-name (uuid id)+);|] 3 3+ expectError [s|+service method-dups (+ bool unique-name/same-name ()+ text different-facial-name/same-name (uuid id)+);|] 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@@ -1005,7 +1092,7 @@ let moduleParsers = [ ("module'", P.module') , ("file", P.file) ] :: [(String, Parser Module)]- forM_ moduleParsers $ \(label, parser') ->+ forM_ moduleParsers $ \ (label, parser') -> describe label $ do let (parse', expectError) = helperFuncs parser' it "emits Module if succeeded to parse" $ do@@ -1053,24 +1140,43 @@ , 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 (v = \"bar\") a, @baz b);"+ `shouldBeRight`+ [ Import ["foo", "bar"] "a" fooAnnotationSet+ , Import ["foo", "bar"] "b" bazAnnotationSet+ ]+ parse' "import foo.bar (@foo (v = \"bar\") @baz a, b);"+ `shouldBeRight`+ [ Import ["foo", "bar"] "a" $+ union fooAnnotationSet bazAnnotationSet+ , Import ["foo", "bar"] "b" empty+ ]+ specify "import names can have a trailing comma" $+ parse' "import foo.bar (a, b,);" `shouldBeRight`+ [ Import ["foo", "bar"] "a" empty+ , Import ["foo", "bar"] "b" empty ]- parse' "import foo.bar (@foo (\"bar\") @baz a, b);" `shouldBeRight`- [ Import ["foo", "bar"] "a" $- union fooAnnotationSet bazAnnotationSet+ specify "import names in parentheses can be multiline" $ do+ -- without a trailing comma+ parse' "import foo.bar (\n a,\n b\n);" `shouldBeRight`+ [ Import ["foo", "bar"] "a" empty , Import ["foo", "bar"] "b" empty ]+ -- with a trailing comma+ parse' "import foo.bar (\n c,\n d,\n);" `shouldBeRight`+ [ Import ["foo", "bar"] "c" empty+ , Import ["foo", "bar"] "d" empty+ ] it "errors if parentheses have nothing" $ expectError "import foo.bar ();" 1 17 specify "parse & parseFile" $ do files <- getDirectoryContents "examples" let examples = map ("examples/" ++) $ filter (isSuffixOf ".nrm") files- forM_ examples $ \filePath -> do- sourceCode <- readFile filePath- let parseResult = P.parse (filePath ++ " (text)") sourceCode+ forM_ examples $ \ filePath -> do+ sourceCode <- B.readFile filePath+ let parseResult = P.parse (filePath ++ " (text)")+ (E.decodeUtf8 sourceCode) parseResult `shouldSatisfy` isRight let Right module' = parseResult P.parse (filePath ++ " (text inverse)") (toCode module')
+ test/Nirum/Targets/DocsSpec.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE OverloadedLists #-}+module Nirum.Targets.DocsSpec where++import System.FilePath ((</>))+import Test.Hspec.Meta+import Text.Blaze.Html.Renderer.Utf8 (renderHtml)++import Nirum.Constructs.Annotation (empty)+import Nirum.Constructs.DeclarationSet (DeclarationSet)+import Nirum.Constructs.Module (Module (..))+import Nirum.Constructs.TypeDeclaration (TypeDeclaration (Import))+import qualified Nirum.Docs as D+import qualified Nirum.Targets.Docs as DT++spec :: Spec+spec = describe "Docs" $ do+ let decls = [Import ["zzz"] "qqq" empty] :: DeclarationSet TypeDeclaration+ mod1 = Module decls Nothing+ mod2 = Module decls $ Just "module level docs...\nblahblah"+ mod3 = Module decls $ Just "# One Spoqa Trinity Studio\nblahblah"+ specify "makeFilePath" $+ DT.makeFilePath ["foo", "bar", "baz"] `shouldBe`+ "foo" </> "bar" </> "baz" </> "index.html"+ specify "makeUri" $+ DT.makeUri ["foo", "bar", "baz"] `shouldBe` "foo/bar/baz/index.html"+ specify "moduleTitle" $ do+ fmap renderHtml (DT.moduleTitle mod1) `shouldBe` Nothing+ fmap renderHtml (DT.moduleTitle mod2) `shouldBe` Nothing+ fmap renderHtml (DT.moduleTitle mod3) `shouldBe`+ Just "One Spoqa Trinity Studio"+ specify "blockToHtml" $ do+ let h = D.Paragraph [D.Strong ["Hi!"]]+ renderHtml (DT.blockToHtml h) `shouldBe` "<p><strong>Hi!</strong></p>"
test/Nirum/Targets/PythonSpec.hs view
@@ -1,265 +1,116 @@-{-# LANGUAGE OverloadedLists, QuasiQuotes, ScopedTypeVariables #-}-{-|-This unit test module optionally depends on Python interpreter.-It internally tries to popen python3 executable, and import nirum Python-package. If any of these prerequisites are not satisfied, tests depending-on Python interpreter are skipped instead of marked failed.--To make Python interpreter possible to import nirum package, you need to-install the nirum package to your Python site-packages using pip command.-We recommend to install the package inside a virtualenv (pyvenv) and-run this unit test in the virtualenv (pyvenv). E.g.:--> $ pyvenv env-> $ . env/bin/activate-> (env)$ pip install git+git://github.com/spoqa/nirum-python.git-> (env)$ cabal test # or: stack test--}+{-# LANGUAGE OverloadedLists, OverloadedStrings, QuasiQuotes,+ ScopedTypeVariables #-} module Nirum.Targets.PythonSpec where -import Control.Monad (forM_, void, unless)-import Data.Char (isSpace)-import Data.Maybe (fromJust, isJust)-import System.IO.Error (catchIOError)-+import Control.Monad (forM_) import Data.Either (isRight)-import Data.List (dropWhileEnd)+import Data.Maybe (fromJust)+ import qualified Data.Map.Strict as M-import qualified Data.Text as T-import qualified Data.Text.IO as TI-import System.Directory (createDirectoryIfMissing)-import System.Exit (ExitCode(ExitSuccess))-import System.FilePath (isValid, takeDirectory, (</>))-import System.Info (os)-import System.IO.Temp (withSystemTempDirectory)-import System.Process ( CreateProcess(cwd)- , proc- , readCreateProcess- , readCreateProcessWithExitCode- )+import qualified Data.SemVer as SV+import System.FilePath ((</>)) import Test.Hspec.Meta+import Text.Email.Validate (emailAddress) import Text.InterpolatedString.Perl6 (q, qq)-import Text.Megaparsec (char, digitChar, runParser, some, space, string')-import Text.Megaparsec.String (Parser) import Nirum.Constructs.Annotation (empty)-import Nirum.Constructs.DeclarationSet (DeclarationSet) import Nirum.Constructs.Identifier (Identifier)-import Nirum.Constructs.Module (Module(Module))+import Nirum.Constructs.Module (Module (Module)) import Nirum.Constructs.ModulePath (ModulePath, fromIdentifiers)-import Nirum.Constructs.Name (Name(Name))-import Nirum.Constructs.Service ( Method (Method)- , Parameter (Parameter)- , Service (Service)- )-import Nirum.Constructs.TypeDeclaration ( Field(Field)- , EnumMember(EnumMember)- , PrimitiveTypeIdentifier(..)- , Tag(Tag)- , Type( Alias- , EnumType- , RecordType- , UnboxedType- , UnionType- )+import Nirum.Constructs.Name (Name (Name))+import Nirum.Constructs.TypeDeclaration ( Field (Field)+ , PrimitiveTypeIdentifier (..)+ , Type ( Alias+ , RecordType+ , UnboxedType+ ) , TypeDeclaration ( Import- , ServiceDeclaration , TypeDeclaration ) )-import Nirum.Constructs.TypeExpression ( TypeExpression( ListModifier- , MapModifier- , OptionModifier- , SetModifier- , TypeIdentifier- )+import Nirum.Constructs.TypeExpression ( TypeExpression ( ListModifier+ , MapModifier+ , OptionModifier+ , SetModifier+ , TypeIdentifier+ ) )-import Nirum.Package (BoundModule(modulePath), Package, resolveBoundModule)+import Nirum.Package hiding (target)+import Nirum.Package.Metadata ( Author (Author, email, name, uri)+ , Metadata ( Metadata+ , authors+ , target+ , version+ , description+ , license+ , keywords+ )+ , Target (compilePackage)+ )+import qualified Nirum.Package.ModuleSet as MS import Nirum.PackageSpec (createPackage)+import qualified Nirum.Targets.Python as PY import Nirum.Targets.Python ( Source (Source)- , Code , CodeGen , CodeGenContext ( localImports , standardImports , thirdPartyImports )- , CompileError , InstallRequires ( InstallRequires , dependencies , optionalDependencies )+ , Python (Python)+ , PythonVersion (Python2, Python3)+ , RenameMap , addDependency , addOptionalDependency- , compilePackage , compilePrimitiveType , compileTypeExpression- , emptyContext- , toAttributeName- , toClassName- , toImportPath- , toNamePair- , unionInstallRequires , insertLocalImport , insertStandardImport , insertThirdPartyImports+ , insertThirdPartyImportsA+ , localImportsMap+ , minimumRuntime+ , parseModulePath+ , renameModulePath , runCodeGen+ , stringLiteral+ , toAttributeName+ , toClassName+ , toNamePair+ , unionInstallRequires )+import Nirum.TypeInstance.BoundModule codeGen :: a -> CodeGen a codeGen = return -windows :: Bool-windows = os `elem` (["mingw32", "cygwin32", "win32"] :: [String])--data PyVersion = PyVersion Int Int Int deriving (Eq, Ord, Show)--installedPythonPaths :: Maybe FilePath -> IO [FilePath]-installedPythonPaths cwd' = do- (exitCode, stdOut, _) <- readCreateProcessWithExitCode proc' ""- return $ case exitCode of- ExitSuccess -> filter isValid $ lines' stdOut- _ -> []- where- proc' :: CreateProcess- proc' = (if windows then proc "where.exe" ["python"] else proc "which" ["python3"]) { cwd = cwd' }- lines' :: String -> [String]- lines' = map T.unpack . filter (not . T.null) . map T.strip . T.lines . T.pack--getPythonVersion :: Maybe FilePath -> FilePath -> IO (Maybe PyVersion)-getPythonVersion cwd' path' = do- let proc' = (proc path' ["-V"]) { cwd = cwd' }- pyVersionStr <- readCreateProcess proc' ""- return $ case runParser pyVersionParser "<python3>" pyVersionStr of- Left _ -> Nothing- Right v -> Just v- where- pyVersionParser :: Parser PyVersion- pyVersionParser = do- void $ string' "python"- space- major <- integer- void $ char '.'- minor <- integer- void $ char '.'- micro <- integer- return $ PyVersion major minor micro- integer :: Parser Int- integer = do- digits <- some digitChar- return (read digits :: Int)--findPython :: Maybe FilePath -> IO (Maybe FilePath)-findPython cwd' = installedPythonPaths cwd' >>= findPython'- where- findPython' :: [FilePath] -> IO (Maybe FilePath)- findPython' (x:xs) = do- pyVerM <- getPythonVersion cwd' x- case pyVerM of- Nothing -> findPython' xs- Just version -> if version >= PyVersion 3 3 0- then return $ Just x- else findPython' xs- findPython' [] = return Nothing--runPython' :: Maybe FilePath -> [String] -> String -> IO (Maybe String)-runPython' cwd' args stdinStr = do- pyPathM <- findPython cwd'- case pyPathM of- Nothing -> do- putStrLn "Python 3 seems not installed; skipping..."- return Nothing- Just path -> execute cwd' path args stdinStr- where- execute :: Maybe FilePath- -> FilePath- -> [String]- -> String- -> IO (Maybe String)- execute cwdPath pyPath args' stdinStr' = do- let proc' = (proc pyPath args') { cwd = cwdPath }- result <- readCreateProcess proc' stdinStr'- return $ Just result--runPython :: Maybe FilePath -> String -> IO (Maybe String)-runPython cwd' code' =- catchIOError (runPython' cwd' [] code') $ \e -> do- putStrLn "\nThe following IO error was raised:\n"- putStrLn $ indent " " $ show e- putStrLn "\n... while the following code was executed:\n"- putStrLn $ indent " " code'- ioError e- where- indent :: String -> String -> String- indent spaces content = unlines [spaces ++ l | l <- lines content]--testPythonSuit :: Maybe FilePath -> String -> T.Text -> IO ()-testPythonSuit cwd' suitCode testCode = do- nirumPackageInstalledM <-- runPython cwd' [q|-try: import nirum-except ImportError: print('F')-else: print('T')- |]- case nirumPackageInstalledM of- Just nirumPackageInstalled ->- case strip nirumPackageInstalled of- "T" -> do- resultM <- runPython cwd' suitCode- case resultM of- Just result ->- unless (strip result == "True") $- expectationFailure $- T.unpack ("Test failed: " `T.append` testCode)- Nothing -> return ()- _ -> putStrLn "The nirum Python package cannot be imported; \- \skipped..."- Nothing -> return ()- where- strip :: String -> String- strip = dropWhile isSpace . dropWhileEnd isSpace--testPython :: Maybe FilePath -> T.Text -> T.Text -> IO ()-testPython cwd' defCode testCode = testPythonSuit cwd' code' testCode'- where- -- to workaround hlint's "Eta reduce" warning- -- hlint seems unable to look inside qq string literal...- testCode' :: T.Text- testCode' = testCode- code' :: String- code' = [qq|$defCode--if __name__ == '__main__':- print(bool($testCode'))-|]--testRaisePython :: Maybe FilePath -> T.Text -> T.Text -> T.Text -> IO ()-testRaisePython cwd' errorClassName defCode testCode =- testPythonSuit cwd' code' testCode''- where- -- to workaround hlint's "Eta reduce" warning- -- hlint seems unable to look inside qq string literal...- testCode'' :: T.Text- testCode'' = testCode- code' :: String- code' = [qq|$defCode--if __name__ == '__main__':- try:- $testCode''- except $errorClassName:- print(True)- else:- print(False)-|]--makeDummySource' :: [Identifier] -> Module -> Source-makeDummySource' pathPrefix m =+makeDummySource' :: [Identifier] -> Module -> RenameMap -> Source+makeDummySource' pathPrefix m renames = Source pkg $ fromJust $ resolveBoundModule ["foo"] pkg where mp :: [Identifier] -> ModulePath mp identifiers = fromJust $ fromIdentifiers (pathPrefix ++ identifiers)- pkg :: Package+ metadata' :: Metadata Python+ metadata' = Metadata+ { version = SV.version 1 2 3 [] []+ , authors =+ [ Author+ { name = "John Doe"+ , email = Just (fromJust $ emailAddress "john@example.com")+ , uri = Nothing+ }+ ]+ , description = Just "Package description"+ , license = Just "MIT"+ , keywords = ["sample", "example", "nirum"]+ , target = Python "sample-package" minimumRuntime renames+ }+ pkg :: Package Python pkg = createPackage+ metadata' [ (mp ["foo"], m) , ( mp ["foo", "bar"] , Module [ Import (mp ["qux"]) "path" empty@@ -283,24 +134,19 @@ ] 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-+makeDummySource m = makeDummySource' [] m [] spec :: Spec-spec = parallel $ do- describe "CodeGen" $ do+spec = parallel $ forM_ ([Python2, Python3] :: [PythonVersion]) $ \ ver -> do+ let empty' = PY.empty ver+ -- run' :: CodeGen a -> (Either CompileError a, CodeGenContext)+ run' c = runCodeGen c empty'+ -- code :: CodeGen a -> a+ code = either (const undefined) id . fst . run'+ -- compileError :: CodeGen a -> Maybe CompileError+ compileError cg = either Just (const Nothing) $ fst $+ runCodeGen cg empty'+ describe [qq|CodeGen ($ver)|] $ do specify "packages and imports" $ do let c = do insertStandardImport "sys"@@ -309,81 +155,113 @@ insertLocalImport ".." "Gender" insertStandardImport "os" insertThirdPartyImports [("nirum", ["serialize_enum_type"])]+ insertThirdPartyImportsA+ [("nirum.constructs", [("name_dict_type", "NameDict")])] insertLocalImport ".." "Path"- let (e, ctx) = runCodeGen c emptyContext+ let (e, ctx) = runCodeGen c empty' e `shouldSatisfy` isRight standardImports ctx `shouldBe` ["os", "sys"] thirdPartyImports ctx `shouldBe`- [("nirum", ["serialize_unboxed_type", "serialize_enum_type"])]+ [ ( "nirum"+ , [ ("serialize_unboxed_type", "serialize_unboxed_type")+ , ("serialize_enum_type", "serialize_enum_type")+ ]+ )+ , ( "nirum.constructs"+ , [("name_dict_type", "NameDict")]+ )+ ] localImports ctx `shouldBe` [("..", ["Gender", "Path"])]+ localImportsMap ctx `shouldBe`+ [ ( ".."+ , [ ("Gender", "Gender")+ , ("Path", "Path")+ ]+ )+ ] specify "insertStandardImport" $ do let codeGen1 = insertStandardImport "sys"- let (e1, ctx1) = runCodeGen codeGen1 emptyContext+ let (e1, ctx1) = runCodeGen codeGen1 empty' e1 `shouldSatisfy` isRight standardImports ctx1 `shouldBe` ["sys"] thirdPartyImports ctx1 `shouldBe` [] localImports ctx1 `shouldBe` [] compileError codeGen1 `shouldBe` Nothing let codeGen2 = codeGen1 >> insertStandardImport "os"- let (e2, ctx2) = runCodeGen codeGen2 emptyContext+ let (e2, ctx2) = runCodeGen codeGen2 empty' e2 `shouldSatisfy` isRight standardImports ctx2 `shouldBe` ["os", "sys"] thirdPartyImports ctx2 `shouldBe` [] localImports ctx2 `shouldBe` [] compileError codeGen2 `shouldBe` Nothing - specify "compilePrimitiveType" $ do+ specify [qq|compilePrimitiveType ($ver)|] $ do code (compilePrimitiveType Bool) `shouldBe` "bool" code (compilePrimitiveType Bigint) `shouldBe` "int" 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 Int64) `shouldBe`+ case ver of+ Python2 -> "numbers.Integral"+ Python3 -> "int" code (compilePrimitiveType Float32) `shouldBe` "float" code (compilePrimitiveType Float64) `shouldBe` "float"- code (compilePrimitiveType Text) `shouldBe` "str"+ code (compilePrimitiveType Text) `shouldBe`+ case ver of+ Python2 -> "unicode"+ Python3 -> "str" code (compilePrimitiveType Binary) `shouldBe` "bytes" let (dateCode, dateContext) = run' (compilePrimitiveType Date) dateCode `shouldBe` Right "datetime.date" standardImports dateContext `shouldBe` ["datetime"]- let (datetimeCode, datetimeContext) = run' (compilePrimitiveType 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"+ code (compilePrimitiveType Uri) `shouldBe`+ case ver of+ Python2 -> "unicode"+ Python3 -> "str" - describe "compileTypeExpression" $ do+ describe [qq|compileTypeExpression ($ver)|] $ do let s = makeDummySource $ Module [] Nothing specify "TypeIdentifier" $ do- let (c, ctx) = run' $ compileTypeExpression s (TypeIdentifier "bigint")+ let (c, ctx) = run' $+ compileTypeExpression s (Just $ TypeIdentifier "bigint") standardImports ctx `shouldBe` [] localImports ctx `shouldBe` [] c `shouldBe` Right "int" specify "OptionModifier" $ do- let (c', ctx') = run' $ compileTypeExpression s (OptionModifier "text")+ let (c', ctx') = run' $+ compileTypeExpression s (Just $ OptionModifier "int32") standardImports ctx' `shouldBe` ["typing"] localImports ctx' `shouldBe` []- c' `shouldBe` Right "typing.Optional[str]"+ c' `shouldBe` Right "typing.Optional[int]" specify "SetModifier" $ do- let (c'', ctx'') = run' $ compileTypeExpression s (SetModifier "text")+ let (c'', ctx'') = run' $+ compileTypeExpression s (Just $ SetModifier "int32") standardImports ctx'' `shouldBe` ["typing"] localImports ctx'' `shouldBe` []- c'' `shouldBe` Right "typing.AbstractSet[str]"+ c'' `shouldBe` Right "typing.AbstractSet[int]" specify "ListModifier" $ do- let (c''', ctx''') = run' $ compileTypeExpression s (ListModifier "text")+ let (c''', ctx''') = run' $+ compileTypeExpression s (Just $ ListModifier "int32") standardImports ctx''' `shouldBe` ["typing"] localImports ctx''' `shouldBe` []- c''' `shouldBe` Right "typing.Sequence[str]"+ c''' `shouldBe` Right "typing.Sequence[int]" specify "MapModifier" $ do- let (c'''', ctx'''') = run' $ compileTypeExpression s (MapModifier "uuid" "text")- standardImports ctx'''' `shouldBe` ["uuid", "typing"]+ let (c'''', ctx'''') = run' $+ compileTypeExpression s (Just $ MapModifier "uuid" "int32")+ standardImports ctx'''' `shouldBe` ["typing", "uuid"] localImports ctx'''' `shouldBe` []- c'''' `shouldBe` Right "typing.Mapping[uuid.UUID, str]"+ c'''' `shouldBe` Right "typing.Mapping[uuid.UUID, int]" - describe "toClassName" $ do+ describe [qq|toClassName ($ver)|] $ do it "transform the facial name of the argument into PascalCase" $ do toClassName "test" `shouldBe` "Test" toClassName "hello-world" `shouldBe` "HelloWorld"@@ -392,7 +270,7 @@ toClassName "false" `shouldBe` "False_" toClassName "none" `shouldBe` "None_" - describe "toAttributeName" $ do+ describe [qq|toAttributeName ($ver)|] $ do it "transform the facial name of the argument into snake_case" $ do toAttributeName "test" `shouldBe` "test" toAttributeName "hello-world" `shouldBe` "hello_world"@@ -401,7 +279,7 @@ toAttributeName "lambda" `shouldBe` "lambda_" toAttributeName "nonlocal" `shouldBe` "nonlocal_" - describe "toNamePair" $ do+ describe [qq|toNamePair ($ver)|] $ do it "transforms the name to a Python code string of facial/behind pair" $ do toNamePair "text" `shouldBe` "('text', 'text')" toNamePair (Name "test" "hello") `shouldBe` "('test', 'hello')"@@ -415,423 +293,78 @@ toNamePair (Name "abc" "lambda") `shouldBe` "('abc', 'lambda')" toNamePair (Name "lambda" "abc") `shouldBe` "('lambda_', 'abc')" - let test testRunner (Source pkg boundM) testCode =- case errors of- error':_ -> fail $ T.unpack error'- [] -> withSystemTempDirectory "nirumpy." $ \dir -> do- forM_ codes $ \(filePath, code') -> do- let filePath' = dir </> filePath- 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)- files = compilePackage pkg- errors :: [CompileError]- errors = [error' | (_, Left error') <- M.toList files]- codes :: [(FilePath, Code)]- codes = [(path, code') | (path, Right code') <- M.toList files]- pyImportPath :: T.Text- pyImportPath = toImportPath $ modulePath boundM- defCode :: Code- defCode = [qq|from $pyImportPath import *|]- tM = test testPython- tT' typeDecls = tM $ makeDummySource $ Module typeDecls Nothing- tT typeDecl = tT' [typeDecl]- tR source excType = test (`testRaisePython` excType) source- tR'' typeDecls = tR $ makeDummySource $ Module typeDecls Nothing- tR' typeDecl = tR'' [typeDecl]+ specify [qq|stringLiteral ($ver)|] $ do+ stringLiteral "asdf" `shouldBe` [q|"asdf"|]+ stringLiteral [q|Say 'hello world'|]+ `shouldBe` [q|"Say 'hello world'"|]+ stringLiteral [q|Say "hello world"|]+ `shouldBe` [q|"Say \"hello world\""|]+ stringLiteral "Say '\xc548\xb155'"+ `shouldBe` [q|u"Say '\uc548\ub155'"|] - describe "compilePackage" $ do+ describe [qq|compilePackage ($ver)|] $ do it "returns a Map of file paths and their contents to generate" $ do let (Source pkg _) = makeDummySource $ Module [] Nothing files = compilePackage pkg- M.keysSet files `shouldBe`- [ "foo" </> "__init__.py"- , "foo" </> "bar" </> "__init__.py"- , "qux" </> "__init__.py"- , "setup.py"- ]+ directoryStructure =+ [ "src-py2" </> "foo" </> "__init__.py"+ , "src-py2" </> "foo" </> "bar" </> "__init__.py"+ , "src-py2" </> "qux" </> "__init__.py"+ , "src" </> "foo" </> "__init__.py"+ , "src" </> "foo" </> "bar" </> "__init__.py"+ , "src" </> "qux" </> "__init__.py"+ , "setup.py"+ , "MANIFEST.in"+ ]+ M.keysSet files `shouldBe` directoryStructure it "creates an emtpy Python package directory if necessary" $ do- let (Source pkg _) = makeDummySource' ["test"] $ Module [] Nothing+ let (Source pkg _) = makeDummySource' ["test"] (Module [] Nothing)+ [] files = compilePackage pkg- M.keysSet files `shouldBe`- [ "test" </> "__init__.py"- , "test" </> "foo" </> "__init__.py"- , "test" </> "foo" </> "bar" </> "__init__.py"- , "test" </> "qux" </> "__init__.py"- , "setup.py"- ]- specify "setup.py" $ do- let setupPyFields = [ ("--name", "TestPackage")- , ("--version", "0.1.0")- , ("--version", "0.1.0")- , ("--provides", "foo\nfoo.bar\nqux")- , ("--requires", "nirum")- ] :: [(String, T.Text)]- source = makeDummySource $ Module [] Nothing- testRunner cwd' _ _ =- {-- <- remove '{' to print debug log- do- let spath = case cwd' of- Just c -> c </> "setup.py"- Nothing -> "setup.py"- contents <- TI.readFile spath- TI.putStrLn "=========== setup.py ==========="- TI.putStrLn contents- TI.putStrLn "=========== /setup.py =========="- -- --}- forM_ setupPyFields $ \(option, expected) -> do- out <- runPython' cwd' ["setup.py", option] ""- out `shouldSatisfy` isJust- let Just result = out- T.strip (T.pack result) `shouldBe` expected- test testRunner source T.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(ImportedTypeUnbox, type)"- tT' decls [q|- 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|- ImportedTypeUnbox(PathUnbox('/path/string')- ).__nirum_serialize__() == '/path/string'- |]- 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"- (UnboxedType "path") empty- ]- tT' boxedAlias "Way('.').value == '.'"- tT' boxedAlias "Way(Path('.')).value == '.'"- tT' boxedAlias "Way.__nirum_deserialize__('.') == Way('.')"- tT' boxedAlias "Way('.').__nirum_serialize__() == '.'"- 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") empty- ] :: DeclarationSet EnumMember- 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'"- tT decl "Gender.female.value == 'yeoseong'"- tT decl "Gender.__nirum_deserialize__('male') == Gender.male"- tT decl "Gender.__nirum_deserialize__('yeoseong') == Gender.female"- tR' decl "ValueError" "Gender.__nirum_deserialize__('namja')"- tT decl "Gender.male.__nirum_serialize__() == 'male'"- tT decl "Gender.female.__nirum_serialize__() == 'yeoseong'"- let members' = [ "soryu-asuka-langley"- , "ayanami-rei"- , "ikari-shinji"- , "katsuragi-misato"- , "nagisa-kaworu"- ] :: DeclarationSet EnumMember- 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, \- \ EvaChar.ikari_shinji, \- \ EvaChar.katsuragi_misato, \- \ EvaChar.nagisa_kaworu}"- tT decl' "EvaChar.soryu_asuka_langley.value=='soryu_asuka_langley'"- tT decl' "EvaChar.soryu_asuka_langley.__nirum_serialize__() == \- \ 'soryu_asuka_langley'"- tT decl' "EvaChar.__nirum_deserialize__('soryu_asuka_langley') == \- \ EvaChar.soryu_asuka_langley"- 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" empty- , Field "top" "bigint" empty- ]- payload = "{'_type': 'point', 'x': 3, 'top': 14}" :: T.Text- 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"- tT decl "Point(left=3, top=14) == Point(left=3, top=14)"- tT decl "Point(left=3, top=14) != Point(left=3, top=15)"- 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) ==- Point(left=3, top=14)|]- tR' decl "ValueError"- "Point.__nirum_deserialize__({'x': 3, 'top': 14})"- tR' decl "ValueError"- "Point.__nirum_deserialize__({'_type': 'foo'})"- 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-unbox" empty- , Field "top" "int-unbox" 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 [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=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=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" empty- , TypeDeclaration "point3d"- (RecordType fields'')- empty- ]- tT' decls' "isinstance(Point3d, type)"- tT' decls' [q|Point3d(xy=Point(x=1, y=2), z=3).xy ==- Point(x=1, y=2)|]- tT' decls' "Point3d(xy=Point(x=1, y=2), z=3).xy.x == 1"- tT' decls' "Point3d(xy=Point(x=1, y=2), z=3).xy.y == 2"- tT' decls' "Point3d(xy=Point(x=1, y=2), z=3).z == 3"- tT' decls' [q|Point3d(xy=Point(x=1, y=2), z=3).__nirum_serialize__()- == {'_type': 'point3d',- 'xy': {'_type': 'point', 'x': 1, 'y': 2},- 'z': 3}|]- tT' decls' [q|Point3d.__nirum_deserialize__({- '_type': 'point3d',- 'xy': {'_type': 'point', 'x': 1, 'y': 2},- 'z': 3- }) == Point3d(xy=Point(x=1, y=2), z=3)|]- specify "record type with one field" $ do- let fields = [ Field "length" "bigint" empty ]- payload = "{'_type': 'line', 'length': 3}" :: T.Text- 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 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" empty- , Field "given-name" "text" empty- ] empty- cultureAgnosticNameTag =- Tag "culture-agnostic-name"- [ Field "fullname" "text" empty ]- empty- tags = [ westernNameTag- , eastAsianNameTag- , cultureAgnosticNameTag- ]- 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'"- tT decl [q|Name.Tag.culture_agnostic_name.value ==- 'culture_agnostic_name'|]- tT decl "isinstance(WesternName, type)"- tT decl "issubclass(WesternName, Name)"- tR' decl "NotImplementedError" "Name()"- tT decl [q|WesternName(first_name='foo', middle_name='bar',- last_name='baz').first_name == 'foo'|]- tT decl [q|WesternName(first_name='foo', middle_name='bar',- last_name='baz').middle_name == 'bar'|]- tT decl [q|WesternName(first_name='foo', middle_name='bar',- last_name='baz').last_name == 'baz'|]- tR' decl "TypeError" [q|WesternName(first_name=1,middle_name='bar',- last_name='baz')|]- tR' decl "TypeError" [q|WesternName(first_name='foo',- middle_name=1,- last_name='baz')|]- tR' decl "TypeError" [q|WesternName(first_name='foo',- middle_name='bar',- last_name=1)|]- tT decl [q|WesternName(first_name='foo', middle_name='bar',- last_name='baz') ==- WesternName(first_name='foo', middle_name='bar',- last_name='baz')- |]- tT decl [q|WesternName(first_name='wrong',- middle_name='bar', last_name='baz') !=- WesternName(first_name='foo', middle_name='bar',- last_name='baz')- |]- tT decl [q|WesternName(first_name='foo', middle_name='wrong',- last_name='baz') !=- WesternName(first_name='foo', middle_name='bar',- last_name='baz')- |]- tT decl [q|WesternName(first_name='foo', middle_name='bar',- last_name='wrong') !=- WesternName(first_name='foo', middle_name='bar',- last_name='baz')- |]- tT decl [q|WesternName(first_name='wrong', middle_name='wrong',- 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',- given_name='baz').family_name == 'foo'|]- tT decl [q|EastAsianName(family_name='foo',- given_name='baz').given_name == 'baz'|]- tT decl [q|EastAsianName(family_name='foo', given_name='baz') ==- EastAsianName(family_name='foo', given_name='baz')|]- tT decl [q|EastAsianName(family_name='foo',- given_name='wrong') !=- EastAsianName(family_name='foo', given_name='baz')|]- tT decl [q|EastAsianName(family_name='wrong', given_name='baz') !=- EastAsianName(family_name='foo', given_name='baz')|]- tT decl [q|EastAsianName(family_name='wrong',- given_name='wrong') !=- EastAsianName(family_name='foo', given_name='baz')|]- tR'- decl- "TypeError"- "EastAsianName(family_name=1, given_name='baz')"- tR'- decl- "TypeError"- "EastAsianName(family_name='foo', given_name=2)"- tT decl "isinstance(CultureAgnosticName, type)"- tT decl "issubclass(CultureAgnosticName, Name)"- tT- decl- "CultureAgnosticName(fullname='foobar').fullname == 'foobar'"- tT decl [q|CultureAgnosticName(fullname='foobar') ==- CultureAgnosticName(fullname='foobar')|]- tT decl [q|CultureAgnosticName(fullname='wrong') !=- CultureAgnosticName(fullname='foobar')|]- tR' decl "TypeError" "CultureAgnosticName(fullname=1)"- specify "union type with one tag" $ do- let cultureAgnosticNameTag =- Tag "pop"- [ Field "country" "text" empty ]- empty- tags = [cultureAgnosticNameTag]- 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')"- tR' decl "TypeError" "Pop(country=1)"- tT decl "Pop.__slots__ == ('country', )"- specify "union type with behind names" $ do- let pop =- Tag (Name "pop" "popular_music")- [ Field "country" "text" empty ]- empty- tags = [pop]- 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 []) empty- pingService = Service [Method "ping"- [Parameter "nonce" "text" empty]- "bool"- 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__) == \- \ {'nonce', 'return'}"- tT ping' "PingService.ping.__annotations__['nonce'] is str"- tT ping' "PingService.ping.__annotations__['return'] is bool"- tR' ping' "NotImplementedError" "PingService().ping('nonce')"- tR' ping' "NotImplementedError" "PingService().ping(nonce='nonce')"- tR' ping' "TypeError" "PingService().ping(wrongkwd='a')"+ directoryStructure =+ [ "src-py2" </> "test" </> "__init__.py"+ , "src-py2" </> "test" </> "foo" </> "__init__.py"+ , "src-py2" </> "test" </> "foo" </> "bar" </> "__init__.py"+ , "src-py2" </> "test" </> "qux" </> "__init__.py"+ , "src" </> "test" </> "__init__.py"+ , "src" </> "test" </> "foo" </> "__init__.py"+ , "src" </> "test" </> "foo" </> "bar" </> "__init__.py"+ , "src" </> "test" </> "qux" </> "__init__.py"+ , "setup.py"+ , "MANIFEST.in"+ ]+ M.keysSet files `shouldBe` directoryStructure+ it "generates renamed package dirs if renames are configured" $ do+ let (Source pkg _) = makeDummySource' [] (Module [] Nothing)+ [(["foo"], ["quz"])]+ files = compilePackage pkg+ directoryStructure =+ [ "src-py2" </> "quz" </> "__init__.py"+ , "src-py2" </> "quz" </> "bar" </> "__init__.py"+ , "src-py2" </> "qux" </> "__init__.py"+ , "src" </> "quz" </> "__init__.py"+ , "src" </> "quz" </> "bar" </> "__init__.py"+ , "src" </> "qux" </> "__init__.py"+ , "setup.py"+ , "MANIFEST.in"+ ]+ M.keysSet files `shouldBe` directoryStructure+ let (Source pkg' _) = makeDummySource' [] (Module [] Nothing)+ [(["foo", "bar"], ["bar"])]+ files' = compilePackage pkg'+ directoryStructure' =+ [ "src-py2" </> "foo" </> "__init__.py"+ , "src-py2" </> "bar" </> "__init__.py"+ , "src-py2" </> "qux" </> "__init__.py"+ , "src" </> "foo" </> "__init__.py"+ , "src" </> "bar" </> "__init__.py"+ , "src" </> "qux" </> "__init__.py"+ , "setup.py"+ , "MANIFEST.in"+ ]+ M.keysSet files' `shouldBe` directoryStructure' - describe "InstallRequires" $ do+ describe [qq|InstallRequires ($ver)|] $ do let req = InstallRequires [] [] req2 = req { dependencies = ["six"] } req3 = req { optionalDependencies = [((3, 4), ["enum34"])] }@@ -874,8 +407,52 @@ (3, 4) "ipaddress" (req4 `unionInstallRequires` req5) `shouldBe` req6 (req5 `unionInstallRequires` req4) `shouldBe` req6--{-# ANN module ("HLint: ignore Functor law" :: String) #-}-{-# ANN module ("HLint: ignore Monad law, left identity" :: String) #-}-{-# ANN module ("HLint: ignore Monad law, right identity" :: String) #-}-{-# ANN module ("HLint: ignore Use >=>" :: String) #-}+ specify [qq|toImportPath ($ver)|] $ do+ let (Source pkg _) = makeDummySource $ Module [] Nothing+ target' = target $ metadata pkg+ PY.toImportPath target' ["foo", "bar"] `shouldBe` "foo.bar"+ describe [qq|toImportPath ($ver)|] $ do+ it "adds ancestors of packages" $ do+ let (Source pkg _) = makeDummySource $ Module [] Nothing+ modulePaths = MS.keysSet $ modules pkg+ target' = target $ metadata pkg+ PY.toImportPaths target' modulePaths `shouldBe`+ [ "foo"+ , "foo.bar"+ , "qux"+ ]+ it "applies renames before add ancestors of packages" $ do+ let (Source pkg _) = makeDummySource' [] (Module [] Nothing)+ [(["foo"], ["f", "oo"])]+ modulePaths = MS.keysSet $ modules pkg+ target' = target $ metadata pkg+ PY.toImportPaths target' modulePaths `shouldBe`+ [ "f" -- > "f" should be added+ , "f.oo"+ , "f.oo.bar"+ , "qux"+ ]+ specify "parseModulePath" $ do+ parseModulePath "" `shouldBe` Nothing+ parseModulePath "foo" `shouldBe` Just ["foo"]+ parseModulePath "foo.bar" `shouldBe` Just ["foo", "bar"]+ parseModulePath "foo.bar-baz" `shouldBe` Just ["foo", "bar-baz"]+ parseModulePath "foo." `shouldBe` Nothing+ parseModulePath "foo.bar." `shouldBe` Nothing+ parseModulePath ".foo" `shouldBe` Nothing+ parseModulePath ".foo.bar" `shouldBe` Nothing+ parseModulePath "foo..bar" `shouldBe` Nothing+ parseModulePath "foo.bar>" `shouldBe` Nothing+ parseModulePath "foo.bar-" `shouldBe` Nothing+ specify "renameModulePath" $ do+ let renames = [ (["foo"], ["poo"])+ , (["foo", "bar"], ["foo"])+ , (["baz"], ["p", "az"])+ ] :: RenameMap+ renameModulePath renames ["foo"] `shouldBe` ["poo"]+ renameModulePath renames ["foo", "baz"] `shouldBe` ["poo", "baz"]+ renameModulePath renames ["foo", "bar"] `shouldBe` ["foo"]+ renameModulePath renames ["foo", "bar", "qux"] `shouldBe` ["foo", "qux"]+ renameModulePath renames ["baz"] `shouldBe` ["p", "az"]+ renameModulePath renames ["baz", "qux"] `shouldBe` ["p", "az", "qux"]+ renameModulePath renames ["qux", "foo"] `shouldBe` ["qux", "foo"]
+ test/Nirum/TargetsSpec.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE OverloadedLists, OverloadedStrings #-}+module Nirum.TargetsSpec where++import Data.Either (isLeft, isRight)+import System.IO.Error (isDoesNotExistError)++import qualified Data.Map.Strict as M+import System.FilePath ((</>))+import Test.Hspec.Meta+import qualified Text.Parsec.Error as PE+import Text.Parsec.Pos (sourceColumn, sourceLine)++import Nirum.Package (PackageError (ImportError, MetadataError, ScanError))+import Nirum.Package.Metadata (MetadataError (FormatError))+import Nirum.Package.ModuleSet (ImportError (MissingModulePathError))+import Nirum.Targets ( BuildError (PackageError, TargetNameError)+ , buildPackage+ )++spec :: Spec+spec =+ describe "Targets" $+ describe "buildPackage" $ do+ it "returns Left TargetNameError if there's no such target" $ do+ let path = "." </> "examples"+ result <- buildPackage "unregisteredtarget" path+ result `shouldBe` Left (TargetNameError "unregisteredtarget")+ it "returns Left PackageError if the given package is invalid" $ do+ let testDir = "." </> "test"+ -- ScanError+ result <- buildPackage "python" $ testDir </> "scan_error"+ result `shouldSatisfy` isLeft+ let Left (PackageError (ScanError filePath ioError')) = result+ filePath `shouldBe` testDir </> "scan_error" </> "package.toml"+ ioError' `shouldSatisfy` isDoesNotExistError+ -- MetadataError+ result2 <- buildPackage "python" $ testDir </> "metadata_error"+ result2 `shouldSatisfy` isLeft+ let Left (PackageError (MetadataError (FormatError e))) =+ result2+ sourceLine (PE.errorPos e) `shouldBe` 3+ sourceColumn (PE.errorPos e) `shouldBe` 14+ -- ImportError+ result3 <- buildPackage "python" $ testDir </> "import_error"+ result3 `shouldSatisfy` isLeft+ let Left (PackageError (ImportError l)) = result3+ l `shouldBe` [MissingModulePathError ["import_error"] ["foo"]]+ it "returns Right BuildResult" $ do+ result <- buildPackage "python" $ "." </> "examples"+ result `shouldSatisfy` isRight+ let Right buildResult = result+ M.keysSet buildResult `shouldBe`+ [ "MANIFEST.in"+ , "setup.py"+ , "src-py2" </> "address" </> "__init__.py"+ , "src-py2" </> "blockchain" </> "__init__.py"+ , "src-py2" </> "builtins" </> "__init__.py"+ , "src-py2" </> "countries" </> "__init__.py"+ , "src-py2" </> "pdf_service" </> "__init__.py"+ , "src-py2" </> "product" </> "__init__.py"+ , "src-py2" </> "shapes" </> "__init__.py"+ , "src" </> "address" </> "__init__.py"+ , "src" </> "blockchain" </> "__init__.py"+ , "src" </> "builtins" </> "__init__.py"+ , "src" </> "countries" </> "__init__.py"+ , "src" </> "pdf_service" </> "__init__.py"+ , "src" </> "product" </> "__init__.py"+ , "src" </> "shapes" </> "__init__.py"+ ]
+ test/Nirum/TypeInstance/BoundModuleSpec.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Nirum.TypeInstance.BoundModuleSpec where++import Data.Proxy++import Test.Hspec.Meta+import Text.InterpolatedString.Perl6 (qq)++import Nirum.Constructs.Annotation hiding (docs)+import Nirum.Constructs.Declaration+import Nirum.Constructs.Module hiding (docs)+import Nirum.Constructs.TypeDeclaration hiding (modulePath)+import Nirum.Package.Metadata+import Nirum.Package.MetadataSpec+import Nirum.PackageSpec (createValidPackage)+import Nirum.Targets.Python (Python (Python), minimumRuntime)+import Nirum.TypeInstance.BoundModule++spec :: Spec+spec = do+ testPackage (Python "nirum-examples" minimumRuntime [])+ testPackage DummyTarget++testPackage :: forall t . Target t => t -> Spec+testPackage target' = do+ let targetName' = targetName (Proxy :: Proxy t)+ validPackage = createValidPackage target'+ specify "resolveBoundModule" $ do+ let Just bm = resolveBoundModule ["foo"] validPackage+ boundPackage bm `shouldBe` validPackage+ modulePath bm `shouldBe` ["foo"]+ resolveBoundModule ["baz"] validPackage `shouldBe` Nothing+ describe [qq|BoundModule (target: $targetName')|] $ do+ let Just bm = resolveBoundModule ["foo", "bar"] validPackage+ Just abc = resolveBoundModule ["abc"] validPackage+ Just xyz = resolveBoundModule ["xyz"] validPackage+ specify "docs" $ do+ docs bm `shouldBe` Just "foo.bar"+ let Just bm' = resolveBoundModule ["foo"] validPackage+ docs bm' `shouldBe` Just "foo"+ specify "boundTypes" $ do+ boundTypes bm `shouldBe` []+ boundTypes abc `shouldBe` [TypeDeclaration "a" (Alias "text") empty]+ boundTypes xyz `shouldBe`+ [ Import ["abc"] "a" empty+ , TypeDeclaration "x" (Alias "text") empty+ ]+ specify "lookupType" $ do+ lookupType "a" bm `shouldBe` Missing+ lookupType "a" abc `shouldBe` Local (Alias "text")+ lookupType "a" xyz `shouldBe` Imported ["abc"] (Alias "text")+ lookupType "x" bm `shouldBe` Missing+ lookupType "x" abc `shouldBe` Missing+ lookupType "x" xyz `shouldBe` Local (Alias "text")+ lookupType "text" bm `shouldBe`+ Imported coreModulePath (PrimitiveType Text String)+ lookupType "text" abc `shouldBe` lookupType "text" bm+ lookupType "text" xyz `shouldBe` lookupType "text" bm
test/Nirum/VersionSpec.hs view
@@ -17,7 +17,7 @@ version `shouldSatisfy` SV.isDevelopment it "is the proper version" $ -- is it a necessary test?- version `shouldBe` SV.version 0 2 0 [] []+ version `shouldBe` SV.version 0 3 0 [] [] describe "versionText" $ do it "is equivalent to version" $ versionText `shouldBe` SV.toText version