diff --git a/CHANGES.md b/CHANGES.md new file mode 100644 --- /dev/null +++ b/CHANGES.md @@ -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 diff --git a/Main.hs b/Main.hs deleted file mode 100644 --- a/Main.hs +++ /dev/null @@ -1,3 +0,0 @@ -module Main (main) where - -import Nirum.Cli (main) diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 diff --git a/app/nirum.hs b/app/nirum.hs new file mode 100644 --- /dev/null +++ b/app/nirum.hs @@ -0,0 +1,3 @@ +module Main (main) where + +import Nirum.Cli (main) diff --git a/app/test-targets.hs b/app/test-targets.hs new file mode 100644 --- /dev/null +++ b/app/test-targets.hs @@ -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 . +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"] diff --git a/nirum.cabal b/nirum.cabal --- a/nirum.cabal +++ b/nirum.cabal @@ -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 diff --git a/src/Nirum/Cli.hs b/src/Nirum/Cli.hs --- a/src/Nirum/Cli.hs +++ b/src/Nirum/Cli.hs @@ -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") diff --git a/src/Nirum/CodeBuilder.hs b/src/Nirum/CodeBuilder.hs new file mode 100644 --- /dev/null +++ b/src/Nirum/CodeBuilder.hs @@ -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" + +-} diff --git a/src/Nirum/CodeGen.hs b/src/Nirum/CodeGen.hs --- a/src/Nirum/CodeGen.hs +++ b/src/Nirum/CodeGen.hs @@ -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 #-} diff --git a/src/Nirum/Constructs/Annotation.hs b/src/Nirum/Constructs/Annotation.hs --- a/src/Nirum/Constructs/Annotation.hs +++ b/src/Nirum/Constructs/Annotation.hs @@ -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 "" + case insertLookup docsAnnotationName args anno of + (Just _ , _) -> fail "" (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' diff --git a/src/Nirum/Constructs/Annotation/Internal.hs b/src/Nirum/Constructs/Annotation/Internal.hs --- a/src/Nirum/Constructs/Annotation/Internal.hs +++ b/src/Nirum/Constructs/Annotation/Internal.hs @@ -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"] + ] diff --git a/src/Nirum/Constructs/Declaration.hs b/src/Nirum/Constructs/Declaration.hs --- a/src/Nirum/Constructs/Declaration.hs +++ b/src/Nirum/Constructs/Declaration.hs @@ -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 diff --git a/src/Nirum/Constructs/DeclarationSet.hs b/src/Nirum/Constructs/DeclarationSet.hs --- a/src/Nirum/Constructs/DeclarationSet.hs +++ b/src/Nirum/Constructs/DeclarationSet.hs @@ -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] diff --git a/src/Nirum/Constructs/Docs.hs b/src/Nirum/Constructs/Docs.hs --- a/src/Nirum/Constructs/Docs.hs +++ b/src/Nirum/Constructs/Docs.hs @@ -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' diff --git a/src/Nirum/Constructs/Identifier.hs b/src/Nirum/Constructs/Identifier.hs --- a/src/Nirum/Constructs/Identifier.hs +++ b/src/Nirum/Constructs/Identifier.hs @@ -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 diff --git a/src/Nirum/Constructs/Module.hs b/src/Nirum/Constructs/Module.hs --- a/src/Nirum/Constructs/Module.hs +++ b/src/Nirum/Constructs/Module.hs @@ -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 _) = diff --git a/src/Nirum/Constructs/ModulePath.hs b/src/Nirum/Constructs/ModulePath.hs --- a/src/Nirum/Constructs/ModulePath.hs +++ b/src/Nirum/Constructs/ModulePath.hs @@ -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] diff --git a/src/Nirum/Constructs/Name.hs b/src/Nirum/Constructs/Name.hs --- a/src/Nirum/Constructs/Name.hs +++ b/src/Nirum/Constructs/Name.hs @@ -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) diff --git a/src/Nirum/Constructs/Service.hs b/src/Nirum/Constructs/Service.hs --- a/src/Nirum/Constructs/Service.hs +++ b/src/Nirum/Constructs/Service.hs @@ -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) diff --git a/src/Nirum/Constructs/TypeDeclaration.hs b/src/Nirum/Constructs/TypeDeclaration.hs --- a/src/Nirum/Constructs/TypeDeclaration.hs +++ b/src/Nirum/Constructs/TypeDeclaration.hs @@ -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' diff --git a/src/Nirum/Constructs/TypeExpression.hs b/src/Nirum/Constructs/TypeExpression.hs --- a/src/Nirum/Constructs/TypeExpression.hs +++ b/src/Nirum/Constructs/TypeExpression.hs @@ -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. diff --git a/src/Nirum/Docs.hs b/src/Nirum/Docs.hs new file mode 100644 --- /dev/null +++ b/src/Nirum/Docs.hs @@ -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 diff --git a/src/Nirum/Docs/Html.hs b/src/Nirum/Docs/Html.hs new file mode 100644 --- /dev/null +++ b/src/Nirum/Docs/Html.hs @@ -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 = "
" +renderInline (HtmlInline html) = html +renderInline (Code code') = [qq|{escape code'}|] +renderInline (Emphasis inlines) = [qq|{renderInlines inlines}|] +renderInline (Strong inlines) = [qq|{renderInlines inlines}|] +renderInline (Link url title inlines) = + let body = renderInlines inlines + in + if T.null title + then [qq|$body|] + else [qq|$body|] +renderInline (Image url title) = + if T.null title + then [qq||] + else [qq||] + +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 = "
" +renderBlock (Paragraph inlines) = [qq|

{renderInlines inlines}

|] +renderBlock (BlockQuote blocks) = + [qq|
{renderBlocks blocks}|] +renderBlock (HtmlBlock html) = html +renderBlock (CodeBlock lang code') = + if T.null lang + then [qq|
$code'
|] + else [qq|
$code'
|] +renderBlock (Heading level inlines) = + let lv = headingLevelInt level + in [qq|{renderInlines inlines}|] +renderBlock (List listType itemList) = + let liList = case itemList of + TightItemList items -> + [ [qq|
  • {renderInlines item}
    • |] + | item <- items + ] + LooseItemList items -> + [ [qq|
  • {renderBlocks item}
    • |] + | 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|] + +renderBlocks :: [Block] -> Html +renderBlocks = T.intercalate "\n" . map renderBlock + +render :: Block -> Html +render = renderBlock diff --git a/src/Nirum/Docs/ReStructuredText.hs b/src/Nirum/Docs/ReStructuredText.hs new file mode 100644 --- /dev/null +++ b/src/Nirum/Docs/ReStructuredText.hs @@ -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 diff --git a/src/Nirum/Package.hs b/src/Nirum/Package.hs --- a/src/Nirum/Package.hs +++ b/src/Nirum/Package.hs @@ -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 diff --git a/src/Nirum/Package/Metadata.hs b/src/Nirum/Package/Metadata.hs new file mode 100644 --- /dev/null +++ b/src/Nirum/Package/Metadata.hs @@ -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' + } diff --git a/src/Nirum/Package/ModuleSet.hs b/src/Nirum/Package/ModuleSet.hs new file mode 100644 --- /dev/null +++ b/src/Nirum/Package/ModuleSet.hs @@ -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 diff --git a/src/Nirum/Parser.hs b/src/Nirum/Parser.hs --- a/src/Nirum/Parser.hs +++ b/src/Nirum/Parser.hs @@ -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) #-} diff --git a/src/Nirum/Targets.hs b/src/Nirum/Targets.hs new file mode 100644 --- /dev/null +++ b/src/Nirum/Targets.hs @@ -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 diff --git a/src/Nirum/Targets/Docs.hs b/src/Nirum/Targets/Docs.hs new file mode 100644 --- /dev/null +++ b/src/Nirum/Targets/Docs.hs @@ -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 + + + + #{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 diff --git a/src/Nirum/Targets/List.hs b/src/Nirum/Targets/List.hs new file mode 100644 --- /dev/null +++ b/src/Nirum/Targets/List.hs @@ -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 + ] diff --git a/src/Nirum/Targets/Python.hs b/src/Nirum/Targets/Python.hs --- a/src/Nirum/Targets/Python.hs +++ b/src/Nirum/Targets/Python.hs @@ -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 diff --git a/src/Nirum/TypeInstance/BoundModule.hs b/src/Nirum/TypeInstance/BoundModule.hs new file mode 100644 --- /dev/null +++ b/src/Nirum/TypeInstance/BoundModule.hs @@ -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 diff --git a/test/Nirum/CliSpec.hs b/test/Nirum/CliSpec.hs --- a/test/Nirum/CliSpec.hs +++ b/test/Nirum/CliSpec.hs @@ -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") diff --git a/test/Nirum/CodeBuilderSpec.hs b/test/Nirum/CodeBuilderSpec.hs new file mode 100644 --- /dev/null +++ b/test/Nirum/CodeBuilderSpec.hs @@ -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 diff --git a/test/Nirum/CodeGenSpec.hs b/test/Nirum/CodeGenSpec.hs --- a/test/Nirum/CodeGenSpec.hs +++ b/test/Nirum/CodeGenSpec.hs @@ -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) diff --git a/test/Nirum/Constructs/AnnotationSpec.hs b/test/Nirum/Constructs/AnnotationSpec.hs --- a/test/Nirum/Constructs/AnnotationSpec.hs +++ b/test/Nirum/Constructs/AnnotationSpec.hs @@ -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 diff --git a/test/Nirum/Constructs/DeclarationSetSpec.hs b/test/Nirum/Constructs/DeclarationSetSpec.hs --- a/test/Nirum/Constructs/DeclarationSetSpec.hs +++ b/test/Nirum/Constructs/DeclarationSetSpec.hs @@ -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' diff --git a/test/Nirum/Constructs/DocsSpec.hs b/test/Nirum/Constructs/DocsSpec.hs --- a/test/Nirum/Constructs/DocsSpec.hs +++ b/test/Nirum/Constructs/DocsSpec.hs @@ -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" diff --git a/test/Nirum/Constructs/IdentifierSpec.hs b/test/Nirum/Constructs/IdentifierSpec.hs --- a/test/Nirum/Constructs/IdentifierSpec.hs +++ b/test/Nirum/Constructs/IdentifierSpec.hs @@ -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" diff --git a/test/Nirum/Constructs/ModulePathSpec.hs b/test/Nirum/Constructs/ModulePathSpec.hs --- a/test/Nirum/Constructs/ModulePathSpec.hs +++ b/test/Nirum/Constructs/ModulePathSpec.hs @@ -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] diff --git a/test/Nirum/Constructs/ModuleSpec.hs b/test/Nirum/Constructs/ModuleSpec.hs --- a/test/Nirum/Constructs/ModuleSpec.hs +++ b/test/Nirum/Constructs/ModuleSpec.hs @@ -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 diff --git a/test/Nirum/Constructs/NameSpec.hs b/test/Nirum/Constructs/NameSpec.hs --- a/test/Nirum/Constructs/NameSpec.hs +++ b/test/Nirum/Constructs/NameSpec.hs @@ -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 = diff --git a/test/Nirum/Constructs/ServiceSpec.hs b/test/Nirum/Constructs/ServiceSpec.hs --- a/test/Nirum/Constructs/ServiceSpec.hs +++ b/test/Nirum/Constructs/ServiceSpec.hs @@ -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,|] diff --git a/test/Nirum/Constructs/TypeDeclarationSpec.hs b/test/Nirum/Constructs/TypeDeclarationSpec.hs --- a/test/Nirum/Constructs/TypeDeclarationSpec.hs +++ b/test/Nirum/Constructs/TypeDeclarationSpec.hs @@ -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 diff --git a/test/Nirum/Constructs/TypeExpressionSpec.hs b/test/Nirum/Constructs/TypeExpressionSpec.hs --- a/test/Nirum/Constructs/TypeExpressionSpec.hs +++ b/test/Nirum/Constructs/TypeExpressionSpec.hs @@ -2,7 +2,7 @@ import Test.Hspec.Meta -import Nirum.Constructs.TypeExpression (TypeExpression(..), toCode) +import Nirum.Constructs.TypeExpression (TypeExpression (..), toCode) spec :: Spec spec = diff --git a/test/Nirum/Docs/HtmlSpec.hs b/test/Nirum/Docs/HtmlSpec.hs new file mode 100644 --- /dev/null +++ b/test/Nirum/Docs/HtmlSpec.hs @@ -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 diff --git a/test/Nirum/Docs/ReStructuredTextSpec.hs b/test/Nirum/Docs/ReStructuredTextSpec.hs new file mode 100644 --- /dev/null +++ b/test/Nirum/Docs/ReStructuredTextSpec.hs @@ -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 diff --git a/test/Nirum/DocsSpec.hs b/test/Nirum/DocsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Nirum/DocsSpec.hs @@ -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" + , "." + ] diff --git a/test/Nirum/Package/MetadataSpec.hs b/test/Nirum/Package/MetadataSpec.hs new file mode 100644 --- /dev/null +++ b/test/Nirum/Package/MetadataSpec.hs @@ -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 diff --git a/test/Nirum/Package/ModuleSetSpec.hs b/test/Nirum/Package/ModuleSetSpec.hs new file mode 100644 --- /dev/null +++ b/test/Nirum/Package/ModuleSetSpec.hs @@ -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"] + ] + ] diff --git a/test/Nirum/PackageSpec.hs b/test/Nirum/PackageSpec.hs --- a/test/Nirum/PackageSpec.hs +++ b/test/Nirum/PackageSpec.hs @@ -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 diff --git a/test/Nirum/ParserSpec.hs b/test/Nirum/ParserSpec.hs --- a/test/Nirum/ParserSpec.hs +++ b/test/Nirum/ParserSpec.hs @@ -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') diff --git a/test/Nirum/Targets/DocsSpec.hs b/test/Nirum/Targets/DocsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Nirum/Targets/DocsSpec.hs @@ -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>" diff --git a/test/Nirum/Targets/PythonSpec.hs b/test/Nirum/Targets/PythonSpec.hs --- a/test/Nirum/Targets/PythonSpec.hs +++ b/test/Nirum/Targets/PythonSpec.hs @@ -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"] diff --git a/test/Nirum/TargetsSpec.hs b/test/Nirum/TargetsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Nirum/TargetsSpec.hs @@ -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" + ] diff --git a/test/Nirum/TypeInstance/BoundModuleSpec.hs b/test/Nirum/TypeInstance/BoundModuleSpec.hs new file mode 100644 --- /dev/null +++ b/test/Nirum/TypeInstance/BoundModuleSpec.hs @@ -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 diff --git a/test/Nirum/VersionSpec.hs b/test/Nirum/VersionSpec.hs --- a/test/Nirum/VersionSpec.hs +++ b/test/Nirum/VersionSpec.hs @@ -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