packages feed

purescript 0.7.4.1 → 0.7.5

raw patch · 110 files changed

+2466/−1659 lines, 110 filesdep +lifted-basedep +monad-controldep +transformers-basedep ~aesondep ~processdep ~semigroups

Dependencies added: lifted-base, monad-control, transformers-base

Dependency ranges changed: aeson, process, semigroups

Files

+ CONTRIBUTING.md view
@@ -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.
+ CONTRIBUTORS.md view
@@ -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
+ INSTALL.md view
@@ -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+```
LICENSE view
@@ -31,6 +31,7 @@   array   attoparsec   base+  binary   blaze-builder   bower-json   boxes@@ -45,9 +46,10 @@   haskeline   integer-gmp   language-javascript+  lifted-base+  monad-control   mtl   nats-  old-locale   optparse-applicative   parsec   pattern-arrows@@ -59,12 +61,14 @@   scientific   semigroups   split+  stm   syb   template-haskell   terminfo   text   time   transformers+  transformers-base   transformers-compat   unix   unordered-containers@@ -449,6 +453,39 @@      ----------------------------------------------------------------------------- +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 @@   (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 @@   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 @@   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 @@   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 @@  void LICENSE file: -  Copyright 2013 Edward Kmett+  Copyright 2015 Edward Kmett      All rights reserved.
+ README.md view
@@ -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)
+ examples/failing/1071.purs view
@@ -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
+ examples/failing/1310.purs view
@@ -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")
+ examples/failing/881.purs view
@@ -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
examples/failing/Arrays.purs view
@@ -1,4 +1,4 @@--- @shouldFailWith ExprDoesNotHaveType+-- @shouldFailWith TypesDoNotUnify module Main where  import Prelude
+ examples/failing/EmptyCase.purs view
@@ -0,0 +1,4 @@+-- @shouldFailWith ErrorParsingModule+module Main where++error err = case err of \_ -> 1
+ examples/failing/KindStar.purs view
@@ -0,0 +1,8 @@+-- @shouldFailWith ExpectedType++module X where++data List a = Nil | Cons a (List a)++test :: List+test = Nil
examples/failing/MultipleErrors.purs view
@@ -1,5 +1,5 @@--- @shouldFailWith ExprDoesNotHaveType--- @shouldFailWith ExprDoesNotHaveType+-- @shouldFailWith TypesDoNotUnify+-- @shouldFailWith TypesDoNotUnify module MultipleErrors where  import Prelude
examples/failing/Rank2Types.purs view
@@ -1,4 +1,4 @@--- @shouldFailWith ExprDoesNotHaveType+-- @shouldFailWith TypesDoNotUnify module Main where  import Prelude
+ examples/failing/TransitiveDctorExport.purs view
@@ -0,0 +1,5 @@+-- @shouldFailWith TransitiveExportError+module Main (Y(..)) where++type X = Int+data Y = Y X
+ examples/failing/TransitiveSynonymExport.purs view
@@ -0,0 +1,5 @@+-- @shouldFailWith TransitiveExportError+module Main (Y()) where++type X = Int+type Y = X
examples/failing/TypeError.purs view
@@ -1,4 +1,4 @@--- @shouldFailWith ExprDoesNotHaveType+-- @shouldFailWith TypesDoNotUnify module Main where  import Prelude
+ examples/failing/TypedBinders.purs view
@@ -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"
+ examples/failing/TypedBinders2.purs view
@@ -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"+
+ examples/failing/TypedBinders3.purs view
@@ -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"
+ examples/passing/862.purs view
@@ -0,0 +1,8 @@+module Main where++import Prelude+import Control.Monad.Eff.Console++id' = (\x -> x) <$> \y -> y++main = log (id' "Done")
+ examples/passing/922.purs view
@@ -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
+ examples/passing/LargeSumType.purs view
@@ -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"
+ examples/passing/NakedConstraint.purs view
@@ -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"
+ examples/passing/OptionalQualified.purs view
@@ -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
+ examples/passing/QualifiedQualifiedImports.purs view
@@ -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!"
+ examples/passing/TypedBinders.purs view
@@ -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"
+ examples/passing/UTF8Sourcefile.purs view
@@ -0,0 +1,10 @@+module Main where++import Control.Monad.Eff.Console+ +-- '→' is multibyte sequence \u2192.+utf8multibyte = "Hello λ→ world!!"++main = do+  log "done"+
psc-docs/Main.hs view
@@ -152,10 +152,10 @@   <> 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
psc/Main.hs view
@@ -32,6 +32,7 @@  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 @@   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 @@   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)]@@ -177,6 +178,7 @@                                 <*> outputDirectory                                 <*> options                                 <*> (not <$> noPrefix)+  main :: IO () main = execParser opts >>= compile
psci/Completion.hs view
@@ -41,7 +41,7 @@   | CtxIdentifier   | CtxType   | CtxFixed String-  deriving (Show)+  deriving (Show, Read)  -- | -- Loads module, function, and file completions.@@ -143,34 +143,34 @@ 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 @@   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
psci/PSCi.hs view
@@ -263,10 +263,10 @@  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 @@ -- 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 @@     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 @@       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 @@             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 $
psci/Parser.hs view
@@ -131,7 +131,6 @@ 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
purescript.cabal view
@@ -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 @@                   , 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 @@  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 @@                    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 @@                    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 @@                      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 @@                      Control.Monad.Supply                      Control.Monad.Supply.Class +                     System.IO.UTF8     exposed: True     buildable: True     hs-source-dirs: src@@ -175,7 +187,7 @@     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,
src/Language/PureScript/AST/Binders.hs view
@@ -21,6 +21,7 @@ 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 @@   -- |   -- 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 @@   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
src/Language/PureScript/AST/Declarations.hs view
@@ -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 @@ -- 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 @@   -- 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 @@   -- 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 @@   --   | 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 @@   -- 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 @@   = 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 _ = 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 @@   -- |   -- 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 @@     -- 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 @@   -- |   -- 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)
src/Language/PureScript/AST/Exported.hs view
@@ -66,7 +66,7 @@   --  * 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
src/Language/PureScript/AST/Operators.hs view
@@ -29,20 +29,29 @@ -- | -- 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) =
src/Language/PureScript/AST/SourcePos.hs view
@@ -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 @@     -- 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 @@   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 @@     -- 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 =@@ -76,6 +86,13 @@              , "start" .= spanStart              , "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)
src/Language/PureScript/AST/Traversals.hs view
@@ -79,6 +79,7 @@   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 @@   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 @@   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 @@   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 @@   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 @@   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 @@   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 @@   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
src/Language/PureScript/Bundle.hs view
@@ -56,16 +56,20 @@   | 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 @@ 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 @@   | 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 @@   : 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 @@   where   isElementEmpty :: ModuleElement -> Bool   isElementEmpty (ExportsList exps) = null exps-  isElementEmpty (Require _ _ _) = True+  isElementEmpty Require{} = True   isElementEmpty (Other _) = True   isElementEmpty _ = False
src/Language/PureScript/CodeGen.hs view
@@ -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
− src/Language/PureScript/CodeGen/Externs.hs 
@@ -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
src/Language/PureScript/CodeGen/JS.hs view
@@ -27,6 +27,7 @@   ) 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 @@ -- 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 @@              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 @@       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)
src/Language/PureScript/CodeGen/JS/AST.hs view
@@ -53,7 +53,7 @@   -- |   -- Constructor   ---  | JSNew deriving (Show, Eq, Data, Typeable)+  | JSNew deriving (Show, Read, Eq, Data, Typeable)  -- | -- Built-in binary operators@@ -134,7 +134,7 @@   -- |   -- 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 @@   -- |   -- Commented Javascript   ---  | JSComment [Comment] JS deriving (Show, Eq, Data, Typeable)+  | JSComment [Comment] JS deriving (Show, Read, Eq, Data, Typeable)  -- -- Traversals
src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs view
@@ -255,7 +255,7 @@     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
src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs view
@@ -124,5 +124,5 @@   hasFunction :: JS -> Bool    hasFunction = getAny . everythingOnJS mappend (Any . isFunction)     where-    isFunction (JSFunction _ _ _) = True+    isFunction JSFunction{} = True     isFunction _ = False
src/Language/PureScript/CodeGen/JS/Optimizer/Unused.hs view
@@ -29,7 +29,7 @@   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
src/Language/PureScript/Comments.hs view
@@ -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)
src/Language/PureScript/CoreFn/Binders.hs view
@@ -45,4 +45,4 @@   -- |   -- 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)
src/Language/PureScript/CoreFn/Desugar.hs view
@@ -166,6 +166,8 @@     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 @@ -- 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
src/Language/PureScript/CoreFn/Expr.hs view
@@ -64,7 +64,7 @@   -- |   -- 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 @@   -- |   -- 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 @@     -- 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)  -- |
src/Language/PureScript/CoreFn/Literals.hs view
@@ -47,4 +47,4 @@   -- |   -- An object literal   ---  | ObjectLiteral [(String, a)] deriving (Show, D.Data, D.Typeable, Functor)+  | ObjectLiteral [(String, a)] deriving (Show, Read, D.Data, D.Typeable, Functor)
src/Language/PureScript/CoreFn/Meta.hs view
@@ -39,7 +39,7 @@   -- |   -- 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 @@   -- |   -- The constructor is for a type with multiple construcors   ---  | SumType deriving (Show, D.Data, D.Typeable)+  | SumType deriving (Show, Read, D.Data, D.Typeable)
src/Language/PureScript/CoreFn/Module.hs view
@@ -26,6 +26,6 @@   , moduleExports :: [Ident]   , moduleForeign :: [ForeignDecl]   , moduleDecls :: [Bind a]-  } deriving (Show)+  } deriving (Show, Read)  type ForeignDecl = (Ident, Type)
src/Language/PureScript/Docs/AsMarkdown.hs view
@@ -98,7 +98,7 @@ data First   = First   | NotFirst-  deriving (Show, Eq, Ord)+  deriving (Show, Read, Eq, Ord)  type Docs = Writer [String] ()
src/Language/PureScript/Docs/Convert.hs view
@@ -26,7 +26,7 @@ -- 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 @@   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 @@   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 @@   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 @@   map (P.getModuleName m, )       (mapMaybe getDeclarationTitle                 (P.exportedDeclarations m))-
src/Language/PureScript/Docs/ParseAndDesugar.hs view
@@ -122,7 +122,7 @@ 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)
src/Language/PureScript/Docs/Render.hs view
@@ -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 @@       , renderType' ty       ]     DataDeclaration dtype args ->-      [ keyword (show dtype)+      [ keyword (P.showDataDeclType dtype)       , renderType' (typeApp declTitle args)       ]     ExternDataDeclaration kind' ->@@ -46,7 +47,7 @@       ]     TypeClassDeclaration args implies ->       [ keywordClass ]-      ++ maybe [] (:[]) superclasses+      ++ maybeToList superclasses       ++ [renderType' (typeApp declTitle args)]       ++ if any (isTypeClassMember . cdeclInfo) declChildren             then [keywordWhere]@@ -75,7 +76,7 @@       [ keywordInstance       , ident cdeclTitle       , syntax "::"-      ] ++ maybe [] (:[]) (renderConstraints constraints)+      ] ++ maybeToList (renderConstraints constraints)         ++ [ renderType' ty ]     ChildDataConstructor args ->       [ renderType' typeApp' ]
src/Language/PureScript/Docs/RenderedCode/Render.hs view
@@ -45,7 +45,7 @@               , 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 ")"
src/Language/PureScript/Docs/Types.hs view
@@ -425,7 +425,7 @@  instance A.ToJSON a => A.ToJSON (Package a) where   toJSON Package{..} =-    A.object $+    A.object       [ "packageMeta"          .= pkgMeta       , "version"              .= showVersion pkgVersion       , "versionTag"           .= pkgVersionTag
src/Language/PureScript/Environment.hs view
@@ -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 @@   --   , 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 @@   -- 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 @@   -- |   -- 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 @@   -- |   -- 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 @@   -- 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 @@   -- |   -- 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 @@ 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)
src/Language/PureScript/Errors.hs view
@@ -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.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 @@   | CtorConflictsWithClass ProperName   | ClassConflictsWithType ProperName   | ClassConflictsWithCtor ProperName+  | DuplicateModuleName ModuleName   | DuplicateClassExport ProperName   | DuplicateValueExport Ident   | DuplicateTypeArgument String@@ -128,7 +127,7 @@   | OverlappingArgNames (Maybe Ident)   | MissingClassMember Ident   | ExtraneousClassMember Ident-  | ExpectedType Kind+  | ExpectedType Type Kind   | IncorrectConstructorArity (Qualified ProperName)   | SubsumptionCheckFailed   | ExprDoesNotHaveType Expr Type@@ -140,44 +139,57 @@   | 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)+  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)+-- | 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 @@   CtorConflictsWithClass{} -> "CtorConflictsWithClass"   ClassConflictsWithType{} -> "ClassConflictsWithType"   ClassConflictsWithCtor{} -> "ClassConflictsWithCtor"+  DuplicateModuleName{} -> "DuplicateModuleName"   DuplicateClassExport{} -> "DuplicateClassExport"   DuplicateValueExport{} -> "DuplicateValueExport"   DuplicateTypeArgument{} -> "DuplicateTypeArgument"@@ -266,9 +279,13 @@   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 @@ -- 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 @@ 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 @@ -- 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 @@   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+            , indent $ typeAsBox 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)+    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)             ]-    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) =+    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"+    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"             ]-    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 (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+            , indent $ prettyPrintValue a             ]-    go (SimpleErrorWrapper sem) = goSimple sem+    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 @@     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-  --+  -- 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+    isPositionHint :: HintCategory -> Bool+    isPositionHint PositionHint = True+    isPositionHint OtherHint = True+    isPositionHint _ = False++  -- | Simplify an error message   simplifyErrorMessage :: ErrorMessage -> ErrorMessage-  simplifyErrorMessage = unwrap Nothing+  simplifyErrorMessage (ErrorMessage hints simple) = ErrorMessage (simplifyHints 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+    -- Take the last instance of each "hint category"+    simplifyHints :: [ErrorMessageHint] -> [ErrorMessageHint]+    simplifyHints = reverse . nubBy categoriesEqual . reverse -    wrap :: Maybe SourceSpan -> ErrorMessage -> ErrorMessage-    wrap Nothing    = id-    wrap (Just pos) = PositionedError pos+    -- 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 @@  -- | 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 @@                       , 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 @@   | 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 @@    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 @@ 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 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
+ src/Language/PureScript/Externs.hs view
@@ -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)
src/Language/PureScript/Kinds.hs view
@@ -49,7 +49,7 @@   -- |   -- 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)
src/Language/PureScript/Linter.hs view
@@ -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 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 @@   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 @@     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 @@     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)
src/Language/PureScript/Linter/Exhaustive.hs view
@@ -29,6 +29,9 @@ 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.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 @@ -- 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 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 @@   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 @@ --       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 @@ -- | -- 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 @@ 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
src/Language/PureScript/Make.hs view
@@ -19,6 +19,8 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE CPP #-}  module Language.PureScript.Make@@ -39,25 +41,31 @@ #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.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 @@ -- | 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 @@   -- |   -- 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 @@ -- | -- Generated code for an externs file. ---type Externs = String+type Externs = B.ByteString  -- | -- Determines when to rebuild a module@@ -139,7 +146,7 @@   -- | 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,67 +154,117 @@ -- 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+  checkModuleNamesAreUnique -  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+  (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+   where+  checkModuleNamesAreUnique :: m ()+  checkModuleNamesAreUnique =+    case findDuplicate (map getModuleName ms) of+      Nothing -> return ()+      Just mn -> throwError . errorMessage $ DuplicateModuleName mn -  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'+  -- 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 -  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+  -- 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-    alterErrors = flip catchError $ \(MultipleErrors errs) ->-      throwError . MultipleErrors $ flip map errs $ \e -> case e of-        SimpleErrorWrapper (ErrorParsingModule err) -> SimpleErrorWrapper (ErrorParsingExterns err)-        _ -> e+    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 -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)+  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 @@ 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 @@   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 @@     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 @@   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
src/Language/PureScript/ModuleDependencies.hs view
@@ -23,20 +23,17 @@  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 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)  -- |
src/Language/PureScript/Names.hs view
@@ -15,6 +15,7 @@  {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE GADTs #-}  module Language.PureScript.Names where@@ -22,6 +23,7 @@ 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 @@   -- |   -- 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 @@     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 @@     where     reconstructModuleName = moduleNameFromString . intercalate "." . reverse - -- | -- Provide a default module name, if a name is unqualified --@@ -109,9 +104,17 @@ 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)
src/Language/PureScript/Parser/Declarations.hs view
@@ -115,16 +115,6 @@ 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 @@   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 @@     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 @@     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 @@   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 @@  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 @@ -- 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
src/Language/PureScript/Parser/Kinds.hs view
@@ -46,4 +46,4 @@ 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 ] ]
src/Language/PureScript/Parser/Lexer.hs view
@@ -115,7 +115,7 @@   | 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 @@   , 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 @@     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 @@   go _ = Nothing  validModuleName :: String -> Bool-validModuleName s = not ('_' `elem` s)+validModuleName s = '_' `notElem` s  -- | -- A list of purescript reserved identifiers@@ -517,4 +518,3 @@ -- opChars :: [Char] opChars = ":!#$%&*+./<=>?@\\^|-~"-
src/Language/PureScript/Parser/Types.hs view
@@ -63,7 +63,7 @@  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 @@             , 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"
src/Language/PureScript/Pretty/Common.hs view
@@ -17,15 +17,18 @@  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 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 " ")
src/Language/PureScript/Pretty/JS.hs view
@@ -45,13 +45,13 @@   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 @@     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 @@     , 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 @@     , 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     ]
src/Language/PureScript/Pretty/Kinds.hs view
@@ -45,14 +45,13 @@   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]
src/Language/PureScript/Pretty/Types.hs view
@@ -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 @@     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 @@   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
src/Language/PureScript/Pretty/Values.hs view
@@ -21,194 +21,139 @@     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+  toLine i a = text [ if i == 0 then open else ',', ' ' ] <> f a -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-  ]+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+  prettyPrintResult :: Either [(Guard, Expr)] Expr -> Box+  prettyPrintResult (Left gs) =+    vcat left (map prettyPrintGuardedValue gs)+  prettyPrintResult (Right v) = text " -> " <> prettyPrintValue v -  prettyPrintGuardedValue (grd, val) =-    concat <$> sequence-      [ return "| "-      , prettyPrintValue' grd-      , return " -> "-      , prettyPrintValue' val-      ]+  prettyPrintGuardedValue :: (Guard, Expr) -> Box+  prettyPrintGuardedValue (grd, val) = foldl1 before+    [ text " | "+    , prettyPrintValue grd+    , text " -> "+    , prettyPrintValue val+    ] -prettyPrintDoNotationElement :: DoNotationElement -> StateT PrinterState Maybe String+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 @@ -- 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
src/Language/PureScript/Publish.hs view
@@ -23,7 +23,6 @@  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 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 @@   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 @@   | 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 @@ 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 @@   handleDeps deps    where+  packUtf8 = TL.encodeUtf8 . TL.pack   catchJSON = flip catchLeft (internalError . JSONError FromBowerList)  findBowerExecutable :: PrepareM String
src/Language/PureScript/Publish/ErrorsWarnings.hs view
@@ -98,10 +98,10 @@   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 @@ 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 @@         , 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 @@   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 @@       , 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 @@       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 =
src/Language/PureScript/Renamer.hs view
@@ -80,12 +80,12 @@ 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 @@   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 @@   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
src/Language/PureScript/Sugar.hs view
@@ -29,6 +29,7 @@  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 @@ -- --  * 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
src/Language/PureScript/Sugar/BindingGroups.hs view
@@ -78,7 +78,6 @@     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 @@   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
src/Language/PureScript/Sugar/CaseDeclarations.hs view
@@ -50,7 +50,7 @@ -- 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 @@   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
src/Language/PureScript/Sugar/DoNotation.hs view
@@ -42,13 +42,13 @@ 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
src/Language/PureScript/Sugar/Names.hs view
@@ -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.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 @@ -- 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 @@    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 @@     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 @@     (,) (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 @@     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 @@     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 @@   -- 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,
src/Language/PureScript/Sugar/Names/Env.hs view
@@ -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 @@   , Exports(..)   , nullExports   , Env-  , initEnv+  , primEnv   , envModuleSourceSpan   , envModuleImports   , envModuleExports@@ -32,11 +28,11 @@   , 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 @@   -- 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 @@   -- came from.   --   , exportedValues :: [(Ident, ModuleName)]-  } deriving (Show)+  } deriving (Show, Read)  -- | -- An empty 'Exports' value.@@ -136,11 +132,9 @@   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 @@ -- 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 @@ -- | -- 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
src/Language/PureScript/Sugar/Names/Exports.hs view
@@ -43,7 +43,7 @@ -- 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 @@ -- 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 @@   -- 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
src/Language/PureScript/Sugar/Names/Imports.hs view
@@ -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 @@ -- | -- 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)-  where+    foldM (resolveModuleImport currentModule env) nullImports (M.toList scope) -  resolveImport' :: Imports -> (ModuleName, [(Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)]) -> m Imports-  resolveImport' ie (mn, imps) = foldM go ie imps+-- | 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+  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 @@     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 @@   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 @@       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 @@        | 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"
src/Language/PureScript/Sugar/Operators.hs view
@@ -20,6 +20,7 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE CPP #-}  module Language.PureScript.Sugar.Operators (@@ -31,6 +32,7 @@ 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 @@ -- | -- 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 @@   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 @@   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 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"
src/Language/PureScript/Sugar/TypeClasses.hs view
@@ -15,6 +15,7 @@ -----------------------------------------------------------------------------  {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE CPP #-}  module Language.PureScript.Sugar.TypeClasses@@ -28,6 +29,7 @@ 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 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,9 +55,16 @@ -- 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   (newExpss, declss) <- unzip <$> parU (sortBy classesFirst decls) (desugarDecl name exps)@@ -166,9 +175,8 @@ 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 @@  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 (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   ]
src/Language/PureScript/Sugar/TypeDeclarations.hs view
@@ -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 @@ -- | -- 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)-  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+  rethrow (addHint (ErrorInModule name)) $+    Module ss coms name <$> desugarTypeDeclarations True ds <*> pure exps   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 []
src/Language/PureScript/TypeChecker.hs view
@@ -27,7 +27,7 @@ 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 @@   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 @@ -- --  * 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 @@     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 @@     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 @@     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 @@     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,30 +235,37 @@     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,   -- extracted from the kind of the type constructor itself.@@ -272,11 +280,11 @@ -- 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,21 +293,35 @@   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
src/Language/PureScript/TypeChecker/Entailment.hs view
@@ -13,7 +13,6 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE CPP #-}  module Language.PureScript.TypeChecker.Entailment (@@ -22,7 +21,7 @@  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 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,12 +48,19 @@ -- 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 @@       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 @@         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 @@ -- 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
src/Language/PureScript/TypeChecker/Kinds.hs view
@@ -83,7 +83,7 @@ -- 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 @@ -- 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 @@     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
src/Language/PureScript/TypeChecker/Monad.hs view
@@ -76,7 +76,7 @@ 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 @@   let uust = unifyCurrentSubstitution ust   tell $ onErrorMessages (replace uust) w   return (a, uust)-
src/Language/PureScript/TypeChecker/Rows.hs view
@@ -46,7 +46,6 @@     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
src/Language/PureScript/TypeChecker/Skolems.hs view
@@ -92,7 +92,7 @@   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, [])
src/Language/PureScript/TypeChecker/Subsumption.hs view
@@ -20,7 +20,6 @@ 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.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 @@ -- 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 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 _) =
src/Language/PureScript/TypeChecker/Synonyms.hs view
@@ -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 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----buildTypeSubstitution :: M.Map (Qualified ProperName) Int -> Type -> Either ErrorMessage (Maybe Type)-buildTypeSubstitution m = go 0 []-  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---- |--- \"Desaturate\" @SaturatedTypeSynonym@s+-- Replace fully applied type synonyms. ---desaturateAllTypeSynonyms :: Type -> Type-desaturateAllTypeSynonyms = everywhereOnTypes replaceSaturatedTypeSynonym+replaceAllTypeSynonyms' :: Environment -> Type -> Either MultipleErrors Type+replaceAllTypeSynonyms' env = everywhereOnTypesTopDownM try   where-  replaceSaturatedTypeSynonym (SaturatedTypeSynonym name args) = foldl TypeApp (TypeConstructor name) args-  replaceSaturatedTypeSynonym t = t+  try :: Type -> Either MultipleErrors Type+  try t = fromMaybe t <$> go 0 [] 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
src/Language/PureScript/TypeChecker/Types.hs view
@@ -67,24 +67,17 @@ 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 @@     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 @@   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 @@   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 @@ -- 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 @@   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 @@     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' (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 (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 _ _ _ _ = 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 @@         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,7 +370,30 @@   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 @@ -- 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 @@                                                       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' (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 @@       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 @@   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 @@ -- 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 @@   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
src/Language/PureScript/TypeChecker/Unify.hs view
@@ -36,11 +36,9 @@ 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 @@ -- 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 @@     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 @@ -- | -- 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
src/Language/PureScript/TypeClassDictionaries.hs view
@@ -36,22 +36,7 @@     , 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 @@   -- 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)
src/Language/PureScript/Types.hs view
@@ -22,6 +22,7 @@  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 @@ -- | -- 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 @@   --   | 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 @@   -- |   -- 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 @@   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 @@   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 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 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 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 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 (<>) 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 @@   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
+ src/System/IO/UTF8.hs view
@@ -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
+ stack-lts-2.yaml view
@@ -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
+ stack-lts-3.yaml view
@@ -0,0 +1,5 @@+flags: {}+packages:+- '.'+extra-deps:+resolver: lts-3.6
+ stack-nightly.yaml view
@@ -0,0 +1,5 @@+flags: {}+packages:+- '.'+extra-deps:+resolver: nightly-2015-09-29
+ stack.yaml view
@@ -0,0 +1,5 @@+flags: {}+packages:+- '.'+extra-deps:+resolver: lts-3.6
tests/Main.hs view
@@ -66,6 +66,7 @@ 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 @@  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 @@    where   getShouldFailWith =-    readFile+    readUTF8File     >>> liftIO     >>> fmap (   lines              >>> mapMaybe (stripPrefix "-- @shouldFailWith ")@@ -184,7 +185,7 @@   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"