summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2015-10-20 20:31:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2015-10-20 20:31:00 (GMT)
commit02ef1718f713f0ba740b412d9c746a6528e315f0 (patch)
tree6183f46dcca728a374cb2f6d6c54da07a4a14a7e
parent414866c38a08e4a8a56cc3b7e8b0712743cb9551 (diff)
version 0.7.50.7.5
-rw-r--r--CONTRIBUTING.md44
-rw-r--r--CONTRIBUTORS.md61
-rw-r--r--INSTALL.md57
-rw-r--r--LICENSE235
-rw-r--r--README.md28
-rw-r--r--examples/failing/1071.purs8
-rw-r--r--examples/failing/1310.purs18
-rw-r--r--examples/failing/881.purs13
-rw-r--r--examples/failing/Arrays.purs2
-rw-r--r--examples/failing/EmptyCase.purs4
-rw-r--r--examples/failing/KindStar.purs8
-rw-r--r--examples/failing/MultipleErrors.purs4
-rw-r--r--examples/failing/Rank2Types.purs2
-rw-r--r--examples/failing/TransitiveDctorExport.purs5
-rw-r--r--examples/failing/TransitiveSynonymExport.purs5
-rw-r--r--examples/failing/TypeError.purs2
-rw-r--r--examples/failing/TypedBinders.purs10
-rw-r--r--examples/failing/TypedBinders2.purs9
-rw-r--r--examples/failing/TypedBinders3.purs12
-rw-r--r--examples/passing/862.purs8
-rw-r--r--examples/passing/922.purs20
-rw-r--r--examples/passing/LargeSumType.purs33
-rw-r--r--examples/passing/NakedConstraint.purs12
-rw-r--r--examples/passing/OptionalQualified.purs13
-rw-r--r--examples/passing/QualifiedQualifiedImports.purs6
-rw-r--r--examples/passing/TypedBinders.purs62
-rw-r--r--examples/passing/UTF8Sourcefile.purs10
-rw-r--r--psc-docs/Main.hs8
-rw-r--r--psc/Main.hs6
-rw-r--r--psci/Completion.hs22
-rw-r--r--psci/PSCi.hs23
-rw-r--r--psci/Parser.hs1
-rw-r--r--purescript.cabal24
-rw-r--r--src/Language/PureScript/AST/Binders.hs8
-rw-r--r--src/Language/PureScript/AST/Declarations.hs34
-rw-r--r--src/Language/PureScript/AST/Exported.hs2
-rw-r--r--src/Language/PureScript/AST/Operators.hs23
-rw-r--r--src/Language/PureScript/AST/SourcePos.hs23
-rw-r--r--src/Language/PureScript/AST/Traversals.hs13
-rw-r--r--src/Language/PureScript/Bundle.hs20
-rw-r--r--src/Language/PureScript/CodeGen.hs5
-rw-r--r--src/Language/PureScript/CodeGen/Externs.hs144
-rw-r--r--src/Language/PureScript/CodeGen/JS.hs11
-rw-r--r--src/Language/PureScript/CodeGen/JS/AST.hs6
-rw-r--r--src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs2
-rw-r--r--src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs2
-rw-r--r--src/Language/PureScript/CodeGen/JS/Optimizer/Unused.hs2
-rw-r--r--src/Language/PureScript/Comments.hs6
-rw-r--r--src/Language/PureScript/CoreFn/Binders.hs2
-rw-r--r--src/Language/PureScript/CoreFn/Desugar.hs3
-rw-r--r--src/Language/PureScript/CoreFn/Expr.hs8
-rw-r--r--src/Language/PureScript/CoreFn/Literals.hs2
-rw-r--r--src/Language/PureScript/CoreFn/Meta.hs4
-rw-r--r--src/Language/PureScript/CoreFn/Module.hs2
-rw-r--r--src/Language/PureScript/Docs/AsMarkdown.hs2
-rw-r--r--src/Language/PureScript/Docs/Convert.hs28
-rw-r--r--src/Language/PureScript/Docs/ParseAndDesugar.hs2
-rw-r--r--src/Language/PureScript/Docs/Render.hs7
-rw-r--r--src/Language/PureScript/Docs/RenderedCode/Render.hs2
-rw-r--r--src/Language/PureScript/Docs/Types.hs2
-rw-r--r--src/Language/PureScript/Environment.hs26
-rw-r--r--src/Language/PureScript/Errors.hs829
-rw-r--r--src/Language/PureScript/Externs.hs216
-rw-r--r--src/Language/PureScript/Kinds.hs2
-rw-r--r--src/Language/PureScript/Linter.hs52
-rw-r--r--src/Language/PureScript/Linter/Exhaustive.hs125
-rw-r--r--src/Language/PureScript/Make.hs215
-rw-r--r--src/Language/PureScript/ModuleDependencies.hs16
-rw-r--r--src/Language/PureScript/Names.hs39
-rw-r--r--src/Language/PureScript/Parser/Declarations.hs71
-rw-r--r--src/Language/PureScript/Parser/Kinds.hs2
-rw-r--r--src/Language/PureScript/Parser/Lexer.hs10
-rw-r--r--src/Language/PureScript/Parser/Types.hs22
-rw-r--r--src/Language/PureScript/Pretty/Common.hs13
-rw-r--r--src/Language/PureScript/Pretty/JS.hs26
-rw-r--r--src/Language/PureScript/Pretty/Kinds.hs5
-rw-r--r--src/Language/PureScript/Pretty/Types.hs95
-rw-r--r--src/Language/PureScript/Pretty/Values.hs260
-rw-r--r--src/Language/PureScript/Publish.hs12
-rw-r--r--src/Language/PureScript/Publish/ErrorsWarnings.hs37
-rw-r--r--src/Language/PureScript/Renamer.hs10
-rw-r--r--src/Language/PureScript/Sugar.hs26
-rw-r--r--src/Language/PureScript/Sugar/BindingGroups.hs3
-rw-r--r--src/Language/PureScript/Sugar/CaseDeclarations.hs4
-rw-r--r--src/Language/PureScript/Sugar/DoNotation.hs4
-rw-r--r--src/Language/PureScript/Sugar/Names.hs69
-rw-r--r--src/Language/PureScript/Sugar/Names/Env.hs26
-rw-r--r--src/Language/PureScript/Sugar/Names/Exports.hs9
-rw-r--r--src/Language/PureScript/Sugar/Names/Imports.hs64
-rw-r--r--src/Language/PureScript/Sugar/Operators.hs20
-rw-r--r--src/Language/PureScript/Sugar/TypeClasses.hs26
-rw-r--r--src/Language/PureScript/Sugar/TypeDeclarations.hs70
-rw-r--r--src/Language/PureScript/TypeChecker.hs138
-rw-r--r--src/Language/PureScript/TypeChecker/Entailment.hs71
-rw-r--r--src/Language/PureScript/TypeChecker/Kinds.hs8
-rw-r--r--src/Language/PureScript/TypeChecker/Monad.hs3
-rw-r--r--src/Language/PureScript/TypeChecker/Rows.hs1
-rw-r--r--src/Language/PureScript/TypeChecker/Skolems.hs2
-rw-r--r--src/Language/PureScript/TypeChecker/Subsumption.hs10
-rw-r--r--src/Language/PureScript/TypeChecker/Synonyms.hs86
-rw-r--r--src/Language/PureScript/TypeChecker/Types.hs145
-rw-r--r--src/Language/PureScript/TypeChecker/Unify.hs42
-rw-r--r--src/Language/PureScript/TypeClassDictionaries.hs26
-rw-r--r--src/Language/PureScript/Types.hs35
-rw-r--r--src/System/IO/UTF8.hs9
-rw-r--r--stack-lts-2.yaml9
-rw-r--r--stack-lts-3.yaml5
-rw-r--r--stack-nightly.yaml5
-rw-r--r--stack.yaml5
-rw-r--r--tests/Main.hs7
110 files changed, 2479 insertions, 1672 deletions
diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md
new file mode 100644
index 0000000..18ee408
--- /dev/null
+++ b/CONTRIBUTING.md
@@ -0,0 +1,44 @@
+An introductory overview of the compiler is available [here](https://www.youtube.com/watch?v=Y3P1dxqwFiE).
+
+Pull requests are encouraged.
+
+## Finding Issues to Work On
+
+If you would like to contribute, please consider the issues in the current milestone first. If you are a new contributor, you may want to have a go at the ["easy" issues](https://github.com/purescript/purescript/labels/easy) to get started.
+
+## Pull Requests
+
+Please follow the following guidelines:
+
+- Add at least a test to `examples/passing/` and possibly to `examples/failing`.
+- Build the binaries and libs with `cabal build`
+- Install the binaries and libs with `cabal install`.
+- Run `cabal configure --enable-tests && cabal build && cabal test` to build the test suite. You will need `npm` and `node` on your PATH to run the tests.
+- Build the core libraries by running the script in `core-tests`.
+
+## Code Review
+
+To prevent core libraries from getting broken, every change must be reviewed. A pull request will be merged as long as one other team member has verified the changes.
+
+## Adding Dependencies
+
+Because the PureScript compiler is distributed in binary form, we include
+the licenses of all dependencies, including transitive ones, in the LICENSE
+file. Therefore, whenever the dependencies change, the LICENSE file should be
+updated.
+
+You can automate this (if you have bash):
+
+- get a copy of [cabal-dependency-licenses][]
+- run at the command line: `./license/generate > LICENSE`
+
+[cabal-dependency-licenses]: https://github.com/jaspervdj/cabal-dependency-licenses
+
+## Writing Issues
+
+- If the issue is actually a question, please consider asking on Reddit, Stack Overflow or IRC first.
+- Please include a minimal, repeatable test case with any bug report.
+
+## Copyright and Licensing
+
+For any code change, please append a copyright and licensing notice to the [CONTRIBUTORS.md](CONTRIBUTORS.md) file.
diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md
new file mode 100644
index 0000000..cac0aad
--- /dev/null
+++ b/CONTRIBUTORS.md
@@ -0,0 +1,61 @@
+## Contributors
+
+This file lists the contributors to the PureScript compiler project, and the terms under which their code is licensed.
+
+### Individuals
+
+- [@5outh](https://github.com/5outh) (Benjamin Kovach) - My existing contributions and all future contributions until further notice are Copyright Benjamin Kovach, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license.
+- [@andyarvanitis](https://github.com/andyarvanitis) (Andy Arvanitis) My existing contributions and all future contributions until further notice are Copyright Andy Arvanitis, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
+- [@anthok88](https://github.com/anthoq88) - My existing contributions and all future contributions until further notice are Copyright anthoq88, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license
+- [@ardumont](https://github.com/ardumont) (Antoine R. Dumont) My existing contributions and all future contributions until further notice are Copyright Antoine R. Dumont, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
+- [@aspidites](https://github.com/aspidites) (Edwin Marshall) My existing contributions and all future contributions until further notice are Copyright Edwin Marshall, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
+- [@balajirrao](https://github.com/balajirrao) (Balaji Rao) - My existing contributions and all future contributions until further notice are Copyright Balaji Rao, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license.
+- [@bergmark](https://github.com/bergmark) (Adam Bergmark) - My existing contributions and all future contributions until further notice are Copyright Adam Bergmark, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license.
+- [@Bogdanp](https://github.com/Bogdanp) (Bogdan Paul Popa) My existing contributions and all future contributions until further notice are Copyright Bogdan Paul Popa, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
+- [@davidchambers](https://github.com/davidchambers) (David Chambers) My existing contributions and all future contributions until further notice are Copyright David Chambers, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
+- [@dckc](https://github.com/dckc) (Dan Connolly) My existing contributions and all future contributions until further notice are Copyright Dan Connolly, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
+- [@dylex](https://github.com/dylex) (Dylan Simon) My existing and all future contributions to the PureScript compiler until further notice are Copyright Dylan Simon, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
+- [@eamelink](https://github.com/eamelink) (Erik Bakker) - My existing contributions and all future contributions until further notice are Copyright Erik Bakker, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license.
+- [@epost](https://github.com/epost) (Erik Post) - My existing contributions and all future contributions until further notice are Copyright Erik Post, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license
+- [@erdeszt](https://github.com/erdeszt) (Tibor Erdesz) My existing contributions and all future contributions until further notice are Copyright Tibor Erdesz, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
+- [@etrepum](https://github.com/etrepum) (Bob Ippolito) My existing contributions and all future contributions until further notice are Copyright Bob Ippolito, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
+- [@garyb](https://github.com/garyb) (Gary Burgess) My existing contributions and all future contributions until further notice are Copyright Gary Burgess, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
+- [@hdgarrood](https://github.com/hdgarrood) (Harry Garrood) My existing contributions and all future contributions until further notice are Copyright Harry Garrood, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
+- [@jacereda](https://github.com/jacereda) (Jorge Acereda) My existing contributions and all future contributions until further notice are Copyright Jorge Acereda, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
+- [@japesinator](https://github.com/japesinator) (JP Smith) My existing contributions and all future contributions until further notice are Copyright JP Smith, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
+- [@joneshf](https://github.com/joneshf) (Hardy Jones) - My existing contributions and all future contributions until further notice are Copyright Hardy Jones, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license.
+- [@kRITZCREEK](https://github.com/kRITZCREEK) (Christoph Hegemann) - My existing contributions and all future contributions until further notice are Copyright Christoph Hegemann, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license.
+- [@L8D](https://github.com/L8D) (Tenor Biel) My existing contributions and all future contributions until further notice are Copyright Tenor Biel, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
+- [@lukerandall](https://github.com/lukerandall) (Luke Randall) My existing contributions and all future contributions until further notice are Copyright Luke Randall, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
+- [@michaelficarra](https://github.com/michaelficarra) (Michael Ficarra) My existing contributions and all future contributions until further notice are Copyright Michael Ficarra, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
+- [@MichaelXavier](https://github.com/MichaelXavier) (Michael Xavier) - My existing contributions and all future contributions until further notice are Copyright Michael Xavier, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license.
+- [@mjgpy3](https://github.com/mjgpy3) (Michael Gilliland) My existing contributions and all future contributions until further notice are Copyright Michael Gilliland, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
+- [@mpietrzak](https://github.com/mpietrzak) (Maciej Pietrzak) My existing contributions and all future contributions until further notice are Copyright Maciej Pietrzak, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
+- [@mrhania](https://github.com/mrhania) (Łukasz Hanuszczak) - My existing contributions and all future contributions until further notice are Copyright Łukasz Hanuszczak, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
+- [@nagisa](https://github.com/nagisa) I hereby release my [only contribution](https://github.com/purescript/purescript/commit/80287a5d0de619862d3b4cda9c1ee276d18fdcd8) into public domain.
+- [@natefaubion](https://github.com/natefaubion) (Nathan Faubion) My existing contributions and all future contributions until further notice are Copyright Nathan Faubion, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
+- [@nicodelpiano](https://github.com/nicodelpiano) (Nicolas Del Piano) My existing contributions and all future contributions until further notice are Copyright Nicolas Del Piano, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
+- [@nullobject](https://github.com/nullobject) (Josh Bassett) My existing contributions and all future contributions until further notice are Copyright Josh Bassett, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
+- [@osa1](https://github.com/osa1) (Ömer Sinan Ağacan) - My existing contributions and all future contributions until further notice are Copyright Ömer Sinan Ağacan, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license.
+- [@paf31](https://github.com/paf31) (Phil Freeman) My existing contributions and all future contributions until further notice are Copyright Phil Freeman, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
+- [@paulyoung](https://github.com/paulyoung) (Paul Young) My existing contributions and all future contributions until further notice are Copyright Paul Young, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
+- [@pelotom](https://github.com/pelotom) (Thomas Crockett) My existing contributions and all future contributions until further notice are Copyright Thomas Crockett, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
+- [@phadej](https://github.com/phadej) (Oleg Grenrus) My existing contributions and all future contributions until further notice are Copyright Oleg Grenrus, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
+- [@philopon](https://github.com/philopon) (Hirotomo Moriwaki) - My existing contributions and all future contributions until further notice are Copyright Hirotomo Moriwaki, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
+- [@pseudonom](https://github.com/pseudonom) (Eric Easley) My existing contributions and all future contributions until further notice are Copyright Eric Easley, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
+- [@puffnfresh](https://github.com/puffnfresh) (Brian McKenna) All contributions I made during June 2015 were during employment at [SlamData, Inc.](#companies) who owns the copyright. I assign copyright of all my personal contributions before June 2015 to the owners of the PureScript compiler.
+- [@robdaemon](https://github.com/robdaemon) (Robert Roland) My existing contributions and all future contributions until further notice are Copyright Robert Roland, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
+- [@RossMeikleham](https://github.com/RossMeikleham) (Ross Meikleham) My existing contributions and all future contributions until further notice are Copyright Ross Meikleham, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
+- [@sebastiaanvisser](https://github.com/sebastiaanvisser) (Sebastiaan Visser) - My existing contributions and all future contributions until further notice are Copyright Sebastiaan Visser, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license.
+- [@sztupi](https://github.com/sztupi) (Attila Sztupak) My existing contributions and all future contributions until further notice are Copyright Attila Sztupak, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
+- [@taku0](https://github.com/taku0) - My existing contributions and all future contributions until further notice are Copyright taku0, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
+- [@trofi](https://github.com/trofi) (Sergei Trofimovich) My existing contributions and all future contributions until further notice are Copyright Sergei Trofimovich, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
+- [@utkarshkukreti](https://github.com/utkarshkukreti) (Utkarsh Kukreti) My existing contributions and all future contributions until further notice are Copyright Utkarsh Kukreti, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
+- [@vkorablin](https://github.com/vkorablin) (Vladimir Korablin) - My existing contributions and all future contributions until further notice are Copyright Vladimir Korablin, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license.
+- [@zudov](https://github.com/zudov) (Konstantin Zudov) My existing contributions and all future contributions until further notice are Copyright Konstantin Zudov, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
+- [@senju](https://github.com/senju) - My existing contributions and all future contributions until further notice are Copyright senju, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
+<http://opensource.org/licenses/MIT>.
+
+### Companies
+
+- [@slamdata](https://github.com/slamdata) (SlamData, Inc.) Speaking on behalf of SlamData for SlamData employees, our existing contributions and all future contributions to the PureScript compiler are, until further notice, Copyright SlamData Inc., and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - @jdegoes
diff --git a/INSTALL.md b/INSTALL.md
new file mode 100644
index 0000000..5e4bc78
--- /dev/null
+++ b/INSTALL.md
@@ -0,0 +1,57 @@
+# Installation information
+
+If you are having difficulty installing the PureScript compiler, feel free to
+ask for help! A good place is the #purescript IRC channel on Freenode, or
+alternatively Stack Overflow.
+
+## Using prebuilt binaries
+
+The prebuilt binaries are compiled with GHC 7.8.4, and therefore they should
+run on any operating system supported by GHC 7.8.4, such as:
+
+* Windows 2000 or later,
+* OS X 10.7 or later,
+* Linux ??? (we're not sure what the minimum version is).
+
+This list is not exhaustive. If your OS is too old or not listed, or if the
+binaries fail to run, you may be able to install the compiler by building it
+from source; see below.
+
+It's probably safe to assume that other prebuilt distributions (eg, Homebrew,
+Chocolatey, AUR, npm) use the same binaries, and therefore have the same
+requirements.
+
+## Compiling from source
+
+GHC 7.6.1 or newer is required to compile from source. The easiest way is to
+use stack:
+
+```
+$ stack install purescript
+```
+
+This will then copy the compiler and utilities into `~/.local/bin`.
+
+
+If you don't have stack installed yet there are install instructions
+[here](https://github.com/commercialhaskell/stack/blob/master/doc/install_and_upgrade.md).
+
+If you don't have ghc installed yet, stack will prompt you to run `stack setup`
+which will install ghc for you.
+
+The PureScript compiler has been known to run on OS X 10.6 when built with GHC
+7.6.
+
+
+## The "curses" library
+
+`psci` depends on the `curses` library (via the Haskell package `terminfo`). If
+you are having difficulty running the compiler, it may be because the `curses`
+library is missing.
+
+On Linux, you will probably need to install `ncurses` manually. On Ubuntu, for
+example, this can be done by running:
+
+```
+$ sudo apt-get install libncurses5-dev
+```
diff --git a/LICENSE b/LICENSE
index 8135c95..6f84bf8 100644
--- a/LICENSE
+++ b/LICENSE
@@ -31,6 +31,7 @@ PureScript uses the following Haskell library packages. Their license files foll
array
attoparsec
base
+ binary
blaze-builder
bower-json
boxes
@@ -45,9 +46,10 @@ PureScript uses the following Haskell library packages. Their license files foll
haskeline
integer-gmp
language-javascript
+ lifted-base
+ monad-control
mtl
nats
- old-locale
optparse-applicative
parsec
pattern-arrows
@@ -59,12 +61,14 @@ PureScript uses the following Haskell library packages. Their license files foll
scientific
semigroups
split
+ stm
syb
template-haskell
terminfo
text
time
transformers
+ transformers-base
transformers-compat
unix
unordered-containers
@@ -449,6 +453,39 @@ base LICENSE file:
-----------------------------------------------------------------------------
+binary LICENSE file:
+
+ Copyright (c) Lennart Kolmodin
+
+ All rights reserved.
+
+ Redistribution and use in source and binary forms, with or without
+ modification, are permitted provided that the following conditions
+ are met:
+
+ 1. Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ 2. Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer in the
+ documentation and/or other materials provided with the distribution.
+
+ 3. Neither the name of the author nor the names of his contributors
+ may be used to endorse or promote products derived from this software
+ without specific prior written permission.
+
+ THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS
+ OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+ WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+ DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
+ ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+ STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
+ ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ POSSIBILITY OF SUCH DAMAGE.
+
blaze-builder LICENSE file:
Copyright Jasper Van der Jeugt 2010, Simon Meier 2010 & 2011
@@ -967,6 +1004,70 @@ language-javascript LICENSE file:
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+lifted-base LICENSE file:
+
+ Copyright © 2010-2012, Bas van Dijk, Anders Kaseorg
+ All rights reserved.
+
+ Redistribution and use in source and binary forms, with or without
+ modification, are permitted provided that the following conditions are
+ met:
+
+ • Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ • Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer in the
+ documentation and/or other materials provided with the distribution.
+
+ • Neither the name of the author nor the names of other contributors
+ may be used to endorse or promote products derived from this
+ software without specific prior written permission.
+
+ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+ “AS IS” AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+ LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+ A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+ HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+ SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+ LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+ DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+ THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+ (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+monad-control LICENSE file:
+
+ Copyright © 2010, Bas van Dijk, Anders Kaseorg
+ All rights reserved.
+
+ Redistribution and use in source and binary forms, with or without
+ modification, are permitted provided that the following conditions are
+ met:
+
+ • Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ • Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer in the
+ documentation and/or other materials provided with the distribution.
+
+ • Neither the name of the author nor the names of other contributors
+ may be used to endorse or promote products derived from this
+ software without specific prior written permission.
+
+ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+ “AS IS” AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+ LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+ A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+ HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+ SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+ LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+ DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+ THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+ (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
mtl LICENSE file:
The Glasgow Haskell Compiler License
@@ -1034,72 +1135,6 @@ nats LICENSE file:
ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.
-old-locale LICENSE file:
-
- This library (libraries/base) is derived from code from two
- sources:
-
- * Code from the GHC project which is largely (c) The University of
- Glasgow, and distributable under a BSD-style license (see below),
-
- * Code from the Haskell 98 Report which is (c) Simon Peyton Jones
- and freely redistributable (but see the full license for
- restrictions).
-
- The full text of these licenses is reproduced below. Both of the
- licenses are BSD-style or compatible.
-
- -----------------------------------------------------------------------------
-
- The Glasgow Haskell Compiler License
-
- Copyright 2004, The University Court of the University of Glasgow.
- All rights reserved.
-
- Redistribution and use in source and binary forms, with or without
- modification, are permitted provided that the following conditions are met:
-
- - Redistributions of source code must retain the above copyright notice,
- this list of conditions and the following disclaimer.
-
- - Redistributions in binary form must reproduce the above copyright notice,
- this list of conditions and the following disclaimer in the documentation
- and/or other materials provided with the distribution.
-
- - Neither name of the University nor the names of its contributors may be
- used to endorse or promote products derived from this software without
- specific prior written permission.
-
- THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF
- GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
- INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
- FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
- UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE
- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
- LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
- OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
- DAMAGE.
-
- -----------------------------------------------------------------------------
-
- Code derived from the document "Report on the Programming Language
- Haskell 98", is distributed under the following license:
-
- Copyright (c) 2002 Simon Peyton Jones
-
- The authors intend this Report to belong to the entire Haskell
- community, and so we grant permission to copy and distribute it for
- any purpose, provided that it is reproduced in its entirety,
- including this Notice. Modified versions of this Report may also be
- copied and distributed for any purpose, provided that the modified
- version is clearly presented as such, and that it does not claim to
- be a definition of the Haskell 98 Language.
-
- -----------------------------------------------------------------------------
-
optparse-applicative LICENSE file:
Copyright (c) 2012, Paolo Capriotti
@@ -1450,6 +1485,40 @@ split LICENSE file:
OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
SUCH DAMAGE.
+stm LICENSE file:
+
+ The Glasgow Haskell Compiler License
+
+ Copyright 2004, The University Court of the University of Glasgow.
+ All rights reserved.
+
+ Redistribution and use in source and binary forms, with or without
+ modification, are permitted provided that the following conditions are met:
+
+ - Redistributions of source code must retain the above copyright notice,
+ this list of conditions and the following disclaimer.
+
+ - Redistributions in binary form must reproduce the above copyright notice,
+ this list of conditions and the following disclaimer in the documentation
+ and/or other materials provided with the distribution.
+
+ - Neither name of the University nor the names of its contributors may be
+ used to endorse or promote products derived from this software without
+ specific prior written permission.
+
+ THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF
+ GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
+ INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+ FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+ UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE
+ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+ SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
+ CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
+ DAMAGE.
+
syb LICENSE file:
This library (libraries/syb) is derived from code from several
@@ -1674,6 +1743,36 @@ transformers LICENSE file:
OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
DAMAGE.
+transformers-base LICENSE file:
+
+ Copyright (c) 2011, Mikhail Vorozhtsov, Bas van Dijk
+ All rights reserved.
+
+ Redistribution and use in source and binary forms, with or without
+ modification, are permitted provided that the following conditions are met:
+
+ - Redistributions of source code must retain the above copyright notice,
+ this list of conditions and the following disclaimer.
+ - Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer in the
+ documentation and/or other materials provided with the distribution.
+ - Neither the names of the copyright owners nor the names of the
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+ "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+ LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+ A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+ OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+ SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+ LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+ DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+ THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+ (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+
transformers-compat LICENSE file:
Copyright 2012 Edward Kmett
@@ -1836,7 +1935,7 @@ vector LICENSE file:
void LICENSE file:
- Copyright 2013 Edward Kmett
+ Copyright 2015 Edward Kmett
All rights reserved.
diff --git a/README.md b/README.md
new file mode 100644
index 0000000..aa4a4ff
--- /dev/null
+++ b/README.md
@@ -0,0 +1,28 @@
+[![PureScript](logo.png)](http://purescript.org)
+
+A small strongly typed programming language with expressive types that compiles to Javascript, written in and inspired by Haskell.
+
+[![Hackage](https://img.shields.io/hackage/v/purescript.svg)](http://hackage.haskell.org/package/purescript) [![Build Status](https://api.travis-ci.org/purescript/purescript.svg?branch=master)](http://travis-ci.org/purescript/purescript)
+
+[![Stackage LTS 2](http://stackage.org/package/purescript/badge/lts-2)](http://stackage.org/lts-2/package/purescript)
+[![Stackage LTS 3](http://stackage.org/package/purescript/badge/lts-3)](http://stackage.org/lts-3/package/purescript)
+[![Stackage Nightly](http://stackage.org/package/purescript/badge/nightly)](http://stackage.org/nightly/package/purescript)
+
+## Language info
+
+- [PureScript home](http://purescript.org)
+- [Releases & changelog](https://github.com/purescript/purescript/releases)
+- [Contributing to PureScript](https://github.com/purescript/purescript/blob/master/CONTRIBUTING.md)
+
+## Resources
+
+- [PureScript book](https://leanpub.com/purescript/read)
+- [Wiki](http://wiki.purescript.org)
+- [Try PureScript](http://try.purescript.org)
+- [Pursuit Package Index](http://pursuit.purescript.org/)
+
+## Help!
+
+- [#purescript IRC @ FreeNode](http://webchat.freenode.net/?channels=purescript)
+- [PureScript on StackOverflow](http://stackoverflow.com/questions/tagged/purescript)
+- [Google Group](https://groups.google.com/forum/#!forum/purescript)
diff --git a/examples/failing/1071.purs b/examples/failing/1071.purs
new file mode 100644
index 0000000..806f51a
--- /dev/null
+++ b/examples/failing/1071.purs
@@ -0,0 +1,8 @@
+-- @shouldFailWith KindsDoNotUnify
+module Main where
+
+class Foo a b where
+ foo :: a -> b
+
+bar :: forall a. (Foo a) => a -> a
+bar a = a
diff --git a/examples/failing/1310.purs b/examples/failing/1310.purs
new file mode 100644
index 0000000..5bc0442
--- /dev/null
+++ b/examples/failing/1310.purs
@@ -0,0 +1,18 @@
+-- @shouldFailWith NoInstanceFound
+
+module Issue1310 where
+
+import Prelude
+import Control.Monad.Eff
+import Control.Monad.Eff.Console
+
+class Inject f g where
+ inj :: forall a. f a -> g a
+
+instance inject :: Inject f f where
+ inj x = x
+
+foreign import data Oops :: !
+
+main :: forall eff. Eff (oops :: Oops | eff) Unit
+main = inj (log "Oops")
diff --git a/examples/failing/881.purs b/examples/failing/881.purs
new file mode 100644
index 0000000..2b409cd
--- /dev/null
+++ b/examples/failing/881.purs
@@ -0,0 +1,13 @@
+-- @shouldFailWith DuplicateValueDeclaration
+module Main where
+
+data X = X | Y
+
+class Foo a where
+ foo :: a -> a
+ bar :: a
+
+instance fooX :: Foo X where
+ foo X = X
+ bar = X
+ foo Y = Y
diff --git a/examples/failing/Arrays.purs b/examples/failing/Arrays.purs
index 6c7d763..479b351 100644
--- a/examples/failing/Arrays.purs
+++ b/examples/failing/Arrays.purs
@@ -1,4 +1,4 @@
--- @shouldFailWith ExprDoesNotHaveType
+-- @shouldFailWith TypesDoNotUnify
module Main where
import Prelude
diff --git a/examples/failing/EmptyCase.purs b/examples/failing/EmptyCase.purs
new file mode 100644
index 0000000..8a919c8
--- /dev/null
+++ b/examples/failing/EmptyCase.purs
@@ -0,0 +1,4 @@
+-- @shouldFailWith ErrorParsingModule
+module Main where
+
+error err = case err of \_ -> 1
diff --git a/examples/failing/KindStar.purs b/examples/failing/KindStar.purs
new file mode 100644
index 0000000..12a1d65
--- /dev/null
+++ b/examples/failing/KindStar.purs
@@ -0,0 +1,8 @@
+-- @shouldFailWith ExpectedType
+
+module X where
+
+data List a = Nil | Cons a (List a)
+
+test :: List
+test = Nil
diff --git a/examples/failing/MultipleErrors.purs b/examples/failing/MultipleErrors.purs
index ecc9b1e..b1d8a8c 100644
--- a/examples/failing/MultipleErrors.purs
+++ b/examples/failing/MultipleErrors.purs
@@ -1,5 +1,5 @@
--- @shouldFailWith ExprDoesNotHaveType
--- @shouldFailWith ExprDoesNotHaveType
+-- @shouldFailWith TypesDoNotUnify
+-- @shouldFailWith TypesDoNotUnify
module MultipleErrors where
import Prelude
diff --git a/examples/failing/Rank2Types.purs b/examples/failing/Rank2Types.purs
index 5cb50ef..68438fd 100644
--- a/examples/failing/Rank2Types.purs
+++ b/examples/failing/Rank2Types.purs
@@ -1,4 +1,4 @@
--- @shouldFailWith ExprDoesNotHaveType
+-- @shouldFailWith TypesDoNotUnify
module Main where
import Prelude
diff --git a/examples/failing/TransitiveDctorExport.purs b/examples/failing/TransitiveDctorExport.purs
new file mode 100644
index 0000000..1de81eb
--- /dev/null
+++ b/examples/failing/TransitiveDctorExport.purs
@@ -0,0 +1,5 @@
+-- @shouldFailWith TransitiveExportError
+module Main (Y(..)) where
+
+type X = Int
+data Y = Y X
diff --git a/examples/failing/TransitiveSynonymExport.purs b/examples/failing/TransitiveSynonymExport.purs
new file mode 100644
index 0000000..9778e1f
--- /dev/null
+++ b/examples/failing/TransitiveSynonymExport.purs
@@ -0,0 +1,5 @@
+-- @shouldFailWith TransitiveExportError
+module Main (Y()) where
+
+type X = Int
+type Y = X
diff --git a/examples/failing/TypeError.purs b/examples/failing/TypeError.purs
index ad26361..8e028b3 100644
--- a/examples/failing/TypeError.purs
+++ b/examples/failing/TypeError.purs
@@ -1,4 +1,4 @@
--- @shouldFailWith ExprDoesNotHaveType
+-- @shouldFailWith TypesDoNotUnify
module Main where
import Prelude
diff --git a/examples/failing/TypedBinders.purs b/examples/failing/TypedBinders.purs
new file mode 100644
index 0000000..bbe1ce6
--- /dev/null
+++ b/examples/failing/TypedBinders.purs
@@ -0,0 +1,10 @@
+-- @shouldFailWith ErrorParsingModule
+module Main where
+
+import Prelude
+
+test = (\f :: Int -> Int -> f 10) id
+
+main = do
+ let t1 = test
+ Control.Monad.Eff.Console.log "Done" \ No newline at end of file
diff --git a/examples/failing/TypedBinders2.purs b/examples/failing/TypedBinders2.purs
new file mode 100644
index 0000000..21b5caf
--- /dev/null
+++ b/examples/failing/TypedBinders2.purs
@@ -0,0 +1,9 @@
+-- @shouldFailWith TypesDoNotUnify
+module Main where
+
+import Prelude
+
+main = do
+ s :: String <- Control.Monad.Eff.Console.log "Foo"
+ Control.Monad.Eff.Console.log "Done"
+
diff --git a/examples/failing/TypedBinders3.purs b/examples/failing/TypedBinders3.purs
new file mode 100644
index 0000000..14987bc
--- /dev/null
+++ b/examples/failing/TypedBinders3.purs
@@ -0,0 +1,12 @@
+-- @shouldFailWith TypesDoNotUnify
+module Main where
+
+import Prelude
+
+test = case 1 of
+ (0 :: String) -> true
+ _ -> false
+
+main = do
+ let t = test
+ Control.Monad.Eff.Console.log "Done"
diff --git a/examples/passing/862.purs b/examples/passing/862.purs
new file mode 100644
index 0000000..97c664d
--- /dev/null
+++ b/examples/passing/862.purs
@@ -0,0 +1,8 @@
+module Main where
+
+import Prelude
+import Control.Monad.Eff.Console
+
+id' = (\x -> x) <$> \y -> y
+
+main = log (id' "Done")
diff --git a/examples/passing/922.purs b/examples/passing/922.purs
new file mode 100644
index 0000000..07a7ad1
--- /dev/null
+++ b/examples/passing/922.purs
@@ -0,0 +1,20 @@
+module Main where
+
+import Prelude
+
+import Control.Monad.Eff.Console
+
+class Default a where
+ def :: a
+
+instance defaultString :: Default String where
+ def = "Done"
+
+data I a = I a
+
+instance defaultI :: (Default a) => Default (I a) where
+ def = I def
+
+main = do
+ case def of
+ I s -> log s
diff --git a/examples/passing/LargeSumType.purs b/examples/passing/LargeSumType.purs
new file mode 100644
index 0000000..1cc8ff0
--- /dev/null
+++ b/examples/passing/LargeSumType.purs
@@ -0,0 +1,33 @@
+module Main where
+
+data Large = A | B | C | D | E | F | G | H | I | J | K | L | M | N | O | P | Q | R | S | T | U | V | W | X | Y | Z
+
+explode A A = "A"
+explode B B = "B"
+explode C C = "C"
+explode D D = "D"
+explode E E = "E"
+explode F F = "F"
+explode G G = "G"
+explode H H = "H"
+explode I I = "I"
+explode J J = "J"
+explode K K = "K"
+explode L L = "L"
+explode M M = "M"
+explode N N = "N"
+explode O O = "O"
+explode P P = "P"
+explode Q Q = "Q"
+explode R R = "R"
+explode S S = "S"
+explode T T = "T"
+explode U U = "U"
+explode V V = "V"
+explode W W = "W"
+explode X X = "X"
+explode Y Y = "Y"
+explode Z Z = "Z"
+explode _ _ = ""
+
+main = Control.Monad.Eff.Console.log "Done" \ No newline at end of file
diff --git a/examples/passing/NakedConstraint.purs b/examples/passing/NakedConstraint.purs
new file mode 100644
index 0000000..d7b58c9
--- /dev/null
+++ b/examples/passing/NakedConstraint.purs
@@ -0,0 +1,12 @@
+module Main where
+
+import Control.Monad.Eff.Console
+
+class Partial where
+
+data List a = Nil | Cons a (List a)
+
+head :: (Partial) => List Int -> Int
+head (Cons x _) = x
+
+main = log "Done"
diff --git a/examples/passing/OptionalQualified.purs b/examples/passing/OptionalQualified.purs
new file mode 100644
index 0000000..fccfd7a
--- /dev/null
+++ b/examples/passing/OptionalQualified.purs
@@ -0,0 +1,13 @@
+module Main where
+
+-- qualified import with the "qualified" keyword
+import qualified Prelude as P
+
+-- qualified import without the "qualified" keyword
+import Control.Monad.Eff.Console as Console
+
+bind = P.bind
+
+main = do
+ message <- P.return "success!"
+ Console.log message
diff --git a/examples/passing/QualifiedQualifiedImports.purs b/examples/passing/QualifiedQualifiedImports.purs
new file mode 100644
index 0000000..91c188c
--- /dev/null
+++ b/examples/passing/QualifiedQualifiedImports.purs
@@ -0,0 +1,6 @@
+module Main where
+
+-- qualified import with qualified imported names
+import qualified Control.Monad.Eff.Console (log) as Console
+
+main = Console.log "Success!"
diff --git a/examples/passing/TypedBinders.purs b/examples/passing/TypedBinders.purs
new file mode 100644
index 0000000..ff66e4d
--- /dev/null
+++ b/examples/passing/TypedBinders.purs
@@ -0,0 +1,62 @@
+module Main where
+
+import Prelude
+
+data Tuple a b = Tuple a b
+
+class MonadState s m where
+ get :: m s
+ put :: s -> m {}
+
+data State s a = State (s -> Tuple s a)
+
+runState s (State f) = f s
+
+instance functorState :: Functor (State s) where
+ map = liftM1
+
+instance applyState :: Apply (State s) where
+ apply = ap
+
+instance applicativeState :: Applicative (State s) where
+ pure a = State $ \s -> Tuple s a
+
+instance bindState :: Bind (State s) where
+ bind f g = State $ \s -> case runState s f of
+ Tuple s1 a -> runState s1 (g a)
+
+instance monadState :: Monad (State s)
+
+instance monadStateState :: MonadState s (State s) where
+ get = State (\s -> Tuple s s)
+ put s = State (\_ -> Tuple s {})
+
+modify :: forall m s. (Prelude.Monad m, MonadState s m) => (s -> s) -> m {}
+modify f = do
+ s <- get
+ put (f s)
+
+test :: Tuple String String
+test = runState "" $ do
+ modify $ (++) "World!"
+ modify $ (++) "Hello, "
+ str :: String <- get
+ return str
+
+test2 :: (Int -> Int) -> Int
+test2 = (\(f :: Int -> Int) -> f 10)
+
+test3 :: Int -> Boolean
+test3 n = case n of
+ (0 :: Int) -> true
+ _ -> false
+
+test4 :: Tuple Int Int -> Tuple Int Int
+test4 = (\(Tuple a b :: Tuple Int Int) -> Tuple b a)
+
+main = do
+ let t1 = test
+ t2 = test2 id
+ t3 = test3 1
+ t4 = test4 (Tuple 1 0)
+ Control.Monad.Eff.Console.log "Done" \ No newline at end of file
diff --git a/examples/passing/UTF8Sourcefile.purs b/examples/passing/UTF8Sourcefile.purs
new file mode 100644
index 0000000..da102a3
--- /dev/null
+++ b/examples/passing/UTF8Sourcefile.purs
@@ -0,0 +1,10 @@
+module Main where
+
+import Control.Monad.Eff.Console
+
+-- '→' is multibyte sequence \u2192.
+utf8multibyte = "Hello λ→ world!!"
+
+main = do
+ log "done"
+
diff --git a/psc-docs/Main.hs b/psc-docs/Main.hs
index a82a8f3..79b7fdc 100644
--- a/psc-docs/Main.hs
+++ b/psc-docs/Main.hs
@@ -152,10 +152,10 @@ inputFile = strArgument $
<> help "The input .purs file(s)"
instance Read Format where
- readsPrec _ "etags" = [(Etags, "")]
- readsPrec _ "ctags" = [(Ctags, "")]
- readsPrec _ "markdown" = [(Markdown, "")]
- readsPrec _ _ = []
+ readsPrec _ "etags" = [(Etags, "")]
+ readsPrec _ "ctags" = [(Ctags, "")]
+ readsPrec _ "markdown" = [(Markdown, "")]
+ readsPrec _ _ = []
format :: Parser Format
format = option auto $ value Markdown
diff --git a/psc/Main.hs b/psc/Main.hs
index be0d11a..d89be91 100644
--- a/psc/Main.hs
+++ b/psc/Main.hs
@@ -32,6 +32,7 @@ import Options.Applicative as Opts
import System.Exit (exitSuccess, exitFailure)
import System.IO (hPutStrLn, stderr)
+import System.IO.UTF8
import System.FilePath.Glob (glob)
import qualified Language.PureScript as P
@@ -60,7 +61,7 @@ compile (PSCMakeOptions inputGlob inputForeignGlob outputDir opts usePrefix) = d
let (jsFiles, pursFiles) = partition (isSuffixOf ".js") input
moduleFiles <- readInput (InputOptions pursFiles)
inputForeign <- globWarningOnMisses warnFileTypeNotFound inputForeignGlob
- foreignFiles <- forM (inputForeign ++ jsFiles) (\inFile -> (inFile,) <$> readFile inFile)
+ foreignFiles <- forM (inputForeign ++ jsFiles) (\inFile -> (inFile,) <$> readUTF8File inFile)
case runWriterT (parseInputs moduleFiles foreignFiles) of
Left errs -> do
hPutStrLn stderr (P.prettyPrintMultipleErrors (P.optionsVerboseErrors opts) errs)
@@ -93,7 +94,7 @@ globWarningOnMisses warn = concatMapM globWithWarning
concatMapM f = liftM concat . mapM f
readInput :: InputOptions -> IO [(Either P.RebuildPolicy FilePath, String)]
-readInput InputOptions{..} = forM ioInputFiles $ \inFile -> (Right inFile, ) <$> readFile inFile
+readInput InputOptions{..} = forM ioInputFiles $ \inFile -> (Right inFile, ) <$> readUTF8File inFile
parseInputs :: (Functor m, Applicative m, MonadError P.MultipleErrors m, MonadWriter P.MultipleErrors m)
=> [(Either P.RebuildPolicy FilePath, String)]
@@ -178,6 +179,7 @@ pscMakeOptions = PSCMakeOptions <$> many inputFile
<*> options
<*> (not <$> noPrefix)
+
main :: IO ()
main = execParser opts >>= compile
where
diff --git a/psci/Completion.hs b/psci/Completion.hs
index b4716cd..3565275 100644
--- a/psci/Completion.hs
+++ b/psci/Completion.hs
@@ -41,7 +41,7 @@ data CompletionContext
| CtxIdentifier
| CtxType
| CtxFixed String
- deriving (Show)
+ deriving (Show, Read)
-- |
-- Loads module, function, and file completions.
@@ -143,34 +143,34 @@ getImportedModules = asks psciImportedModules
getModuleNames :: CompletionM [String]
getModuleNames = moduleNames <$> getLoadedModules
-mapLoadedModulesAndQualify :: (Show a) => (P.Module -> [(a, P.Declaration)]) -> CompletionM [String]
-mapLoadedModulesAndQualify f = do
+mapLoadedModulesAndQualify :: (a -> String) -> (P.Module -> [(a, P.Declaration)]) -> CompletionM [String]
+mapLoadedModulesAndQualify sho f = do
ms <- getLoadedModules
let argPairs = do m <- ms
fm <- f m
return (m, fm)
- concat <$> traverse (uncurry getAllQualifications) argPairs
+ concat <$> traverse (uncurry (getAllQualifications sho)) argPairs
getIdentNames :: CompletionM [String]
-getIdentNames = mapLoadedModulesAndQualify identNames
+getIdentNames = mapLoadedModulesAndQualify P.showIdent identNames
getDctorNames :: CompletionM [String]
-getDctorNames = mapLoadedModulesAndQualify dctorNames
+getDctorNames = mapLoadedModulesAndQualify P.runProperName dctorNames
getTypeNames :: CompletionM [String]
-getTypeNames = mapLoadedModulesAndQualify typeDecls
+getTypeNames = mapLoadedModulesAndQualify P.runProperName typeDecls
-- | Given a module and a declaration in that module, return all possible ways
-- it could have been referenced given the current PSCiState - including fully
-- qualified, qualified using an alias, and unqualified.
-getAllQualifications :: (Show a) => P.Module -> (a, P.Declaration) -> CompletionM [String]
-getAllQualifications m (declName, decl) = do
+getAllQualifications :: (a -> String) -> P.Module -> (a, P.Declaration) -> CompletionM [String]
+getAllQualifications sho m (declName, decl) = do
imports <- getAllImportsOf m
let fullyQualified = qualifyWith (Just (P.getModuleName m))
let otherQuals = nub (concatMap qualificationsUsing imports)
return $ fullyQualified : otherQuals
where
- qualifyWith mMod = show (P.Qualified mMod declName)
+ qualifyWith mMod = P.showQualified sho (P.Qualified mMod declName)
referencedBy refs = P.isExported (Just refs) decl
qualificationsUsing (_, importType, asQ') =
@@ -222,7 +222,7 @@ dctorNames = nubOnFst . concatMap go . P.exportedDeclarations
go _ = []
moduleNames :: [P.Module] -> [String]
-moduleNames ms = nub [show moduleName | P.Module _ _ moduleName _ _ <- ms]
+moduleNames ms = nub [P.runModuleName moduleName | P.Module _ _ moduleName _ _ <- ms]
directivesFirst :: Completion -> Completion -> Ordering
directivesFirst (Completion _ d1 _) (Completion _ d2 _) = go d1 d2
diff --git a/psci/PSCi.hs b/psci/PSCi.hs
index 8512f68..8a704e0 100644
--- a/psci/PSCi.hs
+++ b/psci/PSCi.hs
@@ -263,10 +263,10 @@ makeIO f io = do
make :: PSCiState -> [(Either P.RebuildPolicy FilePath, P.Module)] -> P.Make P.Environment
make PSCiState{..} ms = P.make actions' (map snd (psciLoadedModules ++ ms))
- where
- filePathMap = M.fromList $ (first P.getModuleName . swap) `map` (psciLoadedModules ++ ms)
- actions = P.buildMakeActions modulesDir filePathMap psciForeignFiles False
- actions' = actions { P.progress = const (return ()) }
+ where
+ filePathMap = M.fromList $ (first P.getModuleName . swap) `map` (psciLoadedModules ++ ms)
+ actions = P.buildMakeActions modulesDir filePathMap psciForeignFiles False
+ actions' = actions { P.progress = const (return ()) }
-- |
-- Takes a value declaration and evaluates it with the current state.
@@ -437,10 +437,10 @@ handleKindOf typ = do
-- Parses the input and returns either a Metacommand, or an error as a string.
--
getCommand :: Bool -> InputT (StateT PSCiState IO) (Either String (Maybe Command))
-getCommand singleLineMode = do
- firstLine <- getInputLine "> "
+getCommand singleLineMode = handleInterrupt (return (Right Nothing)) $ do
+ firstLine <- withInterrupt $ getInputLine "> "
case firstLine of
- Nothing -> return (Right Nothing)
+ Nothing -> return (Right (Just QuitPSCi)) -- Ctrl-D when input is empty
Just "" -> return (Right Nothing)
Just s | singleLineMode || head s == ':' -> return . either Left (Right . Just) $ parseCommand s
Just s -> either Left (Right . Just) . parseCommand <$> go [s]
@@ -464,7 +464,7 @@ handleCommand (LoadFile filePath) = whenFileExists filePath $ \absPath -> do
Right mods -> PSCI . lift $ modify (updateModules (map ((,) (Right absPath)) mods))
handleCommand (LoadForeign filePath) = whenFileExists filePath $ \absPath -> do
foreignsOrError <- psciIO . runMake $ do
- foreignFile <- makeIO (const (P.SimpleErrorWrapper $ P.CannotReadFile absPath)) (readFile absPath)
+ foreignFile <- makeIO (const (P.ErrorMessage [] $ P.CannotReadFile absPath)) (readFile absPath)
P.parseForeignModulesFromFiles [(absPath, foreignFile)]
case foreignsOrError of
Left err -> PSCI $ outputStrLn $ P.prettyPrintMultipleErrors False err
@@ -533,7 +533,7 @@ loop PSCiOptions{..} = do
historyFilename <- getHistoryFilename
let settings = defaultSettings { historyFile = Just historyFilename }
foreignsOrError <- runMake $ do
- foreignFilesContent <- forM foreignFiles (\inFile -> (inFile,) <$> makeIO (const (P.SimpleErrorWrapper $ P.CannotReadFile inFile)) (readFile inFile))
+ foreignFilesContent <- forM foreignFiles (\inFile -> (inFile,) <$> makeIO (const (P.ErrorMessage [] $ P.CannotReadFile inFile)) (readFile inFile))
P.parseForeignModulesFromFiles foreignFilesContent
case foreignsOrError of
Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> exitFailure
@@ -555,7 +555,10 @@ loop PSCiOptions{..} = do
Left err -> outputStrLn err >> go
Right Nothing -> go
Right (Just QuitPSCi) -> outputStrLn quitMessage
- Right (Just c') -> runPSCI (loadAllImportedModules >> handleCommand c') >> go
+ Right (Just c') -> do
+ handleInterrupt (outputStrLn "Interrupted.")
+ (withInterrupt (runPSCI (loadAllImportedModules >> handleCommand c')))
+ go
multiLineMode :: Parser Bool
multiLineMode = switch $
diff --git a/psci/Parser.hs b/psci/Parser.hs
index e506c4a..d4a3a2d 100644
--- a/psci/Parser.hs
+++ b/psci/Parser.hs
@@ -131,7 +131,6 @@ acceptable P.DataDeclaration{} = True
acceptable P.TypeSynonymDeclaration{} = True
acceptable P.ExternDeclaration{} = True
acceptable P.ExternDataDeclaration{} = True
-acceptable P.ExternInstanceDeclaration{} = True
acceptable P.TypeClassDeclaration{} = True
acceptable P.TypeInstanceDeclaration{} = True
acceptable _ = False
diff --git a/purescript.cabal b/purescript.cabal
index 3dd3a2b..44b577f 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,5 +1,5 @@
name: purescript
-version: 0.7.4.1
+version: 0.7.5
cabal-version: >=1.8
build-type: Simple
license: MIT
@@ -25,6 +25,14 @@ extra-source-files: examples/passing/*.purs
, tests/support/bower.json
, tests/support/setup-win.cmd
, psci/tests/data/Sample.purs
+ , stack.yaml
+ , stack-lts-2.yaml
+ , stack-lts-3.yaml
+ , stack-nightly.yaml
+ , README.md
+ , INSTALL.md
+ , CONTRIBUTORS.md
+ , CONTRIBUTING.md
source-repository head
type: git
@@ -32,6 +40,9 @@ source-repository head
library
build-depends: base >=4.6 && <5,
+ lifted-base >= 0.2.3 && < 0.2.4,
+ monad-control >= 1.0.0.0 && < 1.1,
+ transformers-base >= 0.4.0 && < 0.5,
containers -any,
unordered-containers -any,
dlist -any,
@@ -45,7 +56,7 @@ library
pattern-arrows >= 0.0.2 && < 0.1,
time -any,
boxes >= 0.1.4 && < 0.2.0,
- aeson >= 0.8 && < 0.10,
+ aeson >= 0.8 && < 0.11,
vector -any,
bower-json >= 0.7,
aeson-better-errors >= 0.8,
@@ -55,9 +66,9 @@ library
language-javascript == 0.5.*,
syb -any,
Glob >= 0.7 && < 0.8,
- process >= 1.2.0 && < 1.3,
+ process >= 1.2.0 && < 1.4,
safe >= 0.3.9 && < 0.4,
- semigroups >= 0.16.2 && < 0.17
+ semigroups >= 0.16.2 && < 0.18
exposed-modules: Language.PureScript
Language.PureScript.AST
@@ -68,8 +79,8 @@ library
Language.PureScript.AST.Traversals
Language.PureScript.AST.Exported
Language.PureScript.Bundle
+ Language.PureScript.Externs
Language.PureScript.CodeGen
- Language.PureScript.CodeGen.Externs
Language.PureScript.CodeGen.JS
Language.PureScript.CodeGen.JS.AST
Language.PureScript.CodeGen.JS.Common
@@ -162,6 +173,7 @@ library
Control.Monad.Supply
Control.Monad.Supply.Class
+ System.IO.UTF8
exposed: True
buildable: True
hs-source-dirs: src
@@ -175,7 +187,7 @@ executable psc
main-is: Main.hs
buildable: True
hs-source-dirs: psc
- ghc-options: -Wall -O2 -fno-warn-unused-do-bind
+ ghc-options: -Wall -O2 -fno-warn-unused-do-bind -threaded -rtsopts "-with-rtsopts=-N"
executable psci
build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,
diff --git a/src/Language/PureScript/AST/Binders.hs b/src/Language/PureScript/AST/Binders.hs
index f264c23..d228bf6 100644
--- a/src/Language/PureScript/AST/Binders.hs
+++ b/src/Language/PureScript/AST/Binders.hs
@@ -21,6 +21,7 @@ import qualified Data.Data as D
import Language.PureScript.AST.SourcePos
import Language.PureScript.Names
import Language.PureScript.Comments
+import Language.PureScript.Types
-- |
-- Data type for binders
@@ -69,7 +70,11 @@ data Binder
-- |
-- A binder with source position information
--
- | PositionedBinder SourceSpan [Comment] Binder deriving (Show, Eq, D.Data, D.Typeable)
+ | PositionedBinder SourceSpan [Comment] Binder
+ -- |
+ -- A binder with a type annotation
+ --
+ | TypedBinder Type Binder deriving (Show, Read, Eq, D.Data, D.Typeable)
-- |
-- Collect all names introduced in binders in an expression
@@ -83,4 +88,5 @@ binderNames = go []
go ns (ArrayBinder bs) = foldl go ns bs
go ns (NamedBinder name b) = go (name : ns) b
go ns (PositionedBinder _ _ b) = go ns b
+ go ns (TypedBinder _ b) = go ns b
go ns _ = ns
diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs
index 6e1e507..7c8f915 100644
--- a/src/Language/PureScript/AST/Declarations.hs
+++ b/src/Language/PureScript/AST/Declarations.hs
@@ -14,10 +14,13 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE CPP #-}
module Language.PureScript.AST.Declarations where
+import Data.Aeson.TH
+
import qualified Data.Data as D
import qualified Data.Map as M
@@ -42,7 +45,7 @@ import Language.PureScript.Environment
-- a list of declarations, and a list of the declarations that are
-- explicitly exported. If the export list is Nothing, everything is exported.
--
-data Module = Module SourceSpan [Comment] ModuleName [Declaration] (Maybe [DeclarationRef]) deriving (Show, D.Data, D.Typeable)
+data Module = Module SourceSpan [Comment] ModuleName [Declaration] (Maybe [DeclarationRef]) deriving (Show, Read, D.Data, D.Typeable)
-- | Return a module's name.
getModuleName :: Module -> ModuleName
@@ -76,7 +79,7 @@ data DeclarationRef
-- A declaration reference with source position information
--
| PositionedDeclarationRef SourceSpan [Comment] DeclarationRef
- deriving (Show, D.Data, D.Typeable)
+ deriving (Show, Read, D.Data, D.Typeable)
instance Eq DeclarationRef where
(TypeRef name dctors) == (TypeRef name' dctors') = name == name' && dctors == dctors'
@@ -108,7 +111,7 @@ data ImportDeclarationType
-- An import with a list of references to hide: `import M hiding (foo)`
--
| Hiding [DeclarationRef]
- deriving (Show, D.Data, D.Typeable)
+ deriving (Show, Read, D.Data, D.Typeable)
-- |
-- The data type of declarations
@@ -147,10 +150,6 @@ data Declaration
--
| ExternDataDeclaration ProperName Kind
-- |
- -- A type class instance foreign import
- --
- | ExternInstanceDeclaration Ident [Constraint] (Qualified ProperName) [Type]
- -- |
-- A fixity declaration (fixity data, operator name)
--
| FixityDeclaration Fixity String
@@ -171,7 +170,7 @@ data Declaration
-- A declaration with source position information
--
| PositionedDeclaration SourceSpan [Comment] Declaration
- deriving (Show, D.Data, D.Typeable)
+ deriving (Show, Read, D.Data, D.Typeable)
-- | The members of a type class instance declaration
data TypeInstanceBody
@@ -179,7 +178,7 @@ data TypeInstanceBody
= DerivedInstance
-- | This is a regular (explicit) instance
| ExplicitInstance [Declaration]
- deriving (Show, D.Data, D.Typeable)
+ deriving (Show, Read, D.Data, D.Typeable)
mapTypeInstanceBody :: ([Declaration] -> [Declaration]) -> TypeInstanceBody -> TypeInstanceBody
mapTypeInstanceBody f = runIdentity . traverseTypeInstanceBody (Identity . f)
@@ -223,14 +222,6 @@ isExternDataDecl (PositionedDeclaration _ _ d) = isExternDataDecl d
isExternDataDecl _ = False
-- |
--- Test if a declaration is a type class instance foreign import
---
-isExternInstanceDecl :: Declaration -> Bool
-isExternInstanceDecl ExternInstanceDeclaration{} = True
-isExternInstanceDecl (PositionedDeclaration _ _ d) = isExternInstanceDecl d
-isExternInstanceDecl _ = False
-
--- |
-- Test if a declaration is a fixity declaration
--
isFixityDecl :: Declaration -> Bool
@@ -406,7 +397,7 @@ data Expr
-- |
-- A value with source position information
--
- | PositionedValue SourceSpan [Comment] Expr deriving (Show, D.Data, D.Typeable)
+ | PositionedValue SourceSpan [Comment] Expr deriving (Show, Read, D.Data, D.Typeable)
-- |
-- An alternative in a case statement
@@ -420,7 +411,7 @@ data CaseAlternative = CaseAlternative
-- The result expression or a collect of guarded expressions
--
, caseAlternativeResult :: Either [(Guard, Expr)] Expr
- } deriving (Show, D.Data, D.Typeable)
+ } deriving (Show, Read, D.Data, D.Typeable)
-- |
-- A statement in a do-notation block
@@ -441,4 +432,7 @@ data DoNotationElement
-- |
-- A do notation element with source position information
--
- | PositionedDoNotationElement SourceSpan [Comment] DoNotationElement deriving (Show, D.Data, D.Typeable)
+ | PositionedDoNotationElement SourceSpan [Comment] DoNotationElement deriving (Show, Read, D.Data, D.Typeable)
+
+$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''DeclarationRef)
+$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ImportDeclarationType)
diff --git a/src/Language/PureScript/AST/Exported.hs b/src/Language/PureScript/AST/Exported.hs
index 54f55f4..a7ad53f 100644
--- a/src/Language/PureScript/AST/Exported.hs
+++ b/src/Language/PureScript/AST/Exported.hs
@@ -66,7 +66,7 @@ filterInstances (Just exps) =
-- * the name is defined in a different module (and must be exported from
-- that module; the code would fail to compile otherwise).
visibleOutside _ (Qualified (Just _) _) = True
- visibleOutside refs (Qualified Nothing n) = any (== n) refs
+ visibleOutside refs (Qualified Nothing n) = n `elem` refs
typeName (TypeRef n _) = Just n
typeName (PositionedDeclarationRef _ _ r) = typeName r
diff --git a/src/Language/PureScript/AST/Operators.hs b/src/Language/PureScript/AST/Operators.hs
index 53b60cd..291490f 100644
--- a/src/Language/PureScript/AST/Operators.hs
+++ b/src/Language/PureScript/AST/Operators.hs
@@ -29,20 +29,29 @@ type Precedence = Integer
-- |
-- Associativity for infix operators
--
-data Associativity = Infixl | Infixr | Infix deriving (Eq, Ord, D.Data, D.Typeable)
+data Associativity = Infixl | Infixr | Infix deriving (Show, Read, Eq, Ord, D.Data, D.Typeable)
-instance Show Associativity where
- show Infixl = "infixl"
- show Infixr = "infixr"
- show Infix = "infix"
+showAssoc :: Associativity -> String
+showAssoc Infixl = "infixl"
+showAssoc Infixr = "infixr"
+showAssoc Infix = "infix"
+
+readAssoc :: String -> Associativity
+readAssoc "infixl" = Infixl
+readAssoc "infixr" = Infixr
+readAssoc "infix" = Infix
+readAssoc _ = error "readAssoc: no parse"
instance A.ToJSON Associativity where
- toJSON = A.toJSON . show
+ toJSON = A.toJSON . showAssoc
+
+instance A.FromJSON Associativity where
+ parseJSON = fmap readAssoc . A.parseJSON
-- |
-- Fixity data for infix operators
--
-data Fixity = Fixity Associativity Precedence deriving (Show, Eq, Ord, D.Data, D.Typeable)
+data Fixity = Fixity Associativity Precedence deriving (Show, Read, Eq, Ord, D.Data, D.Typeable)
instance A.ToJSON Fixity where
toJSON (Fixity associativity precedence) =
diff --git a/src/Language/PureScript/AST/SourcePos.hs b/src/Language/PureScript/AST/SourcePos.hs
index a60f932..e1d8fc5 100644
--- a/src/Language/PureScript/AST/SourcePos.hs
+++ b/src/Language/PureScript/AST/SourcePos.hs
@@ -12,6 +12,7 @@
--
-----------------------------------------------------------------------------
+{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RecordWildCards #-}
@@ -20,9 +21,13 @@
module Language.PureScript.AST.SourcePos where
import qualified Data.Data as D
-import Data.Aeson ((.=))
+import Data.Aeson ((.=), (.:))
import qualified Data.Aeson as A
+#if __GLASGOW_HASKELL__ < 710
+import Control.Applicative
+#endif
+
-- |
-- Source position information
--
@@ -35,7 +40,7 @@ data SourcePos = SourcePos
-- Column number
--
, sourcePosColumn :: Int
- } deriving (Eq, Ord, Show, D.Data, D.Typeable)
+ } deriving (Show, Read, Eq, Ord, D.Data, D.Typeable)
displaySourcePos :: SourcePos -> String
displaySourcePos sp =
@@ -46,6 +51,11 @@ instance A.ToJSON SourcePos where
toJSON SourcePos{..} =
A.toJSON [sourcePosLine, sourcePosColumn]
+instance A.FromJSON SourcePos where
+ parseJSON arr = do
+ [line, col] <- A.parseJSON arr
+ return $ SourcePos line col
+
data SourceSpan = SourceSpan
{ -- |
-- Source name
@@ -58,7 +68,7 @@ data SourceSpan = SourceSpan
-- End of the span
--
, spanEnd :: SourcePos
- } deriving (Eq, Ord, Show, D.Data, D.Typeable)
+ } deriving (Show, Read, Eq, Ord, D.Data, D.Typeable)
displayStartEndPos :: SourceSpan -> String
displayStartEndPos sp =
@@ -77,5 +87,12 @@ instance A.ToJSON SourceSpan where
, "end" .= spanEnd
]
+instance A.FromJSON SourceSpan where
+ parseJSON = A.withObject "SourceSpan" $ \o ->
+ SourceSpan <$>
+ o .: "name" <*>
+ o .: "start" <*>
+ o .: "end"
+
internalModuleSourceSpan :: String -> SourceSpan
internalModuleSourceSpan name = SourceSpan name (SourcePos 0 0) (SourcePos 0 0)
diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs
index c31c59b..1d97ebc 100644
--- a/src/Language/PureScript/AST/Traversals.hs
+++ b/src/Language/PureScript/AST/Traversals.hs
@@ -79,6 +79,7 @@ everywhereOnValues f g h = (f', g', h')
h' (ArrayBinder bs) = h (ArrayBinder (map h' bs))
h' (NamedBinder name b) = h (NamedBinder name (h' b))
h' (PositionedBinder pos com b) = h (PositionedBinder pos com (h' b))
+ h' (TypedBinder t b) = h (TypedBinder t (h' b))
h' other = h other
handleCaseAlternative :: CaseAlternative -> CaseAlternative
@@ -135,6 +136,7 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)
h' (ArrayBinder bs) = ArrayBinder <$> mapM (h' <=< h) bs
h' (NamedBinder name b) = NamedBinder name <$> (h b >>= h')
h' (PositionedBinder pos com b) = PositionedBinder pos com <$> (h b >>= h')
+ h' (TypedBinder t b) = TypedBinder t <$> (h b >>= h')
h' other = h other
handleCaseAlternative (CaseAlternative bs val) = CaseAlternative <$> mapM (h' <=< h) bs
@@ -187,6 +189,7 @@ everywhereOnValuesM f g h = (f', g', h')
h' (ArrayBinder bs) = (ArrayBinder <$> mapM h' bs) >>= h
h' (NamedBinder name b) = (NamedBinder name <$> h' b) >>= h
h' (PositionedBinder pos com b) = (PositionedBinder pos com <$> h' b) >>= h
+ h' (TypedBinder t b) = (TypedBinder t <$> h' b) >>= h
h' other = h other
handleCaseAlternative (CaseAlternative bs val) = CaseAlternative <$> mapM h' bs
@@ -216,10 +219,10 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j')
f' d = f d
g' v@(UnaryMinus v1) = g v <> g' v1
- g' v@(BinaryNoParens op v1 v2) = g v <> g op <> g' v1 <> g' v2
+ g' v@(BinaryNoParens op v1 v2) = g v <> g' op <> g' v1 <> g' v2
g' v@(Parens v1) = g v <> g' v1
- g' v@(OperatorSection op (Left v1)) = g v <> g op <> g' v1
- g' v@(OperatorSection op (Right v1)) = g v <> g op <> g' v1
+ g' v@(OperatorSection op (Left v1)) = g v <> g' op <> g' v1
+ g' v@(OperatorSection op (Right v1)) = g v <> g' op <> g' v1
g' v@(ArrayLiteral vs) = foldl (<>) (g v) (map g' vs)
g' v@(ObjectLiteral vs) = foldl (<>) (g v) (map (g' . snd) vs)
g' v@(ObjectConstructor vs) = foldl (<>) (g v) (map g' (mapMaybe snd vs))
@@ -242,6 +245,7 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j')
h' b@(ArrayBinder bs) = foldl (<>) (h b) (map h' bs)
h' b@(NamedBinder _ b1) = h b <> h' b1
h' b@(PositionedBinder _ _ b1) = h b <> h' b1
+ h' b@(TypedBinder _ b1) = h b <> h' b1
h' b = h b
i' ca@(CaseAlternative bs (Right val)) = foldl (<>) (i ca) (map h' bs) <> g' val
@@ -310,6 +314,7 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'
h' s (ArrayBinder bs) = foldl (<>) r0 (map (h'' s) bs)
h' s (NamedBinder _ b1) = h'' s b1
h' s (PositionedBinder _ _ b1) = h'' s b1
+ h' s (TypedBinder _ b1) = h'' s b1
h' _ _ = r0
i'' s ca = let (s', r) = i s ca in r <> i' s' ca
@@ -379,6 +384,7 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j
h' s (ArrayBinder bs) = ArrayBinder <$> mapM (h'' s) bs
h' s (NamedBinder name b) = NamedBinder name <$> h'' s b
h' s (PositionedBinder pos com b) = PositionedBinder pos com <$> h'' s b
+ h' s (TypedBinder t b) = TypedBinder t <$> h'' s b
h' _ other = return other
i'' s = uncurry i' <=< i s
@@ -397,7 +403,6 @@ accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (con
where
forDecls (DataDeclaration _ _ _ dctors) = mconcat (concatMap (map f . snd) dctors)
forDecls (ExternDeclaration _ ty) = f ty
- forDecls (ExternInstanceDeclaration _ cs _ tys) = mconcat (concatMap (map f . snd) cs) `mappend` mconcat (map f tys)
forDecls (TypeClassDeclaration _ _ implies _) = mconcat (concatMap (map f . snd) implies)
forDecls (TypeInstanceDeclaration _ cs _ tys _) = mconcat (concatMap (map f . snd) cs) `mappend` mconcat (map f tys)
forDecls (TypeSynonymDeclaration _ _ ty) = f ty
diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs
index 6db4539..64f7cc2 100644
--- a/src/Language/PureScript/Bundle.hs
+++ b/src/Language/PureScript/Bundle.hs
@@ -56,16 +56,20 @@ data ErrorMessage
| UnableToParseModule String
| UnsupportedExport
| ErrorInModule ModuleIdentifier ErrorMessage
- deriving Show
+ deriving (Show, Read)
-- | Modules are either "regular modules" (i.e. those generated by psc) or foreign modules.
data ModuleType
= Regular
| Foreign
- deriving (Show, Eq, Ord)
+ deriving (Show, Read, Eq, Ord)
+
+showModuleType :: ModuleType -> String
+showModuleType Regular = "Regular"
+showModuleType Foreign = "Foreign"
-- | A module is identified by its module name and its type.
-data ModuleIdentifier = ModuleIdentifier String ModuleType deriving (Show, Eq, Ord)
+data ModuleIdentifier = ModuleIdentifier String ModuleType deriving (Show, Read, Eq, Ord)
moduleName :: ModuleIdentifier -> String
moduleName (ModuleIdentifier name _) = name
@@ -81,7 +85,7 @@ type Key = (ModuleIdentifier, String)
data ExportType
= RegularExport String
| ForeignReexport
- deriving (Show, Eq, Ord)
+ deriving (Show, Read, Eq, Ord)
-- | There are four types of module element we are interested in:
--
@@ -97,10 +101,10 @@ data ModuleElement
| Member JSNode Bool String [JSNode] [Key]
| ExportsList [(ExportType, String, JSNode, [Key])]
| Other JSNode
- deriving Show
+ deriving (Show, Read)
-- | A module is just a list of elements of the types listed above.
-data Module = Module ModuleIdentifier [ModuleElement] deriving Show
+data Module = Module ModuleIdentifier [ModuleElement] deriving (Show, Read)
-- | Prepare an error message for consumption by humans.
printErrorMessage :: ErrorMessage -> [String]
@@ -127,7 +131,7 @@ printErrorMessage (ErrorInModule mid e) =
: map (" " ++) (printErrorMessage e)
where
displayIdentifier (ModuleIdentifier name ty) =
- name ++ " (" ++ show ty ++ ")"
+ name ++ " (" ++ showModuleType ty ++ ")"
-- | Unpack the node inside a JSNode. This is useful when pattern matching.
node :: JSNode -> Node
@@ -381,7 +385,7 @@ isModuleEmpty (Module _ els) = all isElementEmpty els
where
isElementEmpty :: ModuleElement -> Bool
isElementEmpty (ExportsList exps) = null exps
- isElementEmpty (Require _ _ _) = True
+ isElementEmpty Require{} = True
isElementEmpty (Other _) = True
isElementEmpty _ = False
diff --git a/src/Language/PureScript/CodeGen.hs b/src/Language/PureScript/CodeGen.hs
index fb16fb5..ee305ff 100644
--- a/src/Language/PureScript/CodeGen.hs
+++ b/src/Language/PureScript/CodeGen.hs
@@ -13,13 +13,8 @@
--
-- [@Language.PureScript.CodeGen.JS@] Code generator for Javascript
--
--- [@Language.PureScript.CodeGen.Externs@] Code generator for extern (foreign import) files
---
--- [@Language.PureScript.CodeGen.Optimize@] Optimization passes for generated Javascript
---
-----------------------------------------------------------------------------
module Language.PureScript.CodeGen (module C) where
import Language.PureScript.CodeGen.JS as C
-import Language.PureScript.CodeGen.Externs as C
diff --git a/src/Language/PureScript/CodeGen/Externs.hs b/src/Language/PureScript/CodeGen/Externs.hs
deleted file mode 100644
index 4e4c0e3..0000000
--- a/src/Language/PureScript/CodeGen/Externs.hs
+++ /dev/null
@@ -1,144 +0,0 @@
------------------------------------------------------------------------------
---
--- Module : Language.PureScript.CodeGen.Externs
--- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
--- License : MIT (http://opensource.org/licenses/MIT)
---
--- Maintainer : Phil Freeman <paf31@cantab.net>
--- Stability : experimental
--- Portability :
---
--- |
--- This module generates code for \"externs\" files, i.e. files containing only foreign import declarations.
---
------------------------------------------------------------------------------
-
-module Language.PureScript.CodeGen.Externs (
- moduleToPs
-) where
-
-import Data.List (intercalate, find)
-import Data.Maybe (fromMaybe, mapMaybe)
-import qualified Data.Map as M
-
-import Control.Monad.Writer
-
-import Language.PureScript.AST
-import Language.PureScript.Comments
-import Language.PureScript.Environment
-import Language.PureScript.Kinds
-import Language.PureScript.Names
-import Language.PureScript.Pretty
-import Language.PureScript.TypeClassDictionaries
-import Language.PureScript.Types
-
--- |
--- Generate foreign imports for all declarations in a module
---
-moduleToPs :: Module -> Environment -> String
-moduleToPs (Module _ _ _ _ Nothing) _ = error "Module exports were not elaborated in moduleToPs"
-moduleToPs (Module _ _ moduleName ds (Just exts)) env = intercalate "\n" . execWriter $ do
- let exps = listRefs exts
- tell ["module " ++ runModuleName moduleName ++ (if null exps then "" else " (" ++ exps ++ ")") ++ " where"]
- mapM_ declToPs ds
- mapM_ exportToPs exts
- where
-
- listRefs :: [DeclarationRef] -> String
- listRefs = intercalate ", " . mapMaybe listRef
-
- listRef :: DeclarationRef -> Maybe String
- listRef (PositionedDeclarationRef _ _ d) = listRef d
- listRef (TypeRef name Nothing) = Just $ show name ++ "()"
- listRef (TypeRef name (Just dctors)) = Just $ show name ++ "(" ++ intercalate ", " (map show dctors) ++ ")"
- listRef (ValueRef name) = Just $ show name
- listRef (TypeClassRef name) = Just $ show name
- listRef (ModuleRef name) = Just $ "module " ++ show name
- listRef _ = Nothing
-
- declToPs :: Declaration -> Writer [String] ()
- declToPs (ImportDeclaration mn imp Nothing) =
- tell ["import " ++ show mn ++ importToPs imp]
- declToPs (ImportDeclaration mn imp (Just qual)) =
- tell ["import qualified " ++ show mn ++ importToPs imp ++ " as " ++ show qual]
- declToPs (FixityDeclaration (Fixity assoc prec) op) =
- case find exportsOp exts of
- Nothing -> return ()
- Just _ -> tell [ unwords [ show assoc, show prec, op ] ]
- where
- exportsOp :: DeclarationRef -> Bool
- exportsOp (PositionedDeclarationRef _ _ r) = exportsOp r
- exportsOp (ValueRef ident') = ident' == Op op
- exportsOp _ = False
- declToPs (PositionedDeclaration _ com d) = mapM_ commentToPs com >> declToPs d
- declToPs _ = return ()
-
- importToPs :: ImportDeclarationType -> String
- importToPs Implicit = ""
- importToPs (Explicit refs) = " (" ++ listRefs refs ++ ")"
- importToPs (Hiding refs) = " hiding (" ++ listRefs refs ++ ")"
-
- commentToPs :: Comment -> Writer [String] ()
- commentToPs (LineComment s) = tell ["-- " ++ s]
- commentToPs (BlockComment s) = tell ["{- " ++ s ++ " -}"]
-
- exportToPs :: DeclarationRef -> Writer [String] ()
- exportToPs (PositionedDeclarationRef _ _ r) = exportToPs r
- exportToPs (TypeRef pn dctors) =
- case Qualified (Just moduleName) pn `M.lookup` types env of
- Nothing -> error $ show pn ++ " has no kind in exportToPs"
- Just (kind, ExternData) ->
- tell ["foreign import data " ++ show pn ++ " :: " ++ prettyPrintKind kind]
- Just (_, DataType args tys) -> do
- let dctors' = fromMaybe (map fst tys) dctors
- printDctor dctor = case dctor `lookup` tys of
- Nothing -> Nothing
- Just tyArgs -> Just $ show dctor ++ " " ++ unwords (map prettyPrintTypeAtom tyArgs)
- let dtype = if length dctors' == 1 && isNewtypeConstructor env (Qualified (Just moduleName) $ head dctors')
- then "newtype"
- else "data"
- typeName = prettyPrintType $ foldl TypeApp (TypeConstructor (Qualified Nothing pn)) (map toTypeVar args)
- tell [dtype ++ " " ++ typeName ++ (if null dctors' then "" else " = " ++ intercalate " | " (mapMaybe printDctor dctors'))]
- Just (_, TypeSynonym) ->
- case Qualified (Just moduleName) pn `M.lookup` typeSynonyms env of
- Nothing -> error $ show pn ++ " has no type synonym info in exportToPs"
- Just (args, synTy) ->
- let
- typeName = prettyPrintType $ foldl TypeApp (TypeConstructor (Qualified Nothing pn)) (map toTypeVar args)
- in tell ["type " ++ typeName ++ " = " ++ prettyPrintType synTy]
- _ -> error "Invalid input in exportToPs"
-
- exportToPs (ValueRef ident) =
- case (moduleName, ident) `M.lookup` names env of
- Nothing -> error $ show ident ++ " has no type in exportToPs"
- Just (ty, nk, _) | nk == Public || nk == External ->
- tell ["foreign import " ++ show ident ++ " :: " ++ prettyPrintType ty]
- _ -> return ()
- exportToPs (TypeClassRef className) =
- case Qualified (Just moduleName) className `M.lookup` typeClasses env of
- Nothing -> error $ show className ++ " has no type class definition in exportToPs"
- Just (args, members, implies) -> do
- let impliesString = if null implies
- then ""
- else "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map prettyPrintTypeAtom tys')) implies) ++ ") <= "
- typeName = prettyPrintType $ foldl TypeApp (TypeConstructor (Qualified Nothing className)) (map toTypeVar args)
- tell ["class " ++ impliesString ++ typeName ++ " where"]
- forM_ (filter (isValueExported . fst) members) $ \(member ,ty) ->
- tell [ " " ++ show member ++ " :: " ++ prettyPrintType ty ]
-
- exportToPs (TypeInstanceRef ident) = do
- let TypeClassDictionaryInScope { tcdClassName = className, tcdInstanceTypes = tys, tcdDependencies = deps} =
- fromMaybe (error $ "Type class instance has no dictionary in exportToPs") . find (\tcd -> tcdName tcd == Qualified (Just moduleName) ident && tcdType tcd == TCDRegular) . maybe [] (M.elems >=> M.elems) . M.lookup (Just moduleName) $ typeClassDictionaries env
- let constraintsText = case fromMaybe [] deps of
- [] -> ""
- cs -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map prettyPrintTypeAtom tys')) cs) ++ ") => "
- tell ["foreign import instance " ++ show ident ++ " :: " ++ constraintsText ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys)]
-
- exportToPs (ModuleRef _) = return ()
-
- toTypeVar :: (String, Maybe Kind) -> Type
- toTypeVar (s, Nothing) = TypeVar s
- toTypeVar (s, Just k) = KindedType (TypeVar s) k
-
- isValueExported :: Ident -> Bool
- isValueExported ident = ValueRef ident `elem` exts
diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index 9eadca9..5db67d5 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -27,6 +27,7 @@ module Language.PureScript.CodeGen.JS
) where
import Data.List ((\\), delete, intersect)
+import Data.Maybe (isNothing)
import qualified Data.Traversable as T (traverse)
#if __GLASGOW_HASKELL__ < 710
@@ -55,14 +56,14 @@ import System.FilePath.Posix ((</>))
--
moduleToJs :: forall m. (Applicative m, Monad m, MonadReader Options m, MonadSupply m)
=> Module Ann -> Maybe JS -> m [JS]
-moduleToJs (Module coms mn imps exps foreigns decls) foreign = do
+moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = do
jsImports <- T.traverse importToJs . delete (ModuleName [ProperName C.prim]) . (\\ [mn]) $ imps
jsDecls <- mapM bindToJs decls
optimized <- T.traverse (T.traverse optimize) jsDecls
comments <- not <$> asks optionsNoComments
let strict = JSStringLiteral "use strict"
let header = if comments && not (null coms) then JSComment coms strict else strict
- let foreign' = [JSVariableIntroduction "$foreign" foreign | not $ null foreigns || foreign == Nothing]
+ let foreign' = [JSVariableIntroduction "$foreign" foreign_ | not $ null foreigns || isNothing foreign_]
let moduleBody = header : foreign' ++ jsImports ++ concat optimized
let foreignExps = exps `intersect` (fst `map` foreigns)
let standardExps = exps \\ foreignExps
@@ -172,7 +173,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign = do
then foreignIdent ident
else varToJs qi
valueToJs (Var (_, _, _, Just IsForeign) ident) =
- error $ "Encountered an unqualified reference to a foreign ident " ++ show ident
+ error $ "Encountered an unqualified reference to a foreign ident " ++ showQualified showIdent ident
valueToJs (Var _ ident) =
return $ varToJs ident
valueToJs (Case (maybeSpan, _, _, _) values binders) = do
@@ -320,8 +321,8 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign = do
done'' <- go remain done'
js <- binderToJs argVar done'' binder
return (JSVariableIntroduction argVar (Just (JSAccessor (identToJs field) (JSVar varName))) : js)
- binderToJs _ _ b@(ConstructorBinder{}) =
- error $ "Invalid ConstructorBinder in binderToJs: " ++ show b
+ binderToJs _ _ ConstructorBinder{} =
+ error "binderToJs: Invalid ConstructorBinder in binderToJs"
binderToJs varName done (NamedBinder _ ident binder) = do
js <- binderToJs varName done binder
return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : js)
diff --git a/src/Language/PureScript/CodeGen/JS/AST.hs b/src/Language/PureScript/CodeGen/JS/AST.hs
index 24d961a..90be974 100644
--- a/src/Language/PureScript/CodeGen/JS/AST.hs
+++ b/src/Language/PureScript/CodeGen/JS/AST.hs
@@ -53,7 +53,7 @@ data UnaryOperator
-- |
-- Constructor
--
- | JSNew deriving (Show, Eq, Data, Typeable)
+ | JSNew deriving (Show, Read, Eq, Data, Typeable)
-- |
-- Built-in binary operators
@@ -134,7 +134,7 @@ data BinaryOperator
-- |
-- Bitwise right shift with zero-fill
--
- | ZeroFillShiftRight deriving (Show, Eq, Data, Typeable)
+ | ZeroFillShiftRight deriving (Show, Read, Eq, Data, Typeable)
-- |
-- Data type for simplified Javascript expressions
@@ -255,7 +255,7 @@ data JS
-- |
-- Commented Javascript
--
- | JSComment [Comment] JS deriving (Show, Eq, Data, Typeable)
+ | JSComment [Comment] JS deriving (Show, Read, Eq, Data, Typeable)
--
-- Traversals
diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs
index 59bbba4..eeaafe0 100644
--- a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs
+++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs
@@ -255,7 +255,7 @@ inlineFnComposition = everywhereOnJSTopDownM convert
return $ JSFunction Nothing [arg] (JSBlock [JSReturn $ JSApp x [JSApp y [JSVar arg]]])
convert other = return other
isFnCompose :: JS -> JS -> Bool
- isFnCompose dict' fn = isDict semigroupoidFn dict' && (isPreludeFn (C.<<<) fn || isPreludeFn (C.compose) fn)
+ isFnCompose dict' fn = isDict semigroupoidFn dict' && (isPreludeFn (C.<<<) fn || isPreludeFn C.compose fn)
isDict :: (String, String) -> JS -> Bool
isDict (moduleName, dictName) (JSAccessor x (JSVar y)) = x == dictName && y == moduleName
diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs
index 52bf06f..3908e5f 100644
--- a/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs
+++ b/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs
@@ -124,5 +124,5 @@ tco' = everywhereOnJS convert
hasFunction :: JS -> Bool
hasFunction = getAny . everythingOnJS mappend (Any . isFunction)
where
- isFunction (JSFunction _ _ _) = True
+ isFunction JSFunction{} = True
isFunction _ = False
diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Unused.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Unused.hs
index 3d748fc..7a3b6d3 100644
--- a/src/Language/PureScript/CodeGen/JS/Optimizer/Unused.hs
+++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Unused.hs
@@ -29,7 +29,7 @@ removeCodeAfterReturnStatements = everywhereOnJS (removeFromBlock go)
where
go :: [JS] -> [JS]
go jss | not (any isJSReturn jss) = jss
- | otherwise = let (body, ret : _) = span (not . isJSReturn) jss in body ++ [ret]
+ | otherwise = let (body, ret : _) = break isJSReturn jss in body ++ [ret]
isJSReturn (JSReturn _) = True
isJSReturn _ = False
diff --git a/src/Language/PureScript/Comments.hs b/src/Language/PureScript/Comments.hs
index d6249ef..351731b 100644
--- a/src/Language/PureScript/Comments.hs
+++ b/src/Language/PureScript/Comments.hs
@@ -14,12 +14,16 @@
-----------------------------------------------------------------------------
{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TemplateHaskell #-}
module Language.PureScript.Comments where
+import Data.Aeson.TH
import qualified Data.Data as D
data Comment
= LineComment String
| BlockComment String
- deriving (Show, Eq, Ord, D.Data, D.Typeable)
+ deriving (Show, Read, Eq, Ord, D.Data, D.Typeable)
+
+$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Comment)
diff --git a/src/Language/PureScript/CoreFn/Binders.hs b/src/Language/PureScript/CoreFn/Binders.hs
index 595f2cc..77303a1 100644
--- a/src/Language/PureScript/CoreFn/Binders.hs
+++ b/src/Language/PureScript/CoreFn/Binders.hs
@@ -45,4 +45,4 @@ data Binder a
-- |
-- A binder which binds its input to an identifier
--
- | NamedBinder a Ident (Binder a) deriving (Show, D.Data, D.Typeable, Functor)
+ | NamedBinder a Ident (Binder a) deriving (Show, Read, D.Data, D.Typeable, Functor)
diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs
index a963d7b..f691589 100644
--- a/src/Language/PureScript/CoreFn/Desugar.hs
+++ b/src/Language/PureScript/CoreFn/Desugar.hs
@@ -166,6 +166,8 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =
NamedBinder (ss, com, Nothing, Nothing) name (binderToCoreFn ss [] b)
binderToCoreFn _ com (A.PositionedBinder ss com1 b) =
binderToCoreFn (Just ss) (com ++ com1) b
+ binderToCoreFn ss com (A.TypedBinder _ b) =
+ binderToCoreFn ss com b
-- |
-- Gets metadata for values.
@@ -225,7 +227,6 @@ importToCoreFn _ = Nothing
--
externToCoreFn :: A.Declaration -> Maybe ForeignDecl
externToCoreFn (A.ExternDeclaration name ty) = Just (name, ty)
-externToCoreFn (A.ExternInstanceDeclaration name _ _ _) = Just (name, tyObject)
externToCoreFn (A.PositionedDeclaration _ _ d) = externToCoreFn d
externToCoreFn _ = Nothing
diff --git a/src/Language/PureScript/CoreFn/Expr.hs b/src/Language/PureScript/CoreFn/Expr.hs
index 67decc3..39a1006 100644
--- a/src/Language/PureScript/CoreFn/Expr.hs
+++ b/src/Language/PureScript/CoreFn/Expr.hs
@@ -64,7 +64,7 @@ data Expr a
-- |
-- A let binding
--
- | Let a [Bind a] (Expr a) deriving (Show, D.Data, D.Typeable, Functor)
+ | Let a [Bind a] (Expr a) deriving (Show, Read, D.Data, D.Typeable, Functor)
-- |
-- A let or module binding.
@@ -77,7 +77,7 @@ data Bind a
-- |
-- Mutually recursive binding group for several values
--
- | Rec [(Ident, Expr a)] deriving (Show, D.Data, D.Typeable, Functor)
+ | Rec [(Ident, Expr a)] deriving (Show, Read, D.Data, D.Typeable, Functor)
-- |
-- A guard is just a boolean-valued expression that appears alongside a set of binders
@@ -96,12 +96,12 @@ data CaseAlternative a = CaseAlternative
-- The result expression or a collect of guarded expressions
--
, caseAlternativeResult :: Either [(Guard a, Expr a)] (Expr a)
- } deriving (Show, D.Data, D.Typeable)
+ } deriving (Show, Read, D.Data, D.Typeable)
instance Functor CaseAlternative where
fmap f (CaseAlternative cabs car) = CaseAlternative
- (fmap (fmap f) $ cabs)
+ (fmap (fmap f) cabs)
(either (Left . fmap (fmap f *** fmap f)) (Right . fmap f) car)
-- |
diff --git a/src/Language/PureScript/CoreFn/Literals.hs b/src/Language/PureScript/CoreFn/Literals.hs
index fed1814..7f49c0c 100644
--- a/src/Language/PureScript/CoreFn/Literals.hs
+++ b/src/Language/PureScript/CoreFn/Literals.hs
@@ -47,4 +47,4 @@ data Literal a
-- |
-- An object literal
--
- | ObjectLiteral [(String, a)] deriving (Show, D.Data, D.Typeable, Functor)
+ | ObjectLiteral [(String, a)] deriving (Show, Read, D.Data, D.Typeable, Functor)
diff --git a/src/Language/PureScript/CoreFn/Meta.hs b/src/Language/PureScript/CoreFn/Meta.hs
index 3d21524..bbd2abe 100644
--- a/src/Language/PureScript/CoreFn/Meta.hs
+++ b/src/Language/PureScript/CoreFn/Meta.hs
@@ -39,7 +39,7 @@ data Meta
-- |
-- The contained reference is for a foreign member
--
- | IsForeign deriving (Show, D.Data, D.Typeable)
+ | IsForeign deriving (Show, Read, D.Data, D.Typeable)
-- |
-- Data constructor metadata
@@ -52,4 +52,4 @@ data ConstructorType
-- |
-- The constructor is for a type with multiple construcors
--
- | SumType deriving (Show, D.Data, D.Typeable)
+ | SumType deriving (Show, Read, D.Data, D.Typeable)
diff --git a/src/Language/PureScript/CoreFn/Module.hs b/src/Language/PureScript/CoreFn/Module.hs
index b69e169..c9ceeb1 100644
--- a/src/Language/PureScript/CoreFn/Module.hs
+++ b/src/Language/PureScript/CoreFn/Module.hs
@@ -26,6 +26,6 @@ data Module a = Module
, moduleExports :: [Ident]
, moduleForeign :: [ForeignDecl]
, moduleDecls :: [Bind a]
- } deriving (Show)
+ } deriving (Show, Read)
type ForeignDecl = (Ident, Type)
diff --git a/src/Language/PureScript/Docs/AsMarkdown.hs b/src/Language/PureScript/Docs/AsMarkdown.hs
index 516ea44..5476489 100644
--- a/src/Language/PureScript/Docs/AsMarkdown.hs
+++ b/src/Language/PureScript/Docs/AsMarkdown.hs
@@ -98,7 +98,7 @@ childToString f decl@ChildDeclaration{..} =
data First
= First
| NotFirst
- deriving (Show, Eq, Ord)
+ deriving (Show, Read, Eq, Ord)
type Docs = Writer [String] ()
diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs
index cfeaee0..3d49800 100644
--- a/src/Language/PureScript/Docs/Convert.hs
+++ b/src/Language/PureScript/Docs/Convert.hs
@@ -26,7 +26,7 @@ import Language.PureScript.Docs.Types
--
convertModule :: P.Module -> Module
convertModule m@(P.Module _ coms moduleName _ _) =
- Module (show moduleName) comments (declarations m)
+ Module (P.runModuleName moduleName) comments (declarations m)
where
comments = convertComments coms
declarations =
@@ -106,13 +106,13 @@ addDefaultFixity decl@Declaration{..}
defaultFixity = P.Fixity P.Infixl (-1)
getDeclarationTitle :: P.Declaration -> Maybe String
-getDeclarationTitle (P.TypeDeclaration name _) = Just (show name)
-getDeclarationTitle (P.ExternDeclaration name _) = Just (show name)
-getDeclarationTitle (P.DataDeclaration _ name _ _) = Just (show name)
-getDeclarationTitle (P.ExternDataDeclaration name _) = Just (show name)
-getDeclarationTitle (P.TypeSynonymDeclaration name _ _) = Just (show name)
-getDeclarationTitle (P.TypeClassDeclaration name _ _ _) = Just (show name)
-getDeclarationTitle (P.TypeInstanceDeclaration name _ _ _ _) = Just (show name)
+getDeclarationTitle (P.TypeDeclaration name _) = Just (P.showIdent name)
+getDeclarationTitle (P.ExternDeclaration name _) = Just (P.showIdent name)
+getDeclarationTitle (P.DataDeclaration _ name _ _) = Just (P.runProperName name)
+getDeclarationTitle (P.ExternDataDeclaration name _) = Just (P.runProperName name)
+getDeclarationTitle (P.TypeSynonymDeclaration name _ _) = Just (P.runProperName name)
+getDeclarationTitle (P.TypeClassDeclaration name _ _ _) = Just (P.runProperName name)
+getDeclarationTitle (P.TypeInstanceDeclaration name _ _ _ _) = Just (P.showIdent name)
getDeclarationTitle (P.FixityDeclaration _ name) = Just ("(" ++ name ++ ")")
getDeclarationTitle (P.PositionedDeclaration _ _ d) = getDeclarationTitle d
getDeclarationTitle _ = Nothing
@@ -142,12 +142,12 @@ convertDeclaration (P.DataDeclaration dtype _ args ctors) title =
info = DataDeclaration dtype args
children = map convertCtor ctors
convertCtor (ctor', tys) =
- ChildDeclaration (show ctor') Nothing Nothing (ChildDataConstructor tys)
+ ChildDeclaration (P.runProperName ctor') Nothing Nothing (ChildDataConstructor tys)
convertDeclaration (P.ExternDataDeclaration _ kind') title =
basicDeclaration title (ExternDataDeclaration kind')
convertDeclaration (P.TypeSynonymDeclaration _ args ty) title =
basicDeclaration title (TypeSynonymDeclaration args ty)
-convertDeclaration (P.TypeClassDeclaration _ args implies ds) title = do
+convertDeclaration (P.TypeClassDeclaration _ args implies ds) title =
Just (Right (mkDeclaration title info) { declChildren = children })
where
info = TypeClassDeclaration args implies
@@ -155,18 +155,17 @@ convertDeclaration (P.TypeClassDeclaration _ args implies ds) title = do
convertClassMember (P.PositionedDeclaration _ _ d) =
convertClassMember d
convertClassMember (P.TypeDeclaration ident' ty) =
- ChildDeclaration (show ident') Nothing Nothing (ChildTypeClassMember ty)
+ ChildDeclaration (P.showIdent ident') Nothing Nothing (ChildTypeClassMember ty)
convertClassMember _ =
error "Invalid argument to convertClassMember."
-convertDeclaration (P.TypeInstanceDeclaration _ constraints className tys _) title = do
+convertDeclaration (P.TypeInstanceDeclaration _ constraints className tys _) title =
Just (Left (classNameString : typeNameStrings, AugmentChild childDecl))
where
classNameString = unQual className
typeNameStrings = nub (concatMap (P.everythingOnTypes (++) extractProperNames) tys)
- unQual x = let (P.Qualified _ y) = x in show y
+ unQual x = let (P.Qualified _ y) = x in P.runProperName y
extractProperNames (P.TypeConstructor n) = [unQual n]
- extractProperNames (P.SaturatedTypeSynonym n _) = [unQual n]
extractProperNames _ = []
childDecl = ChildDeclaration title Nothing Nothing (ChildInstance constraints classApp)
@@ -225,4 +224,3 @@ collectBookmarks' m =
map (P.getModuleName m, )
(mapMaybe getDeclarationTitle
(P.exportedDeclarations m))
-
diff --git a/src/Language/PureScript/Docs/ParseAndDesugar.hs b/src/Language/PureScript/Docs/ParseAndDesugar.hs
index 9dcfc7f..b422748 100644
--- a/src/Language/PureScript/Docs/ParseAndDesugar.hs
+++ b/src/Language/PureScript/Docs/ParseAndDesugar.hs
@@ -122,7 +122,7 @@ desugar :: [P.Module] -> Either P.MultipleErrors [P.Module]
desugar = P.evalSupplyT 0 . desugar'
where
desugar' :: [P.Module] -> P.SupplyT (Either P.MultipleErrors) [P.Module]
- desugar' = mapM P.desugarDoModule >=> P.desugarCasesModule >=> ignoreWarnings . P.desugarImports
+ desugar' = mapM P.desugarDoModule >=> P.desugarCasesModule >=> ignoreWarnings . P.desugarImports []
ignoreWarnings m = liftM fst (runWriterT m)
parseFile :: FilePath -> IO (FilePath, String)
diff --git a/src/Language/PureScript/Docs/Render.hs b/src/Language/PureScript/Docs/Render.hs
index 7726cce..ec290be 100644
--- a/src/Language/PureScript/Docs/Render.hs
+++ b/src/Language/PureScript/Docs/Render.hs
@@ -10,6 +10,7 @@
module Language.PureScript.Docs.Render where
+import Data.Maybe (maybeToList)
import Data.Monoid ((<>))
import qualified Language.PureScript as P
@@ -29,7 +30,7 @@ renderDeclarationWithOptions opts Declaration{..} =
, renderType' ty
]
DataDeclaration dtype args ->
- [ keyword (show dtype)
+ [ keyword (P.showDataDeclType dtype)
, renderType' (typeApp declTitle args)
]
ExternDataDeclaration kind' ->
@@ -46,7 +47,7 @@ renderDeclarationWithOptions opts Declaration{..} =
]
TypeClassDeclaration args implies ->
[ keywordClass ]
- ++ maybe [] (:[]) superclasses
+ ++ maybeToList superclasses
++ [renderType' (typeApp declTitle args)]
++ if any (isTypeClassMember . cdeclInfo) declChildren
then [keywordWhere]
@@ -75,7 +76,7 @@ renderChildDeclarationWithOptions opts ChildDeclaration{..} =
[ keywordInstance
, ident cdeclTitle
, syntax "::"
- ] ++ maybe [] (:[]) (renderConstraints constraints)
+ ] ++ maybeToList (renderConstraints constraints)
++ [ renderType' ty ]
ChildDataConstructor args ->
[ renderType' typeApp' ]
diff --git a/src/Language/PureScript/Docs/RenderedCode/Render.hs b/src/Language/PureScript/Docs/RenderedCode/Render.hs
index 9ab8a1c..35030fa 100644
--- a/src/Language/PureScript/Docs/RenderedCode/Render.hs
+++ b/src/Language/PureScript/Docs/RenderedCode/Render.hs
@@ -45,7 +45,7 @@ typeLiterals = mkPattern match
, syntax "}"
]
match (TypeConstructor (Qualified mn name)) =
- Just (ctor (show name) (maybeToContainingModule mn))
+ Just (ctor (runProperName name) (maybeToContainingModule mn))
match (ConstrainedType deps ty) =
Just $ mintersperse sp
[ syntax "(" <> constraints <> syntax ")"
diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs
index 61fba63..131f0a1 100644
--- a/src/Language/PureScript/Docs/Types.hs
+++ b/src/Language/PureScript/Docs/Types.hs
@@ -425,7 +425,7 @@ asSourceSpan = P.SourceSpan <$> key "name" asString
instance A.ToJSON a => A.ToJSON (Package a) where
toJSON Package{..} =
- A.object $
+ A.object
[ "packageMeta" .= pkgMeta
, "version" .= showVersion pkgVersion
, "versionTag" .= pkgVersionTag
diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs
index 1818e80..006c1fa 100644
--- a/src/Language/PureScript/Environment.hs
+++ b/src/Language/PureScript/Environment.hs
@@ -14,11 +14,13 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
module Language.PureScript.Environment where
import Data.Data
import Data.Maybe (fromMaybe)
+import Data.Aeson.TH
import qualified Data.Map as M
import qualified Data.Text as T
import qualified Data.Aeson as A
@@ -42,8 +44,8 @@ data Environment = Environment {
--
, types :: M.Map (Qualified ProperName) (Kind, TypeKind)
-- |
- -- Data constructors currently in scope, along with their associated data type constructors
- --
+ -- Data constructors currently in scope, along with their associated type
+ -- constructor name, argument types and return type.
, dataConstructors :: M.Map (Qualified ProperName) (DataDeclType, ProperName, Type, [Ident])
-- |
-- Type synonyms currently in scope
@@ -57,7 +59,7 @@ data Environment = Environment {
-- Type classes
--
, typeClasses :: M.Map (Qualified ProperName) ([(String, Maybe Kind)], [(Ident, Type)], [Constraint])
- } deriving (Show)
+ } deriving (Show, Read)
-- |
-- The initial environment with no values and only the default javascript types defined
@@ -76,7 +78,7 @@ data NameVisibility
-- |
-- The name is defined in the another binding group, or has been made visible by a function binder
--
- | Defined deriving (Show, Eq)
+ | Defined deriving (Show, Read, Eq)
-- |
-- A flag for whether a name is for an private or public value - only public values will be
@@ -95,7 +97,7 @@ data NameKind
-- |
-- A name for member introduced by foreign import
--
- | External deriving (Show, Eq, Data, Typeable)
+ | External deriving (Show, Read, Eq, Data, Typeable)
-- |
-- The kinds of a type
@@ -121,7 +123,7 @@ data TypeKind
-- A scoped type variable
--
| ScopedTypeVar
- deriving (Show, Eq, Data, Typeable)
+ deriving (Show, Read, Eq, Data, Typeable)
-- |
-- The type ('data' or 'newtype') of a data type declaration
@@ -134,14 +136,14 @@ data DataDeclType
-- |
-- A newtype constructor
--
- | Newtype deriving (Eq, Ord, Data, Typeable)
+ | Newtype deriving (Show, Read, Eq, Ord, Data, Typeable)
-instance Show DataDeclType where
- show Data = "data"
- show Newtype = "newtype"
+showDataDeclType :: DataDeclType -> String
+showDataDeclType Data = "data"
+showDataDeclType Newtype = "newtype"
instance A.ToJSON DataDeclType where
- toJSON = A.toJSON . show
+ toJSON = A.toJSON . showDataDeclType
instance A.FromJSON DataDeclType where
parseJSON = A.withText "DataDeclType" $ \str ->
@@ -266,3 +268,5 @@ isNewtypeConstructor e ctor = case lookupConstructor e ctor of
lookupValue :: Environment -> Qualified Ident -> Maybe (Type, NameKind, NameVisibility)
lookupValue env (Qualified (Just mn) ident) = (mn, ident) `M.lookup` names env
lookupValue _ _ = Nothing
+
+$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''TypeKind)
diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs
index 77a6a40..4b60d79 100644
--- a/src/Language/PureScript/Errors.hs
+++ b/src/Language/PureScript/Errors.hs
@@ -20,10 +20,11 @@
module Language.PureScript.Errors where
import Data.Either (lefts, rights)
-import Data.List (intercalate, transpose)
+import Data.List (intercalate, transpose, nub, nubBy, partition)
import Data.Function (on)
#if __GLASGOW_HASKELL__ < 710
import Data.Foldable (fold, foldMap)
+import Data.Traversable (traverse)
#else
import Data.Foldable (fold)
#endif
@@ -52,11 +53,8 @@ import qualified Text.PrettyPrint.Boxes as Box
import qualified Text.Parsec as P
import qualified Text.Parsec.Error as PE
import Text.Parsec.Error (Message(..))
-import Data.List (nub)
--- |
--- A type of error messages
---
+-- | A type of error messages
data SimpleErrorMessage
= ErrorParsingExterns P.ParseError
| ErrorParsingFFIModule FilePath
@@ -100,6 +98,7 @@ data SimpleErrorMessage
| CtorConflictsWithClass ProperName
| ClassConflictsWithType ProperName
| ClassConflictsWithCtor ProperName
+ | DuplicateModuleName ModuleName
| DuplicateClassExport ProperName
| DuplicateValueExport Ident
| DuplicateTypeArgument String
@@ -128,7 +127,7 @@ data SimpleErrorMessage
| OverlappingArgNames (Maybe Ident)
| MissingClassMember Ident
| ExtraneousClassMember Ident
- | ExpectedType Kind
+ | ExpectedType Type Kind
| IncorrectConstructorArity (Qualified ProperName)
| SubsumptionCheckFailed
| ExprDoesNotHaveType Expr Type
@@ -140,44 +139,57 @@ data SimpleErrorMessage
| InvalidInstanceHead Type
| TransitiveExportError DeclarationRef [DeclarationRef]
| ShadowedName Ident
+ | ShadowedTypeVar String
+ | UnusedTypeVar String
| WildcardInferredType Type
+ | MissingTypeDeclaration Ident
| NotExhaustivePattern [[Binder]] Bool
| OverlappingPattern [[Binder]] Bool
+ | IncompleteExhaustivityCheck
| ClassOperator ProperName Ident
| MisleadingEmptyTypeImport ModuleName ProperName
| ImportHidingModule ModuleName
- deriving (Show)
-
--- |
--- Wrapper of simpler errors
---
-data ErrorMessage
- = NotYetDefined [Ident] ErrorMessage
- | ErrorUnifyingTypes Type Type ErrorMessage
- | ErrorInExpression Expr ErrorMessage
- | ErrorInModule ModuleName ErrorMessage
- | ErrorInInstance (Qualified ProperName) [Type] ErrorMessage
- | ErrorInSubsumption Type Type ErrorMessage
- | ErrorCheckingType Expr Type ErrorMessage
- | ErrorCheckingKind Type ErrorMessage
- | ErrorInferringType Expr ErrorMessage
- | ErrorInApplication Expr Type Expr ErrorMessage
- | ErrorInDataConstructor ProperName ErrorMessage
- | ErrorInTypeConstructor ProperName ErrorMessage
- | ErrorInBindingGroup [Ident] ErrorMessage
- | ErrorInDataBindingGroup ErrorMessage
- | ErrorInTypeSynonym ProperName ErrorMessage
- | ErrorInValueDeclaration Ident ErrorMessage
- | ErrorInForeignImport Ident ErrorMessage
- | PositionedError SourceSpan ErrorMessage
- | SimpleErrorWrapper SimpleErrorMessage
- deriving (Show)
+ deriving Show
+
+-- | Error message hints, providing more detailed information about failure.
+data ErrorMessageHint
+ = NotYetDefined [Ident]
+ | ErrorUnifyingTypes Type Type
+ | ErrorInExpression Expr
+ | ErrorInModule ModuleName
+ | ErrorInInstance (Qualified ProperName) [Type]
+ | ErrorInSubsumption Type Type
+ | ErrorCheckingType Expr Type
+ | ErrorCheckingKind Type
+ | ErrorInferringType Expr
+ | ErrorInApplication Expr Type Expr
+ | ErrorInDataConstructor ProperName
+ | ErrorInTypeConstructor ProperName
+ | ErrorInBindingGroup [Ident]
+ | ErrorInDataBindingGroup
+ | ErrorInTypeSynonym ProperName
+ | ErrorInValueDeclaration Ident
+ | ErrorInTypeDeclaration Ident
+ | ErrorInForeignImport Ident
+ | PositionedError SourceSpan
+ deriving Show
+
+-- | Categories of hints
+data HintCategory
+ = ExprHint
+ | KindHint
+ | CheckHint
+ | PositionHint
+ | OtherHint
+ deriving (Show, Eq)
+
+data ErrorMessage = ErrorMessage [ErrorMessageHint] SimpleErrorMessage deriving (Show)
instance UnificationError Type ErrorMessage where
- occursCheckFailed t = SimpleErrorWrapper $ InfiniteType t
+ occursCheckFailed t = ErrorMessage [] $ InfiniteType t
instance UnificationError Kind ErrorMessage where
- occursCheckFailed k = SimpleErrorWrapper $ InfiniteKind k
+ occursCheckFailed k = ErrorMessage [] $ InfiniteKind k
-- |
-- Get the error code for a particular error type
@@ -226,6 +238,7 @@ errorCode em = case unwrapErrorMessage em of
CtorConflictsWithClass{} -> "CtorConflictsWithClass"
ClassConflictsWithType{} -> "ClassConflictsWithType"
ClassConflictsWithCtor{} -> "ClassConflictsWithCtor"
+ DuplicateModuleName{} -> "DuplicateModuleName"
DuplicateClassExport{} -> "DuplicateClassExport"
DuplicateValueExport{} -> "DuplicateValueExport"
DuplicateTypeArgument{} -> "DuplicateTypeArgument"
@@ -266,9 +279,13 @@ errorCode em = case unwrapErrorMessage em of
InvalidInstanceHead{} -> "InvalidInstanceHead"
TransitiveExportError{} -> "TransitiveExportError"
ShadowedName{} -> "ShadowedName"
+ ShadowedTypeVar{} -> "ShadowedTypeVar"
+ UnusedTypeVar{} -> "UnusedTypeVar"
WildcardInferredType{} -> "WildcardInferredType"
+ MissingTypeDeclaration{} -> "MissingTypeDeclaration"
NotExhaustivePattern{} -> "NotExhaustivePattern"
OverlappingPattern{} -> "OverlappingPattern"
+ IncompleteExhaustivityCheck{} -> "IncompleteExhaustivityCheck"
ClassOperator{} -> "ClassOperator"
MisleadingEmptyTypeImport{} -> "MisleadingEmptyTypeImport"
ImportHidingModule{} -> "ImportHidingModule"
@@ -293,7 +310,7 @@ nonEmpty = not . null . runMultipleErrors
-- Create an error set from a single simple error message
--
errorMessage :: SimpleErrorMessage -> MultipleErrors
-errorMessage err = MultipleErrors [SimpleErrorWrapper err]
+errorMessage err = MultipleErrors [ErrorMessage [] err]
-- |
@@ -302,14 +319,16 @@ errorMessage err = MultipleErrors [SimpleErrorWrapper err]
singleError :: ErrorMessage -> MultipleErrors
singleError = MultipleErrors . pure
--- |
--- Lift a function on ErrorMessage to a function on MultipleErrors
---
+-- | Lift a function on ErrorMessage to a function on MultipleErrors
onErrorMessages :: (ErrorMessage -> ErrorMessage) -> MultipleErrors -> MultipleErrors
onErrorMessages f = MultipleErrors . map f . runMultipleErrors
+-- | Add a hint to an error message
+addHint :: ErrorMessageHint -> MultipleErrors -> MultipleErrors
+addHint hint = onErrorMessages $ \(ErrorMessage hints se) -> ErrorMessage (hint : hints) se
+
-- | The various types of things which might need to be relabelled in errors messages.
-data LabelType = TypeLabel | SkolemLabel String deriving (Show, Eq, Ord)
+data LabelType = TypeLabel | SkolemLabel String deriving (Show, Read, Eq, Ord)
-- | A map from rigid type variable name/unknown variable pairs to new variables.
type UnknownMap = M.Map (LabelType, Unknown) Unknown
@@ -321,26 +340,7 @@ data Level = Error | Warning deriving Show
-- Extract nested error messages from wrapper errors
--
unwrapErrorMessage :: ErrorMessage -> SimpleErrorMessage
-unwrapErrorMessage em = case em of
- (ErrorCheckingKind _ err) -> unwrapErrorMessage err
- (ErrorCheckingType _ _ err) -> unwrapErrorMessage err
- (ErrorInApplication _ _ _ err) -> unwrapErrorMessage err
- (ErrorInBindingGroup _ err) -> unwrapErrorMessage err
- (ErrorInDataBindingGroup err) -> unwrapErrorMessage err
- (ErrorInDataConstructor _ err) -> unwrapErrorMessage err
- (ErrorInExpression _ err) -> unwrapErrorMessage err
- (ErrorInForeignImport _ err) -> unwrapErrorMessage err
- (ErrorInInstance _ _ err) -> unwrapErrorMessage err
- (ErrorInModule _ err) -> unwrapErrorMessage err
- (ErrorInSubsumption _ _ err) -> unwrapErrorMessage err
- (ErrorInTypeConstructor _ err) -> unwrapErrorMessage err
- (ErrorInTypeSynonym _ err) -> unwrapErrorMessage err
- (ErrorInValueDeclaration _ err) -> unwrapErrorMessage err
- (ErrorInferringType _ err) -> unwrapErrorMessage err
- (ErrorUnifyingTypes _ _ err) -> unwrapErrorMessage err
- (NotYetDefined _ err) -> unwrapErrorMessage err
- (PositionedError _ err) -> unwrapErrorMessage err
- (SimpleErrorWrapper sem) -> sem
+unwrapErrorMessage (ErrorMessage _ se) = se
replaceUnknowns :: Type -> State UnknownMap Type
replaceUnknowns = everywhereOnTypesM replaceTypes
@@ -356,383 +356,406 @@ replaceUnknowns = everywhereOnTypesM replaceTypes
replaceTypes other = return other
onTypesInErrorMessageM :: (Applicative m) => (Type -> m Type) -> ErrorMessage -> m ErrorMessage
-onTypesInErrorMessageM f = g
+onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse gHint hints <*> gSimple simple
where
- gSimple (InfiniteType t) = InfiniteType <$> (f t)
- gSimple (TypesDoNotUnify t1 t2) = TypesDoNotUnify <$> (f t1) <*> (f t2)
- gSimple (ConstrainedTypeUnified t1 t2) = ConstrainedTypeUnified <$> (f t1) <*> (f t2)
- gSimple (ExprDoesNotHaveType e t) = ExprDoesNotHaveType e <$> (f t)
- gSimple (PropertyIsMissing s t) = PropertyIsMissing s <$> (f t)
- gSimple (CannotApplyFunction t e) = CannotApplyFunction <$> f t <*> (pure e)
+ gSimple (InfiniteType t) = InfiniteType <$> f t
+ gSimple (TypesDoNotUnify t1 t2) = TypesDoNotUnify <$> f t1 <*> f t2
+ gSimple (ConstrainedTypeUnified t1 t2) = ConstrainedTypeUnified <$> f t1 <*> f t2
+ gSimple (ExprDoesNotHaveType e t) = ExprDoesNotHaveType e <$> f t
+ gSimple (PropertyIsMissing s t) = PropertyIsMissing s <$> f t
+ gSimple (CannotApplyFunction t e) = CannotApplyFunction <$> f t <*> pure e
gSimple (InvalidInstanceHead t) = InvalidInstanceHead <$> f t
gSimple other = pure other
- g (ErrorInSubsumption t1 t2 em) = ErrorInSubsumption <$> (f t1) <*> (f t2) <*> (g em)
- g (ErrorUnifyingTypes t1 t2 e) = ErrorUnifyingTypes <$> (f t1) <*> (f t2) <*> (g e)
- g (ErrorCheckingType e t em) = ErrorCheckingType e <$> (f t) <*> (g em)
- g (ErrorCheckingKind t em) = ErrorCheckingKind <$> (f t) <*> g em
- g (ErrorInApplication e1 t1 e2 em) = ErrorInApplication e1 <$> (f t1) <*> (pure e2) <*> (g em)
- g (NotYetDefined x e) = NotYetDefined x <$> (g e)
- g (ErrorInExpression x e) = ErrorInExpression x <$> (g e)
- g (ErrorInModule x e) = ErrorInModule x <$> (g e)
- g (ErrorInInstance x y e) = ErrorInInstance x y <$> (g e)
- g (ErrorInferringType x e) = ErrorInferringType x <$> (g e)
- g (ErrorInDataConstructor x e) = ErrorInDataConstructor x <$> (g e)
- g (ErrorInTypeConstructor x e) = ErrorInTypeConstructor x <$> (g e)
- g (ErrorInBindingGroup x e) = ErrorInBindingGroup x <$> (g e)
- g (ErrorInDataBindingGroup e) = ErrorInDataBindingGroup <$> (g e)
- g (ErrorInTypeSynonym x e) = ErrorInTypeSynonym x <$> (g e)
- g (ErrorInValueDeclaration x e) = ErrorInValueDeclaration x <$> (g e)
- g (ErrorInForeignImport x e) = ErrorInForeignImport x <$> (g e)
- g (PositionedError x e) = PositionedError x <$> (g e)
- g (SimpleErrorWrapper sem) = SimpleErrorWrapper <$> gSimple sem
+ gHint (ErrorInSubsumption t1 t2) = ErrorInSubsumption <$> f t1 <*> f t2
+ gHint (ErrorUnifyingTypes t1 t2) = ErrorUnifyingTypes <$> f t1 <*> f t2
+ gHint (ErrorCheckingType e t) = ErrorCheckingType e <$> f t
+ gHint (ErrorCheckingKind t) = ErrorCheckingKind <$> f t
+ gHint (ErrorInApplication e1 t1 e2) = ErrorInApplication e1 <$> f t1 <*> pure e2
+ gHint other = pure other
-- |
-- Pretty print a single error, simplifying if necessary
--
prettyPrintSingleError :: Bool -> Level -> ErrorMessage -> State UnknownMap Box.Box
-prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInErrorMessageM replaceUnknowns (if full then e else simplifyErrorMessage e)
+prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFirst . reverseHints <$> onTypesInErrorMessageM replaceUnknowns (if full then e else simplifyErrorMessage e)
where
- -- |
+
-- Pretty print an ErrorMessage
- --
prettyPrintErrorMessage :: ErrorMessage -> Box.Box
- prettyPrintErrorMessage em =
+ prettyPrintErrorMessage (ErrorMessage hints simple) =
paras $
- go em:suggestions em ++
+ map renderHint hints ++
+ renderSimpleErrorMessage simple :
+ suggestions simple ++
[line $ "See " ++ wikiUri ++ " for more information, or to contribute content related to this " ++ levelText ++ "."]
where
wikiUri :: String
wikiUri = "https://github.com/purescript/purescript/wiki/Error-Code-" ++ errorCode e
- go :: ErrorMessage -> Box.Box
- goSimple (CannotGetFileInfo path) =
+ renderSimpleErrorMessage :: SimpleErrorMessage -> Box.Box
+ renderSimpleErrorMessage (CannotGetFileInfo path) =
paras [ line "Unable to read file info: "
, indent . line $ path
]
- goSimple (CannotReadFile path) =
+ renderSimpleErrorMessage (CannotReadFile path) =
paras [ line "Unable to read file: "
, indent . line $ path
]
- goSimple (CannotWriteFile path) =
+ renderSimpleErrorMessage (CannotWriteFile path) =
paras [ line "Unable to write file: "
, indent . line $ path
]
- goSimple (ErrorParsingExterns err) =
+ renderSimpleErrorMessage (ErrorParsingExterns err) =
paras [ lineWithLevel "parsing externs files: "
- , indent . prettyPrintParseError $ err
+ , prettyPrintParseError err
]
- goSimple (ErrorParsingFFIModule path) =
+ renderSimpleErrorMessage (ErrorParsingFFIModule path) =
paras [ line "Unable to parse module from FFI file: "
, indent . line $ path
]
- goSimple (ErrorParsingModule err) =
+ renderSimpleErrorMessage (ErrorParsingModule err) =
paras [ line "Unable to parse module: "
- , indent . prettyPrintParseError $ err
+ , prettyPrintParseError err
]
- goSimple (MissingFFIModule mn) =
- line $ "Missing FFI implementations for module " ++ show mn
- goSimple (UnnecessaryFFIModule mn path) =
- paras [ line $ "Unnecessary FFI implementations have been provided for module " ++ show mn ++ ": "
+ renderSimpleErrorMessage (MissingFFIModule mn) =
+ line $ "Missing FFI implementations for module " ++ runModuleName mn
+ renderSimpleErrorMessage (UnnecessaryFFIModule mn path) =
+ paras [ line $ "Unnecessary FFI implementations have been provided for module " ++ runModuleName mn ++ ": "
, indent . line $ path
]
- goSimple (MultipleFFIModules mn paths) =
- paras $ [ line $ "Multiple FFI implementations have been provided for module " ++ show mn ++ ": " ]
- ++ map (indent . line) paths
- goSimple (InvalidExternsFile path) =
+ renderSimpleErrorMessage (MultipleFFIModules mn paths) =
+ paras [ line $ "Multiple FFI implementations have been provided for module " ++ runModuleName mn ++ ": "
+ , indent . paras $ map line paths
+ ]
+ renderSimpleErrorMessage (InvalidExternsFile path) =
paras [ line "Externs file is invalid: "
, indent . line $ path
]
- goSimple InvalidDoBind =
- line "Bind statement cannot be the last statement in a do block"
- goSimple InvalidDoLet =
- line "Let statement cannot be the last statement in a do block"
- goSimple CannotReorderOperators =
+ renderSimpleErrorMessage InvalidDoBind =
+ line "Bind statement cannot be the last statement in a do block. The last statement must be an expression."
+ renderSimpleErrorMessage InvalidDoLet =
+ line "Let statement cannot be the last statement in a do block. The last statement must be an expression."
+ renderSimpleErrorMessage CannotReorderOperators =
line "Unable to reorder operators"
- goSimple UnspecifiedSkolemScope =
+ renderSimpleErrorMessage UnspecifiedSkolemScope =
line "Skolem variable scope is unspecified"
- goSimple OverlappingNamesInLet =
+ renderSimpleErrorMessage OverlappingNamesInLet =
line "Overlapping names in let binding."
- goSimple (InfiniteType ty) =
- paras [ line "Infinite type detected: "
- , indent $ line $ prettyPrintType ty
+ renderSimpleErrorMessage (InfiniteType ty) =
+ paras [ line "An infinite type was inferred for an expression: "
+ , indent $ typeAsBox ty
]
- goSimple (InfiniteKind ki) =
- paras [ line "Infinite kind detected: "
+ renderSimpleErrorMessage (InfiniteKind ki) =
+ paras [ line "An infinite kind was inferred for a type: "
, indent $ line $ prettyPrintKind ki
]
- goSimple (MultipleFixities name) =
- line $ "Multiple fixity declarations for " ++ show name
- goSimple (OrphanTypeDeclaration nm) =
- line $ "Orphan type declaration for " ++ show nm
- goSimple (OrphanFixityDeclaration op) =
+ renderSimpleErrorMessage (MultipleFixities name) =
+ line $ "Multiple fixity declarations for " ++ showIdent name
+ renderSimpleErrorMessage (OrphanTypeDeclaration nm) =
+ line $ "Orphan type declaration for " ++ showIdent nm
+ renderSimpleErrorMessage (OrphanFixityDeclaration op) =
line $ "Orphan fixity declaration for " ++ show op
- goSimple (RedefinedModule name filenames) =
- paras $ [ line $ "Module " ++ show name ++ " has been defined multiple times:"
- ] ++ map (indent . line . displaySourceSpan) filenames
- goSimple (RedefinedIdent name) =
- line $ "Name " ++ show name ++ " has been defined multiple times"
- goSimple (UnknownModule mn) =
- line $ "Unknown module " ++ show mn
- goSimple (UnknownType name) =
- line $ "Unknown type " ++ show name
- goSimple (UnknownTypeClass name) =
- line $ "Unknown type class " ++ show name
- goSimple (UnknownValue name) =
- line $ "Unknown value " ++ show name
- goSimple (UnknownTypeConstructor name) =
- line $ "Unknown type constructor " ++ show name
- goSimple (UnknownDataConstructor dc tc) =
- line $ "Unknown data constructor " ++ show dc ++ foldMap ((" for type constructor " ++) . show) tc
- goSimple (UnknownImportType mn name) =
- line $ "Module " ++ show mn ++ " does not export type " ++ show name
- goSimple (UnknownExportType name) =
- line $ "Cannot export unknown type " ++ show name
- goSimple (UnknownImportTypeClass mn name) =
- line $ "Module " ++ show mn ++ " does not export type class " ++ show name
- goSimple (UnknownExportTypeClass name) =
- line $ "Cannot export unknown type class " ++ show name
- goSimple (UnknownImportValue mn name) =
- line $ "Module " ++ show mn ++ " does not export value " ++ show name
- goSimple (UnknownExportValue name) =
- line $ "Cannot export unknown value " ++ show name
- goSimple (UnknownExportModule name) =
- line $ "Cannot export unknown module " ++ show name ++ ", it either does not exist or has not been imported by the current module"
- goSimple (UnknownImportDataConstructor mn tcon dcon) =
- line $ "Module " ++ show mn ++ " does not export data constructor " ++ show dcon ++ " for type " ++ show tcon
- goSimple (UnknownExportDataConstructor tcon dcon) =
- line $ "Cannot export data constructor " ++ show dcon ++ " for type " ++ show tcon ++ " as it has not been declared"
- goSimple (ConflictingImport nm mn) =
- line $ "Cannot declare " ++ show nm ++ " since another declaration of that name was imported from " ++ show mn
- goSimple (ConflictingImports nm m1 m2) =
- line $ "Conflicting imports for " ++ nm ++ " from modules " ++ show m1 ++ " and " ++ show m2
- goSimple (ConflictingTypeDecls nm) =
- line $ "Conflicting type declarations for " ++ show nm
- goSimple (ConflictingCtorDecls nm) =
- line $ "Conflicting data constructor declarations for " ++ show nm
- goSimple (TypeConflictsWithClass nm) =
- line $ "Type " ++ show nm ++ " conflicts with type class declaration of the same name"
- goSimple (CtorConflictsWithClass nm) =
- line $ "Data constructor " ++ show nm ++ " conflicts with type class declaration of the same name"
- goSimple (ClassConflictsWithType nm) =
- line $ "Type class " ++ show nm ++ " conflicts with type declaration of the same name"
- goSimple (ClassConflictsWithCtor nm) =
- line $ "Type class " ++ show nm ++ " conflicts with data constructor declaration of the same name"
- goSimple (DuplicateClassExport nm) =
- line $ "Duplicate export declaration for type class " ++ show nm
- goSimple (DuplicateValueExport nm) =
- line $ "Duplicate export declaration for value " ++ show nm
- goSimple (CycleInDeclaration nm) =
- line $ "Cycle in declaration of " ++ show nm
- goSimple (CycleInModules mns) =
- line $ "Cycle in module dependencies: " ++ intercalate ", " (map show mns)
- goSimple (CycleInTypeSynonym pn) =
- line $ "Cycle in type synonym" ++ foldMap ((" " ++) . show) pn
- goSimple (NameIsUndefined ident) =
- line $ show ident ++ " is undefined"
- goSimple (NameNotInScope ident) =
- line $ show ident ++ " may not be defined in the current scope"
- goSimple (UndefinedTypeVariable name) =
- line $ "Type variable " ++ show name ++ " is undefined"
- goSimple (PartiallyAppliedSynonym name) =
- line $ "Partially applied type synonym " ++ show name
- goSimple (EscapedSkolem binding) =
- paras $ [ line "Rigid/skolem type variable has escaped." ]
+ renderSimpleErrorMessage (RedefinedModule name filenames) =
+ paras [ line ("Module " ++ runModuleName name ++ " has been defined multiple times:")
+ , indent . paras $ map (line . displaySourceSpan) filenames
+ ]
+ renderSimpleErrorMessage (RedefinedIdent name) =
+ line $ "Name " ++ showIdent name ++ " has been defined multiple times"
+ renderSimpleErrorMessage (UnknownModule mn) =
+ line $ "Unknown module " ++ runModuleName mn
+ renderSimpleErrorMessage (UnknownType name) =
+ line $ "Unknown type " ++ showQualified runProperName name
+ renderSimpleErrorMessage (UnknownTypeClass name) =
+ line $ "Unknown type class " ++ showQualified runProperName name
+ renderSimpleErrorMessage (UnknownValue name) =
+ line $ "Unknown value " ++ showQualified showIdent name
+ renderSimpleErrorMessage (UnknownTypeConstructor name) =
+ line $ "Unknown type constructor " ++ showQualified runProperName name
+ renderSimpleErrorMessage (UnknownDataConstructor dc tc) =
+ line $ "Unknown data constructor " ++ showQualified runProperName dc ++ foldMap ((" for type constructor " ++) . showQualified runProperName) tc
+ renderSimpleErrorMessage (UnknownImportType mn name) =
+ line $ "Module " ++ runModuleName mn ++ " does not export type " ++ runProperName name
+ renderSimpleErrorMessage (UnknownExportType name) =
+ line $ "Cannot export unknown type " ++ runProperName name
+ renderSimpleErrorMessage (UnknownImportTypeClass mn name) =
+ line $ "Module " ++ runModuleName mn ++ " does not export type class " ++ runProperName name
+ renderSimpleErrorMessage (UnknownExportTypeClass name) =
+ line $ "Cannot export unknown type class " ++ runProperName name
+ renderSimpleErrorMessage (UnknownImportValue mn name) =
+ line $ "Module " ++ runModuleName mn ++ " does not export value " ++ showIdent name
+ renderSimpleErrorMessage (UnknownExportValue name) =
+ line $ "Cannot export unknown value " ++ showIdent name
+ renderSimpleErrorMessage (UnknownExportModule name) =
+ line $ "Cannot export unknown module " ++ runModuleName name ++ ", it either does not exist or has not been imported by the current module"
+ renderSimpleErrorMessage (UnknownImportDataConstructor mn tcon dcon) =
+ line $ "Module " ++ runModuleName mn ++ " does not export data constructor " ++ runProperName dcon ++ " for type " ++ runProperName tcon
+ renderSimpleErrorMessage (UnknownExportDataConstructor tcon dcon) =
+ line $ "Cannot export data constructor " ++ runProperName dcon ++ " for type " ++ runProperName tcon ++ " as it has not been declared"
+ renderSimpleErrorMessage (ConflictingImport nm mn) =
+ line $ "Cannot declare " ++ show nm ++ " since another declaration of that name was imported from " ++ runModuleName mn
+ renderSimpleErrorMessage (ConflictingImports nm m1 m2) =
+ line $ "Conflicting imports for " ++ nm ++ " from modules " ++ runModuleName m1 ++ " and " ++ runModuleName m2
+ renderSimpleErrorMessage (ConflictingTypeDecls nm) =
+ line $ "Conflicting type declarations for " ++ runProperName nm
+ renderSimpleErrorMessage (ConflictingCtorDecls nm) =
+ line $ "Conflicting data constructor declarations for " ++ runProperName nm
+ renderSimpleErrorMessage (TypeConflictsWithClass nm) =
+ line $ "Type " ++ runProperName nm ++ " conflicts with type class declaration of the same name"
+ renderSimpleErrorMessage (CtorConflictsWithClass nm) =
+ line $ "Data constructor " ++ runProperName nm ++ " conflicts with type class declaration of the same name"
+ renderSimpleErrorMessage (ClassConflictsWithType nm) =
+ line $ "Type class " ++ runProperName nm ++ " conflicts with type declaration of the same name"
+ renderSimpleErrorMessage (ClassConflictsWithCtor nm) =
+ line $ "Type class " ++ runProperName nm ++ " conflicts with data constructor declaration of the same name"
+ renderSimpleErrorMessage (DuplicateModuleName mn) =
+ line $ "Module " ++ runModuleName mn ++ " has been defined multiple times."
+ renderSimpleErrorMessage (DuplicateClassExport nm) =
+ line $ "Duplicate export declaration for type class " ++ runProperName nm
+ renderSimpleErrorMessage (DuplicateValueExport nm) =
+ line $ "Duplicate export declaration for value " ++ showIdent nm
+ renderSimpleErrorMessage (CycleInDeclaration nm) =
+ line $ "Cycle in declaration of " ++ showIdent nm
+ renderSimpleErrorMessage (CycleInModules mns) =
+ line $ "Cycle in module dependencies: " ++ intercalate ", " (map runModuleName mns)
+ renderSimpleErrorMessage (CycleInTypeSynonym pn) =
+ line $ "Cycle in type synonym" ++ foldMap ((" " ++) . runProperName) pn
+ renderSimpleErrorMessage (NameIsUndefined ident) =
+ line $ showIdent ident ++ " is undefined"
+ renderSimpleErrorMessage (NameNotInScope ident) =
+ line $ showIdent ident ++ " may not be defined in the current scope"
+ renderSimpleErrorMessage (UndefinedTypeVariable name) =
+ line $ "Type variable " ++ runProperName name ++ " is undefined"
+ renderSimpleErrorMessage (PartiallyAppliedSynonym name) =
+ paras [ line $ "Partially applied type synonym " ++ showQualified runProperName name
+ , line "Type synonyms must be applied to all of their type arguments."
+ ]
+ renderSimpleErrorMessage (EscapedSkolem binding) =
+ paras $ [ line "A type variable has escaped its scope." ]
<> foldMap (\expr -> [ line "Relevant expression: "
- , indent $ line $ prettyPrintValue expr
+ , indent $ prettyPrintValue expr
]) binding
- goSimple (TypesDoNotUnify t1 t2)
+ renderSimpleErrorMessage (TypesDoNotUnify t1 t2)
= paras [ line "Cannot unify type"
- , indent $ line $ prettyPrintType t1
+ , indent $ typeAsBox t1
, line "with type"
- , indent $ line $ prettyPrintType t2
+ , indent $ typeAsBox t2
]
- goSimple (KindsDoNotUnify k1 k2) =
+ renderSimpleErrorMessage (KindsDoNotUnify k1 k2) =
paras [ line "Cannot unify kind"
, indent $ line $ prettyPrintKind k1
, line "with kind"
, indent $ line $ prettyPrintKind k2
]
- goSimple (ConstrainedTypeUnified t1 t2) =
+ renderSimpleErrorMessage (ConstrainedTypeUnified t1 t2) =
paras [ line "Cannot unify constrained type"
- , indent $ line $ prettyPrintType t1
+ , indent $ typeAsBox t1
, line "with type"
- , indent $ line $ prettyPrintType t2
- ]
- goSimple (OverlappingInstances nm ts (d : ds)) =
- paras [ line $ "Overlapping instances found for " ++ show nm ++ " " ++ unwords (map prettyPrintTypeAtom ts) ++ ":"
- , indent $ paras (line (show d ++ " (chosen)") : map (line . show) ds)
- ]
- goSimple OverlappingInstances{} = error "OverlappingInstances: empty instance list"
- goSimple (NoInstanceFound nm ts) =
- line $ "No instance found for " ++ show nm ++ " " ++ unwords (map prettyPrintTypeAtom ts)
- goSimple (PossiblyInfiniteInstance nm ts) =
- line $ "Instance for " ++ show nm ++ " " ++ unwords (map prettyPrintTypeAtom ts) ++ " is possibly infinite."
- goSimple (CannotDerive nm ts) =
- line $ "Cannot derive " ++ show nm ++ " instance for " ++ unwords (map prettyPrintTypeAtom ts)
- goSimple (CannotFindDerivingType nm) =
- line $ "Cannot derive instance, because the type declaration for " ++ show nm ++ " could not be found."
- goSimple (DuplicateLabel l expr) =
+ , indent $ typeAsBox t2
+ ]
+ renderSimpleErrorMessage (OverlappingInstances nm ts (d : ds)) =
+ paras [ line "Overlapping instances found for"
+ , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm)
+ , Box.vcat Box.left (map typeAtomAsBox ts)
+ ]
+ , line "The following instances were found:"
+ , indent $ paras (line (showQualified showIdent d ++ " (chosen)") : map (line . showQualified showIdent) ds)
+ ]
+ renderSimpleErrorMessage OverlappingInstances{} = error "OverlappingInstances: empty instance list"
+ renderSimpleErrorMessage (NoInstanceFound nm ts) =
+ paras [ line "No instance found for"
+ , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm)
+ , Box.vcat Box.left (map typeAtomAsBox ts)
+ ]
+ ]
+ renderSimpleErrorMessage (PossiblyInfiniteInstance nm ts) =
+ paras [ line "Instance for"
+ , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm)
+ , Box.vcat Box.left (map typeAtomAsBox ts)
+ ]
+ , line "is possibly infinite."
+ ]
+ renderSimpleErrorMessage (CannotDerive nm ts) =
+ paras [ line "Cannot derive an instance for"
+ , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm)
+ , Box.vcat Box.left (map typeAtomAsBox ts)
+ ]
+ ]
+ renderSimpleErrorMessage (CannotFindDerivingType nm) =
+ line $ "Cannot derive instance, because the type declaration for " ++ runProperName nm ++ " could not be found."
+ renderSimpleErrorMessage (DuplicateLabel l expr) =
paras $ [ line $ "Duplicate label " ++ show l ++ " in row." ]
<> foldMap (\expr' -> [ line "Relevant expression: "
- , indent $ line $ prettyPrintValue expr'
+ , indent $ prettyPrintValue expr'
]) expr
- goSimple (DuplicateTypeArgument name) =
+ renderSimpleErrorMessage (DuplicateTypeArgument name) =
line $ "Duplicate type argument " ++ show name
- goSimple (DuplicateValueDeclaration nm) =
- line $ "Duplicate value declaration for " ++ show nm
- goSimple (ArgListLengthsDiffer ident) =
- line $ "Argument list lengths differ in declaration " ++ show ident
- goSimple (OverlappingArgNames ident) =
- line $ "Overlapping names in function/binder" ++ foldMap ((" in declaration" ++) . show) ident
- goSimple (MissingClassMember ident) =
- line $ "Member " ++ show ident ++ " has not been implemented"
- goSimple (ExtraneousClassMember ident) =
- line $ "Member " ++ show ident ++ " is not a member of the class being instantiated"
- goSimple (ExpectedType kind) =
- line $ "Expected type of kind *, was " ++ prettyPrintKind kind
- goSimple (IncorrectConstructorArity nm) =
- line $ "Wrong number of arguments to constructor " ++ show nm
- goSimple SubsumptionCheckFailed = line $ "Unable to check type subsumption"
- goSimple (ExprDoesNotHaveType expr ty) =
+ renderSimpleErrorMessage (DuplicateValueDeclaration nm) =
+ line $ "Duplicate value declaration for " ++ showIdent nm
+ renderSimpleErrorMessage (ArgListLengthsDiffer ident) =
+ line $ "Argument list lengths differ in declaration " ++ showIdent ident
+ renderSimpleErrorMessage (OverlappingArgNames ident) =
+ line $ "Overlapping names in function/binder" ++ foldMap ((" in declaration" ++) . showIdent) ident
+ renderSimpleErrorMessage (MissingClassMember ident) =
+ line $ "Member " ++ showIdent ident ++ " has not been implemented"
+ renderSimpleErrorMessage (ExtraneousClassMember ident) =
+ line $ "Member " ++ showIdent ident ++ " is not a member of the class being instantiated"
+ renderSimpleErrorMessage (ExpectedType ty kind) =
+ paras [ line "In a type-annotated expression x :: t, the type t must have kind *."
+ , line "The error arises from the type"
+ , indent $ typeAsBox ty
+ , line "having the kind"
+ , indent $ line $ prettyPrintKind kind
+ , line "instead."
+ ]
+ renderSimpleErrorMessage (IncorrectConstructorArity nm) =
+ line $ "Wrong number of arguments to constructor " ++ showQualified runProperName nm
+ renderSimpleErrorMessage SubsumptionCheckFailed = line "Unable to check type subsumption"
+ renderSimpleErrorMessage (ExprDoesNotHaveType expr ty) =
paras [ line "Expression"
- , indent $ line $ prettyPrintValue expr
+ , indent $ prettyPrintValue expr
, line "does not have type"
- , indent $ line $ prettyPrintType ty
+ , indent $ typeAsBox ty
]
- goSimple (PropertyIsMissing prop row) =
- line $ "Row " ++ prettyPrintRow row ++ " lacks required property " ++ show prop
- goSimple (CannotApplyFunction fn arg) =
+ renderSimpleErrorMessage (PropertyIsMissing prop row) =
+ paras [ line "Row"
+ , indent $ prettyPrintRowWith '(' ')' row
+ , line $ "lacks required property " ++ show prop
+ ]
+ renderSimpleErrorMessage (CannotApplyFunction fn arg) =
paras [ line "Cannot apply function of type"
- , indent $ line $ prettyPrintType fn
+ , indent $ typeAsBox fn
, line "to argument"
- , indent $ line $ prettyPrintValue arg
+ , indent $ prettyPrintValue arg
]
- goSimple TypeSynonymInstance =
+ renderSimpleErrorMessage TypeSynonymInstance =
line "Type synonym instances are disallowed"
- goSimple (OrphanInstance nm cnm ts) =
- line $ "Instance " ++ show nm ++ " for " ++ show cnm ++ " " ++ unwords (map prettyPrintTypeAtom ts) ++ " is an orphan instance"
- goSimple InvalidNewtype =
+ renderSimpleErrorMessage (OrphanInstance nm cnm ts) =
+ paras [ line $ "Instance " ++ showIdent nm ++ " for "
+ , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName cnm)
+ , Box.vcat Box.left (map typeAtomAsBox ts)
+ ]
+ , line "is an orphan instance."
+ , line "An orphan instance is an instance which is defined in neither the class module nor the data type module."
+ , line "Consider moving the instance, if possible, or using a newtype wrapper."
+ ]
+ renderSimpleErrorMessage InvalidNewtype =
line "Newtypes must define a single constructor with a single argument"
- goSimple (InvalidInstanceHead ty) =
+ renderSimpleErrorMessage (InvalidInstanceHead ty) =
paras [ line "Invalid type in class instance head:"
- , indent $ line $ prettyPrintType ty
+ , indent $ typeAsBox ty
]
- goSimple (TransitiveExportError x ys) =
- paras $ (line $ "An export for " ++ prettyPrintExport x ++ " requires the following to also be exported: ")
+ renderSimpleErrorMessage (TransitiveExportError x ys) =
+ paras $ line ("An export for " ++ prettyPrintExport x ++ " requires the following to also be exported: ")
: map (line . prettyPrintExport) ys
- goSimple (ShadowedName nm) =
- line $ "Name '" ++ show nm ++ "' was shadowed."
- goSimple (ClassOperator className opName) =
- paras [ line $ "Class '" ++ show className ++ "' declares operator " ++ show opName ++ "."
- , indent $ line $ "This may be disallowed in the future - consider declaring a named member in the class and making the operator an alias:"
- , indent $ line $ show opName ++ " = someMember"
- ]
- goSimple (MisleadingEmptyTypeImport mn name) =
- line $ "Importing type " ++ show name ++ "(..) from " ++ show mn ++ " is misleading as it has no exported data constructors"
- goSimple (ImportHidingModule name) =
- line $ "Attempted to hide module " ++ show name ++ " in import expression, this is not permitted"
- goSimple (WildcardInferredType ty) =
- line $ "The wildcard type definition has the inferred type " ++ prettyPrintType ty
- goSimple (NotExhaustivePattern bs b) =
- indent $ paras $ [ line "Pattern could not be determined to cover all cases."
- , line $ "The definition has the following uncovered cases:\n"
+ renderSimpleErrorMessage (ShadowedName nm) =
+ line $ "Name '" ++ showIdent nm ++ "' was shadowed"
+ renderSimpleErrorMessage (ShadowedTypeVar tv) =
+ line $ "Type variable '" ++ tv ++ "' was shadowed"
+ renderSimpleErrorMessage (UnusedTypeVar tv) =
+ line $ "Type variable '" ++ tv ++ "' was declared but not used"
+ renderSimpleErrorMessage (ClassOperator className opName) =
+ paras [ line $ "Class '" ++ runProperName className ++ "' declares operator " ++ showIdent opName ++ "."
+ , line "This may be disallowed in the future - consider declaring a named member in the class and making the operator an alias:"
+ , indent . line $ showIdent opName ++ " = someMember"
+ ]
+ renderSimpleErrorMessage (MisleadingEmptyTypeImport mn name) =
+ line $ "Importing type " ++ runProperName name ++ "(..) from " ++ runModuleName mn ++ " is misleading as it has no exported data constructors"
+ renderSimpleErrorMessage (ImportHidingModule name) =
+ line $ "Attempted to hide module " ++ runModuleName name ++ " in import expression, this is not permitted"
+ renderSimpleErrorMessage (WildcardInferredType ty) =
+ paras [ line "The wildcard type definition has the inferred type "
+ , indent $ typeAsBox ty
+ ]
+ renderSimpleErrorMessage (MissingTypeDeclaration ident) =
+ paras [ line $ "No type declaration was provided for the top-level declaration of " ++ showIdent ident ++ "."
+ , line "It is good practice to provide type declarations as a form of documentation."
+ , line "Consider using a type wildcard to display the inferred type:"
+ , indent $ line $ showIdent ident ++ " :: _"
+ ]
+ renderSimpleErrorMessage (NotExhaustivePattern bs b) =
+ paras $ [ line "A case expression could not be determined to cover all inputs."
+ , line "The following additional cases are required to cover all inputs:\n"
, Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs))
- ] ++ if not b then [line "..."] else []
- goSimple (OverlappingPattern bs b) =
- indent $ paras $ [ line "Redundant cases have been detected."
- , line $ "The definition has the following redundant cases:\n"
+ ] ++
+ [ line "..." | not b ]
+ renderSimpleErrorMessage (OverlappingPattern bs b) =
+ paras $ [ line "A case expression contains unreachable cases:\n"
, Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs))
- ] ++ if not b then [line "..."] else []
- go (NotYetDefined names err) =
- paras [ line $ "The following are not yet defined here: " ++ intercalate ", " (map show names) ++ ":"
- , indent $ go err
+ ] ++
+ [ line "..." | not b ]
+ renderSimpleErrorMessage IncompleteExhaustivityCheck =
+ paras [ line "An exhaustivity check was abandoned due to too many possible cases."
+ , line "You may want to decomposing your data types into smaller types."
]
- go (ErrorUnifyingTypes t1 t2 err) =
+
+ renderHint :: ErrorMessageHint -> Box.Box
+ renderHint (NotYetDefined names) =
+ line $ "The following are not yet defined here: " ++ intercalate ", " (map showIdent names) ++ ":"
+ renderHint (ErrorUnifyingTypes t1 t2) =
paras [ lineWithLevel "unifying type "
- , indent $ line $ prettyPrintType t1
+ , indent $ typeAsBox t1
, line "with type"
- , indent $ line $ prettyPrintType t2
- , go err
+ , indent $ typeAsBox t2
]
- go (ErrorInExpression expr err) =
+ renderHint (ErrorInExpression expr) =
paras [ lineWithLevel "in expression:"
- , indent $ line $ prettyPrintValue expr
- , go err
+ , indent $ prettyPrintValue expr
]
- go (ErrorInModule mn err) =
- paras [ lineWithLevel $ "in module " ++ show mn ++ ":"
- , go err
+ renderHint (ErrorInModule mn) =
+ paras [ lineWithLevel $ "in module " ++ runModuleName mn ++ ":"
]
- go (ErrorInSubsumption t1 t2 err) =
+ renderHint (ErrorInSubsumption t1 t2) =
paras [ lineWithLevel "checking that type "
- , indent $ line $ prettyPrintType t1
+ , indent $ typeAsBox t1
, line "subsumes type"
- , indent $ line $ prettyPrintType t2
- , go err
+ , indent $ typeAsBox t2
]
- go (ErrorInInstance name ts err) =
- paras [ lineWithLevel $ "in type class instance " ++ show name ++ " " ++ unwords (map prettyPrintTypeAtom ts) ++ ":"
- , go err
+ renderHint (ErrorInInstance nm ts) =
+ paras [ lineWithLevel "in type class instance"
+ , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm)
+ , Box.vcat Box.left (map typeAtomAsBox ts)
+ ]
]
- go (ErrorCheckingKind ty err) =
+ renderHint (ErrorCheckingKind ty) =
paras [ lineWithLevel "checking kind of type "
- , indent $ line $ prettyPrintType ty
- , go err
+ , indent $ typeAsBox ty
]
- go (ErrorInferringType expr err) =
+ renderHint (ErrorInferringType expr) =
paras [ lineWithLevel "inferring type of value "
- , indent $ line $ prettyPrintValue expr
- , go err
+ , indent $ prettyPrintValue expr
]
- go (ErrorCheckingType expr ty err) =
+ renderHint (ErrorCheckingType expr ty) =
paras [ lineWithLevel "checking that value "
- , indent $ line $ prettyPrintValue expr
+ , indent $ prettyPrintValue expr
, line "has type"
- , indent $ line $ prettyPrintType ty
- , go err
+ , indent $ typeAsBox ty
]
- go (ErrorInApplication f t a err) =
+ renderHint (ErrorInApplication f t a) =
paras [ lineWithLevel "applying function"
- , indent $ line $ prettyPrintValue f
+ , indent $ prettyPrintValue f
, line "of type"
- , indent $ line $ prettyPrintType t
+ , indent $ typeAsBox t
, line "to argument"
- , indent $ line $ prettyPrintValue a
- , go err
- ]
- go (ErrorInDataConstructor nm err) =
- paras [ lineWithLevel $ "in data constructor " ++ show nm ++ ":"
- , go err
- ]
- go (ErrorInTypeConstructor nm err) =
- paras [ lineWithLevel $ "in type constructor " ++ show nm ++ ":"
- , go err
- ]
- go (ErrorInBindingGroup nms err) =
- paras [ lineWithLevel $ "in binding group " ++ intercalate ", " (map show nms) ++ ":"
- , go err
- ]
- go (ErrorInDataBindingGroup err) =
- paras [ lineWithLevel $ "in data binding group:"
- , go err
- ]
- go (ErrorInTypeSynonym name err) =
- paras [ lineWithLevel $ "in type synonym " ++ show name ++ ":"
- , go err
- ]
- go (ErrorInValueDeclaration n err) =
- paras [ lineWithLevel $ "in value declaration " ++ show n ++ ":"
- , go err
- ]
- go (ErrorInForeignImport nm err) =
- paras [ lineWithLevel $ "in foreign import " ++ show nm ++ ":"
- , go err
- ]
- go (PositionedError srcSpan err) =
- paras [ lineWithLevel $ "at " ++ displaySourceSpan srcSpan ++ ":"
- , indent $ go err
- ]
- go (SimpleErrorWrapper sem) = goSimple sem
+ , indent $ prettyPrintValue a
+ ]
+ renderHint (ErrorInDataConstructor nm) =
+ lineWithLevel $ "in data constructor " ++ runProperName nm ++ ":"
+ renderHint (ErrorInTypeConstructor nm) =
+ lineWithLevel $ "in type constructor " ++ runProperName nm ++ ":"
+ renderHint (ErrorInBindingGroup nms) =
+ lineWithLevel $ "in binding group " ++ intercalate ", " (map showIdent nms) ++ ":"
+ renderHint ErrorInDataBindingGroup =
+ lineWithLevel "in data binding group:"
+ renderHint (ErrorInTypeSynonym name) =
+ lineWithLevel $ "in type synonym " ++ runProperName name ++ ":"
+ renderHint (ErrorInValueDeclaration n) =
+ lineWithLevel $ "in value declaration " ++ showIdent n ++ ":"
+ renderHint (ErrorInTypeDeclaration n) =
+ lineWithLevel $ "in type declaration for " ++ showIdent n ++ ":"
+ renderHint (ErrorInForeignImport nm) =
+ lineWithLevel $ "in foreign import " ++ showIdent nm ++ ":"
+ renderHint (PositionedError srcSpan) =
+ lineWithLevel $ "at " ++ displaySourceSpan srcSpan ++ ":"
lineWithLevel :: String -> Box.Box
lineWithLevel text = line $ show level ++ " " ++ text
@@ -742,62 +765,65 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError
Error -> "error"
Warning -> "warning"
- suggestions :: ErrorMessage -> [Box.Box]
- suggestions = suggestions' . unwrapErrorMessage
- where
- suggestions' (ConflictingImport nm im) = [ line $ "Possible fix: hide " ++ show nm ++ " when importing " ++ show im ++ ":"
- , indent . line $ "import " ++ show im ++ " hiding (" ++ nm ++ ")"
+ suggestions :: SimpleErrorMessage -> [Box.Box]
+ suggestions (ConflictingImport nm im) = [ line $ "Possible fix: hide " ++ show nm ++ " when importing " ++ runModuleName im ++ ":"
+ , indent . line $ "import " ++ runModuleName im ++ " hiding (" ++ nm ++ ")"
]
- suggestions' (TypesDoNotUnify t1 t2)
- | isObject t1 && isFunction t2 = [line "Note that function composition in PureScript is defined using (<<<)"]
- | otherwise = []
- suggestions' _ = []
+ suggestions (TypesDoNotUnify t1 t2)
+ | isObject t1 && isFunction t2 = [line "Note that function composition in PureScript is defined using (<<<)"]
+ | otherwise = []
+ suggestions _ = []
paras :: [Box.Box] -> Box.Box
paras = Box.vcat Box.left
- -- |
-- Pretty print and export declaration
- --
prettyPrintExport :: DeclarationRef -> String
- prettyPrintExport (TypeRef pn _) = show pn
- prettyPrintExport (ValueRef ident) = show ident
- prettyPrintExport (TypeClassRef pn) = show pn
- prettyPrintExport (TypeInstanceRef ident) = show ident
- prettyPrintExport (ModuleRef name) = "module " ++ show name
+ prettyPrintExport (TypeRef pn _) = runProperName pn
+ prettyPrintExport (ValueRef ident) = showIdent ident
+ prettyPrintExport (TypeClassRef pn) = runProperName pn
+ prettyPrintExport (TypeInstanceRef ident) = showIdent ident
+ prettyPrintExport (ModuleRef name) = "module " ++ runModuleName name
prettyPrintExport (PositionedDeclarationRef _ _ ref) = prettyPrintExport ref
- -- |
- -- Simplify an error message
- --
- simplifyErrorMessage :: ErrorMessage -> ErrorMessage
- simplifyErrorMessage = unwrap Nothing
+ -- Hints get added at the front, so we need to reverse them before rendering
+ reverseHints :: ErrorMessage -> ErrorMessage
+ reverseHints (ErrorMessage hints simple) = ErrorMessage (reverse hints) simple
+
+ -- | Put positional hints at the front of the list
+ positionHintsFirst :: ErrorMessage -> ErrorMessage
+ positionHintsFirst (ErrorMessage hints simple) = ErrorMessage (uncurry (++) $ partition (isPositionHint . hintCategory) hints) simple
where
- unwrap :: Maybe SourceSpan -> ErrorMessage -> ErrorMessage
- unwrap pos (ErrorInExpression _ err) = unwrap pos err
- unwrap pos (ErrorInInstance name ts err) = ErrorInInstance name ts (unwrap pos err)
- unwrap pos (ErrorInSubsumption t1 t2 err) = ErrorInSubsumption t1 t2 (unwrap pos err)
- unwrap pos (ErrorUnifyingTypes _ _ err) = unwrap pos err
- unwrap pos (ErrorInferringType _ err) = unwrap pos err
- unwrap pos (ErrorCheckingType _ _ err) = unwrap pos err
- unwrap pos (ErrorCheckingKind ty err) = ErrorCheckingKind ty (unwrap pos err)
- unwrap pos (ErrorInModule mn err) = ErrorInModule mn (unwrap pos err)
- unwrap pos (ErrorInApplication _ _ _ err) = unwrap pos err
- unwrap pos (ErrorInDataConstructor nm err) = ErrorInDataConstructor nm (unwrap pos err)
- unwrap pos (ErrorInTypeConstructor nm err) = ErrorInTypeConstructor nm (unwrap pos err)
- unwrap pos (ErrorInBindingGroup nms err) = ErrorInBindingGroup nms (unwrap pos err)
- unwrap pos (ErrorInDataBindingGroup err) = ErrorInDataBindingGroup (unwrap pos err)
- unwrap pos (ErrorInTypeSynonym nm err) = ErrorInTypeSynonym nm (unwrap pos err)
- unwrap pos (ErrorInValueDeclaration nm err) = ErrorInValueDeclaration nm (unwrap pos err)
- unwrap pos (ErrorInForeignImport nm err) = ErrorInForeignImport nm (unwrap pos err)
- unwrap pos (NotYetDefined ns err) = NotYetDefined ns (unwrap pos err)
- unwrap _ (PositionedError pos err) = unwrap (Just pos) err
- unwrap pos other = wrap pos other
-
- wrap :: Maybe SourceSpan -> ErrorMessage -> ErrorMessage
- wrap Nothing = id
- wrap (Just pos) = PositionedError pos
+ isPositionHint :: HintCategory -> Bool
+ isPositionHint PositionHint = True
+ isPositionHint OtherHint = True
+ isPositionHint _ = False
+ -- | Simplify an error message
+ simplifyErrorMessage :: ErrorMessage -> ErrorMessage
+ simplifyErrorMessage (ErrorMessage hints simple) = ErrorMessage (simplifyHints hints) simple
+ where
+ -- Take the last instance of each "hint category"
+ simplifyHints :: [ErrorMessageHint] -> [ErrorMessageHint]
+ simplifyHints = reverse . nubBy categoriesEqual . reverse
+
+ -- Don't remove hints in the "other" category
+ categoriesEqual :: ErrorMessageHint -> ErrorMessageHint -> Bool
+ categoriesEqual x y =
+ case (hintCategory x, hintCategory y) of
+ (OtherHint, _) -> False
+ (_, OtherHint) -> False
+ (c1, c2) -> c1 == c2
+
+ hintCategory :: ErrorMessageHint -> HintCategory
+ hintCategory ErrorCheckingType{} = ExprHint
+ hintCategory ErrorInferringType{} = ExprHint
+ hintCategory ErrorInExpression{} = ExprHint
+ hintCategory ErrorUnifyingTypes{} = CheckHint
+ hintCategory ErrorInSubsumption{} = CheckHint
+ hintCategory ErrorInApplication{} = CheckHint
+ hintCategory PositionedError{} = PositionHint
+ hintCategory _ = OtherHint
-- |
-- Pretty print multiple errors
@@ -813,11 +839,11 @@ prettyPrintMultipleWarnings full = renderBox . prettyPrintMultipleWarningsBox fu
-- | Pretty print warnings as a Box
prettyPrintMultipleWarningsBox :: Bool -> MultipleErrors -> Box.Box
-prettyPrintMultipleWarningsBox full = flip evalState M.empty . prettyPrintMultipleErrorsWith Warning "Warning found:" "Multiple warnings found:" full
+prettyPrintMultipleWarningsBox full = flip evalState M.empty . prettyPrintMultipleErrorsWith Warning "Warning found:" "Warning" full
-- | Pretty print errors as a Box
prettyPrintMultipleErrorsBox :: Bool -> MultipleErrors -> Box.Box
-prettyPrintMultipleErrorsBox full = flip evalState M.empty . prettyPrintMultipleErrorsWith Error "Error found:" "Multiple errors found:" full
+prettyPrintMultipleErrorsBox full = flip evalState M.empty . prettyPrintMultipleErrorsWith Error "Error found:" "Error" full
prettyPrintMultipleErrorsWith :: Level -> String -> String -> Bool -> MultipleErrors -> State UnknownMap Box.Box
prettyPrintMultipleErrorsWith level intro _ full (MultipleErrors [e]) = do
@@ -827,15 +853,16 @@ prettyPrintMultipleErrorsWith level intro _ full (MultipleErrors [e]) = do
, result
]
prettyPrintMultipleErrorsWith level _ intro full (MultipleErrors es) = do
- result <- forM es $ (liftM $ Box.moveRight 2) . prettyPrintSingleError full level
- return $
- Box.vcat Box.left [ Box.text intro
- , Box.vsep 1 Box.left result
- ]
+ result <- forM es $ prettyPrintSingleError full level
+ return $ Box.vsep 1 Box.left $ concat $ zipWith withIntro [1 :: Int ..] result
+ where
+ withIntro i err = [ Box.text (intro ++ " " ++ show i ++ " of " ++ show (length es) ++ ":")
+ , Box.moveRight 2 err
+ ]
-- | Pretty print a Parsec ParseError as a Box
prettyPrintParseError :: P.ParseError -> Box.Box
-prettyPrintParseError = (prettyPrintParseErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input") . PE.errorMessages
+prettyPrintParseError = prettyPrintParseErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" . PE.errorMessages
-- |
-- Pretty print ParseError detail messages.
@@ -848,9 +875,9 @@ prettyPrintParseErrorMessages msgOr msgUnknown msgExpecting msgUnExpected msgEnd
| otherwise = Box.vcat Box.left $ map Box.text $ clean [showSysUnExpect,showUnExpect,showExpect,showMessages]
where
- (sysUnExpect,msgs1) = span ((SysUnExpect "") ==) msgs
- (unExpect,msgs2) = span ((UnExpect "") ==) msgs1
- (expect,messages) = span ((Expect "") ==) msgs2
+ (sysUnExpect,msgs1) = span (SysUnExpect "" ==) msgs
+ (unExpect,msgs2) = span (UnExpect "" ==) msgs1
+ (expect,messages) = span (Expect "" ==) msgs2
showExpect = showMany msgExpecting expect
showUnExpect = showMany msgUnExpected unExpect
@@ -881,8 +908,9 @@ prettyPrintParseErrorMessages msgOr msgUnknown msgExpecting msgUnExpected msgEnd
clean = nub . filter (not . null)
+-- | Indent to the right, and pad on top and bottom.
indent :: Box.Box -> Box.Box
-indent = Box.moveRight 2
+indent = Box.moveUp 1 . Box.moveDown 1 . Box.moveRight 2
line :: String -> Box.Box
line = Box.text
@@ -898,7 +926,7 @@ renderBox = unlines . map trimEnd . lines . Box.render
interpretMultipleErrorsAndWarnings :: (MonadError MultipleErrors m, MonadWriter MultipleErrors m) => (Either MultipleErrors a, MultipleErrors) -> m a
interpretMultipleErrorsAndWarnings (err, ws) = do
tell ws
- either throwError return $ err
+ either throwError return err
-- |
-- Rethrow an error with a more detailed error message in the case of failure
@@ -922,8 +950,7 @@ warnAndRethrowWithPosition :: (MonadError MultipleErrors m, MonadWriter Multiple
warnAndRethrowWithPosition pos = rethrowWithPosition pos . warnWithPosition pos
withPosition :: SourceSpan -> ErrorMessage -> ErrorMessage
-withPosition _ (PositionedError pos err) = withPosition pos err
-withPosition pos err = PositionedError pos err
+withPosition pos (ErrorMessage hints se) = ErrorMessage (PositionedError pos : hints) se
-- |
-- Collect errors in in parallel
diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs
new file mode 100644
index 0000000..6a608da
--- /dev/null
+++ b/src/Language/PureScript/Externs.hs
@@ -0,0 +1,216 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Language.PureScript.Externs
+-- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
+-- License : MIT (http://opensource.org/licenses/MIT)
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+-- This module generates code for \"externs\" files, i.e. files containing only foreign import declarations.
+--
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Language.PureScript.Externs
+ ( ExternsFile(..)
+ , ExternsImport(..)
+ , ExternsFixity(..)
+ , ExternsDeclaration(..)
+ , moduleToExternsFile
+ , applyExternsFileToEnvironment
+ ) where
+
+import Data.List (find, foldl')
+import Data.Maybe (mapMaybe, maybeToList, fromMaybe)
+import Data.Foldable (fold)
+import Data.Version (showVersion)
+#if __GLASGOW_HASKELL__ < 710
+import Data.Monoid
+#endif
+import Data.Aeson.TH
+
+import qualified Data.Map as M
+
+import Language.PureScript.AST
+import Language.PureScript.Environment
+import Language.PureScript.Names
+import Language.PureScript.Types
+import Language.PureScript.Kinds
+import Language.PureScript.TypeClassDictionaries
+
+import Paths_purescript as Paths
+
+-- | The data which will be serialized to an externs file
+data ExternsFile = ExternsFile
+ {
+ -- ^ The externs version
+ efVersion :: String
+ -- ^ Module name
+ , efModuleName :: ModuleName
+ -- ^ List of module exports
+ , efExports :: [DeclarationRef]
+ -- ^ List of module imports
+ , efImports :: [ExternsImport]
+ -- ^ List of operators and their fixities
+ , efFixities :: [ExternsFixity]
+ -- ^ List of type and value declaration
+ , efDeclarations :: [ExternsDeclaration]
+ } deriving (Show, Read)
+
+-- | A module import in an externs file
+data ExternsImport = ExternsImport
+ {
+ -- ^ The imported module
+ eiModule :: ModuleName
+ -- ^ The import type: regular, qualified or hiding
+ , eiImportType :: ImportDeclarationType
+ -- ^ The imported-as name, for qualified imports
+ , eiImportedAs :: Maybe ModuleName
+ } deriving (Show, Read)
+
+-- | A fixity declaration in an externs file
+data ExternsFixity = ExternsFixity
+ {
+ -- ^ The associativity of the operator
+ efAssociativity :: Associativity
+ -- ^ The precedence level of the operator
+ , efPrecedence :: Precedence
+ -- ^ The operator symbol
+ , efOperator :: String
+ } deriving (Show, Read)
+
+-- | A type or value declaration appearing in an externs file
+data ExternsDeclaration =
+ -- ^ A type declaration
+ EDType
+ { edTypeName :: ProperName
+ , edTypeKind :: Kind
+ , edTypeDeclarationKind :: TypeKind
+ }
+ -- ^ A type synonym
+ | EDTypeSynonym
+ { edTypeSynonymName :: ProperName
+ , edTypeSynonymArguments :: [(String, Maybe Kind)]
+ , edTypeSynonymType :: Type
+ }
+ -- ^ A data construtor
+ | EDDataConstructor
+ { edDataCtorName :: ProperName
+ , edDataCtorOrigin :: DataDeclType
+ , edDataCtorTypeCtor :: ProperName
+ , edDataCtorType :: Type
+ , edDataCtorFields :: [Ident]
+ }
+ -- ^ A value declaration
+ | EDValue
+ { edValueName :: Ident
+ , edValueType :: Type
+ }
+ -- ^ A type class declaration
+ | EDClass
+ { edClassName :: ProperName
+ , edClassTypeArguments :: [(String, Maybe Kind)]
+ , edClassMembers :: [(Ident, Type)]
+ , edClassConstraints :: [Constraint]
+ }
+ -- ^ An instance declaration
+ | EDInstance
+ { edInstanceClassName :: Qualified ProperName
+ , edInstanceName :: Ident
+ , edInstanceTypes :: [Type]
+ , edInstanceConstraints :: Maybe [Constraint]
+ }
+ deriving (Show, Read)
+
+-- | Convert an externs file back into a module
+applyExternsFileToEnvironment :: ExternsFile -> Environment -> Environment
+applyExternsFileToEnvironment ExternsFile{..} = flip (foldl' applyDecl) efDeclarations
+ where
+ applyDecl :: Environment -> ExternsDeclaration -> Environment
+ applyDecl env (EDType pn kind tyKind) = env { types = M.insert (qual pn) (kind, tyKind) (types env) }
+ applyDecl env (EDTypeSynonym pn args ty) = env { typeSynonyms = M.insert (qual pn) (args, ty) (typeSynonyms env) }
+ applyDecl env (EDDataConstructor pn dTy tNm ty nms) = env { dataConstructors = M.insert (qual pn) (dTy, tNm, ty, nms) (dataConstructors env) }
+ applyDecl env (EDValue ident ty) = env { names = M.insert (efModuleName, ident) (ty, External, Defined) (names env) }
+ applyDecl env (EDClass pn args members cs) = env { typeClasses = M.insert (qual pn) (args, members, cs) (typeClasses env) }
+ applyDecl env (EDInstance className ident tys cs) = env { typeClassDictionaries = updateMap (updateMap (M.insert (qual ident) dict) className) (Just efModuleName) (typeClassDictionaries env) }
+ where
+ dict :: TypeClassDictionaryInScope
+ dict = TypeClassDictionaryInScope (qual ident) [] className tys cs
+
+ updateMap :: (Ord k, Monoid a) => (a -> a) -> k -> M.Map k a -> M.Map k a
+ updateMap f = M.alter (Just . f . fold)
+
+ qual :: a -> Qualified a
+ qual = Qualified (Just efModuleName)
+
+-- | Generate an externs file for all declarations in a module
+moduleToExternsFile :: Module -> Environment -> ExternsFile
+moduleToExternsFile (Module _ _ _ _ Nothing) _ = error "moduleToExternsFile: module exports were not elaborated"
+moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..}
+ where
+ efVersion = showVersion Paths.version
+ efModuleName = mn
+ efExports = exps
+ efImports = mapMaybe importDecl ds
+ efFixities = mapMaybe fixityDecl ds
+ efDeclarations = concatMap toExternsDeclaration efExports
+
+ fixityDecl :: Declaration -> Maybe ExternsFixity
+ fixityDecl (FixityDeclaration (Fixity assoc prec) op) = fmap (const (ExternsFixity assoc prec op)) (find exportsOp exps)
+ where
+ exportsOp :: DeclarationRef -> Bool
+ exportsOp (PositionedDeclarationRef _ _ r) = exportsOp r
+ exportsOp (ValueRef ident') = ident' == Op op
+ exportsOp _ = False
+ fixityDecl (PositionedDeclaration _ _ d) = fixityDecl d
+ fixityDecl _ = Nothing
+
+ importDecl :: Declaration -> Maybe ExternsImport
+ importDecl (ImportDeclaration m mt qmn) = Just (ExternsImport m mt qmn)
+ importDecl (PositionedDeclaration _ _ d) = importDecl d
+ importDecl _ = Nothing
+
+ toExternsDeclaration :: DeclarationRef -> [ExternsDeclaration]
+ toExternsDeclaration (PositionedDeclarationRef _ _ r) = toExternsDeclaration r
+ toExternsDeclaration (TypeRef pn dctors) =
+ case Qualified (Just mn) pn `M.lookup` types env of
+ Nothing -> error "toExternsDeclaration: no kind in toExternsDeclaration"
+ Just (kind, TypeSynonym)
+ | Just (args, synTy) <- Qualified (Just mn) pn `M.lookup` typeSynonyms env -> [ EDType pn kind TypeSynonym, EDTypeSynonym pn args synTy ]
+ Just (kind, ExternData) -> [ EDType pn kind ExternData ]
+ Just (kind, tk@(DataType _ tys)) ->
+ EDType pn kind tk : [ EDDataConstructor dctor dty pn ty args
+ | dctor <- fromMaybe (map fst tys) dctors
+ , (dty, _, ty, args) <- maybeToList (M.lookup (Qualified (Just mn) dctor) (dataConstructors env))
+ ]
+ _ -> error "toExternsDeclaration: Invalid input"
+ toExternsDeclaration (ValueRef ident)
+ | Just (ty, _, _) <- (mn, ident) `M.lookup` names env
+ = [ EDValue ident ty ]
+ toExternsDeclaration (TypeClassRef className)
+ | Just (args, members, implies) <- Qualified (Just mn) className `M.lookup` typeClasses env
+ , Just (kind, TypeSynonym) <- M.lookup (Qualified (Just mn) className) (types env)
+ , Just (_, synTy) <- Qualified (Just mn) className `M.lookup` typeSynonyms env
+ = [ EDType className kind TypeSynonym
+ , EDTypeSynonym className args synTy
+ , EDClass className args members implies
+ ]
+ toExternsDeclaration (TypeInstanceRef ident)
+ = [ EDInstance tcdClassName ident tcdInstanceTypes tcdDependencies
+ | m1 <- maybeToList (M.lookup (Just mn) (typeClassDictionaries env))
+ , m2 <- M.elems m1
+ , TypeClassDictionaryInScope{..} <- maybeToList (M.lookup (Qualified (Just mn) ident) m2)
+ ]
+ toExternsDeclaration _ = []
+
+$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsImport)
+$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsFixity)
+$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsDeclaration)
+$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsFile)
diff --git a/src/Language/PureScript/Kinds.hs b/src/Language/PureScript/Kinds.hs
index 4355844..1c63b7d 100644
--- a/src/Language/PureScript/Kinds.hs
+++ b/src/Language/PureScript/Kinds.hs
@@ -49,7 +49,7 @@ data Kind
-- |
-- Function kinds
--
- | FunKind Kind Kind deriving (Show, Eq, Ord, Data, Typeable)
+ | FunKind Kind Kind deriving (Show, Read, Eq, Ord, Data, Typeable)
$(A.deriveJSON A.defaultOptions ''Kind)
diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs
index 9d1f6dc..fb98e72 100644
--- a/src/Language/PureScript/Linter.hs
+++ b/src/Language/PureScript/Linter.hs
@@ -19,7 +19,7 @@
module Language.PureScript.Linter (lint, module L) where
-import Data.List (mapAccumL, nub)
+import Data.List (mapAccumL, nub, (\\))
import Data.Maybe (mapMaybe)
import Data.Monoid
@@ -33,13 +33,14 @@ import Control.Monad.Writer.Class
import Language.PureScript.AST
import Language.PureScript.Names
import Language.PureScript.Errors
+import Language.PureScript.Types
import Language.PureScript.Linter.Exhaustive as L
-- | Lint the PureScript AST.
-- |
-- | Right now, this pass only performs a shadowing check.
lint :: forall m. (Applicative m, MonadWriter MultipleErrors m) => Module -> m ()
-lint (Module _ _ mn ds _) = censor (onErrorMessages (ErrorInModule mn)) $ mapM_ lintDeclaration ds
+lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDeclaration ds
where
moduleNames :: S.Set Ident
moduleNames = S.fromList (nub (mapMaybe getDeclIdent ds))
@@ -48,7 +49,6 @@ lint (Module _ _ mn ds _) = censor (onErrorMessages (ErrorInModule mn)) $ mapM_
getDeclIdent (PositionedDeclaration _ _ d) = getDeclIdent d
getDeclIdent (ValueDeclaration ident _ _ _) = Just ident
getDeclIdent (ExternDeclaration ident _) = Just ident
- getDeclIdent (ExternInstanceDeclaration ident _ _ _) = Just ident
getDeclIdent (TypeInstanceDeclaration ident _ _ _ _) = Just ident
getDeclIdent (BindingGroupDeclaration _) = error "lint: binding groups should not be desugared yet."
getDeclIdent _ = Nothing
@@ -58,8 +58,10 @@ lint (Module _ _ mn ds _) = censor (onErrorMessages (ErrorInModule mn)) $ mapM_
let (f, _, _, _, _) = everythingWithContextOnValues moduleNames mempty mappend stepD stepE stepB def def
f' :: Declaration -> MultipleErrors
- f' (PositionedDeclaration pos _ dec) = onErrorMessages (PositionedError pos) (f' dec)
- f' dec = f dec
+ f' (PositionedDeclaration pos _ dec) = addHint (PositionedError pos) (f' dec)
+ f' dec@(ValueDeclaration name _ _ _) = addHint (ErrorInValueDeclaration name) (f dec <> checkTypeVarsInDecl dec)
+ f' (TypeDeclaration name ty) = addHint (ErrorInTypeDeclaration name) (checkTypeVars ty)
+ f' dec = f dec <> checkTypeVarsInDecl dec
in tell (f' d)
where
@@ -75,17 +77,43 @@ lint (Module _ _ mn ds _) = censor (onErrorMessages (ErrorInModule mn)) $ mapM_
stepD s _ = (s, mempty)
stepE :: S.Set Ident -> Expr -> (S.Set Ident, MultipleErrors)
- stepE s (Abs (Left name) _) = bind s name
+ stepE s (Abs (Left name) _) = bindName s name
stepE s (Let ds' _) =
- case mapAccumL bind s (nub (mapMaybe getDeclIdent ds')) of
+ case mapAccumL bindName s (nub (mapMaybe getDeclIdent ds')) of
(s', es) -> (s', mconcat es)
stepE s _ = (s, mempty)
stepB :: S.Set Ident -> Binder -> (S.Set Ident, MultipleErrors)
- stepB s (VarBinder name) = bind s name
- stepB s (NamedBinder name _) = bind s name
+ stepB s (VarBinder name) = bindName s name
+ stepB s (NamedBinder name _) = bindName s name
+ stepB s (TypedBinder _ b) = stepB s b
stepB s _ = (s, mempty)
- bind :: S.Set Ident -> Ident -> (S.Set Ident, MultipleErrors)
- bind s name | name `S.member` s = (s, errorMessage (ShadowedName name))
- | otherwise = (S.insert name s, mempty)
+ bindName :: S.Set Ident -> Ident -> (S.Set Ident, MultipleErrors)
+ bindName = bind ShadowedName
+
+ checkTypeVarsInDecl :: Declaration -> MultipleErrors
+ checkTypeVarsInDecl d = let (f, _, _, _, _) = accumTypes checkTypeVars in f d
+
+ checkTypeVars :: Type -> MultipleErrors
+ checkTypeVars ty = everythingWithContextOnTypes S.empty mempty mappend step ty <> findUnused ty
+ where
+ step :: S.Set String -> Type -> (S.Set String, MultipleErrors)
+ step s (ForAll tv _ _) = bindVar s tv
+ step s _ = (s, mempty)
+ bindVar :: S.Set String -> String -> (S.Set String, MultipleErrors)
+ bindVar = bind ShadowedTypeVar
+ findUnused :: Type -> MultipleErrors
+ findUnused ty' =
+ let used = usedTypeVariables ty'
+ declared = everythingOnTypes (++) go ty'
+ unused = nub declared \\ nub used
+ in foldl (<>) mempty $ map (errorMessage . UnusedTypeVar) unused
+ where
+ go :: Type -> [String]
+ go (ForAll tv _ _) = [tv]
+ go _ = []
+
+ bind :: (Ord a) => (a -> SimpleErrorMessage) -> S.Set a -> a -> (S.Set a, MultipleErrors)
+ bind mkError s name | name `S.member` s = (s, errorMessage (mkError name))
+ | otherwise = (S.insert name s, mempty)
diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs
index 7bd22da..fd6df8b 100644
--- a/src/Language/PureScript/Linter/Exhaustive.hs
+++ b/src/Language/PureScript/Linter/Exhaustive.hs
@@ -29,6 +29,9 @@ import qualified Data.Map as M
import Data.Maybe (fromMaybe)
import Data.List (foldl', sortBy, nub)
import Data.Function (on)
+#if __GLASGOW_HASKELL__ < 710
+import Data.Traversable (sequenceA)
+#endif
import Control.Monad (unless)
import Control.Applicative
@@ -43,7 +46,13 @@ import Language.PureScript.Kinds
import Language.PureScript.Types as P
import Language.PureScript.Errors
-import Language.PureScript.AST.Traversals (everywhereOnValuesTopDownM)
+-- | There are two modes of failure for the redudancy check:
+--
+-- 1. Exhaustivity was incomeplete due to too many cases, so we couldn't determine redundancy.
+-- 2. We didn't attempt to determine redundancy for a binder, e.g. an integer binder.
+--
+-- We want to warn the user in the first case.
+data RedudancyError = Incomplete | Unknown
-- |
-- Qualifies a propername from a given qualified propername and a default module name
@@ -59,20 +68,20 @@ qualifyName n defmn qn = Qualified (Just mn) n
-- where: - ProperName is the name of the constructor (for example, "Nothing" in Maybe)
-- - [Type] is the list of arguments, if it has (for example, "Just" has [TypeVar "a"])
--
-getConstructors :: Environment -> ModuleName -> (Qualified ProperName) -> [(ProperName, [Type])]
+getConstructors :: Environment -> ModuleName -> Qualified ProperName -> [(ProperName, [Type])]
getConstructors env defmn n = extractConstructors lnte
where
qpn :: Qualified ProperName
qpn = getConsDataName n
- getConsDataName :: (Qualified ProperName) -> (Qualified ProperName)
+ getConsDataName :: Qualified ProperName -> Qualified ProperName
getConsDataName con = qualifyName nm defmn con
where
nm = case getConsInfo con of
- Nothing -> error $ "ProperName " ++ show con ++ " not in the scope of the current environment in getConsDataName."
+ Nothing -> error $ "Constructor " ++ showQualified runProperName con ++ " not in the scope of the current environment in getConsDataName."
Just (_, pm, _, _) -> pm
- getConsInfo :: (Qualified ProperName) -> Maybe (DataDeclType, ProperName, Type, [Ident])
+ getConsInfo :: Qualified ProperName -> Maybe (DataDeclType, ProperName, Type, [Ident])
getConsInfo con = M.lookup con dce
where
dce :: M.Map (Qualified ProperName) (DataDeclType, ProperName, Type, [Ident])
@@ -103,27 +112,27 @@ genericMerge _ [] [] = []
genericMerge f bs [] = map (\(s, b) -> f s (Just b) Nothing) bs
genericMerge f [] bs = map (\(s, b) -> f s Nothing (Just b)) bs
genericMerge f bsl@((s, b):bs) bsr@((s', b'):bs')
- | s < s' = (f s (Just b) Nothing) : genericMerge f bs bsr
- | s > s' = (f s' Nothing (Just b')) : genericMerge f bsl bs'
- | otherwise = (f s (Just b) (Just b')) : genericMerge f bs bs'
+ | s < s' = f s (Just b) Nothing : genericMerge f bs bsr
+ | s > s' = f s' Nothing (Just b') : genericMerge f bsl bs'
+ | otherwise = f s (Just b) (Just b') : genericMerge f bs bs'
-- |
-- Find the uncovered set between two binders:
-- the first binder is the case we are trying to cover, the second one is the matching binder
--
-missingCasesSingle :: Environment -> ModuleName -> Binder -> Binder -> ([Binder], Maybe Bool)
-missingCasesSingle _ _ _ NullBinder = ([], Just True)
-missingCasesSingle _ _ _ (VarBinder _) = ([], Just True)
+missingCasesSingle :: Environment -> ModuleName -> Binder -> Binder -> ([Binder], Either RedudancyError Bool)
+missingCasesSingle _ _ _ NullBinder = ([], return True)
+missingCasesSingle _ _ _ (VarBinder _) = ([], return True)
missingCasesSingle env mn (VarBinder _) b = missingCasesSingle env mn NullBinder b
missingCasesSingle env mn br (NamedBinder _ bl) = missingCasesSingle env mn br bl
missingCasesSingle env mn NullBinder cb@(ConstructorBinder con _) =
- (concatMap (\cp -> fst $ missingCasesSingle env mn cp cb) allPatterns, Just True)
+ (concatMap (\cp -> fst $ missingCasesSingle env mn cp cb) allPatterns, return True)
where
allPatterns = map (\(p, t) -> ConstructorBinder (qualifyName p mn con) (initialize $ length t))
$ getConstructors env mn con
missingCasesSingle env mn cb@(ConstructorBinder con bs) (ConstructorBinder con' bs')
| con == con' = let (bs'', pr) = missingCasesMultiple env mn bs bs' in (map (ConstructorBinder con) bs'', pr)
- | otherwise = ([cb], Just False)
+ | otherwise = ([cb], return False)
missingCasesSingle env mn NullBinder (ObjectBinder bs) =
(map (ObjectBinder . zip (map fst bs)) allMisses, pr)
where
@@ -146,12 +155,13 @@ missingCasesSingle env mn (ObjectBinder bs) (ObjectBinder bs') =
compBS e s b b' = (s, compB e b b')
(sortedNames, binders) = unzip $ genericMerge (compBS NullBinder) sbs sbs'
-missingCasesSingle _ _ NullBinder (BooleanBinder b) = ([BooleanBinder $ not b], Just True)
+missingCasesSingle _ _ NullBinder (BooleanBinder b) = ([BooleanBinder $ not b], return True)
missingCasesSingle _ _ (BooleanBinder bl) (BooleanBinder br)
- | bl == br = ([], Just True)
- | otherwise = ([BooleanBinder bl], Just False)
+ | bl == br = ([], return True)
+ | otherwise = ([BooleanBinder bl], return False)
missingCasesSingle env mn b (PositionedBinder _ _ cb) = missingCasesSingle env mn b cb
-missingCasesSingle _ _ b _ = ([b], Nothing)
+missingCasesSingle env mn b (TypedBinder _ cb) = missingCasesSingle env mn b cb
+missingCasesSingle _ _ b _ = ([b], Left Unknown)
-- |
-- Returns the uncovered set of binders
@@ -179,7 +189,7 @@ missingCasesSingle _ _ b _ = ([b], Nothing)
-- redundant or not, but uncovered at least. If we use `y` instead, we'll need to have a redundancy checker
-- (which ought to be available soon), or increase the complexity of the algorithm.
--
-missingCasesMultiple :: Environment -> ModuleName -> [Binder] -> [Binder] -> ([[Binder]], Maybe Bool)
+missingCasesMultiple :: Environment -> ModuleName -> [Binder] -> [Binder] -> ([[Binder]], Either RedudancyError Bool)
missingCasesMultiple env mn = go
where
go [] [] = ([], pure True)
@@ -213,10 +223,10 @@ isExhaustiveGuard (Right _) = True
-- |
-- Returns the uncovered set of case alternatives
--
-missingCases :: Environment -> ModuleName -> [Binder] -> CaseAlternative -> ([[Binder]], Maybe Bool)
+missingCases :: Environment -> ModuleName -> [Binder] -> CaseAlternative -> ([[Binder]], Either RedudancyError Bool)
missingCases env mn uncovered ca = missingCasesMultiple env mn uncovered (caseAlternativeBinders ca)
-missingAlternative :: Environment -> ModuleName -> CaseAlternative -> [Binder] -> ([[Binder]], Maybe Bool)
+missingAlternative :: Environment -> ModuleName -> CaseAlternative -> [Binder] -> ([[Binder]], Either RedudancyError Bool)
missingAlternative env mn ca uncovered
| isExhaustiveGuard (caseAlternativeResult ca) = mcases
| otherwise = ([uncovered], snd mcases)
@@ -232,52 +242,69 @@ missingAlternative env mn ca uncovered
checkExhaustive :: forall m. (MonadWriter MultipleErrors m) => Environment -> ModuleName -> Int -> [CaseAlternative] -> m ()
checkExhaustive env mn numArgs cas = makeResult . first nub $ foldl' step ([initialize numArgs], (pure True, [])) cas
where
- step :: ([[Binder]], (Maybe Bool, [[Binder]])) -> CaseAlternative -> ([[Binder]], (Maybe Bool, [[Binder]]))
+ step :: ([[Binder]], (Either RedudancyError Bool, [[Binder]])) -> CaseAlternative -> ([[Binder]], (Either RedudancyError Bool, [[Binder]]))
step (uncovered, (nec, redundant)) ca =
let (missed, pr) = unzip (map (missingAlternative env mn ca) uncovered)
- cond = or <$> sequenceA pr
- in (concat missed, (liftA2 (&&) cond nec,
- if fromMaybe True cond then redundant else caseAlternativeBinders ca : redundant))
-#if __GLASGOW_HASKELL__ < 710
- where
- sequenceA = foldr (liftA2 (:)) (pure [])
-#endif
+ (missed', approx) = splitAt 10000 (concat missed)
+ cond = liftA2 (&&) (or <$> sequenceA pr) nec
+ in (missed', ( if null approx
+ then cond
+ else Left Incomplete
+ , if either (const True) id cond
+ then redundant
+ else caseAlternativeBinders ca : redundant
+ )
+ )
- makeResult :: ([[Binder]], (Maybe Bool, [[Binder]])) -> m ()
- makeResult (bss, (_, bss')) =
+ makeResult :: ([[Binder]], (Either RedudancyError Bool, [[Binder]])) -> m ()
+ makeResult (bss, (rr, bss')) =
do unless (null bss) tellExhaustive
unless (null bss') tellRedundant
+ case rr of
+ Left Incomplete -> tellIncomplete
+ _ -> return ()
where
tellExhaustive = tell . errorMessage . uncurry NotExhaustivePattern . second null . splitAt 5 $ bss
tellRedundant = tell . errorMessage . uncurry OverlappingPattern . second null . splitAt 5 $ bss'
+ tellIncomplete = tell . errorMessage $ IncompleteExhaustivityCheck
-- |
-- Exhaustivity checking over a list of declarations
--
checkExhaustiveDecls :: forall m. (Applicative m, MonadWriter MultipleErrors m) => Environment -> ModuleName -> [Declaration] -> m ()
-checkExhaustiveDecls env mn ds =
- let (f, _, _) = everywhereOnValuesTopDownM return checkExpr return
+checkExhaustiveDecls env mn = mapM_ onDecl
+ where
+ onDecl :: Declaration -> m ()
+ onDecl (BindingGroupDeclaration bs) = mapM_ (onDecl . convert) bs
+ where
+ convert :: (Ident, NameKind, Expr) -> Declaration
+ convert (name, nk, e) = ValueDeclaration name nk [] (Right e)
+ onDecl (ValueDeclaration name _ _ (Right e)) = censor (addHint (ErrorInValueDeclaration name)) (onExpr e)
+ onDecl (PositionedDeclaration pos _ dec) = censor (addHint (PositionedError pos)) (onDecl dec)
+ onDecl _ = return ()
- f' :: Declaration -> m Declaration
- f' d@(BindingGroupDeclaration bs) = mapM_ (f' . convert) bs >> return d
- where
- convert :: (Ident, NameKind, Expr) -> Declaration
- convert (name, nk, e) = ValueDeclaration name nk [] (Right e)
- f' d@(ValueDeclaration name _ _ _) = censor (onErrorMessages (ErrorInValueDeclaration name)) $ f d
- f' (PositionedDeclaration pos com dec) = PositionedDeclaration pos com <$> censor (onErrorMessages (PositionedError pos)) (f' dec)
- -- Don't generate two warnings for desugared dictionaries.
- f' d@TypeInstanceDeclaration{} = return d
- f' d = f d
+ onExpr :: Expr -> m ()
+ onExpr (UnaryMinus e) = onExpr e
+ onExpr (ArrayLiteral es) = mapM_ onExpr es
+ onExpr (ObjectLiteral es) = mapM_ (onExpr . snd) es
+ onExpr (TypeClassDictionaryConstructorApp _ e) = onExpr e
+ onExpr (Accessor _ e) = onExpr e
+ onExpr (ObjectUpdate o es) = onExpr o >> mapM_ (onExpr . snd) es
+ onExpr (Abs _ e) = onExpr e
+ onExpr (App e1 e2) = onExpr e1 >> onExpr e2
+ onExpr (IfThenElse e1 e2 e3) = onExpr e1 >> onExpr e2 >> onExpr e3
+ onExpr (Case es cas) = checkExhaustive env mn (length es) cas >> mapM_ onExpr es >> mapM_ onCaseAlternative cas
+ onExpr (TypedValue _ e _) = onExpr e
+ onExpr (Let ds e) = mapM_ onDecl ds >> onExpr e
+ onExpr (PositionedValue pos _ e) = censor (addHint (PositionedError pos)) (onExpr e)
+ onExpr _ = return ()
- in mapM_ f' ds
- where
- checkExpr :: Expr -> m Expr
- checkExpr c@(Case expr cas) = checkExhaustive env mn (length expr) cas >> return c
- checkExpr other = return other
+ onCaseAlternative :: CaseAlternative -> m ()
+ onCaseAlternative (CaseAlternative _ (Left es)) = mapM_ (\(e, g) -> onExpr e >> onExpr g) es
+ onCaseAlternative (CaseAlternative _ (Right e)) = onExpr e
-- |
-- Exhaustivity checking over a single module
--
checkExhaustiveModule :: forall m. (Applicative m, MonadWriter MultipleErrors m) => Environment -> Module -> m ()
-checkExhaustiveModule env (Module _ _ mn ds _) = censor (onErrorMessages (ErrorInModule mn)) $ checkExhaustiveDecls env mn ds
-
+checkExhaustiveModule env (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ checkExhaustiveDecls env mn ds
diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs
index 598f33e..4dce3b5 100644
--- a/src/Language/PureScript/Make.hs
+++ b/src/Language/PureScript/Make.hs
@@ -19,6 +19,8 @@
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE CPP #-}
module Language.PureScript.Make
@@ -39,25 +41,31 @@ module Language.PureScript.Make
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
#endif
-import Control.Arrow ((&&&))
import Control.Monad
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.Trans.Except
import Control.Monad.Reader
import Control.Monad.Writer.Strict
import Control.Monad.Supply
+import Control.Monad.Base (MonadBase(..))
+import Control.Monad.Trans.Control (MonadBaseControl(..))
-import Data.Function (on)
-import Data.List (sortBy, groupBy)
-import Data.Maybe (fromMaybe)
+import Control.Concurrent.Lifted as C
+
+import Data.List (foldl', sort)
+import Data.Maybe (fromMaybe, catMaybes)
import Data.Time.Clock
+import Data.String (fromString)
import Data.Foldable (for_)
#if __GLASGOW_HASKELL__ < 710
import Data.Traversable (traverse)
#endif
+import Data.Traversable (for)
import Data.Version (showVersion)
-import qualified Data.Map as M
+import Data.Aeson (encode, decode)
+import qualified Data.ByteString.Lazy as B
import qualified Data.Set as S
+import qualified Data.Map as M
import System.Directory
(doesFileExist, getModificationTime, createDirectoryIfMissing)
@@ -65,14 +73,13 @@ import System.FilePath ((</>), takeDirectory)
import System.IO.Error (tryIOError)
import Language.PureScript.AST
-import Language.PureScript.CodeGen.Externs (moduleToPs)
+import Language.PureScript.Externs
import Language.PureScript.Environment
import Language.PureScript.Errors
import Language.PureScript.Linter
import Language.PureScript.ModuleDependencies
import Language.PureScript.Names
import Language.PureScript.Options
-import Language.PureScript.Parser
import Language.PureScript.Pretty
import Language.PureScript.Renamer
import Language.PureScript.Sugar
@@ -86,7 +93,7 @@ import qualified Paths_purescript as Paths
-- | Progress messages from the make process
data ProgressMessage
= CompilingModule ModuleName
- deriving (Show, Eq, Ord)
+ deriving (Show, Read, Eq, Ord)
-- | Render a progress message
renderProgressMessage :: ProgressMessage -> String
@@ -116,7 +123,7 @@ data MakeActions m = MakeActions {
-- |
-- Read the externs file for a module as a string and also return the actual
-- path for the file.
- , readExterns :: ModuleName -> m (FilePath, String)
+ , readExterns :: ModuleName -> m (FilePath, B.ByteString)
-- |
-- Run the code generator for the module and write any required output files.
--
@@ -130,7 +137,7 @@ data MakeActions m = MakeActions {
-- |
-- Generated code for an externs file.
--
-type Externs = String
+type Externs = B.ByteString
-- |
-- Determines when to rebuild a module
@@ -139,7 +146,7 @@ data RebuildPolicy
-- | Never rebuild this module
= RebuildNever
-- | Always rebuild this module
- | RebuildAlways deriving (Show, Eq, Ord)
+ | RebuildAlways deriving (Show, Read, Eq, Ord)
-- |
-- Compiles in "make" mode, compiling each module separately to a js files and an externs file
@@ -147,66 +154,116 @@ data RebuildPolicy
-- If timestamps have not changed, the externs file can be used to provide the module's types without
-- having to typecheck the module again.
--
-make :: forall m. (Functor m, Applicative m, Monad m, MonadReader Options m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+make :: forall m. (Functor m, Applicative m, Monad m, MonadBaseControl IO m, MonadReader Options m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
=> MakeActions m
-> [Module]
-> m Environment
make MakeActions{..} ms = do
- (sorted, graph) <- sortModules $ map importPrim ms
- toRebuild <- foldM (\s (Module _ _ moduleName' _ _) -> do
- inputTimestamp <- getInputTimestamp moduleName'
- outputTimestamp <- getOutputTimestamp moduleName'
- return $ case (inputTimestamp, outputTimestamp) of
- (Right (Just t1), Just t2) | t1 < t2 -> s
- (Left RebuildNever, Just _) -> s
- _ -> S.insert moduleName' s) S.empty sorted
-
- marked <- rebuildIfNecessary (reverseDependencies graph) toRebuild sorted
- for_ marked $ \(willRebuild, m) -> when willRebuild (lint m)
- (desugared, nextVar) <- runSupplyT 0 $ zip (map fst marked) <$> desugar (map snd marked)
- evalSupplyT nextVar $ go initEnvironment desugared
- where
+ checkModuleNamesAreUnique
- go :: Environment -> [(Bool, Module)] -> SupplyT m Environment
- go env [] = return env
- go env ((False, m) : ms') = do
- (_, env') <- lift . runCheck' env $ typeCheckModule Nothing m
- go env' ms'
- go env ((True, m@(Module ss coms moduleName' _ exps)) : ms') = do
- lift . progress $ CompilingModule moduleName'
- (checked@(Module _ _ _ elaborated _), env') <- lift . runCheck' env $ typeCheckModule Nothing m
- checkExhaustiveModule env' checked
- regrouped <- createBindingGroups moduleName' . collapseBindingGroups $ elaborated
- let mod' = Module ss coms moduleName' regrouped exps
- corefn = CF.moduleToCoreFn env' mod'
- [renamed] = renameInModules [corefn]
- exts = moduleToPs mod' env'
- codegen renamed env' exts
- go env' ms'
-
- rebuildIfNecessary :: M.Map ModuleName [ModuleName] -> S.Set ModuleName -> [Module] -> m [(Bool, Module)]
- rebuildIfNecessary _ _ [] = return []
- rebuildIfNecessary graph toRebuild (m@(Module _ _ moduleName' _ _) : ms') | moduleName' `S.member` toRebuild = do
- let deps = fromMaybe [] $ moduleName' `M.lookup` graph
- toRebuild' = toRebuild `S.union` S.fromList deps
- (:) (True, m) <$> rebuildIfNecessary graph toRebuild' ms'
- rebuildIfNecessary graph toRebuild (Module _ _ moduleName' _ _ : ms') = do
- (path, externs) <- readExterns moduleName'
- externsModules <- fmap (map snd) . alterErrors $ parseModulesFromFiles id [(path, externs)]
- case externsModules of
- [m'@(Module _ _ moduleName'' _ _)] | moduleName'' == moduleName' -> (:) (False, m') <$> rebuildIfNecessary graph toRebuild ms'
- _ -> throwError . errorMessage . InvalidExternsFile $ path
- where
- alterErrors = flip catchError $ \(MultipleErrors errs) ->
- throwError . MultipleErrors $ flip map errs $ \e -> case e of
- SimpleErrorWrapper (ErrorParsingModule err) -> SimpleErrorWrapper (ErrorParsingExterns err)
- _ -> e
+ (sorted, graph) <- sortModules ms
+
+ barriers <- zip (map getModuleName sorted) <$> replicateM (length ms) ((,) <$> C.newEmptyMVar <*> C.newEmptyMVar)
+
+ for_ sorted $ \m -> fork $ do
+ let deps = fromMaybe (error "make: module not found in dependency graph.") (lookup (getModuleName m) graph)
+ buildModule barriers (importPrim m) (deps `inOrderOf` map getModuleName sorted)
+
+ -- Wait for all threads to complete, and collect errors.
+ errors <- catMaybes <$> for barriers (takeMVar . snd . snd)
+
+ -- All threads have completed, rethrow any caught errors.
+ unless (null errors) $ throwError (mconcat errors)
+
+ -- Bundle up all the externs and return them as an Environment
+ (warnings, externs) <- unzip . fromMaybe (error "make: externs were missing but no errors reported.") . sequence <$> for barriers (takeMVar . fst . snd)
+ tell (mconcat warnings)
+ return $ foldl' (flip applyExternsFileToEnvironment) initEnvironment externs
-reverseDependencies :: ModuleGraph -> M.Map ModuleName [ModuleName]
-reverseDependencies g = combine [ (dep, mn) | (mn, deps) <- g, dep <- deps ]
where
- combine :: (Ord a) => [(a, b)] -> M.Map a [b]
- combine = M.fromList . map ((fst . head) &&& map snd) . groupBy ((==) `on` fst) . sortBy (compare `on` fst)
+ checkModuleNamesAreUnique :: m ()
+ checkModuleNamesAreUnique =
+ case findDuplicate (map getModuleName ms) of
+ Nothing -> return ()
+ Just mn -> throwError . errorMessage $ DuplicateModuleName mn
+
+ -- Verify that a list of values has unique keys
+ findDuplicate :: (Ord a) => [a] -> Maybe a
+ findDuplicate = go . sort
+ where
+ go (x : y : xs)
+ | x == y = Just x
+ | otherwise = go (y : xs)
+ go _ = Nothing
+
+ -- Sort a list so its elements appear in the same order as in another list.
+ inOrderOf :: (Ord a) => [a] -> [a] -> [a]
+ inOrderOf xs ys = let s = S.fromList xs in filter (`S.member` s) ys
+
+ buildModule :: [(ModuleName, (C.MVar (Maybe (MultipleErrors, ExternsFile)), C.MVar (Maybe MultipleErrors)))] -> Module -> [ModuleName] -> m ()
+ buildModule barriers m@(Module _ _ moduleName _ _) deps = flip catchError (markComplete Nothing . Just) $ do
+ -- We need to wait for dependencies to be built, before checking if the current
+ -- module should be rebuilt, so the first thing to do is to wait on the
+ -- MVars for the module's dependencies.
+ mexterns <- fmap unzip . sequence <$> mapM (readMVar . fst . fromMaybe (error "make: no barrier") . flip lookup barriers) deps
+
+ outputTimestamp <- getOutputTimestamp moduleName
+ dependencyTimestamp <- maximumMaybe <$> mapM (fmap shouldExist . getOutputTimestamp) deps
+ inputTimestamp <- getInputTimestamp moduleName
+
+ let shouldRebuild = case (inputTimestamp, dependencyTimestamp, outputTimestamp) of
+ (Right (Just t1), Just t3, Just t2) -> t1 > t2 || t3 > t2
+ (Right (Just t1), Nothing, Just t2) -> t1 > t2
+ (Left RebuildNever, _, Just _) -> False
+ _ -> True
+
+ let rebuild =
+ case mexterns of
+ Just (_, externs) -> do
+ (exts, warnings) <- listen $ do
+ progress $ CompilingModule moduleName
+ let env = foldl' (flip applyExternsFileToEnvironment) initEnvironment externs
+ lint m
+ ([desugared], nextVar) <- runSupplyT 0 $ desugar externs [m]
+ (checked@(Module ss coms _ elaborated exps), env') <- runCheck' env $ typeCheckModule desugared
+ checkExhaustiveModule env' checked
+ regrouped <- createBindingGroups moduleName . collapseBindingGroups $ elaborated
+ let mod' = Module ss coms moduleName regrouped exps
+ corefn = CF.moduleToCoreFn env' mod'
+ [renamed] = renameInModules [corefn]
+ exts = moduleToExternsFile mod' env'
+ evalSupplyT nextVar $ codegen renamed env' $ encode exts
+ return exts
+ markComplete (Just (warnings, exts)) Nothing
+ Nothing -> markComplete Nothing Nothing
+
+ if shouldRebuild
+ then rebuild
+ else do
+ mexts <- decodeExterns . snd <$> readExterns moduleName
+ case mexts of
+ Just exts -> markComplete (Just (mempty, exts)) Nothing
+ Nothing -> rebuild
+ where
+ markComplete :: Maybe (MultipleErrors, ExternsFile) -> Maybe MultipleErrors -> m ()
+ markComplete externs errors = do
+ putMVar (fst $ fromMaybe (error "make: no barrier") $ lookup moduleName barriers) externs
+ putMVar (snd $ fromMaybe (error "make: no barrier") $ lookup moduleName barriers) errors
+
+ maximumMaybe :: (Ord a) => [a] -> Maybe a
+ maximumMaybe [] = Nothing
+ maximumMaybe xs = Just $ maximum xs
+
+ -- Make sure a dependency exists
+ shouldExist :: Maybe UTCTime -> UTCTime
+ shouldExist (Just t) = t
+ shouldExist _ = error "make: dependency should already have been built."
+
+ decodeExterns :: B.ByteString -> Maybe ExternsFile
+ decodeExterns bs = do
+ externs <- decode bs
+ guard $ efVersion externs == showVersion Paths.version
+ return externs
-- |
-- Add an import declaration for a module if it does not already explicitly import it.
@@ -229,6 +286,14 @@ importPrim = addDefaultImport (ModuleName [ProperName C.prim])
newtype Make a = Make { unMake :: ReaderT Options (WriterT MultipleErrors (ExceptT MultipleErrors IO)) a }
deriving (Functor, Applicative, Monad, MonadIO, MonadError MultipleErrors, MonadWriter MultipleErrors, MonadReader Options)
+instance MonadBase IO Make where
+ liftBase = liftIO
+
+instance MonadBaseControl IO Make where
+ type StM Make a = Either MultipleErrors (a, MultipleErrors)
+ liftBaseWith f = Make $ liftBaseWith $ \q -> f (q . unMake)
+ restoreM = Make . restoreM
+
-- |
-- Execute a 'Make' monad, returning either errors, or the result of the compile plus any warnings.
--
@@ -268,12 +333,12 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
getOutputTimestamp mn = do
let filePath = runModuleName mn
jsFile = outputDir </> filePath </> "index.js"
- externsFile = outputDir </> filePath </> "externs.purs"
+ externsFile = outputDir </> filePath </> "externs.json"
min <$> getTimestamp jsFile <*> getTimestamp externsFile
- readExterns :: ModuleName -> Make (FilePath, String)
+ readExterns :: ModuleName -> Make (FilePath, B.ByteString)
readExterns mn = do
- let path = outputDir </> runModuleName mn </> "externs.purs"
+ let path = outputDir </> runModuleName mn </> "externs.json"
(path, ) <$> readTextFile path
codegen :: CF.Module CF.Ann -> Environment -> Externs -> SupplyT Make ()
@@ -290,12 +355,12 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
pjs <- prettyPrintJS <$> J.moduleToJs m foreignInclude
let filePath = runModuleName mn
jsFile = outputDir </> filePath </> "index.js"
- externsFile = outputDir </> filePath </> "externs.purs"
+ externsFile = outputDir </> filePath </> "externs.json"
foreignFile = outputDir </> filePath </> "foreign.js"
prefix = ["Generated by psc version " ++ showVersion Paths.version | usePrefix]
js = unlines $ map ("// " ++) prefix ++ [pjs]
lift $ do
- writeTextFile jsFile js
+ writeTextFile jsFile (fromString js)
for_ (mn `M.lookup` foreigns) (readTextFile >=> writeTextFile foreignFile)
writeTextFile externsFile exts
@@ -303,17 +368,17 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
requiresForeign = not . null . CF.moduleForeign
getTimestamp :: FilePath -> Make (Maybe UTCTime)
- getTimestamp path = makeIO (const (SimpleErrorWrapper $ CannotGetFileInfo path)) $ do
+ getTimestamp path = makeIO (const (ErrorMessage [] $ CannotGetFileInfo path)) $ do
exists <- doesFileExist path
traverse (const $ getModificationTime path) $ guard exists
- readTextFile :: FilePath -> Make String
- readTextFile path = makeIO (const (SimpleErrorWrapper $ CannotReadFile path)) $ readFile path
+ readTextFile :: FilePath -> Make B.ByteString
+ readTextFile path = makeIO (const (ErrorMessage [] $ CannotReadFile path)) $ B.readFile path
- writeTextFile :: FilePath -> String -> Make ()
- writeTextFile path text = makeIO (const (SimpleErrorWrapper $ CannotWriteFile path)) $ do
+ writeTextFile :: FilePath -> B.ByteString -> Make ()
+ writeTextFile path text = makeIO (const (ErrorMessage [] $ CannotWriteFile path)) $ do
mkdirp path
- writeFile path text
+ B.writeFile path text
where
mkdirp :: FilePath -> IO ()
mkdirp = createDirectoryIfMissing True . takeDirectory
diff --git a/src/Language/PureScript/ModuleDependencies.hs b/src/Language/PureScript/ModuleDependencies.hs
index 0425a43..cc4736b 100644
--- a/src/Language/PureScript/ModuleDependencies.hs
+++ b/src/Language/PureScript/ModuleDependencies.hs
@@ -23,20 +23,17 @@ import Control.Monad.Error.Class (MonadError(..))
import Data.Graph
import Data.List (nub)
-import Data.Maybe (mapMaybe)
+import Data.Maybe (fromMaybe, mapMaybe)
import Language.PureScript.AST
import Language.PureScript.Names
import Language.PureScript.Types
import Language.PureScript.Errors
--- |
--- A list of modules with their dependencies
---
+-- | A list of modules with their transitive dependencies
type ModuleGraph = [(ModuleName, [ModuleName])]
--- |
--- Sort a collection of modules based on module dependencies.
+-- | Sort a collection of modules based on module dependencies.
--
-- Reports an error if the module graph contains a cycle.
--
@@ -44,7 +41,12 @@ sortModules :: (MonadError MultipleErrors m) => [Module] -> m ([Module], ModuleG
sortModules ms = do
let verts = map (\m@(Module _ _ _ ds _) -> (m, getModuleName m, nub (concatMap usedModules ds))) ms
ms' <- mapM toModule $ stronglyConnComp verts
- let moduleGraph = map (\(_, mn, deps) -> (mn, deps)) verts
+ let (graph, fromVertex, toVertex) = graphFromEdges verts
+ moduleGraph = do (_, mn, _) <- verts
+ let v = fromMaybe (error "sortModules: vertex not found") (toVertex mn)
+ deps = reachable graph v
+ toKey i = case fromVertex i of (_, key, _) -> key
+ return (mn, filter (/= mn) (map toKey deps))
return (ms', moduleGraph)
-- |
diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs
index 28eb8ae..1b003d2 100644
--- a/src/Language/PureScript/Names.hs
+++ b/src/Language/PureScript/Names.hs
@@ -15,6 +15,7 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE GADTs #-}
module Language.PureScript.Names where
@@ -22,6 +23,7 @@ module Language.PureScript.Names where
import Data.List
import Data.Data
import Data.List.Split (splitOn)
+import Data.Aeson.TH
import qualified Data.Aeson as A
import qualified Data.Text as T
@@ -36,28 +38,25 @@ data Ident
-- |
-- A symbolic name for an infix operator
--
- | Op String deriving (Eq, Ord, Data, Typeable)
+ | Op String deriving (Show, Read, Eq, Ord, Data, Typeable)
runIdent :: Ident -> String
runIdent (Ident i) = i
runIdent (Op op) = op
-instance Show Ident where
- show (Ident s) = s
- show (Op op) = '(':op ++ ")"
+showIdent :: Ident -> String
+showIdent (Ident i) = i
+showIdent (Op op) = '(' : op ++ ")"
-- |
-- Proper names, i.e. capitalized names for e.g. module names, type//data constructors.
--
-newtype ProperName = ProperName { runProperName :: String } deriving (Eq, Ord, Data, Typeable)
-
-instance Show ProperName where
- show = runProperName
+newtype ProperName = ProperName { runProperName :: String } deriving (Show, Read, Eq, Ord, Data, Typeable)
-- |
-- Module names
--
-data ModuleName = ModuleName [ProperName] deriving (Eq, Ord, Data, Typeable)
+newtype ModuleName = ModuleName [ProperName] deriving (Show, Read, Eq, Ord, Data, Typeable)
runModuleName :: ModuleName -> String
runModuleName (ModuleName pns) = intercalate "." (runProperName `map` pns)
@@ -70,20 +69,17 @@ moduleNameFromString = ModuleName . splitProperNames
s' -> ProperName w : splitProperNames s''
where (w, s'') = break (== '.') s'
-instance Show ModuleName where
- show = runModuleName
-
-- |
-- A qualified name, i.e. a name with an optional module name
--
-data Qualified a = Qualified (Maybe ModuleName) a deriving (Eq, Ord, Data, Typeable, Functor)
+data Qualified a = Qualified (Maybe ModuleName) a deriving (Show, Read, Eq, Ord, Data, Typeable, Functor)
-instance (Show a) => Show (Qualified a) where
- show (Qualified Nothing a) = show a
- show (Qualified (Just name) a) = show name ++ "." ++ show a
+showQualified :: (a -> String) -> Qualified a -> String
+showQualified f (Qualified Nothing a) = f a
+showQualified f (Qualified (Just name) a) = runModuleName name ++ "." ++ f a
instance (a ~ ProperName) => A.ToJSON (Qualified a) where
- toJSON = A.toJSON . show
+ toJSON = A.toJSON . showQualified runProperName
instance (a ~ ProperName) => A.FromJSON (Qualified a) where
parseJSON =
@@ -95,7 +91,6 @@ instance (a ~ ProperName) => A.FromJSON (Qualified a) where
where
reconstructModuleName = moduleNameFromString . intercalate "." . reverse
-
-- |
-- Provide a default module name, if a name is unqualified
--
@@ -109,9 +104,17 @@ qualify _ (Qualified (Just m) a) = (m, a)
mkQualified :: a -> ModuleName -> Qualified a
mkQualified name mn = Qualified (Just mn) name
+-- | Remove the module name from a qualified name
+disqualify :: Qualified a -> a
+disqualify (Qualified _ a) = a
+
-- |
-- Checks whether a qualified value is actually qualified with a module reference
--
isUnqualified :: Qualified a -> Bool
isUnqualified (Qualified Nothing _) = True
isUnqualified _ = False
+
+$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Ident)
+$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ProperName)
+$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ModuleName)
diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs
index cb54ddc..a9347d1 100644
--- a/src/Language/PureScript/Parser/Declarations.hs
+++ b/src/Language/PureScript/Parser/Declarations.hs
@@ -115,16 +115,6 @@ parseExternDeclaration :: TokenParser Declaration
parseExternDeclaration = P.try (reserved "foreign") *> indented *> reserved "import" *> indented *>
(ExternDataDeclaration <$> (P.try (reserved "data") *> indented *> properName)
<*> (indented *> doubleColon *> parseKind)
- <|> (do reserved "instance"
- name <- parseIdent <* indented <* doubleColon
- deps <- P.option [] $ do
- deps' <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many (noWildcards parseTypeAtom)))
- indented
- rfatArrow
- return deps'
- className <- indented *> parseQualified properName
- tys <- P.many (indented *> noWildcards parseTypeAtom)
- return $ ExternInstanceDeclaration name deps className tys)
<|> (do ident <- parseIdent
-- TODO: add a wiki page link with migration info
-- TODO: remove this deprecation warning in 0.8
@@ -161,33 +151,34 @@ parseImportDeclaration' = do
where
stdImport = do
moduleName' <- moduleName
- stdImportHiding moduleName' <|> stdImportQualifying moduleName'
+ suffixHiding moduleName' <|> suffixQualifyingList moduleName'
where
- stdImportHiding mn = do
+ suffixHiding mn = do
reserved "hiding"
- declType <- importDeclarationType Hiding
- return (mn, declType, Nothing)
- stdImportQualifying mn = do
- declType <- importDeclarationType Explicit
+ declType <- qualifyingList Hiding
return (mn, declType, Nothing)
+ suffixQualifyingList mn = do
+ declType <- qualifyingList Explicit
+ qName <- P.optionMaybe qualifiedName
+ return (mn, declType, qName)
+ qualifiedName = reserved "as" *> moduleName
qualImport = do
reserved "qualified"
indented
moduleName' <- moduleName
- declType <- importDeclarationType Explicit
- reserved "as"
- asQ <- moduleName
- return (moduleName', declType, Just asQ)
- importDeclarationType expectedType = do
+ declType <- qualifyingList Explicit
+ qName <- qualifiedName
+ return (moduleName', declType, Just qName)
+ qualifyingList expectedType = do
idents <- P.optionMaybe $ indented *> parens (commaSep parseDeclarationRef)
return $ fromMaybe Implicit (expectedType <$> idents)
parseDeclarationRef :: TokenParser DeclarationRef
parseDeclarationRef =
- parseModuleRef <|> (
- withSourceSpan PositionedDeclarationRef $
- ValueRef <$> parseIdent
+ parseModuleRef <|>
+ withSourceSpan PositionedDeclarationRef
+ (ValueRef <$> parseIdent
<|> do name <- properName
dctors <- P.optionMaybe $ parens (symbol' ".." *> pure Nothing <|> Just <$> commaSep properName)
return $ maybe (TypeClassRef name) (TypeRef name) dctors
@@ -213,8 +204,8 @@ parseTypeClassDeclaration = do
mark (P.many (same *> positioned parseTypeDeclaration))
return $ TypeClassDeclaration className idents implies members
-parseTypeInstanceDeclaration :: TokenParser Declaration
-parseTypeInstanceDeclaration = do
+parseInstanceDeclaration :: TokenParser (TypeInstanceBody -> Declaration)
+parseInstanceDeclaration = do
reserved "instance"
name <- parseIdent <* indented <* doubleColon
deps <- P.optionMaybe $ do
@@ -224,24 +215,21 @@ parseTypeInstanceDeclaration = do
return deps
className <- indented *> parseQualified properName
ty <- P.many (indented *> noWildcards parseTypeAtom)
+ return $ TypeInstanceDeclaration name (fromMaybe [] deps) className ty
+
+parseTypeInstanceDeclaration :: TokenParser Declaration
+parseTypeInstanceDeclaration = do
+ instanceDecl <- parseInstanceDeclaration
members <- P.option [] . P.try $ do
indented *> reserved "where"
mark (P.many (same *> positioned parseValueDeclaration))
- return $ TypeInstanceDeclaration name (fromMaybe [] deps) className ty (ExplicitInstance members)
+ return $ instanceDecl (ExplicitInstance members)
parseDerivingInstanceDeclaration :: TokenParser Declaration
parseDerivingInstanceDeclaration = do
reserved "derive"
- reserved "instance"
- name <- parseIdent <* indented <* doubleColon
- deps <- P.optionMaybe $ do
- deps <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many (noWildcards parseTypeAtom)))
- indented
- rfatArrow
- return deps
- className <- indented *> parseQualified properName
- ty <- P.many (indented *> noWildcards parseTypeAtom)
- return $ TypeInstanceDeclaration name (fromMaybe [] deps) className ty DerivedInstance
+ instanceDecl <- parseInstanceDeclaration
+ return $ instanceDecl DerivedInstance
positioned :: TokenParser Declaration -> TokenParser Declaration
positioned = withSourceSpan PositionedDeclaration
@@ -305,7 +293,7 @@ parseModulesFromFiles toFilePath input = do
collect vss = [ (k, v) | (k, vs) <- vss, v <- vs ]
toPositionedError :: P.ParseError -> ErrorMessage
-toPositionedError perr = PositionedError (SourceSpan name start end) (SimpleErrorWrapper (ErrorParsingModule perr))
+toPositionedError perr = ErrorMessage [ PositionedError (SourceSpan name start end) ] (ErrorParsingModule perr)
where
name = (P.sourceName . P.errorPos) perr
start = (toSourcePos . P.errorPos) perr
@@ -366,7 +354,7 @@ parseConstructor = Constructor <$> C.parseQualified C.properName
parseCase :: TokenParser Expr
parseCase = Case <$> P.between (P.try (reserved "case")) (C.indented *> reserved "of") (return <$> parseValue)
- <*> (C.indented *> C.mark (P.many (C.same *> C.mark parseCaseAlternative)))
+ <*> (C.indented *> C.mark (P.many1 (C.same *> C.mark parseCaseAlternative)))
parseCaseAlternative :: TokenParser CaseAlternative
parseCaseAlternative = CaseAlternative <$> (return <$> parseBinder)
@@ -535,10 +523,13 @@ parseIdentifierAndBinder = do
-- Parse a binder
--
parseBinder :: TokenParser Binder
-parseBinder = withSourceSpan PositionedBinder (P.buildExpressionParser operators parseBinderAtom)
+parseBinder = withSourceSpan PositionedBinder (P.buildExpressionParser operators (buildPostfixParser postfixTable parseBinderAtom))
where
-- TODO: remove this deprecation warning in 0.8
operators = [ [ P.Infix (P.try $ C.indented *> colon *> featureWasRemoved "Cons binders are no longer supported. Consider using purescript-lists or purescript-sequences instead.") P.AssocRight ] ]
+ -- TODO: parsePolyType when adding support for polymorphic types
+ postfixTable = [ \b -> flip TypedBinder b <$> (P.try (indented *> doubleColon) *> parseType)
+ ]
parseBinderAtom :: TokenParser Binder
parseBinderAtom = P.choice (map P.try
[ parseNullBinder
diff --git a/src/Language/PureScript/Parser/Kinds.hs b/src/Language/PureScript/Parser/Kinds.hs
index 9773b42..f45473c 100644
--- a/src/Language/PureScript/Parser/Kinds.hs
+++ b/src/Language/PureScript/Parser/Kinds.hs
@@ -46,4 +46,4 @@ parseKind :: TokenParser Kind
parseKind = P.buildExpressionParser operators parseTypeAtom P.<?> "kind"
where
operators = [ [ P.Prefix (symbol' "#" >> return Row) ]
- , [ P.Infix ((P.try rarrow) >> return FunKind) P.AssocRight ] ]
+ , [ P.Infix (P.try rarrow >> return FunKind) P.AssocRight ] ]
diff --git a/src/Language/PureScript/Parser/Lexer.hs b/src/Language/PureScript/Parser/Lexer.hs
index 449c055..a4a2857 100644
--- a/src/Language/PureScript/Parser/Lexer.hs
+++ b/src/Language/PureScript/Parser/Lexer.hs
@@ -115,7 +115,7 @@ data Token
| CharLiteral Char
| StringLiteral String
| Number (Either Integer Double)
- deriving (Show, Eq, Ord)
+ deriving (Show, Read, Eq, Ord)
prettyPrintToken :: Token -> String
prettyPrintToken LParen = "("
@@ -153,8 +153,9 @@ data PositionedToken = PositionedToken
, ptComments :: [Comment]
} deriving (Eq)
+-- Parsec requires this instance for various token-level combinators
instance Show PositionedToken where
- show = show . ptToken
+ show = prettyPrintToken . ptToken
lex :: FilePath -> String -> Either P.ParseError [PositionedToken]
lex filePath input = P.parse parseTokens filePath input
@@ -251,7 +252,7 @@ parseToken = P.choice
where
-- lookAhead doesn't consume any input if its parser succeeds
-- if notFollowedBy fails though, the consumed '0' will break the choice chain
- consumeLeadingZero = P.lookAhead (P.char '0' >>
+ consumeLeadingZero = P.lookAhead (P.char '0' >>
(P.notFollowedBy P.digit P.<?> "no leading zero in number literal"))
-- |
@@ -478,7 +479,7 @@ identifier = token go P.<?> "identifier"
go _ = Nothing
validModuleName :: String -> Bool
-validModuleName s = not ('_' `elem` s)
+validModuleName s = '_' `notElem` s
-- |
-- A list of purescript reserved identifiers
@@ -517,4 +518,3 @@ reservedTypeNames = [ "forall", "where" ]
--
opChars :: [Char]
opChars = ":!#$%&*+./<=>?@\\^|-~"
-
diff --git a/src/Language/PureScript/Parser/Types.hs b/src/Language/PureScript/Parser/Types.hs
index a982abf..7cd1602 100644
--- a/src/Language/PureScript/Parser/Types.hs
+++ b/src/Language/PureScript/Parser/Types.hs
@@ -63,7 +63,7 @@ parseTypeConstructor = TypeConstructor <$> parseQualified properName
parseForAll :: TokenParser Type
parseForAll = mkForAll <$> (P.try (reserved "forall") *> P.many1 (indented *> identifier) <* indented <* dot)
- <*> parseConstrainedType
+ <*> parseType
-- |
-- Parse a type as it appears in e.g. a data constructor
@@ -79,21 +79,21 @@ parseTypeAtom = indented *> P.choice (map P.try
, parseTypeConstructor
, parseForAll
, parens parseRow
- , parens parsePolyType ])
+ , parseConstrainedType
+ , parens parsePolyType
+ ])
parseConstrainedType :: TokenParser Type
parseConstrainedType = do
- constraints <- P.optionMaybe . P.try $ do
- constraints <- parens . commaSep1 $ do
- className <- parseQualified properName
- indented
- ty <- P.many parseTypeAtom
- return (className, ty)
- _ <- rfatArrow
- return constraints
+ constraints <- parens . commaSep1 $ do
+ className <- parseQualified properName
+ indented
+ ty <- P.many parseTypeAtom
+ return (className, ty)
+ _ <- rfatArrow
indented
ty <- parseType
- return $ maybe ty (flip ConstrainedType ty) constraints
+ return $ ConstrainedType constraints ty
parseAnyType :: TokenParser Type
parseAnyType = P.buildExpressionParser operators (buildPostfixParser postfixTable parseTypeAtom) P.<?> "type"
diff --git a/src/Language/PureScript/Pretty/Common.hs b/src/Language/PureScript/Pretty/Common.hs
index 4c11054..ce6fc33 100644
--- a/src/Language/PureScript/Pretty/Common.hs
+++ b/src/Language/PureScript/Pretty/Common.hs
@@ -17,15 +17,18 @@ module Language.PureScript.Pretty.Common where
import Control.Monad.State
import Data.List (intercalate)
+
import Language.PureScript.Parser.Lexer (reservedPsNames, opChars)
+import Text.PrettyPrint.Boxes
+
-- |
-- Wrap a string in parentheses
--
parens :: String -> String
parens s = ('(':s) ++ ")"
-newtype PrinterState = PrinterState { indent :: Int } deriving (Show, Eq, Ord)
+newtype PrinterState = PrinterState { indent :: Int } deriving (Show, Read, Eq, Ord)
-- |
-- Number of characters per identation level
@@ -67,3 +70,11 @@ prettyPrintObjectKey :: String -> String
prettyPrintObjectKey s | s `elem` reservedPsNames = show s
| any (`elem` opChars) s = show s
| otherwise = s
+
+-- | Place a box before another, vertically when the first box takes up multiple lines.
+before :: Box -> Box -> Box
+before b1 b2 | rows b1 > 1 = b1 // b2
+ | otherwise = b1 <> b2
+
+beforeWithSpace :: Box -> Box -> Box
+beforeWithSpace b1 = before (b1 <> text " ")
diff --git a/src/Language/PureScript/Pretty/JS.hs b/src/Language/PureScript/Pretty/JS.hs
index 6fcf1cc..22a17ab 100644
--- a/src/Language/PureScript/Pretty/JS.hs
+++ b/src/Language/PureScript/Pretty/JS.hs
@@ -45,13 +45,13 @@ literals = mkPattern' match
match (JSStringLiteral s) = return $ string s
match (JSBooleanLiteral True) = return "true"
match (JSBooleanLiteral False) = return "false"
- match (JSArrayLiteral xs) = fmap concat $ sequence
+ match (JSArrayLiteral xs) = concat <$> sequence
[ return "[ "
- , fmap (intercalate ", ") $ forM xs prettyPrintJS'
+ , intercalate ", " <$> forM xs prettyPrintJS'
, return " ]"
]
match (JSObjectLiteral []) = return "{}"
- match (JSObjectLiteral ps) = fmap concat $ sequence
+ match (JSObjectLiteral ps) = concat <$> sequence
[ return "{\n"
, withIndent $ do
jss <- forM ps $ \(key, value) -> fmap ((objectPropertyToString key ++ ": ") ++) . prettyPrintJS' $ value
@@ -65,7 +65,7 @@ literals = mkPattern' match
objectPropertyToString :: String -> String
objectPropertyToString s | identNeedsEscaping s = show s
| otherwise = s
- match (JSBlock sts) = fmap concat $ sequence
+ match (JSBlock sts) = concat <$> sequence
[ return "{\n"
, withIndent $ prettyStatements sts
, return "\n"
@@ -73,23 +73,23 @@ literals = mkPattern' match
, return "}"
]
match (JSVar ident) = return ident
- match (JSVariableIntroduction ident value) = fmap concat $ sequence
+ match (JSVariableIntroduction ident value) = concat <$> sequence
[ return "var "
, return ident
, maybe (return "") (fmap (" = " ++) . prettyPrintJS') value
]
- match (JSAssignment target value) = fmap concat $ sequence
+ match (JSAssignment target value) = concat <$> sequence
[ prettyPrintJS' target
, return " = "
, prettyPrintJS' value
]
- match (JSWhile cond sts) = fmap concat $ sequence
+ match (JSWhile cond sts) = concat <$> sequence
[ return "while ("
, prettyPrintJS' cond
, return ") "
, prettyPrintJS' sts
]
- match (JSFor ident start end sts) = fmap concat $ sequence
+ match (JSFor ident start end sts) = concat <$> sequence
[ return $ "for (var " ++ ident ++ " = "
, prettyPrintJS' start
, return $ "; " ++ ident ++ " < "
@@ -97,30 +97,30 @@ literals = mkPattern' match
, return $ "; " ++ ident ++ "++) "
, prettyPrintJS' sts
]
- match (JSForIn ident obj sts) = fmap concat $ sequence
+ match (JSForIn ident obj sts) = concat <$> sequence
[ return $ "for (var " ++ ident ++ " in "
, prettyPrintJS' obj
, return ") "
, prettyPrintJS' sts
]
- match (JSIfElse cond thens elses) = fmap concat $ sequence
+ match (JSIfElse cond thens elses) = concat <$> sequence
[ return "if ("
, prettyPrintJS' cond
, return ") "
, prettyPrintJS' thens
, maybe (return "") (fmap (" else " ++) . prettyPrintJS') elses
]
- match (JSReturn value) = fmap concat $ sequence
+ match (JSReturn value) = concat <$> sequence
[ return "return "
, prettyPrintJS' value
]
- match (JSThrow value) = fmap concat $ sequence
+ match (JSThrow value) = concat <$> sequence
[ return "throw "
, prettyPrintJS' value
]
match (JSBreak lbl) = return $ "break " ++ lbl
match (JSContinue lbl) = return $ "continue " ++ lbl
- match (JSLabel lbl js) = fmap concat $ sequence
+ match (JSLabel lbl js) = concat <$> sequence
[ return $ lbl ++ ": "
, prettyPrintJS' js
]
diff --git a/src/Language/PureScript/Pretty/Kinds.hs b/src/Language/PureScript/Pretty/Kinds.hs
index 53f8f82..236dd56 100644
--- a/src/Language/PureScript/Pretty/Kinds.hs
+++ b/src/Language/PureScript/Pretty/Kinds.hs
@@ -45,14 +45,13 @@ funKind = mkPattern match
match (FunKind arg ret) = Just (arg, ret)
match _ = Nothing
--- |
--- Generate a pretty-printed string representing a Kind
---
+-- | Generate a pretty-printed string representing a Kind
prettyPrintKind :: Kind -> String
prettyPrintKind = fromMaybe (error "Incomplete pattern") . pattern matchKind ()
where
matchKind :: Pattern () Kind String
matchKind = buildPrettyPrinter operators (typeLiterals <+> fmap parens matchKind)
+
operators :: OperatorTable () Kind String
operators =
OperatorTable [ [ Wrap matchRow $ \_ k -> "# " ++ k]
diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs
index 37e006c..e975743 100644
--- a/src/Language/PureScript/Pretty/Types.hs
+++ b/src/Language/PureScript/Pretty/Types.hs
@@ -14,53 +14,76 @@
-----------------------------------------------------------------------------
module Language.PureScript.Pretty.Types (
+ typeAsBox,
prettyPrintType,
+ typeAtomAsBox,
prettyPrintTypeAtom,
+ prettyPrintRowWith,
prettyPrintRow
) where
import Data.Maybe (fromMaybe)
-import Data.List (intercalate)
import Control.Arrow ((<+>))
import Control.PatternArrows
import Language.PureScript.Types
+import Language.PureScript.Names
import Language.PureScript.Kinds
import Language.PureScript.Pretty.Common
import Language.PureScript.Pretty.Kinds
import Language.PureScript.Environment
-typeLiterals :: Pattern () Type String
+import Text.PrettyPrint.Boxes hiding ((<+>))
+
+typeLiterals :: Pattern () Type Box
typeLiterals = mkPattern match
where
- match TypeWildcard = Just "_"
- match (TypeVar var) = Just var
- match (PrettyPrintObject row) = Just $ "{ " ++ prettyPrintRow row ++ " }"
- match (TypeConstructor ctor) = Just $ show ctor
- match (TUnknown u) = Just $ '_' : show u
- match (Skolem name s _) = Just $ name ++ show s
- match (ConstrainedType deps ty) = Just $ "(" ++ intercalate ", " (map (\(pn, ty') -> show pn ++ " " ++ unwords (map prettyPrintTypeAtom ty')) deps) ++ ") => " ++ prettyPrintType ty
- match (SaturatedTypeSynonym name args) = Just $ show name ++ "<" ++ intercalate "," (map prettyPrintTypeAtom args) ++ ">"
- match REmpty = Just "()"
- match row@RCons{} = Just $ '(' : prettyPrintRow row ++ ")"
+ match TypeWildcard = Just $ text "_"
+ match (TypeVar var) = Just $ text var
+ match (PrettyPrintObject row) = Just $ prettyPrintRowWith '{' '}' row
+ match (TypeConstructor ctor) = Just $ text $ runProperName $ disqualify ctor
+ match (TUnknown u) = Just $ text $ '_' : show u
+ match (Skolem name s _) = Just $ text $ name ++ show s
+ match (ConstrainedType deps ty) = Just $ constraintsAsBox deps ty
+ match REmpty = Just $ text "()"
+ match row@RCons{} = Just $ prettyPrintRowWith '(' ')' row
match _ = Nothing
+constraintsAsBox :: [(Qualified ProperName, [Type])] -> Type -> Box
+constraintsAsBox [(pn, tys)] ty = text "(" <> constraintAsBox pn tys <> text ") => " <> typeAsBox ty
+constraintsAsBox xs ty = vcat left (zipWith (\i (pn, tys) -> text (if i == 0 then "( " else ", ") <> constraintAsBox pn tys) [0 :: Int ..] xs) `before` (text ") => " <> typeAsBox ty)
+
+constraintAsBox :: Qualified ProperName -> [Type] -> Box
+constraintAsBox pn tys = hsep 1 left (text (runProperName (disqualify pn)) : map typeAtomAsBox tys)
+
-- |
-- Generate a pretty-printed string representing a Row
--
-prettyPrintRow :: Type -> String
-prettyPrintRow = (\(tys, rest) -> intercalate ", " (map (uncurry nameAndTypeToPs) tys) ++ tailToPs rest) . toList []
+prettyPrintRowWith :: Char -> Char -> Type -> Box
+prettyPrintRowWith open close = uncurry listToBox . toList []
where
- nameAndTypeToPs :: String -> Type -> String
- nameAndTypeToPs name ty = prettyPrintObjectKey name ++ " :: " ++ prettyPrintType ty
- tailToPs :: Type -> String
- tailToPs REmpty = ""
- tailToPs other = " | " ++ prettyPrintType other
+ nameAndTypeToPs :: Char -> String -> Type -> Box
+ nameAndTypeToPs start name ty = text (start : ' ' : prettyPrintObjectKey name ++ " :: ") <> typeAsBox ty
+
+ tailToPs :: Type -> Box
+ tailToPs REmpty = nullBox
+ tailToPs other = text "| " <> typeAsBox other
+
+ listToBox :: [(String, Type)] -> Type -> Box
+ listToBox [] REmpty = text [open, close]
+ listToBox [] rest = text [ open, ' ' ] <> tailToPs rest <> text [ ' ', close ]
+ listToBox ts rest = vcat left $
+ zipWith (\(nm, ty) i -> nameAndTypeToPs (if i == 0 then open else ',') nm ty) ts [0 :: Int ..] ++
+ [ tailToPs rest, text [close] ]
+
toList :: [(String, Type)] -> Type -> ([(String, Type)], Type)
toList tys (RCons name ty row) = toList ((name, ty):tys) row
toList tys r = (tys, r)
+prettyPrintRow :: Type -> String
+prettyPrintRow = render . prettyPrintRowWith '(' ')'
+
typeApp :: Pattern () Type (Type, Type)
typeApp = mkPattern match
where
@@ -91,19 +114,19 @@ insertPlaceholders = everywhereOnTypesTopDown convertForAlls . everywhereOnTypes
go idents other = PrettyPrintForAll idents other
convertForAlls other = other
-matchTypeAtom :: Pattern () Type String
-matchTypeAtom = typeLiterals <+> fmap parens matchType
+matchTypeAtom :: Pattern () Type Box
+matchTypeAtom = typeLiterals <+> fmap ((`before` text ")") . (text "(" <>)) matchType
-matchType :: Pattern () Type String
+matchType :: Pattern () Type Box
matchType = buildPrettyPrinter operators matchTypeAtom
where
- operators :: OperatorTable () Type String
+ operators :: OperatorTable () Type Box
operators =
- OperatorTable [ [ AssocL typeApp $ \f x -> f ++ " " ++ x ]
- , [ AssocR appliedFunction $ \arg ret -> arg ++ " -> " ++ ret
+ OperatorTable [ [ AssocL typeApp $ \f x -> f `beforeWithSpace` x ]
+ , [ AssocR appliedFunction $ \arg ret -> (arg <> text " ") `before` (text "-> " <> ret)
]
- , [ Wrap forall_ $ \idents ty -> "forall " ++ unwords idents ++ ". " ++ ty ]
- , [ Wrap kinded $ \k ty -> ty ++ " :: " ++ prettyPrintKind k ]
+ , [ Wrap forall_ $ \idents ty -> text ("forall " ++ unwords idents ++ ". ") <> ty ]
+ , [ Wrap kinded $ \k ty -> ty `before` (text (" :: " ++ prettyPrintKind k)) ]
]
forall_ :: Pattern () Type ([String], Type)
@@ -112,16 +135,16 @@ forall_ = mkPattern match
match (PrettyPrintForAll idents ty) = Just (idents, ty)
match _ = Nothing
--- |
--- Generate a pretty-printed string representing a Type, as it should appear inside parentheses
---
+typeAtomAsBox :: Type -> Box
+typeAtomAsBox = fromMaybe (error "Incomplete pattern") . pattern matchTypeAtom () . insertPlaceholders
+
+-- | Generate a pretty-printed string representing a Type, as it should appear inside parentheses
prettyPrintTypeAtom :: Type -> String
-prettyPrintTypeAtom = fromMaybe (error "Incomplete pattern") . pattern matchTypeAtom () . insertPlaceholders
+prettyPrintTypeAtom = render . typeAtomAsBox
+typeAsBox :: Type -> Box
+typeAsBox = fromMaybe (error "Incomplete pattern") . pattern matchType () . insertPlaceholders
--- |
--- Generate a pretty-printed string representing a Type
---
+-- | Generate a pretty-printed string representing a Type
prettyPrintType :: Type -> String
-prettyPrintType = fromMaybe (error "Incomplete pattern") . pattern matchType () . insertPlaceholders
-
+prettyPrintType = render . typeAsBox
diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs
index e476b37..2e35813 100644
--- a/src/Language/PureScript/Pretty/Values.hs
+++ b/src/Language/PureScript/Pretty/Values.hs
@@ -21,194 +21,139 @@ module Language.PureScript.Pretty.Values (
prettyPrintBinderAtom
) where
-import Data.Maybe (fromMaybe)
import Data.List (intercalate)
-import Control.Arrow ((<+>), runKleisli, second)
-import Control.PatternArrows
-import Control.Monad.State
-#if __GLASGOW_HASKELL__ < 710
-import Control.Applicative
-#endif
+import Control.Arrow (second)
import Language.PureScript.AST
import Language.PureScript.Names
import Language.PureScript.Pretty.Common
-import Language.PureScript.Pretty.Types (prettyPrintType, prettyPrintTypeAtom)
+import Language.PureScript.Pretty.Types (typeAsBox, typeAtomAsBox)
-literals :: Pattern PrinterState Expr String
-literals = mkPattern' match
+import Text.PrettyPrint.Boxes
+
+-- | Render an aligned list of items separated with commas
+list :: Char -> Char -> (a -> Box) -> [a] -> Box
+list open close _ [] = text [open, close]
+list open close f xs = vcat left (zipWith toLine [0 :: Int ..] xs ++ [ text [ close ] ])
where
- match :: Expr -> StateT PrinterState Maybe String
- match (NumericLiteral n) = return $ either show show n
- match (StringLiteral s) = return $ show s
- match (CharLiteral c) = return $ show c
- match (BooleanLiteral True) = return "true"
- match (BooleanLiteral False) = return "false"
- match (ArrayLiteral xs) = return $ "[" ++ intercalate ", " (map prettyPrintValue xs) ++ "]"
- match (ObjectLiteral ps) = prettyPrintObject' $ second Just `map` ps
- match (ObjectConstructor ps) = prettyPrintObject' ps
- match (ObjectGetter prop) = return $ "(." ++ prop ++ ")"
- match (TypeClassDictionaryConstructorApp className ps) = concat <$> sequence
- [ return (show className ++ "(\n")
- , match ps
- , return ")"
- ]
- match (Constructor name) = return $ show name
- match (Case values binders) = concat <$> sequence
- [ return "case "
- , unwords <$> forM values prettyPrintValue'
- , return " of\n"
- , withIndent $ prettyPrintMany prettyPrintCaseAlternative binders
- , currentIndent
- ]
- match (Let ds val) = concat <$> sequence
- [ return "let\n"
- , withIndent $ prettyPrintMany prettyPrintDeclaration ds
- , return "\n"
- , currentIndent
- , return "in "
- , prettyPrintValue' val
- ]
- match (Var ident) = return $ show ident
- match (Do els) = concat <$> sequence
- [ return "do\n"
- , withIndent $ prettyPrintMany prettyPrintDoNotationElement els
- , currentIndent
- ]
- match (OperatorSection op (Right val)) = return $ "(" ++ prettyPrintValue op ++ " " ++ prettyPrintValue val ++ ")"
- match (OperatorSection op (Left val)) = return $ "(" ++ prettyPrintValue val ++ " " ++ prettyPrintValue op ++ ")"
- match (TypeClassDictionary (name, tys) _) = return $ "<<dict " ++ show name ++ " " ++ unwords (map prettyPrintTypeAtom tys) ++ ">>"
- match (SuperClassDictionary name _) = return $ "<<superclass dict " ++ show name ++ ">>"
- match (TypedValue _ val _) = prettyPrintValue' val
- match (PositionedValue _ _ val) = prettyPrintValue' val
- match _ = mzero
-
-prettyPrintDeclaration :: Declaration -> StateT PrinterState Maybe String
-prettyPrintDeclaration (TypeDeclaration ident ty) = return $ show ident ++ " :: " ++ prettyPrintType ty
-prettyPrintDeclaration (ValueDeclaration ident _ [] (Right val)) = concat <$> sequence
- [ return $ show ident ++ " = "
- , prettyPrintValue' val
- ]
+ toLine i a = text [ if i == 0 then open else ',', ' ' ] <> f a
+
+prettyPrintObject :: [(String, Maybe Expr)] -> Box
+prettyPrintObject = list '{' '}' prettyPrintObjectProperty
+ where
+ prettyPrintObjectProperty :: (String, Maybe Expr) -> Box
+ prettyPrintObjectProperty (key, value) = text (prettyPrintObjectKey key ++ ": ") <> maybe (text "_") prettyPrintValue value
+
+-- | Pretty-print an expression
+prettyPrintValue :: Expr -> Box
+prettyPrintValue (IfThenElse cond th el) =
+ (text "if " <> prettyPrintValueAtom cond)
+ // moveRight 2 (vcat left [ text "then " <> prettyPrintValueAtom th
+ , text "else " <> prettyPrintValueAtom el
+ ])
+prettyPrintValue (Accessor prop val) = prettyPrintValueAtom val <> text ("." ++ show prop)
+prettyPrintValue (ObjectUpdate o ps) = prettyPrintValueAtom o <> text " " <> list '{' '}' (\(key, val) -> text (key ++ " = ") <> prettyPrintValue val) ps
+prettyPrintValue (ObjectUpdater o ps) = maybe (text "_") prettyPrintValueAtom o <> text " " <> list '{' '}' (\(key, val) -> text (key ++ " = ") <> maybe (text "_") prettyPrintValue val) ps
+prettyPrintValue (App val arg) = prettyPrintValueAtom val `beforeWithSpace` prettyPrintValueAtom arg
+prettyPrintValue (Abs (Left arg) val) = text ('\\' : showIdent arg ++ " -> ") // moveRight 2 (prettyPrintValue val)
+prettyPrintValue (TypeClassDictionaryConstructorApp className ps) =
+ text (runProperName (disqualify className) ++ " ") <> prettyPrintValueAtom ps
+prettyPrintValue (Case values binders) =
+ (text "case " <> foldl1 beforeWithSpace (map prettyPrintValueAtom values) <> text " of") //
+ moveRight 2 (vcat left (map prettyPrintCaseAlternative binders))
+prettyPrintValue (Let ds val) =
+ text "let" //
+ moveRight 2 (vcat left (map prettyPrintDeclaration ds)) //
+ (text "in " <> prettyPrintValue val)
+prettyPrintValue (Do els) =
+ text "do " <> vcat left (map prettyPrintDoNotationElement els)
+prettyPrintValue (TypeClassDictionary (name, tys) _) = foldl1 beforeWithSpace $ text ("#dict " ++ runProperName (disqualify name)) : map typeAtomAsBox tys
+prettyPrintValue (SuperClassDictionary name _) = text $ "#dict " ++ runProperName (disqualify name)
+prettyPrintValue (TypedValue _ val _) = prettyPrintValue val
+prettyPrintValue (PositionedValue _ _ val) = prettyPrintValue val
+prettyPrintValue expr = prettyPrintValueAtom expr
+
+-- | Pretty-print an atomic expression, adding parentheses if necessary.
+prettyPrintValueAtom :: Expr -> Box
+prettyPrintValueAtom (NumericLiteral n) = text $ either show show n
+prettyPrintValueAtom (StringLiteral s) = text $ show s
+prettyPrintValueAtom (CharLiteral c) = text $ show c
+prettyPrintValueAtom (BooleanLiteral True) = text "true"
+prettyPrintValueAtom (BooleanLiteral False) = text "false"
+prettyPrintValueAtom (ArrayLiteral xs) = list '[' ']' prettyPrintValue xs
+prettyPrintValueAtom (ObjectLiteral ps) = prettyPrintObject $ second Just `map` ps
+prettyPrintValueAtom (ObjectConstructor ps) = prettyPrintObject ps
+prettyPrintValueAtom (ObjectGetter prop) = text $ "_." ++ show prop
+prettyPrintValueAtom (Constructor name) = text $ runProperName (disqualify name)
+prettyPrintValueAtom (Var ident) = text $ showIdent (disqualify ident)
+prettyPrintValueAtom (OperatorSection op (Right val)) = ((text "(" <> prettyPrintValue op) `beforeWithSpace` prettyPrintValue val) `before` text ")"
+prettyPrintValueAtom (OperatorSection op (Left val)) = ((text "(" <> prettyPrintValue val) `beforeWithSpace` prettyPrintValue op) `before` text ")"
+prettyPrintValueAtom (TypedValue _ val _) = prettyPrintValueAtom val
+prettyPrintValueAtom (PositionedValue _ _ val) = prettyPrintValueAtom val
+prettyPrintValueAtom expr = (text "(" <> prettyPrintValue expr) `before` text ")"
+
+prettyPrintDeclaration :: Declaration -> Box
+prettyPrintDeclaration (TypeDeclaration ident ty) =
+ text (showIdent ident ++ " :: ") <> typeAsBox ty
+prettyPrintDeclaration (ValueDeclaration ident _ [] (Right val)) =
+ text (showIdent ident ++ " = ") <> prettyPrintValue val
+prettyPrintDeclaration (BindingGroupDeclaration ds) =
+ vsep 1 left (map (prettyPrintDeclaration . toDecl) ds)
+ where
+ toDecl (nm, t, e) = ValueDeclaration nm t [] (Right e)
prettyPrintDeclaration (PositionedDeclaration _ _ d) = prettyPrintDeclaration d
prettyPrintDeclaration _ = error "Invalid argument to prettyPrintDeclaration"
-prettyPrintCaseAlternative :: CaseAlternative -> StateT PrinterState Maybe String
+prettyPrintCaseAlternative :: CaseAlternative -> Box
prettyPrintCaseAlternative (CaseAlternative binders result) =
- concat <$> sequence
- [ return (unwords (map prettyPrintBinderAtom binders))
- , prettyPrintResult result
- ]
+ text (unwords (map prettyPrintBinderAtom binders)) <> prettyPrintResult result
where
- prettyPrintResult (Left gs) = concat <$> sequence
- [ return "\n"
- , withIndent $ prettyPrintMany prettyPrintGuardedValue gs
- ]
- prettyPrintResult (Right v) = (" -> " ++) <$> prettyPrintValue' v
-
- prettyPrintGuardedValue (grd, val) =
- concat <$> sequence
- [ return "| "
- , prettyPrintValue' grd
- , return " -> "
- , prettyPrintValue' val
- ]
-
-prettyPrintDoNotationElement :: DoNotationElement -> StateT PrinterState Maybe String
+ prettyPrintResult :: Either [(Guard, Expr)] Expr -> Box
+ prettyPrintResult (Left gs) =
+ vcat left (map prettyPrintGuardedValue gs)
+ prettyPrintResult (Right v) = text " -> " <> prettyPrintValue v
+
+ prettyPrintGuardedValue :: (Guard, Expr) -> Box
+ prettyPrintGuardedValue (grd, val) = foldl1 before
+ [ text " | "
+ , prettyPrintValue grd
+ , text " -> "
+ , prettyPrintValue val
+ ]
+
+prettyPrintDoNotationElement :: DoNotationElement -> Box
prettyPrintDoNotationElement (DoNotationValue val) =
- prettyPrintValue' val
+ prettyPrintValue val
prettyPrintDoNotationElement (DoNotationBind binder val) =
- concat <$> sequence
- [ return (prettyPrintBinder binder)
- , return " <- "
- , prettyPrintValue' val
- ]
+ text (prettyPrintBinder binder ++ " <- ") <> prettyPrintValue val
prettyPrintDoNotationElement (DoNotationLet ds) =
- concat <$> sequence
- [ return "let "
- , withIndent $ prettyPrintMany prettyPrintDeclaration ds
- ]
+ text "let" //
+ moveRight 2 (vcat left (map prettyPrintDeclaration ds))
prettyPrintDoNotationElement (PositionedDoNotationElement _ _ el) = prettyPrintDoNotationElement el
-prettyPrintObject' :: [(String, Maybe Expr)] -> StateT PrinterState Maybe String
-prettyPrintObject' [] = return "{}"
-prettyPrintObject' ps = return $ "{ " ++ intercalate ", " (map prettyPrintObjectProperty ps) ++ "}"
- where
- prettyPrintObjectProperty :: (String, Maybe Expr) -> String
- prettyPrintObjectProperty (key, value) = prettyPrintObjectKey key ++ ": " ++ maybe "_" prettyPrintValue value
-
-ifThenElse :: Pattern PrinterState Expr ((Expr, Expr), Expr)
-ifThenElse = mkPattern match
- where
- match (IfThenElse cond th el) = Just ((th, el), cond)
- match _ = Nothing
-
-accessor :: Pattern PrinterState Expr (String, Expr)
-accessor = mkPattern match
- where
- match (Accessor prop val) = Just (prop, val)
- match _ = Nothing
-
-objectUpdate :: Pattern PrinterState Expr ([String], Expr)
-objectUpdate = mkPattern match
- where
- match (ObjectUpdate o ps) = Just (flip map ps $ \(key, val) -> key ++ " = " ++ prettyPrintValue val, o)
- match (ObjectUpdater o ps) = Just (flip map ps $ \(key, val) -> key ++ " = " ++ maybe "_" prettyPrintValue val, fromMaybe (Var (Qualified Nothing $ Ident "_")) o)
- match _ = Nothing
-
-app :: Pattern PrinterState Expr (String, Expr)
-app = mkPattern match
- where
- match (App val arg) = Just (prettyPrintValue arg, val)
- match _ = Nothing
-
-lam :: Pattern PrinterState Expr (String, Expr)
-lam = mkPattern match
- where
- match (Abs (Left arg) val) = Just (show arg, val)
- match _ = Nothing
-
--- |
--- Generate a pretty-printed string representing an expression
---
-prettyPrintValue :: Expr -> String
-prettyPrintValue = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyPrintValue'
-
-prettyPrintValue' :: Expr -> StateT PrinterState Maybe String
-prettyPrintValue' = runKleisli $ runPattern matchValue
- where
- matchValue :: Pattern PrinterState Expr String
- matchValue = buildPrettyPrinter operators (literals <+> fmap parens matchValue)
- operators :: OperatorTable PrinterState Expr String
- operators =
- OperatorTable [ [ Wrap accessor $ \prop val -> val ++ "." ++ prop ]
- , [ Wrap objectUpdate $ \ps val -> val ++ "{ " ++ intercalate ", " ps ++ " }" ]
- , [ Wrap app $ \arg val -> val ++ "(" ++ arg ++ ")" ]
- , [ Split lam $ \arg val -> "\\" ++ arg ++ " -> " ++ prettyPrintValue val ]
- , [ Wrap ifThenElse $ \(th, el) cond -> "if " ++ cond ++ " then " ++ prettyPrintValue th ++ " else " ++ prettyPrintValue el ]
- ]
-
prettyPrintBinderAtom :: Binder -> String
+
prettyPrintBinderAtom NullBinder = "_"
prettyPrintBinderAtom (StringBinder str) = show str
prettyPrintBinderAtom (CharBinder c) = show c
prettyPrintBinderAtom (NumberBinder num) = either show show num
prettyPrintBinderAtom (BooleanBinder True) = "true"
prettyPrintBinderAtom (BooleanBinder False) = "false"
-prettyPrintBinderAtom (VarBinder ident) = show ident
-prettyPrintBinderAtom (ConstructorBinder ctor []) = show ctor
-prettyPrintBinderAtom (ObjectBinder bs) =
- "{ "
+prettyPrintBinderAtom (VarBinder ident) = showIdent ident
+prettyPrintBinderAtom (ConstructorBinder ctor []) = runProperName (disqualify ctor)
+prettyPrintBinderAtom (ObjectBinder bs) =
+ "{ "
++ intercalate ", " (map prettyPrintObjectPropertyBinder bs)
++ " }"
where
prettyPrintObjectPropertyBinder :: (String, Binder) -> String
prettyPrintObjectPropertyBinder (key, binder) = prettyPrintObjectKey key ++ ": " ++ prettyPrintBinder binder
prettyPrintBinderAtom (ArrayBinder bs) =
- "[ "
+ "[ "
++ intercalate ", " (map prettyPrintBinder bs)
++ " ]"
-prettyPrintBinderAtom (NamedBinder ident binder) = show ident ++ "@" ++ prettyPrintBinder binder
+prettyPrintBinderAtom (NamedBinder ident binder) = showIdent ident ++ "@" ++ prettyPrintBinder binder
prettyPrintBinderAtom (PositionedBinder _ _ binder) = prettyPrintBinderAtom binder
prettyPrintBinderAtom b = parens (prettyPrintBinder b)
@@ -216,7 +161,8 @@ prettyPrintBinderAtom b = parens (prettyPrintBinder b)
-- Generate a pretty-printed string representing a Binder
--
prettyPrintBinder :: Binder -> String
-prettyPrintBinder (ConstructorBinder ctor []) = show ctor
-prettyPrintBinder (ConstructorBinder ctor args) = show ctor ++ " " ++ unwords (map prettyPrintBinderAtom args)
+prettyPrintBinder (ConstructorBinder ctor []) = runProperName (disqualify ctor)
+prettyPrintBinder (ConstructorBinder ctor args) = runProperName (disqualify ctor) ++ " " ++ unwords (map prettyPrintBinderAtom args)
prettyPrintBinder (PositionedBinder _ _ binder) = prettyPrintBinder binder
+prettyPrintBinder (TypedBinder _ binder) = prettyPrintBinder binder
prettyPrintBinder b = prettyPrintBinderAtom b
diff --git a/src/Language/PureScript/Publish.hs b/src/Language/PureScript/Publish.hs
index b8e8453..e80c964 100644
--- a/src/Language/PureScript/Publish.hs
+++ b/src/Language/PureScript/Publish.hs
@@ -23,7 +23,6 @@ import Prelude hiding (userError)
import Data.Maybe
import Data.Char (isSpace)
-import Data.String (fromString)
import Data.List (stripPrefix, isSuffixOf, (\\), nubBy)
import Data.List.Split (splitOn)
import Data.List.NonEmpty (NonEmpty(..))
@@ -32,6 +31,8 @@ import Data.Function (on)
import Safe (headMay)
import Data.Aeson.BetterErrors
import qualified Data.Text as T
+import qualified Data.Text.Lazy as TL
+import qualified Data.Text.Lazy.Encoding as TL
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
@@ -146,13 +147,13 @@ getModulesAndBookmarks = do
renderModules bookmarks modules =
return (bookmarks, map D.convertModule modules)
-data TreeStatus = Clean | Dirty deriving (Show, Eq, Ord, Enum)
+data TreeStatus = Clean | Dirty deriving (Show, Read, Eq, Ord, Enum)
getGitWorkingTreeStatus :: PrepareM TreeStatus
getGitWorkingTreeStatus = do
out <- readProcess' "git" ["status", "--porcelain"] ""
return $
- if null . filter (not . null) . lines $ out
+ if all null . lines $ out
then Clean
else Dirty
@@ -227,7 +228,7 @@ data DependencyStatus
| ResolvedVersion String
-- ^ Resolved to a version. The String argument is the resolution tag (eg,
-- "v0.1.0").
- deriving (Show, Eq)
+ deriving (Show, Read, Eq)
-- Go through all bower dependencies which contain purescript code, and
-- extract their versions.
@@ -245,7 +246,7 @@ data DependencyStatus
getResolvedDependencies :: [PackageName] -> PrepareM [(PackageName, Version)]
getResolvedDependencies declaredDeps = do
bower <- findBowerExecutable
- depsBS <- fromString <$> readProcess' bower ["list", "--json", "--offline"] ""
+ depsBS <- packUtf8 <$> readProcess' bower ["list", "--json", "--offline"] ""
-- Check for undeclared dependencies
toplevels <- catchJSON (parse asToplevelDependencies depsBS)
@@ -255,6 +256,7 @@ getResolvedDependencies declaredDeps = do
handleDeps deps
where
+ packUtf8 = TL.encodeUtf8 . TL.pack
catchJSON = flip catchLeft (internalError . JSONError FromBowerList)
findBowerExecutable :: PrepareM String
diff --git a/src/Language/PureScript/Publish/ErrorsWarnings.hs b/src/Language/PureScript/Publish/ErrorsWarnings.hs
index b4d5125..7224438 100644
--- a/src/Language/PureScript/Publish/ErrorsWarnings.hs
+++ b/src/Language/PureScript/Publish/ErrorsWarnings.hs
@@ -98,10 +98,10 @@ renderError err =
case err of
UserError e ->
vcat
- [ para (concat
- [ "There is a problem with your package, which meant that "
- , "it could not be published."
- ])
+ [ para (
+ "There is a problem with your package, which meant that " ++
+ "it could not be published."
+ )
, para "Details:"
, indented (displayUserError e)
]
@@ -123,10 +123,10 @@ renderError err =
displayUserError :: UserError -> Box
displayUserError e = case e of
BowerJSONNotFound ->
- para (concat
- [ "The bower.json file was not found. Please create one, or run "
- , "`pulp init`."
- ])
+ para (
+ "The bower.json file was not found. Please create one, or run " ++
+ "`pulp init`."
+ )
BowerExecutableNotFound names ->
para (concat
[ "The Bower executable was not found (tried: ", format names, "). Please"
@@ -162,6 +162,12 @@ displayUserError e = case e of
, para "Note: tagged versions must be in one of the following forms:"
, indented (para "* v{MAJOR}.{MINOR}.{PATCH} (example: \"v1.6.2\")")
, indented (para "* {MAJOR}.{MINOR}.{PATCH} (example: \"1.6.2\")")
+ , spacer
+ , para (concat
+ [ "If the version you are publishing is not yet tagged, you might want to use"
+ , "the --dry-run flag instead, which removes this requirement. Run"
+ , "psc-publish --help for more details."
+ ])
]
AmbiguousVersions vs ->
vcat $
@@ -198,7 +204,7 @@ displayUserError e = case e of
ParseAndDesugarError (D.ParseError err) ->
vcat
[ para "Parse error:"
- , indented (para (show err))
+ , indented (P.prettyPrintMultipleErrorsBox False err)
]
ParseAndDesugarError (D.SortModulesError err) ->
vcat
@@ -211,10 +217,10 @@ displayUserError e = case e of
, indented (P.prettyPrintMultipleErrorsBox False err)
]
DirtyWorkingTree ->
- para (concat
- [ "Your git working tree is dirty. Please commit, discard, or stash "
- , "your changes first."
- ])
+ para (
+ "Your git working tree is dirty. Please commit, discard, or stash " ++
+ "your changes first."
+ )
displayRepositoryError :: RepositoryFieldError -> Box
displayRepositoryError err = case err of
@@ -350,12 +356,11 @@ warnUndeclaredDependencies pkgNames =
are = pl "are" "is"
dependencies = pl "dependencies" "a dependency"
in vcat $
- [ para (concat
+ para (concat
[ "The following Bower ", packages, " ", are, " installed, but not "
, "declared as ", dependencies, " in your bower.json file:"
])
- ] ++
- bulletedList runPackageName (NonEmpty.toList pkgNames)
+ : bulletedList runPackageName (NonEmpty.toList pkgNames)
warnUnacceptableVersions :: NonEmpty (PackageName, String) -> Box
warnUnacceptableVersions pkgs =
diff --git a/src/Language/PureScript/Renamer.hs b/src/Language/PureScript/Renamer.hs
index 7576e51..ab20854 100644
--- a/src/Language/PureScript/Renamer.hs
+++ b/src/Language/PureScript/Renamer.hs
@@ -80,12 +80,12 @@ updateScope :: Ident -> Rename Ident
updateScope i@(Ident name) | name == C.__unused = return i
updateScope name = do
scope <- get
- name' <- case name `S.member` rsUsedNames scope of
- True -> do
+ name' <- if name `S.member` rsUsedNames scope
+ then do
let newNames = [ Ident (runIdent name ++ "_" ++ show (i :: Int)) | i <- [1..] ]
Just newName = find (`S.notMember` rsUsedNames scope) newNames
return newName
- False -> return name
+ else return name
modify $ \s -> s { rsBoundNames = M.insert name name' (rsBoundNames s)
, rsUsedNames = S.insert name' (rsUsedNames s)
}
@@ -100,7 +100,7 @@ lookupIdent name = do
name' <- gets $ M.lookup name . rsBoundNames
case name' of
Just name'' -> return name''
- Nothing -> error $ "Rename scope is missing ident '" ++ show name ++ "'"
+ Nothing -> error $ "Rename scope is missing ident '" ++ showIdent name ++ "'"
-- |
-- Finds idents introduced by declarations.
@@ -119,7 +119,7 @@ renameInModules = map go
where
go :: Module Ann -> Module Ann
go m@(Module _ _ _ _ _ decls) = m { moduleDecls = map (renameInDecl' (findDeclIdents decls)) decls }
-
+
renameInDecl' :: [Ident] -> Bind Ann -> Bind Ann
renameInDecl' scope = runRename scope . renameInDecl True
diff --git a/src/Language/PureScript/Sugar.hs b/src/Language/PureScript/Sugar.hs
index eeafd21..ba37227 100644
--- a/src/Language/PureScript/Sugar.hs
+++ b/src/Language/PureScript/Sugar.hs
@@ -29,6 +29,7 @@ import Control.Monad.Supply.Class
import Language.PureScript.AST
import Language.PureScript.Errors
+import Language.PureScript.Externs
import Language.PureScript.Sugar.BindingGroups as S
import Language.PureScript.Sugar.CaseDeclarations as S
@@ -63,15 +64,16 @@ import Language.PureScript.Sugar.TypeDeclarations as S
--
-- * Group mutually recursive value and data declarations into binding groups.
--
-desugar :: (Applicative m, MonadSupply m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [Module] -> m [Module]
-desugar = map removeSignedLiterals
- >>> mapM desugarObjectConstructors
- >=> mapM desugarOperatorSections
- >=> mapM desugarDoModule
- >=> desugarCasesModule
- >=> desugarTypeDeclarationsModule
- >=> desugarImports
- >=> rebracket
- >=> mapM deriveInstances
- >=> desugarTypeClasses
- >=> createBindingGroupsModule
+desugar :: (Applicative m, MonadSupply m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module]
+desugar externs =
+ map removeSignedLiterals
+ >>> mapM desugarObjectConstructors
+ >=> mapM desugarOperatorSections
+ >=> mapM desugarDoModule
+ >=> desugarCasesModule
+ >=> desugarTypeDeclarationsModule
+ >=> desugarImports externs
+ >=> rebracket externs
+ >=> mapM deriveInstances
+ >=> desugarTypeClasses externs
+ >=> createBindingGroupsModule
diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs
index 968ef1e..29e6706 100644
--- a/src/Language/PureScript/Sugar/BindingGroups.hs
+++ b/src/Language/PureScript/Sugar/BindingGroups.hs
@@ -78,7 +78,6 @@ createBindingGroups moduleName = mapM f <=< handleDecls
bindingGroupDecls <- parU (stronglyConnComp valueVerts) (toBindingGroup moduleName)
return $ filter isImportDecl ds ++
filter isExternDataDecl ds ++
- filter isExternInstanceDecl ds ++
dataBindingGroupDecls ++
filter isTypeClassDeclaration ds ++
filter isTypeClassInstanceDeclaration ds ++
@@ -185,7 +184,7 @@ toBindingGroup moduleName (CyclicSCC ds') =
cycleError :: (MonadError MultipleErrors m) => Declaration -> [Declaration] -> m a
cycleError (PositionedDeclaration p _ d) ds = rethrowWithPosition p $ cycleError d ds
cycleError (ValueDeclaration n _ _ (Right _)) [] = throwError . errorMessage $ CycleInDeclaration n
- cycleError d ds@(_:_) = rethrow (onErrorMessages (NotYetDefined (map getIdent ds))) $ cycleError d []
+ cycleError d ds@(_:_) = rethrow (addHint (NotYetDefined (map getIdent ds))) $ cycleError d []
cycleError _ _ = error "Expected ValueDeclaration"
toDataBindingGroup :: (MonadError MultipleErrors m) => SCC Declaration -> m Declaration
diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs
index af7ab01..5b55a44 100644
--- a/src/Language/PureScript/Sugar/CaseDeclarations.hs
+++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs
@@ -50,7 +50,7 @@ isLeft (Right _) = False
--
desugarCasesModule :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Module] -> m [Module]
desugarCasesModule ms = forM ms $ \(Module ss coms name ds exps) ->
- rethrow (onErrorMessages (ErrorInModule name)) $
+ rethrow (addHint (ErrorInModule name)) $
Module ss coms name <$> (desugarCases <=< desugarAbs $ ds) <*> pure exps
desugarAbs :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]
@@ -104,12 +104,14 @@ toDecls [ValueDeclaration ident nameKind bs (Right val)] | all isVarBinder bs =
isVarBinder NullBinder = True
isVarBinder (VarBinder _) = True
isVarBinder (PositionedBinder _ _ b) = isVarBinder b
+ isVarBinder (TypedBinder _ b) = isVarBinder b
isVarBinder _ = False
fromVarBinder :: Binder -> m Ident
fromVarBinder NullBinder = Ident <$> freshName
fromVarBinder (VarBinder name) = return name
fromVarBinder (PositionedBinder _ _ b) = fromVarBinder b
+ fromVarBinder (TypedBinder _ b) = fromVarBinder b
fromVarBinder _ = error "fromVarBinder: Invalid argument"
toDecls ds@(ValueDeclaration ident _ bs result : _) = do
let tuples = map toTuple ds
diff --git a/src/Language/PureScript/Sugar/DoNotation.hs b/src/Language/PureScript/Sugar/DoNotation.hs
index 17da9d3..be86c20 100644
--- a/src/Language/PureScript/Sugar/DoNotation.hs
+++ b/src/Language/PureScript/Sugar/DoNotation.hs
@@ -42,13 +42,13 @@ desugarDoModule :: forall m. (Applicative m, MonadSupply m, MonadError MultipleE
desugarDoModule (Module ss coms mn ds exts) = Module ss coms mn <$> parU ds desugarDo <*> pure exts
desugarDo :: forall m. (Applicative m, MonadSupply m, MonadError MultipleErrors m) => Declaration -> m Declaration
-desugarDo (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> (rethrowWithPosition pos $ desugarDo d)
+desugarDo (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> rethrowWithPosition pos (desugarDo d)
desugarDo d =
let (f, _, _) = everywhereOnValuesM return replace return
in f d
where
bind :: Expr
- bind = Var (Qualified Nothing (Ident (C.bind)))
+ bind = Var (Qualified Nothing (Ident C.bind))
replace :: Expr -> m Expr
replace (Do els) = go els
diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs
index dd282c9..ee28115 100644
--- a/src/Language/PureScript/Sugar/Names.hs
+++ b/src/Language/PureScript/Sugar/Names.hs
@@ -13,6 +13,7 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Language.PureScript.Sugar.Names (desugarImports) where
@@ -34,6 +35,7 @@ import Language.PureScript.Names
import Language.PureScript.Types
import Language.PureScript.Errors
import Language.PureScript.Traversals
+import Language.PureScript.Externs
import Language.PureScript.Sugar.Names.Env
import Language.PureScript.Sugar.Names.Imports
import Language.PureScript.Sugar.Names.Exports
@@ -42,11 +44,47 @@ import Language.PureScript.Sugar.Names.Exports
-- Replaces all local names with qualified names within a list of modules. The
-- modules should be topologically sorted beforehand.
--
-desugarImports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [Module] -> m [Module]
-desugarImports modules = do
- env <- foldM updateEnv initEnv modules
- mapM (renameInModule' env) modules
+desugarImports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module]
+desugarImports externs modules = do
+ env <- foldM externsEnv primEnv externs
+ env' <- foldM updateEnv env modules
+ mapM (renameInModule' env') modules
where
+ -- | Create an environment from a collection of externs files
+ externsEnv :: Env -> ExternsFile -> m Env
+ externsEnv env ExternsFile{..} = do
+ let members = Exports{..}
+ ss = internalModuleSourceSpan "<Externs>"
+ env' = M.insert efModuleName (ss, nullImports, members) env
+ fromEFImport (ExternsImport mn mt qmn) = (mn, [(Nothing, mt, qmn)])
+ imps <- foldM (resolveModuleImport efModuleName env') nullImports (map fromEFImport efImports)
+ exps <- resolveExports env' efModuleName imps members efExports
+ return $ M.insert efModuleName (ss, imps, exps) env
+ where
+
+ exportedTypes :: [((ProperName, [ProperName]), ModuleName)]
+ exportedTypes = mapMaybe toExportedType efExports
+ where
+ toExportedType (TypeRef tyCon dctors) = Just ((tyCon, fromMaybe (mapMaybe forTyCon efDeclarations) dctors), efModuleName)
+ where
+ forTyCon :: ExternsDeclaration -> Maybe ProperName
+ forTyCon (EDDataConstructor pn _ tNm _ _) | tNm == tyCon = Just pn
+ forTyCon _ = Nothing
+ toExportedType (PositionedDeclarationRef _ _ r) = toExportedType r
+ toExportedType _ = Nothing
+ exportedTypeClasses :: [(ProperName, ModuleName)]
+ exportedTypeClasses = mapMaybe toExportedTypeClass efExports
+ where
+ toExportedTypeClass (TypeClassRef className) = Just (className, efModuleName)
+ toExportedTypeClass (PositionedDeclarationRef _ _ r) = toExportedTypeClass r
+ toExportedTypeClass _ = Nothing
+ exportedValues :: [(Ident, ModuleName)]
+ exportedValues = mapMaybe toExportedValue efExports
+ where
+ toExportedValue (ValueRef ident) = Just (ident, efModuleName)
+ toExportedValue (PositionedDeclarationRef _ _ r) = toExportedValue r
+ toExportedValue _ = Nothing
+
updateEnv :: Env -> Module -> m Env
updateEnv env m@(Module ss _ mn _ refs) =
case mn `M.lookup` env of
@@ -60,7 +98,7 @@ desugarImports modules = do
renameInModule' :: Env -> Module -> m Module
renameInModule' env m@(Module _ _ mn _ _) =
- rethrow (onErrorMessages (ErrorInModule mn)) $ do
+ rethrow (addHint (ErrorInModule mn)) $ do
let (_, imps, exps) = fromMaybe (error "Module is missing in renameInModule'") $ M.lookup mn env
elaborateImports imps <$> renameInModule env imps (elaborateExports exps m)
@@ -94,7 +132,7 @@ elaborateImports imps (Module ss coms mn decls exps) = Module ss coms mn decls'
let (f, _, _, _, _) = everythingOnValues (++) (const []) fqValues (const []) (const []) (const [])
in mkImport `map` nub (f `concatMap` decls) ++ decls
fqValues :: Expr -> [ModuleName]
- fqValues (Var (Qualified (Just mn') _)) | notElem mn' (importedModules imps) = [mn']
+ fqValues (Var (Qualified (Just mn') _)) | mn' `notElem` importedModules imps = [mn']
fqValues _ = []
mkImport :: ModuleName -> Declaration
mkImport mn' = ImportDeclaration mn' (Explicit []) Nothing
@@ -120,8 +158,6 @@ renameInModule env imports (Module ss coms mn decls exps) =
(,) (pos, bound) <$> (TypeClassDeclaration className args <$> updateConstraints pos implies <*> pure ds)
updateDecl (pos, bound) (TypeInstanceDeclaration name cs cn ts ds) =
(,) (pos, bound) <$> (TypeInstanceDeclaration name <$> updateConstraints pos cs <*> updateClassName cn pos <*> mapM (updateTypesEverywhere pos) ts <*> pure ds)
- updateDecl (pos, bound) (ExternInstanceDeclaration name cs cn ts) =
- (,) (pos, bound) <$> (ExternInstanceDeclaration name <$> updateConstraints pos cs <*> updateClassName cn Nothing <*> mapM (updateTypesEverywhere pos) ts)
updateDecl (pos, bound) (TypeDeclaration name ty) =
(,) (pos, bound) <$> (TypeDeclaration name <$> updateTypesEverywhere pos ty)
updateDecl (pos, bound) (ExternDeclaration name ty) =
@@ -154,6 +190,10 @@ renameInModule env imports (Module ss coms mn decls exps) =
return ((Just pos, bound), v)
updateBinder s@(pos, _) (ConstructorBinder name b) =
(,) s <$> (ConstructorBinder <$> updateDataConstructorName name pos <*> pure b)
+ updateBinder s (TypedBinder t b) = do
+ (s'@ (span', _), b') <- updateBinder s b
+ t' <- updateTypesEverywhere span' t
+ return (s', TypedBinder t' b')
updateBinder s v =
return (s, v)
@@ -171,7 +211,6 @@ renameInModule env imports (Module ss coms mn decls exps) =
where
updateType :: Type -> m Type
updateType (TypeConstructor name) = TypeConstructor <$> updateTypeName name pos
- updateType (SaturatedTypeSynonym name tys) = SaturatedTypeSynonym <$> updateTypeName name pos <*> pure tys
updateType (ConstrainedType cs t) = ConstrainedType <$> updateConstraints pos cs <*> pure t
updateType t = return t
@@ -208,12 +247,12 @@ renameInModule env imports (Module ss coms mn decls exps) =
-- Update names so unqualified references become qualified, and locally
-- qualified references are replaced with their canoncial qualified names
-- (e.g. M.Map -> Data.Map.Map).
- update :: (Ord a, Show a) => (Qualified a -> SimpleErrorMessage)
- -> M.Map (Qualified a) (Qualified a, ModuleName)
- -> (Exports -> a -> Maybe (Qualified a))
- -> Qualified a
- -> Maybe SourceSpan
- -> m (Qualified a)
+ update :: (Ord a) => (Qualified a -> SimpleErrorMessage)
+ -> M.Map (Qualified a) (Qualified a, ModuleName)
+ -> (Exports -> a -> Maybe (Qualified a))
+ -> Qualified a
+ -> Maybe SourceSpan
+ -> m (Qualified a)
update unknown imps getE qname@(Qualified mn' name) pos = positioned $
case (M.lookup qname imps, mn') of
-- We found the name in our imports, so we return the name for it,
diff --git a/src/Language/PureScript/Sugar/Names/Env.hs b/src/Language/PureScript/Sugar/Names/Env.hs
index 115fbaf..62f8514 100644
--- a/src/Language/PureScript/Sugar/Names/Env.hs
+++ b/src/Language/PureScript/Sugar/Names/Env.hs
@@ -12,10 +12,6 @@
-----------------------------------------------------------------------------
{-# LANGUAGE FlexibleContexts #-}
---{-# LANGUAGE ScopedTypeVariables #-}
---{-# LANGUAGE PatternGuards #-}
---{-# LANGUAGE RankNTypes #-}
---{-# LANGUAGE TupleSections #-}
module Language.PureScript.Sugar.Names.Env
( Imports(..)
@@ -23,7 +19,7 @@ module Language.PureScript.Sugar.Names.Env
, Exports(..)
, nullExports
, Env
- , initEnv
+ , primEnv
, envModuleSourceSpan
, envModuleImports
, envModuleExports
@@ -32,11 +28,11 @@ module Language.PureScript.Sugar.Names.Env
, exportValue
) where
+import qualified Data.Map as M
+
import Control.Monad
import Control.Monad.Error.Class (MonadError(..))
-import qualified Data.Map as M
-
import Language.PureScript.AST
import Language.PureScript.Names
import Language.PureScript.Environment
@@ -67,7 +63,7 @@ data Imports = Imports
-- The list of modules that have been imported into the current scope.
--
, importedModules :: [ModuleName]
- } deriving (Show)
+ } deriving (Show, Read)
-- |
-- An empty 'Imports' value.
@@ -95,7 +91,7 @@ data Exports = Exports
-- came from.
--
, exportedValues :: [(Ident, ModuleName)]
- } deriving (Show)
+ } deriving (Show, Read)
-- |
-- An empty 'Exports' value.
@@ -136,11 +132,9 @@ primExports = Exports (mkTypeEntry `map` M.keys primTypes) [] []
where
mkTypeEntry (Qualified _ name) = ((name, []), ModuleName [ProperName "Prim"])
--- |
--- The initial global import/export environment containing the @Prim@ module.
---
-initEnv :: Env
-initEnv = M.singleton
+-- | Environment which only contains the Prim module.
+primEnv :: Env
+primEnv = M.singleton
(ModuleName [ProperName "Prim"])
(internalModuleSourceSpan "<Prim>", nullImports, primExports)
@@ -184,7 +178,7 @@ exportValue exps name mn = do
-- Adds an entry to a list of exports unless it is already present, in which case an error is
-- returned.
--
-addExport :: (MonadError MultipleErrors m, Eq a, Show a) => (a -> SimpleErrorMessage) -> a -> ModuleName -> [(a, ModuleName)] -> m [(a, ModuleName)]
+addExport :: (MonadError MultipleErrors m, Eq a) => (a -> SimpleErrorMessage) -> a -> ModuleName -> [(a, ModuleName)] -> m [(a, ModuleName)]
addExport what name mn exports =
if any ((== name) . fst) exports
then throwConflictError what name
@@ -193,5 +187,5 @@ addExport what name mn exports =
-- |
-- Raises an error for when there is more than one definition for something.
--
-throwConflictError :: (MonadError MultipleErrors m, Show a) => (a -> SimpleErrorMessage) -> a -> m b
+throwConflictError :: (MonadError MultipleErrors m) => (a -> SimpleErrorMessage) -> a -> m b
throwConflictError conflict = throwError . errorMessage . conflict
diff --git a/src/Language/PureScript/Sugar/Names/Exports.hs b/src/Language/PureScript/Sugar/Names/Exports.hs
index 2c0f87c..34c1649 100644
--- a/src/Language/PureScript/Sugar/Names/Exports.hs
+++ b/src/Language/PureScript/Sugar/Names/Exports.hs
@@ -43,7 +43,7 @@ import Language.PureScript.Sugar.Names.Env
--
findExportable :: forall m. (Applicative m, MonadError MultipleErrors m) => Module -> m Exports
findExportable (Module _ _ mn ds _) =
- rethrow (onErrorMessages (ErrorInModule mn)) $ foldM updateExports nullExports ds
+ rethrow (addHint (ErrorInModule mn)) $ foldM updateExports nullExports ds
where
updateExports :: Exports -> Declaration -> m Exports
updateExports exps (TypeClassDeclaration tcn _ _ ds') = do
@@ -67,7 +67,7 @@ findExportable (Module _ _ mn ds _) =
--
resolveExports :: forall m. (Applicative m, MonadError MultipleErrors m) => Env -> ModuleName -> Imports -> Exports -> [DeclarationRef] -> m Exports
resolveExports env mn imps exps refs =
- rethrow (onErrorMessages (ErrorInModule mn)) $ do
+ rethrow (addHint (ErrorInModule mn)) $ do
filtered <- filterModule mn exps refs
foldM elaborateModuleExports filtered refs
@@ -205,9 +205,8 @@ filterModule mn exps refs = do
-- the data constructor to check.
checkDcon :: ProperName -> [ProperName] -> ProperName -> m ()
checkDcon tcon exps' name =
- if name `elem` exps'
- then return ()
- else throwError . errorMessage $ UnknownExportDataConstructor tcon name
+ unless (name `elem` exps') $
+ throwError . errorMessage $ UnknownExportDataConstructor tcon name
-- Takes a list of all the exportable classes, the accumulated list of
-- filtered exports, and a `DeclarationRef` for an explicit export. When the
diff --git a/src/Language/PureScript/Sugar/Names/Imports.hs b/src/Language/PureScript/Sugar/Names/Imports.hs
index b82182e..0839ba0 100644
--- a/src/Language/PureScript/Sugar/Names/Imports.hs
+++ b/src/Language/PureScript/Sugar/Names/Imports.hs
@@ -16,7 +16,10 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
-module Language.PureScript.Sugar.Names.Imports (resolveImports) where
+module Language.PureScript.Sugar.Names.Imports
+ ( resolveImports
+ , resolveModuleImport
+ ) where
import Data.List (find)
import Data.Maybe (fromMaybe, isNothing)
@@ -59,25 +62,29 @@ findImports = foldM (go Nothing) M.empty
-- |
-- Constructs a set of imports for a module.
--
-resolveImports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Env -> Module -> m Imports
+resolveImports :: (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Env -> Module -> m Imports
resolveImports env (Module _ _ currentModule decls _) =
- censor (onErrorMessages (ErrorInModule currentModule)) $ do
+ censor (addHint (ErrorInModule currentModule)) $ do
scope <- M.insert currentModule [(Nothing, Implicit, Nothing)] <$> findImports decls
- foldM resolveImport' nullImports (M.toList scope)
+ foldM (resolveModuleImport currentModule env) nullImports (M.toList scope)
+
+-- | Constructs a set of imports for a single module import.
+resolveModuleImport ::
+ forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
+ ModuleName -> Env -> Imports ->
+ (ModuleName, [(Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)]) ->
+ m Imports
+resolveModuleImport currentModule env ie (mn, imps) = foldM go ie imps
where
-
- resolveImport' :: Imports -> (ModuleName, [(Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)]) -> m Imports
- resolveImport' ie (mn, imps) = foldM go ie imps
+ go :: Imports -> (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName) -> m Imports
+ go ie' (pos, typ, impQual) = do
+ modExports <- positioned $ maybe (throwError . errorMessage $ UnknownModule mn) (return . envModuleExports) $ mn `M.lookup` env
+ let ie'' = ie' { importedModules = mn : importedModules ie' }
+ positioned $ resolveImport currentModule mn modExports ie'' impQual typ
where
- go :: Imports -> (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName) -> m Imports
- go ie' (pos, typ, impQual) = do
- modExports <- positioned $ maybe (throwError . errorMessage $ UnknownModule mn) (return . envModuleExports) $ mn `M.lookup` env
- let ie'' = ie' { importedModules = mn : importedModules ie' }
- positioned $ resolveImport currentModule mn modExports ie'' impQual typ
- where
- positioned err = case pos of
- Nothing -> err
- Just pos' -> rethrowWithPosition pos' err
+ positioned err = case pos of
+ Nothing -> err
+ Just pos' -> rethrowWithPosition pos' err
-- |
-- Extends the local environment for a module by resolving an import of another module.
@@ -111,7 +118,7 @@ resolveImport currentModule importModule exps imps impQual =
check _ = error "Invalid argument to checkRefs"
-- Check that an explicitly imported item exists in the module it is being imported from
- checkImportExists :: (Eq a, Show a) => (ModuleName -> a -> SimpleErrorMessage) -> [a] -> a -> m ()
+ checkImportExists :: (Eq a) => (ModuleName -> a -> SimpleErrorMessage) -> [a] -> a -> m ()
checkImportExists unknown exports item =
when (item `notElem` exports) $ throwError . errorMessage $ unknown importModule item
@@ -149,20 +156,20 @@ resolveImport currentModule importModule exps imps impQual =
importExplicit imp (PositionedDeclarationRef pos _ r) =
rethrowWithPosition pos . warnWithPosition pos $ importExplicit imp r
importExplicit imp (ValueRef name) = do
- values' <- updateImports (importedValues imp) (exportedValues exps) name
+ values' <- updateImports (importedValues imp) showIdent (exportedValues exps) name
return $ imp { importedValues = values' }
importExplicit imp (TypeRef name dctors) = do
- types' <- updateImports (importedTypes imp) (first fst `map` exportedTypes exps) name
+ types' <- updateImports (importedTypes imp) runProperName (first fst `map` exportedTypes exps) name
let exportedDctors :: [(ProperName, ModuleName)]
exportedDctors = allExportedDataConstructors name
dctorNames :: [ProperName]
dctorNames = fst `map` exportedDctors
maybe (return ()) (mapM_ $ checkDctorExists name dctorNames) dctors
when (null dctorNames && isNothing dctors) . tell . errorMessage $ MisleadingEmptyTypeImport importModule name
- dctors' <- foldM (flip updateImports exportedDctors) (importedDataConstructors imp) (fromMaybe dctorNames dctors)
+ dctors' <- foldM (\m -> updateImports m runProperName exportedDctors) (importedDataConstructors imp) (fromMaybe dctorNames dctors)
return $ imp { importedTypes = types', importedDataConstructors = dctors' }
importExplicit imp (TypeClassRef name) = do
- typeClasses' <- updateImports (importedTypeClasses imp) (exportedTypeClasses exps) name
+ typeClasses' <- updateImports (importedTypeClasses imp) runProperName (exportedTypeClasses exps) name
return $ imp { importedTypeClasses = typeClasses' }
importExplicit _ _ = error "Invalid argument to importExplicit"
@@ -174,11 +181,12 @@ resolveImport currentModule importModule exps imps impQual =
Just ((_, dctors), mn) -> map (, mn) dctors
-- Add something to the Imports if it does not already exist there
- updateImports :: (Ord a, Show a) => M.Map (Qualified a) (Qualified a, ModuleName)
- -> [(a, ModuleName)]
- -> a
- -> m (M.Map (Qualified a) (Qualified a, ModuleName))
- updateImports imps' exps' name = case M.lookup (Qualified impQual name) imps' of
+ updateImports :: (Ord a) => M.Map (Qualified a) (Qualified a, ModuleName)
+ -> (a -> String)
+ -> [(a, ModuleName)]
+ -> a
+ -> m (M.Map (Qualified a) (Qualified a, ModuleName))
+ updateImports imps' render exps' name = case M.lookup (Qualified impQual name) imps' of
-- If the name is not already present add it to the list, after looking up
-- where it was originally defined
@@ -195,8 +203,8 @@ resolveImport currentModule importModule exps imps impQual =
| otherwise -> throwError . errorMessage $ err
where
err = if currentModule `elem` [mn, importModule]
- then ConflictingImport (show name) importModule
- else ConflictingImports (show name) mn importModule
+ then ConflictingImport (render name) importModule
+ else ConflictingImports (render name) mn importModule
Just (Qualified Nothing _, _) ->
error "Invalid state in updateImports"
diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs
index 17e5a41..767a4f6 100644
--- a/src/Language/PureScript/Sugar/Operators.hs
+++ b/src/Language/PureScript/Sugar/Operators.hs
@@ -20,6 +20,7 @@
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE CPP #-}
module Language.PureScript.Sugar.Operators (
@@ -31,6 +32,7 @@ module Language.PureScript.Sugar.Operators (
import Language.PureScript.AST
import Language.PureScript.Errors
import Language.PureScript.Names
+import Language.PureScript.Externs
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
@@ -52,9 +54,9 @@ import qualified Language.PureScript.Constants as C
-- |
-- Remove explicit parentheses and reorder binary operator applications
--
-rebracket :: (Applicative m, MonadError MultipleErrors m) => [Module] -> m [Module]
-rebracket ms = do
- let fixities = concatMap collectFixities ms
+rebracket :: (Applicative m, MonadError MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module]
+rebracket externs ms = do
+ let fixities = concatMap externsFixities externs ++ concatMap collectFixities ms
ensureNoDuplicates $ map (\(i, pos, _) -> (i, pos)) fixities
let opTable = customOperatorTable $ map (\(i, _, f) -> (i, f)) fixities
mapM (rebracketModule opTable) ms
@@ -80,6 +82,12 @@ removeParens =
go (Parens val) = val
go val = val
+externsFixities :: ExternsFile -> [(Qualified Ident, SourceSpan, Fixity)]
+externsFixities ExternsFile{..} =
+ [ (Qualified (Just efModuleName) (Op op), internalModuleSourceSpan "", Fixity assoc prec)
+ | ExternsFixity assoc prec op <- efFixities
+ ]
+
collectFixities :: Module -> [(Qualified Ident, SourceSpan, Fixity)]
collectFixities (Module _ _ moduleName ds _) = concatMap collect ds
where
@@ -94,7 +102,7 @@ ensureNoDuplicates m = go $ sortBy (compare `on` fst) m
go [] = return ()
go [_] = return ()
go ((x@(Qualified (Just mn) name), _) : (y, pos) : _) | x == y =
- rethrow (onErrorMessages (ErrorInModule mn)) $
+ rethrow (addHint (ErrorInModule mn)) $
rethrowWithPosition pos $
throwError . errorMessage $ MultipleFixities name
go (_ : rest) = go rest
@@ -131,8 +139,8 @@ toAssoc Infixl = P.AssocLeft
toAssoc Infixr = P.AssocRight
toAssoc Infix = P.AssocNone
-token :: (P.Stream s Identity t, Show t) => (t -> Maybe a) -> P.Parsec s u a
-token = P.token show (const (P.initialPos ""))
+token :: (P.Stream s Identity t) => (t -> Maybe a) -> P.Parsec s u a
+token = P.token (const "") (const (P.initialPos ""))
parseValue :: P.Parsec Chain () Expr
parseValue = token (either Just (const Nothing)) P.<?> "expression"
diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs
index aa9a1f8..e393673 100644
--- a/src/Language/PureScript/Sugar/TypeClasses.hs
+++ b/src/Language/PureScript/Sugar/TypeClasses.hs
@@ -15,6 +15,7 @@
-----------------------------------------------------------------------------
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE CPP #-}
module Language.PureScript.Sugar.TypeClasses
@@ -28,6 +29,7 @@ import Language.PureScript.Environment
import Language.PureScript.Errors
import Language.PureScript.Kinds
import Language.PureScript.Names
+import Language.PureScript.Externs
import Language.PureScript.Sugar.CaseDeclarations
import Control.Monad.Supply.Class
import Language.PureScript.Types
@@ -45,7 +47,7 @@ import Data.Maybe (catMaybes, mapMaybe, isJust)
import qualified Data.Map as M
-type MemberMap = M.Map (ModuleName, ProperName) Declaration
+type MemberMap = M.Map (ModuleName, ProperName) ([(String, Maybe Kind)], [Constraint], [Declaration])
type Desugar = StateT MemberMap
@@ -53,8 +55,15 @@ type Desugar = StateT MemberMap
-- Add type synonym declarations for type class dictionary types, and value declarations for type class
-- instance dictionary expressions.
--
-desugarTypeClasses :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Module] -> m [Module]
-desugarTypeClasses = flip evalStateT M.empty . mapM desugarModule
+desugarTypeClasses :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module]
+desugarTypeClasses externs = flip evalStateT initialState . mapM desugarModule
+ where
+ initialState :: MemberMap
+ initialState = M.fromList (externs >>= \ExternsFile{..} -> mapMaybe (fromExternsDecl efModuleName) efDeclarations)
+
+ fromExternsDecl :: ModuleName -> ExternsDeclaration -> Maybe ((ModuleName, ProperName), ([(String, Maybe Kind)], [Constraint], [Declaration]))
+ fromExternsDecl mn (EDClass name args members implies) = Just ((mn, name), (args, implies, map (uncurry TypeDeclaration) members))
+ fromExternsDecl _ _ = Nothing
desugarModule :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Module -> Desugar m Module
desugarModule (Module ss coms name decls (Just exps)) = do
@@ -166,9 +175,8 @@ desugarDecl :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErro
desugarDecl mn exps = go
where
go d@(TypeClassDeclaration name args implies members) = do
- modify (M.insert (mn, name) d)
+ modify (M.insert (mn, name) (args, implies, members))
return (Nothing, d : typeClassDictionaryDeclaration name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members)
- go d@(ExternInstanceDeclaration name _ className tys) = return (expRef name className tys, [d])
go (TypeInstanceDeclaration _ _ _ _ DerivedInstance) = error "Derived instanced should have been desugared"
go d@(TypeInstanceDeclaration name deps className tys (ExplicitInstance members)) = do
desugared <- desugarCases members
@@ -235,11 +243,11 @@ unit = TypeApp tyObject REmpty
typeInstanceDictionaryDeclaration :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Ident -> ModuleName -> [Constraint] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar m Declaration
typeInstanceDictionaryDeclaration name mn deps className tys decls =
- rethrow (onErrorMessages (ErrorInInstance className tys)) $ do
+ rethrow (addHint (ErrorInInstance className tys)) $ do
m <- get
-- Lookup the type arguments and member types for the type class
- (TypeClassDeclaration _ args implies tyDecls) <-
+ (args, implies, tyDecls) <-
maybe (throwError . errorMessage $ UnknownTypeClass className) return $
M.lookup (qualify mn className) m
@@ -292,10 +300,10 @@ typeClassMemberName :: Declaration -> String
typeClassMemberName (TypeDeclaration ident _) = runIdent ident
typeClassMemberName (ValueDeclaration ident _ _ _) = runIdent ident
typeClassMemberName (PositionedDeclaration _ _ d) = typeClassMemberName d
-typeClassMemberName d = error $ "Invalid declaration in type class definition: " ++ show d
+typeClassMemberName _ = error "typeClassMemberName: Invalid declaration in type class definition"
superClassDictionaryNames :: [Constraint] -> [String]
superClassDictionaryNames supers =
- [ C.__superclass_ ++ show pn ++ "_" ++ show (index :: Integer)
+ [ C.__superclass_ ++ showQualified runProperName pn ++ "_" ++ show (index :: Integer)
| (index, (pn, _)) <- zip [0..] supers
]
diff --git a/src/Language/PureScript/Sugar/TypeDeclarations.hs b/src/Language/PureScript/Sugar/TypeDeclarations.hs
index 1ed4231..f6ecf37 100644
--- a/src/Language/PureScript/Sugar/TypeDeclarations.hs
+++ b/src/Language/PureScript/Sugar/TypeDeclarations.hs
@@ -15,18 +15,19 @@
-----------------------------------------------------------------------------
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE CPP #-}
module Language.PureScript.Sugar.TypeDeclarations (
- desugarTypeDeclarations,
desugarTypeDeclarationsModule
) where
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
#endif
-import Control.Monad (forM)
+import Control.Monad (forM, when)
import Control.Monad.Error.Class (MonadError(..))
+import Control.Monad.Writer.Class (MonadWriter(tell))
import Language.PureScript.AST
import Language.PureScript.Names
@@ -37,36 +38,39 @@ import Language.PureScript.Traversals
-- |
-- Replace all top level type declarations in a module with type annotations
--
-desugarTypeDeclarationsModule :: (Functor m, Applicative m, MonadError MultipleErrors m) => [Module] -> m [Module]
+desugarTypeDeclarationsModule :: forall m. (Functor m, Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [Module] -> m [Module]
desugarTypeDeclarationsModule ms = forM ms $ \(Module ss coms name ds exps) ->
- rethrow (onErrorMessages (ErrorInModule name)) $
- Module ss coms name <$> desugarTypeDeclarations ds <*> pure exps
-
--- |
--- Replace all top level type declarations with type annotations
---
-desugarTypeDeclarations :: (Functor m, Applicative m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]
-desugarTypeDeclarations (PositionedDeclaration pos com d : ds) = do
- (d' : ds') <- rethrowWithPosition pos $ desugarTypeDeclarations (d : ds)
- return (PositionedDeclaration pos com d' : ds')
-desugarTypeDeclarations (TypeDeclaration name ty : d : rest) = do
- (_, nameKind, val) <- fromValueDeclaration d
- desugarTypeDeclarations (ValueDeclaration name nameKind [] (Right (TypedValue True val ty)) : rest)
+ rethrow (addHint (ErrorInModule name)) $
+ Module ss coms name <$> desugarTypeDeclarations True ds <*> pure exps
where
- fromValueDeclaration :: (Functor m, Applicative m, MonadError MultipleErrors m) => Declaration -> m (Ident, NameKind, Expr)
- fromValueDeclaration (ValueDeclaration name' nameKind [] (Right val)) | name == name' = return (name', nameKind, val)
- fromValueDeclaration (PositionedDeclaration pos com d') = do
- (ident, nameKind, val) <- rethrowWithPosition pos $ fromValueDeclaration d'
- return (ident, nameKind, PositionedValue pos com val)
- fromValueDeclaration _ = throwError . errorMessage $ OrphanTypeDeclaration name
-desugarTypeDeclarations (TypeDeclaration name _ : []) = throwError . errorMessage $ OrphanTypeDeclaration name
-desugarTypeDeclarations (ValueDeclaration name nameKind bs val : rest) = do
- let (_, f, _) = everywhereOnValuesTopDownM return go return
- f' (Left gs) = Left <$> mapM (pairM return f) gs
- f' (Right v) = Right <$> f v
- (:) <$> (ValueDeclaration name nameKind bs <$> f' val) <*> desugarTypeDeclarations rest
- where
- go (Let ds val') = Let <$> desugarTypeDeclarations ds <*> pure val'
- go other = return other
-desugarTypeDeclarations (d:ds) = (:) d <$> desugarTypeDeclarations ds
-desugarTypeDeclarations [] = return []
+
+ desugarTypeDeclarations :: Bool -> [Declaration] -> m [Declaration]
+ desugarTypeDeclarations reqd (PositionedDeclaration pos com d : ds) = do
+ (d' : ds') <- rethrowWithPosition pos $ desugarTypeDeclarations reqd (d : ds)
+ return (PositionedDeclaration pos com d' : ds')
+ desugarTypeDeclarations reqd (TypeDeclaration name ty : d : rest) = do
+ (_, nameKind, val) <- fromValueDeclaration d
+ desugarTypeDeclarations reqd (ValueDeclaration name nameKind [] (Right (TypedValue True val ty)) : rest)
+ where
+ fromValueDeclaration :: Declaration -> m (Ident, NameKind, Expr)
+ fromValueDeclaration (ValueDeclaration name' nameKind [] (Right val)) | name == name' = return (name', nameKind, val)
+ fromValueDeclaration (PositionedDeclaration pos com d') = do
+ (ident, nameKind, val) <- rethrowWithPosition pos $ fromValueDeclaration d'
+ return (ident, nameKind, PositionedValue pos com val)
+ fromValueDeclaration _ = throwError . errorMessage $ OrphanTypeDeclaration name
+ desugarTypeDeclarations _ [TypeDeclaration name _] = throwError . errorMessage $ OrphanTypeDeclaration name
+ desugarTypeDeclarations reqd (ValueDeclaration name nameKind bs val : rest) = do
+ -- At the top level, match a type signature or emit a warning.
+ when reqd $ case val of
+ Right TypedValue{} -> return ()
+ Left _ -> error "desugarTypeDeclarations: cases were not desugared"
+ _ -> tell (addHint (ErrorInValueDeclaration name) $ errorMessage $ MissingTypeDeclaration name)
+ let (_, f, _) = everywhereOnValuesTopDownM return go return
+ f' (Left gs) = Left <$> mapM (pairM return f) gs
+ f' (Right v) = Right <$> f v
+ (:) <$> (ValueDeclaration name nameKind bs <$> f' val) <*> desugarTypeDeclarations reqd rest
+ where
+ go (Let ds val') = Let <$> desugarTypeDeclarations False ds <*> pure val'
+ go other = return other
+ desugarTypeDeclarations reqd (d:ds) = (:) d <$> desugarTypeDeclarations reqd ds
+ desugarTypeDeclarations _ [] = return []
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
index 0a126dd..7164eeb 100644
--- a/src/Language/PureScript/TypeChecker.hs
+++ b/src/Language/PureScript/TypeChecker.hs
@@ -27,7 +27,7 @@ import Language.PureScript.TypeChecker.Types as T
import Language.PureScript.TypeChecker.Synonyms as T
import Data.Maybe
-import Data.List (nub, (\\))
+import Data.List (nub, (\\), sort, group)
import Data.Foldable (for_)
import qualified Data.Map as M
@@ -51,7 +51,7 @@ addDataType moduleName dtype name args dctors ctorKind = do
env <- getEnv
putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (ctorKind, DataType args dctors) (types env) }
forM_ dctors $ \(dctor, tys) ->
- warnAndRethrow (onErrorMessages (ErrorInDataConstructor dctor)) $
+ warnAndRethrow (addHint (ErrorInDataConstructor dctor)) $
addDataConstructor moduleName dtype name (map fst args) dctor tys
addDataConstructor :: ModuleName -> DataDeclType -> ProperName -> [String] -> ProperName -> [Type] -> Check ()
@@ -132,12 +132,12 @@ checkTypeSynonyms = void . replaceAllTypeSynonyms
--
-- * Process module imports
--
-typeCheckAll :: Maybe ModuleName -> ModuleName -> [DeclarationRef] -> [Declaration] -> Check [Declaration]
-typeCheckAll mainModuleName moduleName _ ds = mapM go ds <* mapM_ checkOrphanFixities ds
+typeCheckAll :: ModuleName -> [DeclarationRef] -> [Declaration] -> Check [Declaration]
+typeCheckAll moduleName _ ds = mapM go ds <* mapM_ checkOrphanFixities ds
where
go :: Declaration -> Check Declaration
go (DataDeclaration dtype name args dctors) = do
- warnAndRethrow (onErrorMessages (ErrorInTypeConstructor name)) $ do
+ warnAndRethrow (addHint (ErrorInTypeConstructor name)) $ do
when (dtype == Newtype) $ checkNewtype dctors
checkDuplicateTypeArguments $ map fst args
ctorKind <- kindsOf True moduleName name args (concatMap snd dctors)
@@ -150,7 +150,7 @@ typeCheckAll mainModuleName moduleName _ ds = mapM go ds <* mapM_ checkOrphanFix
checkNewtype [(_, _)] = throwError . errorMessage $ InvalidNewtype
checkNewtype _ = throwError . errorMessage $ InvalidNewtype
go (d@(DataBindingGroupDeclaration tys)) = do
- warnAndRethrow (onErrorMessages ErrorInDataBindingGroup) $ do
+ warnAndRethrow (addHint ErrorInDataBindingGroup) $ do
let syns = mapMaybe toTypeSynonym tys
let dataDecls = mapMaybe toDataDecl tys
(syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(_, name, args, dctors) -> (name, args, concatMap snd dctors)) dataDecls)
@@ -171,7 +171,7 @@ typeCheckAll mainModuleName moduleName _ ds = mapM go ds <* mapM_ checkOrphanFix
toDataDecl (PositionedDeclaration _ _ d') = toDataDecl d'
toDataDecl _ = Nothing
go (TypeSynonymDeclaration name args ty) = do
- warnAndRethrow (onErrorMessages (ErrorInTypeSynonym name)) $ do
+ warnAndRethrow (addHint (ErrorInTypeSynonym name)) $ do
checkDuplicateTypeArguments $ map fst args
kind <- kindsOf False moduleName name args [ty]
let args' = args `withKinds` kind
@@ -179,17 +179,17 @@ typeCheckAll mainModuleName moduleName _ ds = mapM go ds <* mapM_ checkOrphanFix
return $ TypeSynonymDeclaration name args ty
go (TypeDeclaration{}) = error "Type declarations should have been removed"
go (ValueDeclaration name nameKind [] (Right val)) =
- warnAndRethrow (onErrorMessages (ErrorInValueDeclaration name)) $ do
+ warnAndRethrow (addHint (ErrorInValueDeclaration name)) $ do
valueIsNotDefined moduleName name
- [(_, (val', ty))] <- typesOf mainModuleName moduleName [(name, val)]
+ [(_, (val', ty))] <- typesOf moduleName [(name, val)]
addValue moduleName name ty nameKind
return $ ValueDeclaration name nameKind [] $ Right val'
go (ValueDeclaration{}) = error "Binders were not desugared"
go (BindingGroupDeclaration vals) =
- warnAndRethrow (onErrorMessages (ErrorInBindingGroup (map (\(ident, _, _) -> ident) vals))) $ do
+ warnAndRethrow (addHint (ErrorInBindingGroup (map (\(ident, _, _) -> ident) vals))) $ do
forM_ (map (\(ident, _, _) -> ident) vals) $ \name ->
valueIsNotDefined moduleName name
- tys <- typesOf mainModuleName moduleName $ map (\(ident, _, ty) -> (ident, ty)) vals
+ tys <- typesOf moduleName $ map (\(ident, _, ty) -> (ident, ty)) vals
vals' <- forM [ (name, val, nameKind, ty)
| (name, nameKind, _) <- vals
, (name', (val, ty)) <- tys
@@ -203,26 +203,27 @@ typeCheckAll mainModuleName moduleName _ ds = mapM go ds <* mapM_ checkOrphanFix
putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (kind, ExternData) (types env) }
return d
go (d@(ExternDeclaration name ty)) = do
- warnAndRethrow (onErrorMessages (ErrorInForeignImport name)) $ do
+ warnAndRethrow (addHint (ErrorInForeignImport name)) $ do
env <- getEnv
kind <- kindOf moduleName ty
- guardWith (errorMessage (ExpectedType kind)) $ kind == Star
+ guardWith (errorMessage (ExpectedType ty kind)) $ kind == Star
case M.lookup (moduleName, name) (names env) of
Just _ -> throwError . errorMessage $ RedefinedIdent name
Nothing -> putEnv (env { names = M.insert (moduleName, name) (ty, External, Defined) (names env) })
return d
go (d@(FixityDeclaration{})) = return d
- go (d@(ImportDeclaration importedModule _ _)) = do
- instances <- lookupTypeClassDictionaries $ Just importedModule
- addTypeClassDictionaries (Just moduleName) instances
- return d
+ go (d@(ImportDeclaration{})) = return d
go (d@(TypeClassDeclaration pn args implies tys)) = do
addTypeClass moduleName pn args implies tys
return d
- go (d@(TypeInstanceDeclaration dictName deps className tys _)) =
- goInstance d dictName deps className tys
- go (d@(ExternInstanceDeclaration dictName deps className tys)) =
- goInstance d dictName deps className tys
+ go (d@(TypeInstanceDeclaration dictName deps className tys body)) = rethrow (addHint (ErrorInInstance className tys)) $ do
+ mapM_ (checkTypeClassInstance moduleName) tys
+ forM_ deps $ mapM_ (checkTypeClassInstance moduleName) . snd
+ checkOrphanInstance dictName className tys
+ _ <- traverseTypeInstanceBody checkInstanceMembers body
+ let dict = TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) [] className tys (Just deps)
+ addTypeClassDictionaries (Just moduleName) . M.singleton className $ M.singleton (tcdName dict) dict
+ return d
go (PositionedDeclaration pos com d) =
warnAndRethrowWithPosition pos $ PositionedDeclaration pos com <$> go d
@@ -234,29 +235,36 @@ typeCheckAll mainModuleName moduleName _ ds = mapM go ds <* mapM_ checkOrphanFix
warnAndRethrowWithPosition pos $ checkOrphanFixities d
checkOrphanFixities _ = return ()
- goInstance :: Declaration -> Ident -> [Constraint] -> Qualified ProperName -> [Type] -> Check Declaration
- goInstance d dictName deps className tys = do
- mapM_ (checkTypeClassInstance moduleName) tys
- forM_ deps $ mapM_ (checkTypeClassInstance moduleName) . snd
- checkOrphanInstance moduleName className tys
- let dict = TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) [] className tys (Just deps) TCDRegular
- addTypeClassDictionaries (Just moduleName) . M.singleton className $ M.singleton (canonicalizeDictionary dict) dict
- return d
-
+ checkInstanceMembers :: [Declaration] -> Check [Declaration]
+ checkInstanceMembers instDecls = do
+ let idents = sort . map head . group . map memberName $ instDecls
+ for_ (firstDuplicate idents) $ \ident ->
+ throwError . errorMessage $ DuplicateValueDeclaration ident
+ return instDecls
where
+ memberName :: Declaration -> Ident
+ memberName (ValueDeclaration ident _ _ _) = ident
+ memberName (PositionedDeclaration _ _ d) = memberName d
+ memberName _ = error "checkInstanceMembers: Invalid declaration in type instance definition"
- checkOrphanInstance :: ModuleName -> Qualified ProperName -> [Type] -> Check ()
- checkOrphanInstance mn (Qualified (Just mn') _) tys'
- | mn == mn' || any checkType tys' = return ()
- | otherwise = throwError . errorMessage $ OrphanInstance dictName className tys'
- where
- checkType :: Type -> Bool
- checkType (TypeVar _) = False
- checkType (TypeConstructor (Qualified (Just mn'') _)) = mn == mn''
- checkType (TypeConstructor (Qualified Nothing _)) = error "Unqualified type name in checkOrphanInstance"
- checkType (TypeApp t1 _) = checkType t1
- checkType _ = error "Invalid type in instance in checkOrphanInstance"
- checkOrphanInstance _ _ _ = error "Unqualified class name in checkOrphanInstance"
+ firstDuplicate :: (Eq a) => [a] -> Maybe a
+ firstDuplicate (x : xs@(y : _))
+ | x == y = Just x
+ | otherwise = firstDuplicate xs
+ firstDuplicate _ = Nothing
+
+ checkOrphanInstance :: Ident -> Qualified ProperName -> [Type] -> Check ()
+ checkOrphanInstance dictName className@(Qualified (Just mn') _) tys'
+ | moduleName == mn' || any checkType tys' = return ()
+ | otherwise = throwError . errorMessage $ OrphanInstance dictName className tys'
+ where
+ checkType :: Type -> Bool
+ checkType (TypeVar _) = False
+ checkType (TypeConstructor (Qualified (Just mn'') _)) = moduleName == mn''
+ checkType (TypeConstructor (Qualified Nothing _)) = error "Unqualified type name in checkOrphanInstance"
+ checkType (TypeApp t1 _) = checkType t1
+ checkType _ = error "Invalid type in instance in checkOrphanInstance"
+ checkOrphanInstance _ _ _ = error "Unqualified class name in checkOrphanInstance"
-- |
-- This function adds the argument kinds for a type constructor so that they may appear in the externs file,
@@ -272,11 +280,11 @@ typeCheckAll mainModuleName moduleName _ ds = mapM go ds <* mapM_ checkOrphanFix
-- Type check an entire module and ensure all types and classes defined within the module that are
-- required by exported members are also exported.
--
-typeCheckModule :: Maybe ModuleName -> Module -> Check Module
-typeCheckModule _ (Module _ _ _ _ Nothing) = error "exports should have been elaborated"
-typeCheckModule mainModuleName (Module ss coms mn decls (Just exps)) = warnAndRethrow (onErrorMessages (ErrorInModule mn)) $ do
+typeCheckModule :: Module -> Check Module
+typeCheckModule (Module _ _ _ _ Nothing) = error "exports should have been elaborated"
+typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint (ErrorInModule mn)) $ do
modify (\s -> s { checkCurrentModule = Just mn })
- decls' <- typeCheckAll mainModuleName mn exps decls
+ decls' <- typeCheckAll mn exps decls
forM_ exps $ \e -> do
checkTypesAreExported e
checkClassMembersAreExported e
@@ -285,22 +293,36 @@ typeCheckModule mainModuleName (Module ss coms mn decls (Just exps)) = warnAndRe
where
checkMemberExport :: (Type -> [DeclarationRef]) -> DeclarationRef -> Check ()
+ checkMemberExport extract dr@(TypeRef name dctors) = do
+ env <- getEnv
+ case M.lookup (Qualified (Just mn) name) (typeSynonyms env) of
+ Nothing -> return ()
+ Just (_, ty) -> checkExport dr extract ty
+ case dctors of
+ Nothing -> return ()
+ Just dctors' -> forM_ dctors' $ \dctor ->
+ case M.lookup (Qualified (Just mn) dctor) (dataConstructors env) of
+ Nothing -> return ()
+ Just (_, _, ty, _) -> checkExport dr extract ty
+ return ()
checkMemberExport extract dr@(ValueRef name) = do
ty <- lookupVariable mn (Qualified (Just mn) name)
- case filter (not . exported) (extract ty) of
- [] -> return ()
- hidden -> throwError . errorMessage $ TransitiveExportError dr hidden
- where
- exported e = any (exports e) exps
- exports (TypeRef pn1 _) (TypeRef pn2 _) = pn1 == pn2
- exports (ValueRef id1) (ValueRef id2) = id1 == id2
- exports (TypeClassRef pn1) (TypeClassRef pn2) = pn1 == pn2
- exports (TypeInstanceRef id1) (TypeInstanceRef id2) = id1 == id2
- exports (PositionedDeclarationRef _ _ r1) r2 = exports r1 r2
- exports r1 (PositionedDeclarationRef _ _ r2) = exports r1 r2
- exports _ _ = False
+ checkExport dr extract ty
checkMemberExport _ _ = return ()
+ checkExport :: DeclarationRef -> (Type -> [DeclarationRef]) -> Type -> Check ()
+ checkExport dr extract ty = case filter (not . exported) (extract ty) of
+ [] -> return ()
+ hidden -> throwError . errorMessage $ TransitiveExportError dr hidden
+ where
+ exported e = any (exports e) exps
+ exports (TypeRef pn1 _) (TypeRef pn2 _) = pn1 == pn2
+ exports (ValueRef id1) (ValueRef id2) = id1 == id2
+ exports (TypeClassRef pn1) (TypeClassRef pn2) = pn1 == pn2
+ exports (PositionedDeclarationRef _ _ r1) r2 = exports r1 r2
+ exports r1 (PositionedDeclarationRef _ _ r2) = exports r1 r2
+ exports _ _ = False
+
-- Check that all the type constructors defined in the current module that appear in member types
-- have also been exported from the module
checkTypesAreExported :: DeclarationRef -> Check ()
diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs
index 4a24e75..63490c4 100644
--- a/src/Language/PureScript/TypeChecker/Entailment.hs
+++ b/src/Language/PureScript/TypeChecker/Entailment.hs
@@ -13,7 +13,6 @@
--
-----------------------------------------------------------------------------
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE CPP #-}
module Language.PureScript.TypeChecker.Entailment (
@@ -22,7 +21,7 @@ module Language.PureScript.TypeChecker.Entailment (
import Data.Function (on)
import Data.List
-import Data.Maybe (maybeToList)
+import Data.Maybe (maybeToList, mapMaybe)
#if __GLASGOW_HASKELL__ < 710
import Data.Foldable (foldMap)
#endif
@@ -38,10 +37,8 @@ import Control.Monad.Writer.Class (tell)
import Language.PureScript.AST
import Language.PureScript.Errors
-import Language.PureScript.Environment
import Language.PureScript.Names
import Language.PureScript.TypeChecker.Monad
-import Language.PureScript.TypeChecker.Synonyms
import Language.PureScript.TypeChecker.Unify
import Language.PureScript.TypeClassDictionaries
import Language.PureScript.Types
@@ -51,11 +48,18 @@ import qualified Language.PureScript.Constants as C
-- Check that the current set of type class dictionaries entail the specified type class goal, and, if so,
-- return a type class dictionary reference.
--
-entails :: Environment -> ModuleName -> M.Map (Maybe ModuleName) (M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope)) -> Constraint -> Check Expr
-entails env moduleName context = solve
+entails :: ModuleName -> M.Map (Maybe ModuleName) (M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope)) -> Constraint -> Check Expr
+entails moduleName context = solve
where
- forClassName :: Qualified ProperName -> [TypeClassDictionaryInScope]
- forClassName cn = findDicts cn Nothing ++ findDicts cn (Just moduleName)
+ forClassName :: Qualified ProperName -> [Type] -> [TypeClassDictionaryInScope]
+ forClassName cn@(Qualified (Just mn) _) tys = concatMap (findDicts cn) (Nothing : Just mn : map Just (mapMaybe ctorModules tys))
+ forClassName _ _ = error "forClassName: expected qualified class name"
+
+ ctorModules :: Type -> Maybe ModuleName
+ ctorModules (TypeConstructor (Qualified (Just mn) _)) = Just mn
+ ctorModules (TypeConstructor (Qualified Nothing _)) = error "ctorModules: unqualified type name"
+ ctorModules (TypeApp ty _) = ctorModules ty
+ ctorModules _ = Nothing
findDicts :: Qualified ProperName -> Maybe ModuleName -> [TypeClassDictionaryInScope]
findDicts cn = maybe [] M.elems . (>>= M.lookup cn) . flip M.lookup context
@@ -69,18 +73,18 @@ entails env moduleName context = solve
go work className' tys' | work > 1000 = throwError . errorMessage $ PossiblyInfiniteInstance className' tys'
go work className' tys' = do
let instances = do
- tcd <- forClassName className'
+ tcd <- forClassName className' tys'
-- Make sure the type unifies with the type in the type instance definition
- subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' (tcdInstanceTypes tcd)
+ subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName) tys' (tcdInstanceTypes tcd)
return (subst, tcd)
(subst, tcd) <- unique instances
-- Solve any necessary subgoals
args <- solveSubgoals subst (tcdDependencies tcd)
- return $ foldr (\(superclassName, index) dict -> SubclassDictionaryValue dict superclassName index)
- (mkDictionary (canonicalizeDictionary tcd) args)
+ return $ foldr (\(superclassName, index) dict -> SubclassDictionaryValue dict superclassName index)
+ (mkDictionary (tcdName tcd) args)
(tcdPath tcd)
where
-
+
unique :: [(a, TypeClassDictionaryInScope)] -> Check (a, TypeClassDictionaryInScope)
unique [] = throwError . errorMessage $ NoInstanceFound className' tys'
unique [a] = return a
@@ -109,29 +113,29 @@ entails env moduleName context = solve
solveSubgoals subst (Just subgoals) = do
dict <- mapM (uncurry (go (work + 1)) . second (map (replaceAllTypeVars subst))) subgoals
return $ Just dict
-
+
-- Make a dictionary from subgoal dictionaries by applying the correct function
mkDictionary :: Qualified Ident -> Maybe [DictionaryValue] -> DictionaryValue
mkDictionary fnName Nothing = LocalDictionaryValue fnName
mkDictionary fnName (Just []) = GlobalDictionaryValue fnName
mkDictionary fnName (Just dicts) = DependentDictionaryValue fnName dicts
-
+
-- Turn a DictionaryValue into a Expr
dictionaryValueToValue :: DictionaryValue -> Expr
dictionaryValueToValue (LocalDictionaryValue fnName) = Var fnName
dictionaryValueToValue (GlobalDictionaryValue fnName) = Var fnName
dictionaryValueToValue (DependentDictionaryValue fnName dicts) = foldl App (Var fnName) (map dictionaryValueToValue dicts)
dictionaryValueToValue (SubclassDictionaryValue dict superclassName index) =
- App (Accessor (C.__superclass_ ++ show superclassName ++ "_" ++ show index)
+ App (Accessor (C.__superclass_ ++ showQualified runProperName superclassName ++ "_" ++ show index)
(dictionaryValueToValue dict))
valUndefined
-- Ensure that a substitution is valid
verifySubstitution :: [(String, Type)] -> Maybe [(String, Type)]
verifySubstitution subst = do
- let grps = groupBy ((==) `on` fst) subst
- guard (all (pairwise (unifiesWith env) . map snd) grps)
+ let grps = groupBy ((==) `on` fst) . sortBy (compare `on` fst) $ subst
+ guard (all (pairwise unifiesWith . map snd) grps)
return $ map head grps
-
+
valUndefined :: Expr
valUndefined = Var (Qualified (Just (ModuleName [ProperName C.prim])) (Ident C.undefined))
@@ -139,34 +143,31 @@ entails env moduleName context = solve
-- Check whether the type heads of two types are equal (for the purposes of type class dictionary lookup),
-- and return a substitution from type variables to types which makes the type heads unify.
--
-typeHeadsAreEqual :: ModuleName -> Environment -> Type -> Type -> Maybe [(String, Type)]
-typeHeadsAreEqual _ _ (Skolem _ s1 _) (Skolem _ s2 _) | s1 == s2 = Just []
-typeHeadsAreEqual _ _ t (TypeVar v) = Just [(v, t)]
-typeHeadsAreEqual _ _ (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = Just []
-typeHeadsAreEqual m e (TypeApp h1 t1) (TypeApp h2 t2) = (++) <$> typeHeadsAreEqual m e h1 h2
- <*> typeHeadsAreEqual m e t1 t2
-typeHeadsAreEqual m e (SaturatedTypeSynonym name args) t2 = case expandTypeSynonym' e name args of
- Left _ -> Nothing
- Right t1 -> typeHeadsAreEqual m e t1 t2
-typeHeadsAreEqual _ _ REmpty REmpty = Just []
-typeHeadsAreEqual m e r1@(RCons _ _ _) r2@(RCons _ _ _) =
+typeHeadsAreEqual :: ModuleName -> Type -> Type -> Maybe [(String, Type)]
+typeHeadsAreEqual _ (Skolem _ s1 _) (Skolem _ s2 _) | s1 == s2 = Just []
+typeHeadsAreEqual _ t (TypeVar v) = Just [(v, t)]
+typeHeadsAreEqual _ (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = Just []
+typeHeadsAreEqual m (TypeApp h1 t1) (TypeApp h2 t2) = (++) <$> typeHeadsAreEqual m h1 h2
+ <*> typeHeadsAreEqual m t1 t2
+typeHeadsAreEqual _ REmpty REmpty = Just []
+typeHeadsAreEqual m r1@RCons{} r2@RCons{} =
let (s1, r1') = rowToList r1
(s2, r2') = rowToList r2
-
+
int = [ (t1, t2) | (name, t1) <- s1, (name', t2) <- s2, name == name' ]
sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ]
sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ]
- in (++) <$> foldMap (\(t1, t2) -> typeHeadsAreEqual m e t1 t2) int
+ in (++) <$> foldMap (uncurry (typeHeadsAreEqual m)) int
<*> go sd1 r1' sd2 r2'
where
go :: [(String, Type)] -> Type -> [(String, Type)] -> Type -> Maybe [(String, Type)]
- go [] REmpty [] REmpty = Just []
- go [] (TUnknown _) _ _ = Just []
+ go [] REmpty [] REmpty = Just []
+ go [] (TUnknown _) _ _ = Just []
go [] (TypeVar v1) [] (TypeVar v2) | v1 == v2 = Just []
go [] (Skolem _ s1 _) [] (Skolem _ s2 _) | s1 == s2 = Just []
go sd r [] (TypeVar v) = Just [(v, rowFromList (sd, r))]
go _ _ _ _ = Nothing
-typeHeadsAreEqual _ _ _ _ = Nothing
+typeHeadsAreEqual _ _ _ = Nothing
-- |
-- Check all values in a list pairwise match a predicate
diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs
index 5cfe53e..26c2e87 100644
--- a/src/Language/PureScript/TypeChecker/Kinds.hs
+++ b/src/Language/PureScript/TypeChecker/Kinds.hs
@@ -83,7 +83,7 @@ kindOf _ ty = fst <$> kindOfWithScopedVars ty
--
kindOfWithScopedVars :: Type -> Check (Kind, [(String, Kind)])
kindOfWithScopedVars ty =
- rethrow (onErrorMessages (ErrorCheckingKind ty)) $
+ rethrow (addHint (ErrorCheckingKind ty)) $
fmap tidyUp . liftUnify $ infer ty
where
tidyUp ((k, args), sub) = ( starIfUnknown (sub $? k)
@@ -161,7 +161,7 @@ starIfUnknown k = k
-- Infer a kind for a type
--
infer :: Type -> UnifyT Kind Check (Kind, [(String, Kind)])
-infer ty = rethrow (onErrorMessages (ErrorCheckingKind ty)) $ infer' ty
+infer ty = rethrow (addHint (ErrorCheckingKind ty)) $ infer' ty
infer' :: Type -> UnifyT Kind Check (Kind, [(String, Kind)])
infer' (ForAll ident ty _) = do
@@ -215,8 +215,8 @@ infer' other = (, []) <$> go other
return $ Row k1
go (ConstrainedType deps ty) = do
forM_ deps $ \(className, tys) -> do
- _ <- go $ foldl TypeApp (TypeConstructor className) tys
- return ()
+ k <- go $ foldl TypeApp (TypeConstructor className) tys
+ k =?= Star
k <- go ty
k =?= Star
return Star
diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs
index 62c5648..22c0d8c 100644
--- a/src/Language/PureScript/TypeChecker/Monad.hs
+++ b/src/Language/PureScript/TypeChecker/Monad.hs
@@ -76,7 +76,7 @@ withScopedTypeVars mn ks = bindTypes (M.fromList (map (\(name, k) -> (Qualified
withTypeClassDictionaries :: (MonadState CheckState m) => [TypeClassDictionaryInScope] -> m a -> m a
withTypeClassDictionaries entries action = do
orig <- get
- let mentries = M.fromListWith (M.unionWith M.union) [ (mn, M.singleton className (M.singleton (canonicalizeDictionary entry) entry)) | entry@TypeClassDictionaryInScope{ tcdName = Qualified mn _, tcdClassName = className } <- entries ]
+ let mentries = M.fromListWith (M.unionWith M.union) [ (mn, M.singleton className (M.singleton (tcdName entry) entry)) | entry@TypeClassDictionaryInScope{ tcdName = Qualified mn _, tcdClassName = className } <- entries ]
modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = M.unionWith (M.unionWith M.union) (typeClassDictionaries . checkEnv $ st) mentries } }
a <- action
modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = typeClassDictionaries . checkEnv $ orig } }
@@ -276,4 +276,3 @@ liftUnifyWarnings replace unify = do
let uust = unifyCurrentSubstitution ust
tell $ onErrorMessages (replace uust) w
return (a, uust)
-
diff --git a/src/Language/PureScript/TypeChecker/Rows.hs b/src/Language/PureScript/TypeChecker/Rows.hs
index 2bd7b7f..1b16e10 100644
--- a/src/Language/PureScript/TypeChecker/Rows.hs
+++ b/src/Language/PureScript/TypeChecker/Rows.hs
@@ -46,7 +46,6 @@ checkDuplicateLabels =
where
checkDups :: Type -> Check ()
checkDups (TypeApp t1 t2) = checkDups t1 >> checkDups t2
- checkDups (SaturatedTypeSynonym _ ts) = mapM_ checkDups ts
checkDups (ForAll _ t _) = checkDups t
checkDups (ConstrainedType args t) = do
mapM_ checkDups $ concatMap snd args
diff --git a/src/Language/PureScript/TypeChecker/Skolems.hs b/src/Language/PureScript/TypeChecker/Skolems.hs
index f282e14..c388b6f 100644
--- a/src/Language/PureScript/TypeChecker/Skolems.hs
+++ b/src/Language/PureScript/TypeChecker/Skolems.hs
@@ -92,7 +92,7 @@ skolemEscapeCheck root@TypedValue{} =
let (_, f, _, _, _) = everythingWithContextOnValues [] [] (++) def go def def def
in case f root of
[] -> return ()
- ((binding, val) : _) -> throwError . singleError $ ErrorInExpression val $ SimpleErrorWrapper $ EscapedSkolem binding
+ ((binding, val) : _) -> throwError . singleError $ ErrorMessage [ ErrorInExpression val ] $ EscapedSkolem binding
where
def s _ = (s, [])
diff --git a/src/Language/PureScript/TypeChecker/Subsumption.hs b/src/Language/PureScript/TypeChecker/Subsumption.hs
index b370a29..d87acfc 100644
--- a/src/Language/PureScript/TypeChecker/Subsumption.hs
+++ b/src/Language/PureScript/TypeChecker/Subsumption.hs
@@ -20,7 +20,6 @@ module Language.PureScript.TypeChecker.Subsumption (
import Data.List (sortBy)
import Data.Ord (comparing)
-import Control.Monad
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.Unify
@@ -29,7 +28,6 @@ import Language.PureScript.Environment
import Language.PureScript.Errors
import Language.PureScript.TypeChecker.Monad
import Language.PureScript.TypeChecker.Skolems
-import Language.PureScript.TypeChecker.Synonyms
import Language.PureScript.TypeChecker.Unify
import Language.PureScript.Types
@@ -37,7 +35,7 @@ import Language.PureScript.Types
-- Check whether one type subsumes another, rethrowing errors to provide a better error message
--
subsumes :: Maybe Expr -> Type -> Type -> UnifyT Type Check (Maybe Expr)
-subsumes val ty1 ty2 = rethrow (onErrorMessages (ErrorInSubsumption ty1 ty2)) $ subsumes' val ty1 ty2
+subsumes val ty1 ty2 = rethrow (addHint (ErrorInSubsumption ty1 ty2)) $ subsumes' val ty1 ty2
-- |
-- Check whether one type subsumes another
@@ -57,12 +55,6 @@ subsumes' val (TypeApp (TypeApp f1 arg1) ret1) (TypeApp (TypeApp f2 arg2) ret2)
_ <- subsumes Nothing arg2 arg1
_ <- subsumes Nothing ret1 ret2
return val
-subsumes' val (SaturatedTypeSynonym name tyArgs) ty2 = do
- ty1 <- introduceSkolemScope <=< expandTypeSynonym name $ tyArgs
- subsumes val ty1 ty2
-subsumes' val ty1 (SaturatedTypeSynonym name tyArgs) = do
- ty2 <- introduceSkolemScope <=< expandTypeSynonym name $ tyArgs
- subsumes val ty1 ty2
subsumes' val (KindedType ty1 _) ty2 =
subsumes val ty1 ty2
subsumes' val ty1 (KindedType ty2 _) =
diff --git a/src/Language/PureScript/TypeChecker/Synonyms.hs b/src/Language/PureScript/TypeChecker/Synonyms.hs
index 71a2422..0796665 100644
--- a/src/Language/PureScript/TypeChecker/Synonyms.hs
+++ b/src/Language/PureScript/TypeChecker/Synonyms.hs
@@ -9,22 +9,18 @@
-- Portability :
--
-- |
--- Functions for replacing fully applied type synonyms with the @SaturatedTypeSynonym@ data constructor
+-- Functions for replacing fully applied type synonyms
--
-----------------------------------------------------------------------------
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE CPP #-}
module Language.PureScript.TypeChecker.Synonyms (
- saturateAllTypeSynonyms,
- desaturateAllTypeSynonyms,
- replaceAllTypeSynonyms,
- expandAllTypeSynonyms,
- expandTypeSynonym,
- expandTypeSynonym'
+ replaceAllTypeSynonyms
) where
import Data.Maybe (fromMaybe)
@@ -38,73 +34,31 @@ import Control.Monad.State
import Language.PureScript.Environment
import Language.PureScript.Errors
-import Language.PureScript.Names
import Language.PureScript.TypeChecker.Monad
import Language.PureScript.Types
-- |
--- Build a type substitution for a type synonym
+-- Replace fully applied type synonyms.
--
-buildTypeSubstitution :: M.Map (Qualified ProperName) Int -> Type -> Either ErrorMessage (Maybe Type)
-buildTypeSubstitution m = go 0 []
+replaceAllTypeSynonyms' :: Environment -> Type -> Either MultipleErrors Type
+replaceAllTypeSynonyms' env = everywhereOnTypesTopDownM try
where
- go :: Int -> [Type] -> Type -> Either ErrorMessage (Maybe Type)
- go c args (TypeConstructor ctor) | M.lookup ctor m == Just c = return (Just $ SaturatedTypeSynonym ctor args)
- go c _ (TypeConstructor ctor) | M.lookup ctor m > Just c = throwError $ SimpleErrorWrapper $ PartiallyAppliedSynonym ctor
- go c args (TypeApp f arg) = go (c + 1) (arg:args) f
- go _ _ _ = return Nothing
-
--- |
--- Replace all type synonyms with the @SaturatedTypeSynonym@ data constructor
---
-saturateAllTypeSynonyms :: M.Map (Qualified ProperName) Int -> Type -> Either ErrorMessage Type
-saturateAllTypeSynonyms syns = everywhereOnTypesTopDownM replace
- where
- replace t = fromMaybe t <$> buildTypeSubstitution syns t
+ try :: Type -> Either MultipleErrors Type
+ try t = fromMaybe t <$> go 0 [] t
--- |
--- \"Desaturate\" @SaturatedTypeSynonym@s
---
-desaturateAllTypeSynonyms :: Type -> Type
-desaturateAllTypeSynonyms = everywhereOnTypes replaceSaturatedTypeSynonym
- where
- replaceSaturatedTypeSynonym (SaturatedTypeSynonym name args) = foldl TypeApp (TypeConstructor name) args
- replaceSaturatedTypeSynonym t = t
-
--- |
--- Replace fully applied type synonyms with the @SaturatedTypeSynonym@ data constructor, which helps generate
--- better error messages during unification.
---
-replaceAllTypeSynonyms' :: Environment -> Type -> Either ErrorMessage Type
-replaceAllTypeSynonyms' env d =
- let
- syns = length . fst <$> typeSynonyms env
- in
- saturateAllTypeSynonyms syns d
+ go :: Int -> [Type] -> Type -> Either MultipleErrors (Maybe Type)
+ go c args (TypeConstructor ctor)
+ | Just (synArgs, body) <- M.lookup ctor (typeSynonyms env)
+ , c == length synArgs
+ = let repl = replaceAllTypeVars (zip (map fst synArgs) args) body
+ in Just <$> try repl
+ | Just (synArgs, _) <- M.lookup ctor (typeSynonyms env)
+ , length synArgs > c
+ = throwError . errorMessage $ PartiallyAppliedSynonym ctor
+ go c args (TypeApp f arg) = go (c + 1) (arg : args) f
+ go _ _ _ = return Nothing
replaceAllTypeSynonyms :: (e ~ MultipleErrors, Functor m, Monad m, MonadState CheckState m, MonadError e m) => Type -> m Type
replaceAllTypeSynonyms d = do
env <- getEnv
- either (throwError . singleError) return $ replaceAllTypeSynonyms' env d
-
--- |
--- Replace a type synonym and its arguments with the aliased type
---
-expandTypeSynonym' :: Environment -> Qualified ProperName -> [Type] -> Either ErrorMessage Type
-expandTypeSynonym' env name args =
- case M.lookup name (typeSynonyms env) of
- Just (synArgs, body) -> do
- let repl = replaceAllTypeVars (zip (map fst synArgs) args) body
- replaceAllTypeSynonyms' env repl
- Nothing -> error "Type synonym was not defined"
-
-expandTypeSynonym :: (e ~ MultipleErrors, Functor m, Monad m, MonadState CheckState m, MonadError e m) => Qualified ProperName -> [Type] -> m Type
-expandTypeSynonym name args = do
- env <- getEnv
- either (throwError . singleError) return $ expandTypeSynonym' env name args
-
-expandAllTypeSynonyms :: (e ~ MultipleErrors, Functor m, Applicative m, Monad m, MonadState CheckState m, MonadError e m) => Type -> m Type
-expandAllTypeSynonyms = everywhereOnTypesTopDownM go
- where
- go (SaturatedTypeSynonym name args) = expandTypeSynonym name args
- go other = return other
+ either throwError return $ replaceAllTypeSynonyms' env d
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index 2121a97..c34fb5f 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -67,24 +67,17 @@ import Language.PureScript.TypeChecker.Synonyms
import Language.PureScript.TypeChecker.Unify
import Language.PureScript.TypeClassDictionaries
import Language.PureScript.Types
-import qualified Language.PureScript.Constants as C
-- |
-- Infer the types of multiple mutually-recursive values, and return elaborated values including
-- type class dictionaries and type annotations.
--
-typesOf :: Maybe ModuleName -> ModuleName -> [(Ident, Expr)] -> Check [(Ident, (Expr, Type))]
-typesOf mainModuleName moduleName vals = do
+typesOf :: ModuleName -> [(Ident, Expr)] -> Check [(Ident, (Expr, Type))]
+typesOf moduleName vals = do
tys <- fmap tidyUp . liftUnifyWarnings replace $ do
(untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName vals
- ds1 <- parU typed $ \e -> do
- triple@(_, (_, ty)) <- checkTypedBindingGroupElement moduleName e dict
- checkMain (fst e) ty
- return triple
- ds2 <- forM untyped $ \e -> do
- triple@(_, (_, ty)) <- typeForBindingGroupElement e dict untypedDict
- checkMain (fst e) ty
- return triple
+ ds1 <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict
+ ds2 <- forM untyped $ \e -> typeForBindingGroupElement e dict untypedDict
return $ ds1 ++ ds2
forM tys $ \(ident, (val, ty)) -> do
@@ -94,21 +87,13 @@ typesOf mainModuleName moduleName vals = do
skolemEscapeCheck val'
-- Check rows do not contain duplicate labels
checkDuplicateLabels val'
- -- Remove type synonyms placeholders, and replace
- -- top-level unification variables with named type variables.
- let val'' = overTypes desaturateAllTypeSynonyms val'
- ty' = varIfUnknown . desaturateAllTypeSynonyms $ ty
- return (ident, (val'', ty'))
+ return (ident, (val', varIfUnknown ty))
where
-- Apply the substitution that was returned from runUnify to both types and (type-annotated) values
tidyUp (ts, sub) = map (\(i, (val, ty)) -> (i, (overTypes (sub $?) val, sub $? ty))) ts
-- Replace all the wildcards types with their inferred types
- replace sub (SimpleErrorWrapper (WildcardInferredType ty)) = SimpleErrorWrapper $ WildcardInferredType (sub $? ty)
+ replace sub (ErrorMessage hints (WildcardInferredType ty)) = ErrorMessage hints $ WildcardInferredType (sub $? ty)
replace _ em = em
- -- If --main is enabled, need to check that `main` has type Eff eff a for some eff, a
- checkMain nm ty = when (Just moduleName == mainModuleName && nm == Ident C.main) $ do
- [eff, a] <- replicateM 2 fresh
- ty =?= TypeApp (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Control", ProperName "Monad", ProperName "Eff"])) (ProperName "Eff"))) eff) a
type TypeData = M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility)
@@ -141,7 +126,7 @@ checkTypedBindingGroupElement mn (ident, (val', ty, checkType)) dict = do
ty' <- replaceTypeWildcards ty
-- Kind check
(kind, args) <- liftCheck $ kindOfWithScopedVars ty
- checkTypeKind kind
+ checkTypeKind ty kind
-- Check the type with the new names in scope
ty'' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty'
val'' <- if checkType
@@ -182,16 +167,14 @@ replaceTypeClassDictionaries mn =
let (_, f, _) = everywhereOnValuesTopDownM return go return
in f
where
- go (TypeClassDictionary constraint dicts) = do
- env <- getEnv
- entails env mn dicts constraint
+ go (TypeClassDictionary constraint dicts) = entails mn dicts constraint
go other = return other
-- |
-- Check the kind of a type, failing if it is not of kind *.
--
-checkTypeKind :: Kind -> UnifyT t Check ()
-checkTypeKind kind = guardWith (errorMessage (ExpectedType kind)) $ kind == Star
+checkTypeKind :: Type -> Kind -> UnifyT t Check ()
+checkTypeKind ty kind = guardWith (errorMessage (ExpectedType ty kind)) $ kind == Star
-- |
-- Remove any ForAlls and ConstrainedType constructors in a type by introducing new unknowns
@@ -214,7 +197,7 @@ instantiatePolyTypeWithUnknowns val ty = return (val, ty)
-- Infer a type for a value, rethrowing any error to provide a more useful error message
--
infer :: Expr -> UnifyT Type Check Expr
-infer val = rethrow (onErrorMessages (ErrorInferringType val)) $ infer' val
+infer val = rethrow (addHint (ErrorInferringType val)) $ infer' val
-- |
-- Infer a type for a value
@@ -246,15 +229,10 @@ infer' (ObjectUpdate o ps) = do
o' <- TypedValue True <$> check o oldTy <*> pure oldTy
return $ TypedValue True (ObjectUpdate o' newVals) $ TypeApp tyObject $ rowFromList (newTys, row)
infer' (Accessor prop val) = do
- typed@(TypedValue _ _ objTy) <- infer val
- propTy <- inferProperty objTy prop
- case propTy of
- Nothing -> do
- field <- fresh
- rest <- fresh
- _ <- subsumes Nothing objTy (TypeApp tyObject (RCons prop field rest))
- return $ TypedValue True (Accessor prop typed) field
- Just ty -> return $ TypedValue True (Accessor prop typed) ty
+ field <- fresh
+ rest <- fresh
+ typed <- check val (TypeApp tyObject (RCons prop field rest))
+ return $ TypedValue True (Accessor prop typed) field
infer' (Abs (Left arg) ret) = do
ty <- fresh
Just moduleName <- checkCurrentModule <$> get
@@ -282,10 +260,10 @@ infer' v@(Constructor c) = do
Just (_, _, ty, _) -> do (v', ty') <- sndM (introduceSkolemScope <=< replaceAllTypeSynonyms) <=< instantiatePolyTypeWithUnknowns v $ ty
return $ TypedValue True v' ty'
infer' (Case vals binders) = do
- ts <- mapM infer vals
+ (vals', ts) <- instantiateForBinders vals binders
ret <- fresh
- binders' <- checkBinders (map (\(TypedValue _ _ t) -> t) ts) ret binders
- return $ TypedValue True (Case ts binders') ret
+ binders' <- checkBinders ts ret binders
+ return $ TypedValue True (Case vals' binders') ret
infer' (IfThenElse cond th el) = do
cond' <- check cond tyBoolean
v2@(TypedValue _ _ t2) <- infer th
@@ -301,7 +279,7 @@ infer' (SuperClassDictionary className tys) = do
infer' (TypedValue checkType val ty) = do
Just moduleName <- checkCurrentModule <$> get
(kind, args) <- liftCheck $ kindOfWithScopedVars ty
- checkTypeKind kind
+ checkTypeKind ty kind
ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty
val' <- if checkType then withScopedTypeVars moduleName args (check val ty') else return val
return $ TypedValue True val' ty'
@@ -313,7 +291,7 @@ inferLetBinding seen [] ret j = (,) seen <$> withBindingGroupVisible (j ret)
inferLetBinding seen (ValueDeclaration ident nameKind [] (Right (tv@(TypedValue checkType val ty))) : rest) ret j = do
Just moduleName <- checkCurrentModule <$> get
(kind, args) <- liftCheck $ kindOfWithScopedVars ty
- checkTypeKind kind
+ checkTypeKind ty kind
let dict = M.singleton (moduleName, ident) (ty, nameKind, Undefined)
ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty
TypedValue _ val' ty'' <- if checkType then withScopedTypeVars moduleName args (bindNames dict (check val ty')) else return tv
@@ -340,21 +318,6 @@ inferLetBinding seen (PositionedDeclaration pos com d : ds) ret j = warnAndRethr
inferLetBinding _ _ _ _ = error "Invalid argument to inferLetBinding"
-- |
--- Infer the type of a property inside a record with a given type
---
-inferProperty :: Type -> String -> UnifyT Type Check (Maybe Type)
-inferProperty (TypeApp obj row) prop | obj == tyObject = do
- let (props, _) = rowToList row
- return $ lookup prop props
-inferProperty (SaturatedTypeSynonym name args) prop = do
- replaced <- introduceSkolemScope <=< expandTypeSynonym name $ args
- inferProperty replaced prop
-inferProperty (ForAll ident ty _) prop = do
- replaced <- replaceVarWithUnknown ident ty
- inferProperty replaced prop
-inferProperty _ _ = return Nothing
-
--- |
-- Infer the types of variables brought into scope by a binder
--
inferBinder :: Type -> Binder -> UnifyT Type Check (M.Map Ident Type)
@@ -376,7 +339,7 @@ inferBinder val (ConstructorBinder ctor binders) = do
go [] ty' = case (val, ty') of
(TypeConstructor _, TypeApp _ _) -> throwIncorrectArity
_ -> do
- _ <- subsumes Nothing val ty'
+ _ <- val =?= ty'
return M.empty
go (binder : binders') (TypeApp (TypeApp t obj) ret) | t == tyFunction =
M.union <$> inferBinder obj binder <*> go binders' ret
@@ -407,6 +370,29 @@ inferBinder val (NamedBinder name binder) = do
return $ M.insert name val m
inferBinder val (PositionedBinder pos _ binder) =
warnAndRethrowWithPosition pos $ inferBinder val binder
+-- TODO: When adding support for polymorphic types, check subsumption here
+-- and change the definition of `binderRequiresMonotype`
+inferBinder val (TypedBinder ty binder) = val =?= ty >> inferBinder val binder
+
+-- | Returns true if a binder requires its argument type to be a monotype.
+-- | If this is the case, we need to instantiate any polymorphic types before checking binders.
+binderRequiresMonotype :: Binder -> Bool
+binderRequiresMonotype NullBinder = False
+binderRequiresMonotype (VarBinder _) = False
+binderRequiresMonotype (NamedBinder _ b) = binderRequiresMonotype b
+binderRequiresMonotype (PositionedBinder _ _ b) = binderRequiresMonotype b
+binderRequiresMonotype _ = True
+
+-- | Instantiate polytypes only when necessitated by a binder.
+instantiateForBinders :: [Expr] -> [CaseAlternative] -> UnifyT Type Check ([Expr], [Type])
+instantiateForBinders vals cas = unzip <$> zipWithM (\val inst -> do
+ TypedValue _ val' ty <- infer val
+ if inst
+ then instantiatePolyTypeWithUnknowns val' ty
+ else return (val', ty)) vals shouldInstantiate
+ where
+ shouldInstantiate :: [Bool]
+ shouldInstantiate = map (any binderRequiresMonotype) . transpose . map caseAlternativeBinders $ cas
-- |
-- Check the types of the return values in a set of binders in a case statement
@@ -437,7 +423,7 @@ checkBinders nvals ret (CaseAlternative binders result : bs) = do
-- Check the type of a value, rethrowing errors to provide a better error message
--
check :: Expr -> Type -> UnifyT Type Check Expr
-check val ty = rethrow (onErrorMessages (ErrorCheckingType val ty)) $ check' val ty
+check val ty = rethrow (addHint (ErrorCheckingType val ty)) $ check' val ty
-- |
-- Check the type of a value
@@ -469,13 +455,10 @@ check' val t@(ConstrainedType constraints ty) = do
name
(supName, instantiateSuperclass (map fst args) supArgs instanceTy)
) superclasses [0..]
- return (TypeClassDictionaryInScope name path className instanceTy Nothing TCDRegular : supDicts)
+ return (TypeClassDictionaryInScope name path className instanceTy Nothing : supDicts)
instantiateSuperclass :: [String] -> [Type] -> [Type] -> [Type]
instantiateSuperclass args supArgs tys = map (replaceAllTypeVars (zip args tys)) supArgs
-check' val (SaturatedTypeSynonym name args) = do
- ty <- introduceSkolemScope <=< expandTypeSynonym name $ args
- check val ty
check' val u@(TUnknown _) = do
val'@(TypedValue _ _ ty) <- infer val
-- Don't unify an unknown with an inferred polytype
@@ -527,7 +510,7 @@ check' (SuperClassDictionary className tys) _ = do
check' (TypedValue checkType val ty1) ty2 = do
Just moduleName <- checkCurrentModule <$> get
(kind, args) <- liftCheck $ kindOfWithScopedVars ty1
- checkTypeKind kind
+ checkTypeKind ty1 kind
ty1' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty1
ty2' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty2
val' <- subsumes (Just val) ty1' ty2'
@@ -537,8 +520,7 @@ check' (TypedValue checkType val ty1) ty2 = do
val''' <- if checkType then withScopedTypeVars moduleName args (check val ty2') else return val
return $ TypedValue checkType val''' ty2'
check' (Case vals binders) ret = do
- vals' <- mapM infer vals
- let ts = map (\(TypedValue _ _ t) -> t) vals'
+ (vals', ts) <- instantiateForBinders vals binders
binders' <- checkBinders ts ret binders
return $ TypedValue True (Case vals' binders') ret
check' (IfThenElse cond th el) ty = do
@@ -567,33 +549,31 @@ check' (Accessor prop val) ty = do
rest <- fresh
val' <- check val (TypeApp tyObject (RCons prop ty rest))
return $ TypedValue True (Accessor prop val') ty
-check' (Constructor c) ty = do
+check' v@(Constructor c) ty = do
env <- getEnv
case M.lookup c (dataConstructors env) of
Nothing -> throwError . errorMessage $ UnknownDataConstructor c Nothing
Just (_, _, ty1, _) -> do
repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1
- _ <- subsumes Nothing repl ty
- return $ TypedValue True (Constructor c) ty
+ mv <- subsumes (Just v) repl ty
+ case mv of
+ Nothing -> throwError . errorMessage $ SubsumptionCheckFailed
+ Just v' -> return $ TypedValue True v' ty
check' (Let ds val) ty = do
(ds', val') <- inferLetBinding [] ds val (`check` ty)
return $ TypedValue True (Let ds' val') ty
-check' val ty | containsTypeSynonyms ty = do
- ty' <- introduceSkolemScope <=< expandAllTypeSynonyms <=< replaceTypeWildcards $ ty
- check val ty'
check' val kt@(KindedType ty kind) = do
- checkTypeKind kind
+ checkTypeKind ty kind
val' <- check' val ty
return $ TypedValue True val' kt
check' (PositionedValue pos _ val) ty =
warnAndRethrowWithPosition pos $ check' val ty
-check' val ty = throwError . errorMessage $ ExprDoesNotHaveType val ty
-
-containsTypeSynonyms :: Type -> Bool
-containsTypeSynonyms = everythingOnTypes (||) go where
- go (SaturatedTypeSynonym _ _) = True
- go _ = False
-
+check' val ty = do
+ TypedValue _ val' ty' <- infer val
+ mt <- subsumes (Just val') ty' ty
+ case mt of
+ Nothing -> throwError . errorMessage $ SubsumptionCheckFailed
+ Just v' -> return $ TypedValue True v' ty
-- |
-- Check the type of a collection of named record fields
@@ -629,7 +609,7 @@ checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where
-- Check the type of a function application, rethrowing errors to provide a better error message
--
checkFunctionApplication :: Expr -> Type -> Expr -> Maybe Type -> UnifyT Type Check (Type, Expr)
-checkFunctionApplication fn fnTy arg ret = rethrow (onErrorMessages (ErrorInApplication fn fnTy arg)) $ do
+checkFunctionApplication fn fnTy arg ret = rethrow (addHint (ErrorInApplication fn fnTy arg)) $ do
subst <- unifyCurrentSubstitution <$> UnifyT get
checkFunctionApplication' fn (subst $? fnTy) arg (($?) subst <$> ret)
@@ -657,9 +637,6 @@ checkFunctionApplication' fn u@(TUnknown _) arg ret = do
ret' <- maybe fresh return ret
u =?= function ty ret'
return (ret', App fn arg')
-checkFunctionApplication' fn (SaturatedTypeSynonym name tyArgs) arg ret = do
- ty <- introduceSkolemScope <=< expandTypeSynonym name $ tyArgs
- checkFunctionApplication fn ty arg ret
checkFunctionApplication' fn (KindedType ty _) arg ret =
checkFunctionApplication fn ty arg ret
checkFunctionApplication' fn (ConstrainedType constraints fnTy) arg ret = do
diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs
index e803dbf..5c2ff55 100644
--- a/src/Language/PureScript/TypeChecker/Unify.hs
+++ b/src/Language/PureScript/TypeChecker/Unify.hs
@@ -36,11 +36,9 @@ import Control.Monad.Unify
import Control.Monad.Writer
import Control.Monad.Error.Class (MonadError(..))
-import Language.PureScript.Environment
import Language.PureScript.Errors
import Language.PureScript.TypeChecker.Monad
import Language.PureScript.TypeChecker.Skolems
-import Language.PureScript.TypeChecker.Synonyms
import Language.PureScript.Types
instance Partial Type where
@@ -63,16 +61,12 @@ instance Unifiable Check Type where
-- Unify two types, updating the current substitution
--
unifyTypes :: Type -> Type -> UnifyT Type Check ()
-unifyTypes t1 t2 = rethrow (onErrorMessages (ErrorUnifyingTypes t1 t2)) $
+unifyTypes t1 t2 = rethrow (addHint (ErrorUnifyingTypes t1 t2)) $
unifyTypes' t1 t2
where
unifyTypes' (TUnknown u1) (TUnknown u2) | u1 == u2 = return ()
unifyTypes' (TUnknown u) t = u =:= t
unifyTypes' t (TUnknown u) = u =:= t
- unifyTypes' (SaturatedTypeSynonym name args) ty = do
- ty1 <- introduceSkolemScope <=< expandTypeSynonym name $ args
- ty1 `unifyTypes` ty
- unifyTypes' ty s@(SaturatedTypeSynonym _ _) = s `unifyTypes` ty
unifyTypes' (ForAll ident1 ty1 sc1) (ForAll ident2 ty2 sc2) =
case (sc1, sc2) of
(Just sc1', Just sc2') -> do
@@ -132,10 +126,6 @@ unifyRows r1 r2 =
rest <- fresh
u1 =:= rowFromList (sd2, rest)
u2 =:= rowFromList (sd1, rest)
- unifyRows' sd1 (SaturatedTypeSynonym name args) sd2 r2' = do
- r1' <- expandTypeSynonym name $ args
- unifyRows (rowFromList (sd1, r1')) (rowFromList (sd2, r2'))
- unifyRows' sd1 r1' sd2 r2'@(SaturatedTypeSynonym _ _) = unifyRows' sd2 r2' sd1 r1'
unifyRows' [] REmpty [] REmpty = return ()
unifyRows' [] (TypeVar v1) [] (TypeVar v2) | v1 == v2 = return ()
unifyRows' [] (Skolem _ s1 _) [] (Skolem _ s2 _) | s1 == s2 = return ()
@@ -144,35 +134,31 @@ unifyRows r1 r2 =
-- |
-- Check that two types unify
--
-unifiesWith :: Environment -> Type -> Type -> Bool
-unifiesWith _ (TUnknown u1) (TUnknown u2) | u1 == u2 = True
-unifiesWith _ (Skolem _ s1 _) (Skolem _ s2 _) | s1 == s2 = True
-unifiesWith _ (TypeVar v1) (TypeVar v2) | v1 == v2 = True
-unifiesWith _ (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = True
-unifiesWith e (TypeApp h1 t1) (TypeApp h2 t2) = unifiesWith e h1 h2 && unifiesWith e t1 t2
-unifiesWith e (SaturatedTypeSynonym name args) t2 =
- case expandTypeSynonym' e name args of
- Left _ -> False
- Right t1 -> unifiesWith e t1 t2
-unifiesWith e t1 t2@(SaturatedTypeSynonym _ _) = unifiesWith e t2 t1
-unifiesWith _ REmpty REmpty = True
-unifiesWith e r1@(RCons _ _ _) r2@(RCons _ _ _) =
+unifiesWith :: Type -> Type -> Bool
+unifiesWith (TUnknown u1) (TUnknown u2) | u1 == u2 = True
+unifiesWith (Skolem _ s1 _) (Skolem _ s2 _) | s1 == s2 = True
+unifiesWith (TypeVar v1) (TypeVar v2) | v1 == v2 = True
+unifiesWith (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = True
+unifiesWith (TypeApp h1 t1) (TypeApp h2 t2) = h1 `unifiesWith` h2 && t1 `unifiesWith` t2
+unifiesWith REmpty REmpty = True
+unifiesWith r1@RCons{} r2@RCons{} =
let (s1, r1') = rowToList r1
(s2, r2') = rowToList r2
int = [ (t1, t2) | (name, t1) <- s1, (name', t2) <- s2, name == name' ]
sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ]
sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ]
- in all (\(t1, t2) -> unifiesWith e t1 t2) int && go sd1 r1' sd2 r2'
+ in all (uncurry unifiesWith) int && go sd1 r1' sd2 r2'
where
go :: [(String, Type)] -> Type -> [(String, Type)] -> Type -> Bool
go [] REmpty [] REmpty = True
go [] (TypeVar v1) [] (TypeVar v2) = v1 == v2
go [] (Skolem _ s1 _) [] (Skolem _ s2 _) = s1 == s2
- go _ (TUnknown _) _ _ = True
- go _ _ _ (TUnknown _) = True
+ go [] (TUnknown _) _ _ = True
+ go _ _ [] (TUnknown _) = True
+ go _ (TUnknown _) _ (TUnknown _) = True
go _ _ _ _ = False
-unifiesWith _ _ _ = False
+unifiesWith _ _ = False
-- |
-- Replace a single type variable with a new unification variable
diff --git a/src/Language/PureScript/TypeClassDictionaries.hs b/src/Language/PureScript/TypeClassDictionaries.hs
index 33435c2..6c0ccd5 100644
--- a/src/Language/PureScript/TypeClassDictionaries.hs
+++ b/src/Language/PureScript/TypeClassDictionaries.hs
@@ -36,22 +36,7 @@ data TypeClassDictionaryInScope
, tcdInstanceTypes :: [Type]
-- | Type class dependencies which must be satisfied to construct this dictionary
, tcdDependencies :: Maybe [Constraint]
- -- | The type of this dictionary
- , tcdType :: TypeClassDictionaryType
- } deriving (Show, Data, Typeable)
-
--- |
--- The type of a type class dictionary
---
-data TypeClassDictionaryType
- -- |
- -- A regular type class dictionary
- --
- = TCDRegular
- -- |
- -- A type class dictionary which is an alias for an imported dictionary from another module
- --
- | TCDAlias (Qualified Ident) deriving (Show, Eq, Data, Typeable)
+ } deriving (Show, Read, Data, Typeable)
-- |
-- A simplified representation of expressions which are used to represent type
@@ -74,11 +59,4 @@ data DictionaryValue
-- A subclass dictionary
--
| SubclassDictionaryValue DictionaryValue (Qualified ProperName) Integer
- deriving (Show, Ord, Eq)
-
--- |
--- Find the original dictionary which a type class dictionary in scope refers to
---
-canonicalizeDictionary :: TypeClassDictionaryInScope -> Qualified Ident
-canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDRegular, tcdName = nm }) = nm
-canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDAlias nm }) = nm
+ deriving (Show, Read, Ord, Eq)
diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs
index c9b6ef4..dec6641 100644
--- a/src/Language/PureScript/Types.hs
+++ b/src/Language/PureScript/Types.hs
@@ -22,6 +22,7 @@ module Language.PureScript.Types where
import Data.Data
import Data.List (nub)
+import Data.Maybe (fromMaybe)
import qualified Data.Aeson as A
import qualified Data.Aeson.TH as A
@@ -39,7 +40,7 @@ import Language.PureScript.Traversals
-- |
-- An identifier for the scope of a skolem variable
--
-newtype SkolemScope = SkolemScope { runSkolemScope :: Int } deriving (Show, Eq, Ord, Data, Typeable, A.ToJSON, A.FromJSON)
+newtype SkolemScope = SkolemScope { runSkolemScope :: Int } deriving (Show, Read, Eq, Ord, Data, Typeable, A.ToJSON, A.FromJSON)
-- |
-- The type of types
@@ -66,10 +67,6 @@ data Type
--
| TypeApp Type Type
-- |
- -- A type synonym which is \"saturated\", i.e. fully applied
- --
- | SaturatedTypeSynonym (Qualified ProperName) [Type]
- -- |
-- Forall quantifier
--
| ForAll String Type (Maybe SkolemScope)
@@ -105,7 +102,7 @@ data Type
-- |
-- A placeholder used in pretty printing
--
- | PrettyPrintForAll [String] Type deriving (Show, Eq, Ord, Data, Typeable)
+ | PrettyPrintForAll [String] Type deriving (Show, Read,Eq, Ord, Data, Typeable)
-- |
-- A typeclass constraint
@@ -156,12 +153,8 @@ replaceAllTypeVars = go []
where
go :: [String] -> [(String, Type)] -> Type -> Type
- go _ m (TypeVar v) =
- case v `lookup` m of
- Just r -> r
- Nothing -> TypeVar v
+ go _ m (TypeVar v) = fromMaybe (TypeVar v) (v `lookup` m)
go bs m (TypeApp t1 t2) = TypeApp (go bs m t1) (go bs m t2)
- go bs m (SaturatedTypeSynonym name' ts) = SaturatedTypeSynonym name' $ map (go bs m) ts
go bs m f@(ForAll v t sco) | v `elem` keys = go bs (filter ((/= v) . fst) m) f
| v `elem` usedVars =
let v' = genName v (keys ++ bs ++ usedVars)
@@ -200,7 +193,6 @@ freeTypeVariables = nub . go []
go :: [String] -> Type -> [String]
go bound (TypeVar v) | v `notElem` bound = [v]
go bound (TypeApp t1 t2) = go bound t1 ++ go bound t2
- go bound (SaturatedTypeSynonym _ ts) = concatMap (go bound) ts
go bound (ForAll v t _) = go (v : bound) t
go bound (ConstrainedType cs t) = concatMap (concatMap (go bound) . snd) cs ++ go bound t
go bound (RCons _ t r) = go bound t ++ go bound r
@@ -247,7 +239,6 @@ everywhereOnTypes :: (Type -> Type) -> Type -> Type
everywhereOnTypes f = go
where
go (TypeApp t1 t2) = f (TypeApp (go t1) (go t2))
- go (SaturatedTypeSynonym name tys) = f (SaturatedTypeSynonym name (map go tys))
go (ForAll arg ty sco) = f (ForAll arg (go ty) sco)
go (ConstrainedType cs ty) = f (ConstrainedType (map (fmap (map go)) cs) (go ty))
go (RCons name ty rest) = f (RCons name (go ty) (go rest))
@@ -261,7 +252,6 @@ everywhereOnTypesTopDown :: (Type -> Type) -> Type -> Type
everywhereOnTypesTopDown f = go . f
where
go (TypeApp t1 t2) = TypeApp (go (f t1)) (go (f t2))
- go (SaturatedTypeSynonym name tys) = SaturatedTypeSynonym name (map (go . f) tys)
go (ForAll arg ty sco) = ForAll arg (go (f ty)) sco
go (ConstrainedType cs ty) = ConstrainedType (map (fmap (map (go . f))) cs) (go (f ty))
go (RCons name ty rest) = RCons name (go (f ty)) (go (f rest))
@@ -275,7 +265,6 @@ everywhereOnTypesM :: (Functor m, Applicative m, Monad m) => (Type -> m Type) ->
everywhereOnTypesM f = go
where
go (TypeApp t1 t2) = (TypeApp <$> go t1 <*> go t2) >>= f
- go (SaturatedTypeSynonym name tys) = (SaturatedTypeSynonym name <$> mapM go tys) >>= f
go (ForAll arg ty sco) = (ForAll arg <$> go ty <*> pure sco) >>= f
go (ConstrainedType cs ty) = (ConstrainedType <$> mapM (sndM (mapM go)) cs <*> go ty) >>= f
go (RCons name ty rest) = (RCons name <$> go ty <*> go rest) >>= f
@@ -289,7 +278,6 @@ everywhereOnTypesTopDownM :: (Functor m, Applicative m, Monad m) => (Type -> m T
everywhereOnTypesTopDownM f = go <=< f
where
go (TypeApp t1 t2) = TypeApp <$> (f t1 >>= go) <*> (f t2 >>= go)
- go (SaturatedTypeSynonym name tys) = SaturatedTypeSynonym name <$> mapM (go <=< f) tys
go (ForAll arg ty sco) = ForAll arg <$> (f ty >>= go) <*> pure sco
go (ConstrainedType cs ty) = ConstrainedType <$> mapM (sndM (mapM (go <=< f))) cs <*> (f ty >>= go)
go (RCons name ty rest) = RCons name <$> (f ty >>= go) <*> (f rest >>= go)
@@ -303,7 +291,6 @@ everythingOnTypes :: (r -> r -> r) -> (Type -> r) -> Type -> r
everythingOnTypes (<>) f = go
where
go t@(TypeApp t1 t2) = f t <> go t1 <> go t2
- go t@(SaturatedTypeSynonym _ tys) = foldl (<>) (f t) (map go tys)
go t@(ForAll _ ty _) = f t <> go ty
go t@(ConstrainedType cs ty) = foldl (<>) (f t) (map go $ concatMap snd cs) <> go ty
go t@(RCons _ ty rest) = f t <> go ty <> go rest
@@ -312,3 +299,17 @@ everythingOnTypes (<>) f = go
go t@(PrettyPrintObject t1) = f t <> go t1
go t@(PrettyPrintForAll _ t1) = f t <> go t1
go other = f other
+
+everythingWithContextOnTypes :: s -> r -> (r -> r -> r) -> (s -> Type -> (s, r)) -> Type -> r
+everythingWithContextOnTypes s0 r0 (<>) f = go' s0
+ where
+ go' s t = let (s', r) = f s t in r <> go s' t
+ go s (TypeApp t1 t2) = go' s t1 <> go' s t2
+ go s (ForAll _ ty _) = go' s ty
+ go s (ConstrainedType cs ty) = foldl (<>) r0 (map (go' s) $ concatMap snd cs) <> go' s ty
+ go s (RCons _ ty rest) = go' s ty <> go' s rest
+ go s (KindedType ty _) = go' s ty
+ go s (PrettyPrintFunction t1 t2) = go' s t1 <> go' s t2
+ go s (PrettyPrintObject t1) = go' s t1
+ go s (PrettyPrintForAll _ t1) = go' s t1
+ go _ _ = r0
diff --git a/src/System/IO/UTF8.hs b/src/System/IO/UTF8.hs
new file mode 100644
index 0000000..d2b8ff9
--- /dev/null
+++ b/src/System/IO/UTF8.hs
@@ -0,0 +1,9 @@
+module System.IO.UTF8
+where
+import System.IO (hGetContents, hSetEncoding, openFile, utf8, IOMode (..))
+
+readUTF8File :: FilePath -> IO String
+readUTF8File inFile = do
+ h <- openFile inFile ReadMode
+ hSetEncoding h utf8
+ hGetContents h
diff --git a/stack-lts-2.yaml b/stack-lts-2.yaml
new file mode 100644
index 0000000..6bf1652
--- /dev/null
+++ b/stack-lts-2.yaml
@@ -0,0 +1,9 @@
+flags: {}
+packages:
+- '.'
+extra-deps:
+- aeson-better-errors-0.8.0
+- bower-json-0.7.0.0
+- boxes-0.1.4
+- pattern-arrows-0.0.2
+resolver: lts-2.22
diff --git a/stack-lts-3.yaml b/stack-lts-3.yaml
new file mode 100644
index 0000000..c69fe3d
--- /dev/null
+++ b/stack-lts-3.yaml
@@ -0,0 +1,5 @@
+flags: {}
+packages:
+- '.'
+extra-deps:
+resolver: lts-3.6
diff --git a/stack-nightly.yaml b/stack-nightly.yaml
new file mode 100644
index 0000000..cd12fa3
--- /dev/null
+++ b/stack-nightly.yaml
@@ -0,0 +1,5 @@
+flags: {}
+packages:
+- '.'
+extra-deps:
+resolver: nightly-2015-09-29
diff --git a/stack.yaml b/stack.yaml
new file mode 100644
index 0000000..c69fe3d
--- /dev/null
+++ b/stack.yaml
@@ -0,0 +1,5 @@
+flags: {}
+packages:
+- '.'
+extra-deps:
+resolver: lts-3.6
diff --git a/tests/Main.hs b/tests/Main.hs
index 6644c8a..6d202e1 100644
--- a/tests/Main.hs
+++ b/tests/Main.hs
@@ -66,6 +66,7 @@ import System.Exit
import System.Process
import System.FilePath
import System.Directory
+import System.IO.UTF8
import qualified System.Info
import qualified System.FilePath.Glob as Glob
@@ -97,7 +98,7 @@ makeActions foreigns = (P.buildMakeActions modulesDir (error "makeActions: input
readInput :: [FilePath] -> IO [(FilePath, String)]
readInput inputFiles = forM inputFiles $ \inputFile -> do
- text <- readFile inputFile
+ text <- readUTF8File inputFile
return (inputFile, text)
type TestM = WriterT [(FilePath, String)] IO
@@ -157,7 +158,7 @@ assertDoesNotCompile inputFiles foreigns = do
where
getShouldFailWith =
- readFile
+ readUTF8File
>>> liftIO
>>> fmap ( lines
>>> mapMaybe (stripPrefix "-- @shouldFailWith ")
@@ -184,7 +185,7 @@ main = do
supportPurs <- supportFiles "purs"
supportJS <- supportFiles "js"
- foreignFiles <- forM supportJS (\f -> (f,) <$> readFile f)
+ foreignFiles <- forM supportJS (\f -> (f,) <$> readUTF8File f)
Right (foreigns, _) <- runExceptT $ runWriterT $ P.parseForeignModulesFromFiles foreignFiles
let passing = cwd </> "examples" </> "passing"