summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2016-09-24 20:26:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2016-09-24 20:26:00 (GMT)
commit2acef0fe7e56d4fd60d611d3cf48b5ea37537fd0 (patch)
treeb364973659ce94072fdaf3c61ec694ef6d14d9c2
parent4d61f80cdcce39749da53bdcab7d71e406710222 (diff)
version 0.10.00.10.0
-rw-r--r--CONTRIBUTING.md5
-rw-r--r--CONTRIBUTORS.md13
-rw-r--r--INSTALL.md9
-rw-r--r--LICENSE870
-rw-r--r--examples/docs/src/ExplicitTypeSignatures.purs2
-rw-r--r--examples/failing/CannotDeriveNewtypeForData.purs8
-rw-r--r--examples/failing/DoNotSuggestComposition2.purs2
-rw-r--r--examples/failing/NewtypeInstance.purs8
-rw-r--r--examples/failing/NewtypeInstance2.purs8
-rw-r--r--examples/failing/NewtypeInstance3.purs8
-rw-r--r--examples/failing/NewtypeInstance4.purs8
-rw-r--r--examples/failing/NonWildcardNewtypeInstance.purs8
-rw-r--r--examples/failing/OperatorSections.purs3
-rw-r--r--examples/failing/OverlappingVars.purs1
-rw-r--r--examples/failing/ProgrammableTypeErrorsTypeString.purs18
-rw-r--r--examples/failing/TypeWildcards3.purs3
-rw-r--r--examples/failing/UnifyInTypeInstanceLookup.purs22
-rw-r--r--examples/passing/1807.purs14
-rw-r--r--examples/passing/ConstraintParsingIssue.purs9
-rw-r--r--examples/passing/DeriveNewtype.purs17
-rw-r--r--examples/passing/FunWithFunDeps.js32
-rw-r--r--examples/passing/FunWithFunDeps.purs41
-rw-r--r--examples/passing/FunctionalDependencies.purs21
-rw-r--r--examples/passing/GHCGenerics.purs140
-rw-r--r--examples/passing/NewtypeClass.purs39
-rw-r--r--examples/passing/NewtypeInstance.purs30
-rw-r--r--examples/passing/NumberLiterals.purs4
-rw-r--r--examples/passing/RowPolyInstanceContext.purs2
-rw-r--r--examples/passing/Stream.purs26
-rw-r--r--examples/passing/UnifyInTypeInstanceLookup.purs25
-rw-r--r--examples/passing/WildcardInInstance.purs23
-rw-r--r--hierarchy/Main.hs39
-rw-r--r--psc-bundle/Main.hs53
-rw-r--r--psc-docs/Tags.hs2
-rw-r--r--psc-ide-client/Main.hs13
-rw-r--r--psc-ide-server/Main.hs25
-rw-r--r--psc-publish/Main.hs23
-rw-r--r--psc/Main.hs14
-rw-r--r--psci/Main.hs6
-rw-r--r--purescript.cabal13
-rw-r--r--src/Control/Monad/Supply/Class.hs4
-rw-r--r--src/Language/PureScript/AST/Declarations.hs32
-rw-r--r--src/Language/PureScript/AST/Exported.hs2
-rw-r--r--src/Language/PureScript/AST/Traversals.hs18
-rw-r--r--src/Language/PureScript/Bundle.hs26
-rw-r--r--src/Language/PureScript/CodeGen/JS.hs8
-rw-r--r--src/Language/PureScript/CodeGen/JS/Optimizer.hs6
-rw-r--r--src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs11
-rw-r--r--src/Language/PureScript/CoreFn/Desugar.hs2
-rw-r--r--src/Language/PureScript/CoreFn/ToJSON.hs116
-rw-r--r--src/Language/PureScript/Docs/Convert/Single.hs4
-rw-r--r--src/Language/PureScript/Environment.hs70
-rw-r--r--src/Language/PureScript/Errors.hs86
-rw-r--r--src/Language/PureScript/Externs.hs53
-rw-r--r--src/Language/PureScript/Ide.hs12
-rw-r--r--src/Language/PureScript/Ide/Command.hs2
-rw-r--r--src/Language/PureScript/Ide/Completion.hs15
-rw-r--r--src/Language/PureScript/Ide/Externs.hs36
-rw-r--r--src/Language/PureScript/Ide/Imports.hs4
-rw-r--r--src/Language/PureScript/Ide/Matcher.hs16
-rw-r--r--src/Language/PureScript/Ide/Pursuit.hs44
-rw-r--r--src/Language/PureScript/Ide/Rebuild.hs3
-rw-r--r--src/Language/PureScript/Ide/Reexports.hs6
-rw-r--r--src/Language/PureScript/Ide/SourceFile.hs25
-rw-r--r--src/Language/PureScript/Ide/State.hs104
-rw-r--r--src/Language/PureScript/Ide/Types.hs113
-rw-r--r--src/Language/PureScript/Ide/Util.hs66
-rw-r--r--src/Language/PureScript/Interactive/Completion.hs4
-rw-r--r--src/Language/PureScript/Interactive/Printer.hs22
-rw-r--r--src/Language/PureScript/Interactive/Types.hs4
-rw-r--r--src/Language/PureScript/Linter/Imports.hs4
-rw-r--r--src/Language/PureScript/Make.hs9
-rw-r--r--src/Language/PureScript/Options.hs5
-rw-r--r--src/Language/PureScript/Parser/Declarations.hs13
-rw-r--r--src/Language/PureScript/Parser/Lexer.hs7
-rw-r--r--src/Language/PureScript/Parser/Types.hs6
-rw-r--r--src/Language/PureScript/Pretty/Common.hs2
-rw-r--r--src/Language/PureScript/Pretty/Types.hs8
-rw-r--r--src/Language/PureScript/Pretty/Values.hs4
-rw-r--r--src/Language/PureScript/Publish/ErrorsWarnings.hs16
-rw-r--r--src/Language/PureScript/Renamer.hs6
-rw-r--r--src/Language/PureScript/Sugar/Names.hs4
-rw-r--r--src/Language/PureScript/Sugar/Names/Exports.hs2
-rw-r--r--src/Language/PureScript/Sugar/ObjectWildcards.hs27
-rw-r--r--src/Language/PureScript/Sugar/Operators.hs8
-rw-r--r--src/Language/PureScript/Sugar/Operators/Common.hs4
-rw-r--r--src/Language/PureScript/Sugar/Operators/Expr.hs2
-rw-r--r--src/Language/PureScript/Sugar/TypeClasses.hs43
-rwxr-xr-xsrc/Language/PureScript/Sugar/TypeClasses/Deriving.hs93
-rw-r--r--src/Language/PureScript/TypeChecker.hs40
-rw-r--r--src/Language/PureScript/TypeChecker/Entailment.hs503
-rw-r--r--src/Language/PureScript/TypeChecker/Kinds.hs15
-rw-r--r--src/Language/PureScript/TypeChecker/Monad.hs50
-rw-r--r--src/Language/PureScript/TypeChecker/Skolems.hs6
-rw-r--r--src/Language/PureScript/TypeChecker/Subsumption.hs25
-rw-r--r--src/Language/PureScript/TypeChecker/Types.hs244
-rw-r--r--src/Language/PureScript/TypeChecker/Unify.hs32
-rw-r--r--src/Language/PureScript/TypeClassDictionaries.hs23
-rw-r--r--src/Language/PureScript/Types.hs4
-rw-r--r--stack.yaml13
-rw-r--r--tests/Language/PureScript/Ide/ImportsSpec.hs2
-rw-r--r--tests/Language/PureScript/Ide/Integration.hs28
-rw-r--r--tests/Language/PureScript/Ide/MatcherSpec.hs16
-rw-r--r--tests/Language/PureScript/Ide/ReexportsSpec.hs2
-rw-r--r--tests/Language/PureScript/Ide/SourceFile/IntegrationSpec.hs21
-rw-r--r--tests/Language/PureScript/Ide/SourceFileSpec.hs10
-rw-r--r--tests/Language/PureScript/Ide/StateSpec.hs51
-rw-r--r--tests/TestDocs.hs1
-rw-r--r--tests/TestPscIde.hs1
-rw-r--r--tests/TestPsci.hs1
-rw-r--r--tests/TestUtils.hs2
-rw-r--r--tests/support/bower.json5
112 files changed, 2859 insertions, 1020 deletions
diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md
index 08dfdd7..888a087 100644
--- a/CONTRIBUTING.md
+++ b/CONTRIBUTING.md
@@ -11,9 +11,8 @@ If you would like to contribute, please consider the issues in the current miles
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 binaries and libs with `stack build`
+- Run the test suite with `stack test`. 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
diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md
index 51c3506..7025494 100644
--- a/CONTRIBUTORS.md
+++ b/CONTRIBUTORS.md
@@ -12,8 +12,11 @@ This file lists the contributors to the PureScript compiler project, and the ter
- [@bagl](https://github.com/bagl) (Petr Vapenka) My existing contributions and all future contributions until further notice are Copyright Petr Vapenka, 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.
+- [@bmjames](https://github.com/bmjames) (Ben James) My existing contributions and all future contributions until further notice are Copyright Ben James, 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).
- [@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).
+- [@bsermons](https://github.com/bsermons) (Brian Sermons) My existing contributions and all future contributions until further notice are Copyright Brian Sermons, 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).
- [@cdepillabout](https://github.com/cdepillabout) (Dennis Gosnell) My existing contributions and all future contributions until further notice are Copyright Dennis Gosnell, 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).
+- [@charleso](https://github.com/charleso) (Charles O'Farrell) My existing contributions to the PureScript compiler and all future contributions to the PureScript compiler until further notice, are Copyright Charles O'Farrell, 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).
- [@chrissmoak](https://github.com/chrissmoak) (Chris Smoak) My existing contributions to the PureScript compiler and all future contributions to the PureScript compiler until further notice, are Copyright Chris Smoak, 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).
- [@codedmart](https://github.com/codedmart) (Brandon Martin) My existing contributions and all future contributions until further notice are Copyright Brandon Martin, 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).
@@ -25,8 +28,11 @@ This file lists the contributors to the PureScript compiler project, and the ter
- [@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).
- [@faineance](https://github.com/faineance) My existing contributions and all future contributions until further notice are Copyright faineance, 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).
+- [@felixSchl](https://github.com/felixSchl) (Felix Schlitter) My existing contributions and all future contributions until further notice are Copyright Felix Schlitter, 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).
+- [@FrigoEU](https://github.com/FrigoEU) (Simon Van Casteren) My existing contributions and all future contributions until further notice are Copyright Simon Van Casteren, 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).
+- [@ianbollinger](https://github.com/ianbollinger) (Ian D. Bollinger) My existing contributions and all future contributions until further notice are Copyright Ian D. Bollinger, 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).
- [@ilovezfs](https://github.com/ilovezfs) - My existing contributions and all future contributions until further notice are Copyright ilovezfs, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license
- [@izgzhen](https://github.com/izgzhen) (Zhen Zhang) My existing contributions and all future contributions until further notice are Copyright Zhen Zhang, 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).
@@ -36,6 +42,7 @@ This file lists the contributors to the PureScript compiler project, and the ter
- [@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).
- [@leighman](http://github.com/leighman) (Jack Leigh) My existing contributions and all future contributions until further notice are Copyright Jack Leigh, 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).
+- [@LiamGoodacre](https://github.com/LiamGoodacre) (Liam Goodacre) My existing contributions and all future contributions until further notice are Copyright Liam Goodacre, 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).
- [@mgmeier](https://github.com/mgmeier) (Michael Karg) 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).
- [@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).
@@ -57,8 +64,10 @@ This file lists the contributors to the PureScript compiler project, and the ter
- [@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.
+- [@rightfold](https://github.com/rightfold) (rightfold) My existing contributions and all future contributions until further notice are Copyright rightfold, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](https://opensource.org/licenses/MIT).
- [@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).
+- [@rvion](https://github.com/rvion) (Rémi Vion) My existing contributions and all future contributions until further notice are Copyright Rémi Vion, 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.
- [@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).
- [@sharkdp](https://github.com/sharkdp) (David Peter) My existing contributions and all future contributions until further notice are Copyright David Peter, 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).
@@ -70,10 +79,6 @@ This file lists the contributors to the PureScript compiler project, and the ter
- [@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).
-- [@LiamGoodacre](https://github.com/LiamGoodacre) (Liam Goodacre) My existing contributions and all future contributions until further notice are Copyright Liam Goodacre, 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).
-- [@bsermons](https://github.com/bsermons) (Brian Sermons) My existing contributions and all future contributions until further notice are Copyright Brian Sermons, 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).
-- [@bmjames](https://github.com/bmjames) (Ben James) My existing contributions and all future contributions until further notice are Copyright Ben James, 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).
-- - [@felixSchl](https://github.com/felixSchl) (Felix Schlitter) My existing contributions and all future contributions until further notice are Copyright Felix Schlitter, 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).
### Companies
diff --git a/INSTALL.md b/INSTALL.md
index 4414a13..4031f9e 100644
--- a/INSTALL.md
+++ b/INSTALL.md
@@ -27,16 +27,19 @@ GHC 7.10.1 or newer is required to compile from source. The easiest way is to
use stack:
```
-$ stack install --resolver=nightly purescript
+$ stack update
+$ stack unpack purescript
+$ cd purescript-x.y.z # (replace x.y.z with whichever version you just downloaded)
+$ stack install
```
This will then copy the compiler and utilities into `~/.local/bin`.
-If you don't have stack installed yet there are install instructions
+If you don't have stack installed, 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`
+If you don't have ghc installed, stack will prompt you to run `stack setup`
which will install ghc for you.
## The "curses" library
diff --git a/LICENSE b/LICENSE
index e6ad9e7..d05ff61 100644
--- a/LICENSE
+++ b/LICENSE
@@ -23,10 +23,13 @@ CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
PureScript uses the following Haskell library packages. Their license files follow.
Glob
+ SHA
aeson
aeson-better-errors
+ aeson-pretty
ansi-terminal
ansi-wl-pprint
+ appar
array
asn1-encoding
asn1-parse
@@ -39,14 +42,18 @@ PureScript uses the following Haskell library packages. Their license files foll
base64-bytestring
binary
blaze-builder
+ blaze-html
+ blaze-markup
bower-json
boxes
byteable
+ byteorder
bytestring
bytestring-builder
case-insensitive
cereal
clock
+ cmdargs
conduit
conduit-extra
connection
@@ -54,25 +61,32 @@ PureScript uses the following Haskell library packages. Their license files foll
cookie
cryptonite
data-default-class
+ data-ordlist
deepseq
directory
dlist
easy-file
edit-distance
+ entropy
exceptions
fail
fast-logger
+ file-embed
filepath
fsnotify
ghc-prim
hashable
haskeline
- hinotify
+ hex
+ hfsevents
hourglass
http-client
http-client-tls
+ http-date
http-types
+ http2
integer-gmp
+ iproute
language-javascript
lifted-base
memory
@@ -96,6 +110,7 @@ PureScript uses the following Haskell library packages. Their license files foll
primitive
process
protolude
+ psqueues
random
regex-base
regex-tdfa
@@ -103,6 +118,7 @@ PureScript uses the following Haskell library packages. Their license files foll
safe
scientific
semigroups
+ simple-sendfile
socks
sourcemap
spdx
@@ -110,13 +126,14 @@ PureScript uses the following Haskell library packages. Their license files foll
stm
stm-chans
streaming-commons
- string-conv
+ stringsearch
syb
tagged
template-haskell
terminfo
text
time
+ time-locale-compat
tls
transformers
transformers-base
@@ -126,8 +143,17 @@ PureScript uses the following Haskell library packages. Their license files foll
unix-time
unordered-containers
utf8-string
+ vault
vector
void
+ wai
+ wai-app-static
+ wai-extra
+ wai-logger
+ wai-websockets
+ warp
+ websockets
+ word8
x509
x509-store
x509-system
@@ -140,7 +166,7 @@ Glob LICENSE file:
the code are held by whoever wrote the code in question: see CREDITS.txt for a
list of authors.
- Copyright (c) 2008-2012 <authors>
+ Copyright (c) 2008-2016 <authors>
All rights reserved.
Redistribution and use in source and binary forms, with or without
@@ -165,6 +191,38 @@ Glob LICENSE file:
OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+SHA LICENSE file:
+
+ Copyright (c) 2008, Galois, Inc.
+ 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 Galois, Inc. 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 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.
+
aeson LICENSE file:
Copyright (c) 2011, MailRank, Inc.
@@ -221,6 +279,39 @@ aeson-better-errors LICENSE file:
TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+aeson-pretty LICENSE file:
+
+ Copyright (c)2011, Falko Peters
+
+ 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 Falko Peters 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
+ 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.
+
ansi-terminal LICENSE file:
Copyright (c) 2008, Maximilian Bolingbroke
@@ -274,6 +365,38 @@ ansi-wl-pprint LICENSE file:
or otherwise) arising in any way out of the use of this software, even
if advised of the possibility of such damage.
+appar LICENSE file:
+
+ Copyright (c) 2009, IIJ Innovation Institute Inc.
+ 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 copyright holders 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 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.
+
array LICENSE file:
This library (libraries/base) is derived from code from several
@@ -746,6 +869,72 @@ blaze-builder LICENSE file:
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+blaze-html LICENSE file:
+
+ Copyright Jasper Van der Jeugt 2010
+
+ 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 Jasper Van der Jeugt 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
+ 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.
+
+blaze-markup LICENSE file:
+
+ Copyright Jasper Van der Jeugt 2010
+
+ 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 Jasper Van der Jeugt 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
+ 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.
+
bower-json LICENSE file:
Copyright (c) 2015 Harry Garrood
@@ -829,6 +1018,39 @@ byteable LICENSE file:
OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
SUCH DAMAGE.
+byteorder LICENSE file:
+
+ Copyright 2009, Antoine Latter
+
+ 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
+ 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.
+
bytestring LICENSE file:
Copyright (c) Don Stewart 2005-2009
@@ -997,6 +1219,39 @@ clock LICENSE file:
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+cmdargs LICENSE file:
+
+ Copyright Neil Mitchell 2009-2016.
+ 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 Neil Mitchell 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
+ 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.
+
conduit LICENSE file:
Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/
@@ -1109,31 +1364,26 @@ containers LICENSE file:
cookie LICENSE file:
- The following license covers this documentation, and the source code, except
- where otherwise indicated.
-
- Copyright 2010, Michael Snoyman. All rights reserved.
-
- Redistribution and use in source and binary forms, with or without
- modification, are permitted provided that the following conditions are met:
+ Copyright (c) 2010 Michael Snoyman, http://www.yesodweb.com/
- * Redistributions of source code must retain the above copyright notice, this
- list of conditions and the following disclaimer.
+ Permission is hereby granted, free of charge, to any person obtaining
+ a copy of this software and associated documentation files (the
+ "Software"), to deal in the Software without restriction, including
+ without limitation the rights to use, copy, modify, merge, publish,
+ distribute, sublicense, and/or sell copies of the Software, and to
+ permit persons to whom the Software is furnished to do so, subject to
+ the following conditions:
- * 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.
+ The above copyright notice and this permission notice shall be
+ included in all copies or substantial portions of the Software.
- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "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 HOLDERS 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.
+ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
cryptonite LICENSE file:
@@ -1195,6 +1445,19 @@ data-default-class LICENSE file:
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.
+data-ordlist LICENSE file:
+
+ Copyright (c) 2009-2010, Melding Monads
+ 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 Melding Monads 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 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.
+
deepseq LICENSE file:
This library (deepseq) is derived from code from the GHC project which
@@ -1305,7 +1568,7 @@ directory LICENSE file:
dlist LICENSE file:
- Copyright (c) 2006-2009 Don Stewart, 2013-2014 Sean Leather
+ Copyright (c) 2006-2009 Don Stewart, 2013-2016 Sean Leather
All rights reserved.
@@ -1394,6 +1657,39 @@ edit-distance LICENSE file:
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.
+entropy LICENSE file:
+
+ Copyright (c) Thomas DuBuisson
+
+ 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.
+
exceptions LICENSE file:
Copyright 2013-2015 Edward Kmett
@@ -1493,6 +1789,34 @@ fast-logger LICENSE file:
ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.
+file-embed LICENSE file:
+
+ The following license covers this documentation, and the source code, except
+ where otherwise indicated.
+
+ Copyright 2008, Michael Snoyman. 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.
+
+ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "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 HOLDERS 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.
+
filepath LICENSE file:
Copyright Neil Mitchell 2005-2015.
@@ -1683,38 +2007,42 @@ haskeline LICENSE file:
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.
-hinotify LICENSE file:
+hex LICENSE file:
- Copyright (c) Lennart Kolmodin
+ Page not found: Sorry, it's just not here.
+
+hfsevents LICENSE file:
+
+ Copyright (c) 2012, Luite Stegeman
All rights reserved.
Redistribution and use in source and binary forms, with or without
- modification, are permitted provided that the following conditions
- are met:
+ 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.
+ * 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.
+ * 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.
+ * Neither the name of Luite Stegeman 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 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.
+ 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.
hourglass LICENSE file:
@@ -1792,6 +2120,38 @@ http-client-tls LICENSE file:
IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+http-date LICENSE file:
+
+ Copyright (c) 2009, IIJ Innovation Institute Inc.
+ 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 copyright holders 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 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.
+
http-types LICENSE file:
Copyright (c) 2011, Aristid Breitkreuz
@@ -1826,6 +2186,38 @@ http-types LICENSE file:
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+http2 LICENSE file:
+
+ Copyright (c) 2013, IIJ Innovation Institute Inc.
+ 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 copyright holders 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 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.
+
integer-gmp LICENSE file:
Copyright (c) 2014, Herbert Valerio Riedel
@@ -1859,6 +2251,38 @@ integer-gmp LICENSE file:
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+iproute LICENSE file:
+
+ Copyright (c) 2009, IIJ Innovation Institute Inc.
+ 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 copyright holders 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 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.
+
language-javascript LICENSE file:
Copyright (c)2010, Alan Zimmerman
@@ -2622,6 +3046,40 @@ protolude LICENSE file:
FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
IN THE SOFTWARE.
+psqueues 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.
+
random LICENSE file:
This library (libraries/base) is derived from code from two
@@ -2846,6 +3304,38 @@ semigroups LICENSE file:
ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.
+simple-sendfile LICENSE file:
+
+ Copyright (c) 2009, IIJ Innovation Institute Inc.
+ 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 copyright holders 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 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.
+
socks LICENSE file:
Copyright (c) 2010-2011 Vincent Hanquez <vincent@snarc.org>
@@ -3068,38 +3558,9 @@ streaming-commons LICENSE file:
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
SOFTWARE.
-string-conv LICENSE file:
-
- Copyright (c) 2012, Ozgun Ataman
-
- 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 Ozgun Ataman nor the names of other
- contributors may be used to endorse or promote products derived
- from this software without specific prior written permission.
+stringsearch LICENSE file:
- 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.
+ Page not found: Sorry, it's just not here.
syb LICENSE file:
@@ -3324,6 +3785,39 @@ time LICENSE file:
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.
+time-locale-compat LICENSE file:
+
+ Copyright (c) 2014, Kei Hibino
+
+ 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 Kei Hibino 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
+ 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.
+
tls LICENSE file:
Copyright (c) 2010-2015 Vincent Hanquez <vincent@snarc.org>
@@ -3609,6 +4103,39 @@ utf8-string LICENSE file:
* (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+vault LICENSE file:
+
+ Copyright (c)2011, Heinrich Apfelmus
+
+ 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 Heinrich Apfelmus 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
+ 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.
+
vector LICENSE file:
Copyright (c) 2008-2012, Roman Leshchinskiy
@@ -3675,6 +4202,189 @@ void LICENSE file:
ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.
+wai LICENSE file:
+
+ Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/
+
+ Permission is hereby granted, free of charge, to any person obtaining
+ a copy of this software and associated documentation files (the
+ "Software"), to deal in the Software without restriction, including
+ without limitation the rights to use, copy, modify, merge, publish,
+ distribute, sublicense, and/or sell copies of the Software, and to
+ permit persons to whom the Software is furnished to do so, subject to
+ the following conditions:
+
+ The above copyright notice and this permission notice shall be
+ included in all copies or substantial portions of the Software.
+
+ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+
+wai-app-static LICENSE file:
+
+ Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/
+
+ Permission is hereby granted, free of charge, to any person obtaining
+ a copy of this software and associated documentation files (the
+ "Software"), to deal in the Software without restriction, including
+ without limitation the rights to use, copy, modify, merge, publish,
+ distribute, sublicense, and/or sell copies of the Software, and to
+ permit persons to whom the Software is furnished to do so, subject to
+ the following conditions:
+
+ The above copyright notice and this permission notice shall be
+ included in all copies or substantial portions of the Software.
+
+ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+
+wai-extra LICENSE file:
+
+ Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/
+
+ Permission is hereby granted, free of charge, to any person obtaining
+ a copy of this software and associated documentation files (the
+ "Software"), to deal in the Software without restriction, including
+ without limitation the rights to use, copy, modify, merge, publish,
+ distribute, sublicense, and/or sell copies of the Software, and to
+ permit persons to whom the Software is furnished to do so, subject to
+ the following conditions:
+
+ The above copyright notice and this permission notice shall be
+ included in all copies or substantial portions of the Software.
+
+ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+
+wai-logger LICENSE file:
+
+ Copyright (c) 2009, IIJ Innovation Institute Inc.
+ 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 copyright holders 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 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.
+
+wai-websockets LICENSE file:
+
+ Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/
+
+ Permission is hereby granted, free of charge, to any person obtaining
+ a copy of this software and associated documentation files (the
+ "Software"), to deal in the Software without restriction, including
+ without limitation the rights to use, copy, modify, merge, publish,
+ distribute, sublicense, and/or sell copies of the Software, and to
+ permit persons to whom the Software is furnished to do so, subject to
+ the following conditions:
+
+ The above copyright notice and this permission notice shall be
+ included in all copies or substantial portions of the Software.
+
+ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+
+warp LICENSE file:
+
+ Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/
+
+ Permission is hereby granted, free of charge, to any person obtaining
+ a copy of this software and associated documentation files (the
+ "Software"), to deal in the Software without restriction, including
+ without limitation the rights to use, copy, modify, merge, publish,
+ distribute, sublicense, and/or sell copies of the Software, and to
+ permit persons to whom the Software is furnished to do so, subject to
+ the following conditions:
+
+ The above copyright notice and this permission notice shall be
+ included in all copies or substantial portions of the Software.
+
+ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+
+websockets LICENSE file:
+
+ Page not found: Sorry, it's just not here.
+
+word8 LICENSE file:
+
+ Copyright (c) 2012, IIJ Innovation Institute Inc.
+ 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 copyright holders 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 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.
+
x509 LICENSE file:
Copyright (c) 2010-2013 Vincent Hanquez <vincent@snarc.org>
diff --git a/examples/docs/src/ExplicitTypeSignatures.purs b/examples/docs/src/ExplicitTypeSignatures.purs
index 396ca14..f9fa06f 100644
--- a/examples/docs/src/ExplicitTypeSignatures.purs
+++ b/examples/docs/src/ExplicitTypeSignatures.purs
@@ -14,3 +14,5 @@ anInt = 0
-- This should infer a type.
aNumber = 1.0
+
+foreign import nestedForAll :: forall c. (forall a b. c)
diff --git a/examples/failing/CannotDeriveNewtypeForData.purs b/examples/failing/CannotDeriveNewtypeForData.purs
new file mode 100644
index 0000000..f40568d
--- /dev/null
+++ b/examples/failing/CannotDeriveNewtypeForData.purs
@@ -0,0 +1,8 @@
+-- @shouldFailWith CannotDeriveNewtypeForData
+module CannotDeriveNewtypeForData where
+
+import Data.Newtype
+
+data Test = Test String
+
+derive instance newtypeTest :: Newtype Test _
diff --git a/examples/failing/DoNotSuggestComposition2.purs b/examples/failing/DoNotSuggestComposition2.purs
index b6e13dc..907d15b 100644
--- a/examples/failing/DoNotSuggestComposition2.purs
+++ b/examples/failing/DoNotSuggestComposition2.purs
@@ -1,4 +1,4 @@
--- @shouldFailWith CannotApplyFunction
+-- @shouldFailWith TypesDoNotUnify
-- TODO: Check that this does not produce a "function composition is (<<<)"
-- suggestion.
diff --git a/examples/failing/NewtypeInstance.purs b/examples/failing/NewtypeInstance.purs
new file mode 100644
index 0000000..3ffe080
--- /dev/null
+++ b/examples/failing/NewtypeInstance.purs
@@ -0,0 +1,8 @@
+-- @shouldFailWith InvalidNewtypeInstance
+module Main where
+
+import Prelude
+
+data X = X
+
+derive newtype instance showX :: Show X
diff --git a/examples/failing/NewtypeInstance2.purs b/examples/failing/NewtypeInstance2.purs
new file mode 100644
index 0000000..67b16fc
--- /dev/null
+++ b/examples/failing/NewtypeInstance2.purs
@@ -0,0 +1,8 @@
+-- @shouldFailWith InvalidNewtypeInstance
+module Main where
+
+import Prelude
+
+data X a = X a a
+
+derive newtype instance showX :: Show a => Show (X a)
diff --git a/examples/failing/NewtypeInstance3.purs b/examples/failing/NewtypeInstance3.purs
new file mode 100644
index 0000000..528eefb
--- /dev/null
+++ b/examples/failing/NewtypeInstance3.purs
@@ -0,0 +1,8 @@
+-- @shouldFailWith InvalidNewtypeInstance
+module Main where
+
+import Prelude
+
+class Nullary
+
+derive newtype instance nullary :: Nullary
diff --git a/examples/failing/NewtypeInstance4.purs b/examples/failing/NewtypeInstance4.purs
new file mode 100644
index 0000000..4004520
--- /dev/null
+++ b/examples/failing/NewtypeInstance4.purs
@@ -0,0 +1,8 @@
+-- @shouldFailWith InvalidNewtypeInstance
+module Main where
+
+import Prelude
+
+data X = X | Y
+
+derive newtype instance showX :: Show X
diff --git a/examples/failing/NonWildcardNewtypeInstance.purs b/examples/failing/NonWildcardNewtypeInstance.purs
new file mode 100644
index 0000000..3c8f947
--- /dev/null
+++ b/examples/failing/NonWildcardNewtypeInstance.purs
@@ -0,0 +1,8 @@
+-- @shouldFailWith NonWildcardNewtypeInstance
+module NonWildcardNewtypeInstance where
+
+import Data.Newtype
+
+data Test = Test String
+
+derive instance newtypeTest :: Newtype Test String
diff --git a/examples/failing/OperatorSections.purs b/examples/failing/OperatorSections.purs
index 7be5b3f..14fc674 100644
--- a/examples/failing/OperatorSections.purs
+++ b/examples/failing/OperatorSections.purs
@@ -1,8 +1,7 @@
--- @shouldFailWith CannotApplyFunction
+-- @shouldFailWith TypesDoNotUnify
module Main where
import Prelude
main = do
(true `not` _)
-
diff --git a/examples/failing/OverlappingVars.purs b/examples/failing/OverlappingVars.purs
index 82059ac..78919e8 100644
--- a/examples/failing/OverlappingVars.purs
+++ b/examples/failing/OverlappingVars.purs
@@ -12,4 +12,3 @@ instance overlappingVarsFoo :: OverlappingVars (Foo a a) where
f a = a
test = f (Foo "" 0)
-
diff --git a/examples/failing/ProgrammableTypeErrorsTypeString.purs b/examples/failing/ProgrammableTypeErrorsTypeString.purs
new file mode 100644
index 0000000..b0b7c0f
--- /dev/null
+++ b/examples/failing/ProgrammableTypeErrorsTypeString.purs
@@ -0,0 +1,18 @@
+-- @shouldFailWith NoInstanceFound
+
+module Main where
+
+import Prelude
+import Control.Monad.Eff (Eff)
+import Control.Monad.Eff.Console (log)
+
+newtype MyType a = MyType a
+
+instance cannotShowFunctions :: Fail ("Don't want to show " <> TypeString (MyType a) <> " because.") => Show (MyType a) where
+ show _ = "unreachable"
+
+infixl 6 type TypeConcat as <>
+
+main :: Eff _ _
+main = do
+ log $ show (MyType 2)
diff --git a/examples/failing/TypeWildcards3.purs b/examples/failing/TypeWildcards3.purs
index 5c60b30..c0463fa 100644
--- a/examples/failing/TypeWildcards3.purs
+++ b/examples/failing/TypeWildcards3.purs
@@ -1,4 +1,4 @@
--- @shouldFailWith ErrorParsingModule
+-- @shouldFailWith InvalidInstanceHead
module TypeWildcards where
import Prelude
@@ -7,4 +7,3 @@ data Foo a = Foo
instance showFoo :: Show (Foo _) where
show Foo = "Foo"
-
diff --git a/examples/failing/UnifyInTypeInstanceLookup.purs b/examples/failing/UnifyInTypeInstanceLookup.purs
deleted file mode 100644
index 50aa41a..0000000
--- a/examples/failing/UnifyInTypeInstanceLookup.purs
+++ /dev/null
@@ -1,22 +0,0 @@
--- @shouldFailWith NoInstanceFound
--- See issue #390.
--- TODO: Improve this error.
-module Main where
-
-import Prelude
-
-data Z = Z
-data S n = S n
-
-data T
-data F
-
-class EQ x y b
-instance eqT :: EQ x x T
-instance eqF :: EQ x y F
-
-foreign import test :: forall a b. (EQ a b T) => a -> b -> a
-
-foreign import anyNat :: forall a. a
-
-test1 = test anyNat (S Z)
diff --git a/examples/passing/1807.purs b/examples/passing/1807.purs
new file mode 100644
index 0000000..7b221b3
--- /dev/null
+++ b/examples/passing/1807.purs
@@ -0,0 +1,14 @@
+module Main where
+
+import Prelude
+import Control.Monad.Eff.Console (log)
+
+fn = _.b.c.d
+a = {b:{c:{d:2}}}
+
+d :: Int
+d = fn a + a.b.c.d
+
+main = if fn a + a.b.c.d == 4
+ then log "Done"
+ else log "Fail"
diff --git a/examples/passing/ConstraintParsingIssue.purs b/examples/passing/ConstraintParsingIssue.purs
new file mode 100644
index 0000000..b16f684
--- /dev/null
+++ b/examples/passing/ConstraintParsingIssue.purs
@@ -0,0 +1,9 @@
+module Main where
+
+import Control.Monad.Eff.Console
+
+class X a
+
+instance x :: X (Array (Array a)) => X (Array a)
+
+main = log "Done"
diff --git a/examples/passing/DeriveNewtype.purs b/examples/passing/DeriveNewtype.purs
new file mode 100644
index 0000000..6b05c0d
--- /dev/null
+++ b/examples/passing/DeriveNewtype.purs
@@ -0,0 +1,17 @@
+module Main where
+
+import Control.Monad.Eff.Console (log)
+
+import Data.Newtype
+
+newtype Test = Test String
+
+derive instance newtypeTest :: Newtype Test _
+
+t :: Test
+t = wrap "hello"
+
+a :: String
+a = unwrap t
+
+main = log "Done"
diff --git a/examples/passing/FunWithFunDeps.js b/examples/passing/FunWithFunDeps.js
new file mode 100644
index 0000000..dea73d1
--- /dev/null
+++ b/examples/passing/FunWithFunDeps.js
@@ -0,0 +1,32 @@
+
+//: forall e. FVect Z e
+exports.fnil = [];
+
+//: forall n e. e -> FVect n e -> FVect (S n) e
+exports.fcons = function (hd) {
+ return function (tl) {
+ return [hd].concat(tl);
+ };
+};
+
+exports.fappend = function (dict) {
+ return function (left) {
+ return function (right) {
+ return left.concat(right);
+ };
+ };
+};
+
+exports.fflatten = function (dict) {
+ return function (v) {
+ var accRef = [];
+ for (var indexRef = 0; indexRef < v.length; indexRef += 1) {
+ accRef = accRef.concat(v[indexRef]);
+ }
+ return accRef;
+ };
+};
+
+exports.ftoArray = function (vect) {
+ return vect;
+};
diff --git a/examples/passing/FunWithFunDeps.purs b/examples/passing/FunWithFunDeps.purs
new file mode 100644
index 0000000..fa40b2f
--- /dev/null
+++ b/examples/passing/FunWithFunDeps.purs
@@ -0,0 +1,41 @@
+-- Taken from https://github.com/LiamGoodacre/purescript-fun-with-fundeps
+
+module Main where
+
+import Control.Monad.Eff.Console (log)
+
+-- Nat : Type
+data Z
+data S n
+
+type S2 n = S (S n)
+type S3 n = S (S2 n)
+type S4 n = S (S3 n)
+type S5 n = S (S4 n)
+type S15 n = S5 (S5 (S5 n))
+
+class NatPlus l r o | l r -> o
+instance natPlusZ :: NatPlus Z r r
+instance natPlusS :: (NatPlus l r o) => NatPlus (S l) r (S o)
+
+class NatMult l r o | l r -> o
+instance natMultZ :: NatMult Z n Z
+instance natMultS :: (NatMult m n r, NatPlus n r s) => NatMult (S m) n s
+
+-- Foreign Vect
+foreign import data FVect :: * -> * -> *
+foreign import fnil :: forall e. FVect Z e
+foreign import fcons :: forall n e. e -> FVect n e -> FVect (S n) e
+foreign import fappend :: forall l r o e. (NatPlus l r o) => FVect l e -> FVect r e -> FVect o e
+foreign import fflatten :: forall f s t o. (NatMult f s o) => FVect f (FVect s t) -> FVect o t
+foreign import ftoArray :: forall n e. FVect n e -> Array e
+
+-- should be able to figure these out
+fsingleton x = fcons x fnil
+fexample = fcons 1 (fsingleton 2) `fappend` fsingleton 3 `fappend` fcons 4 (fsingleton 5)
+fexample2 = fexample `fappend` fexample `fappend` fexample
+fexample3 = fsingleton fexample `fappend` fsingleton fexample `fappend` fsingleton fexample
+
+fexample4 = fflatten fexample3
+
+main = log "Done"
diff --git a/examples/passing/FunctionalDependencies.purs b/examples/passing/FunctionalDependencies.purs
new file mode 100644
index 0000000..cb8026e
--- /dev/null
+++ b/examples/passing/FunctionalDependencies.purs
@@ -0,0 +1,21 @@
+module Main where
+
+import Control.Monad.Eff.Console (log)
+
+data Nil
+data Cons x xs
+
+class Append a b c | a b -> c
+
+instance appendNil :: Append Nil b b
+
+instance appendCons :: Append xs b c => Append (Cons x xs) b (Cons x c)
+
+data Proxy a = Proxy
+
+appendProxy :: forall a b c. Append a b c => Proxy a -> Proxy b -> Proxy c
+appendProxy Proxy Proxy = Proxy
+
+test = appendProxy (Proxy :: Proxy (Cons Int Nil)) (Proxy :: Proxy (Cons String Nil))
+
+main = log "Done"
diff --git a/examples/passing/GHCGenerics.purs b/examples/passing/GHCGenerics.purs
new file mode 100644
index 0000000..d3f0abe
--- /dev/null
+++ b/examples/passing/GHCGenerics.purs
@@ -0,0 +1,140 @@
+-- An example to show how we could implement GHC-style Generics using
+-- functional dependencies.
+--
+-- See https://hackage.haskell.org/package/base-4.9.0.0/docs/GHC-Generics.html
+
+module Main where
+
+import Prelude
+import Control.Monad.Eff (Eff)
+import Control.Monad.Eff.Console (CONSOLE, log, logShow)
+
+-- Representation for types with no constructors
+data V1
+
+-- Representation for constructors with no arguments
+data U1 = U1
+
+-- Representation for sum types
+data Sum a b = Inl a | Inr b
+
+infixr 5 type Sum as +
+
+-- Representation for product types
+data Product a b = Product a b
+
+infixr 6 type Product as *
+
+-- Representation for data constructors, with the data constructor name indicated
+-- at the type level.
+data Ctor (name :: Symbol) a = Ctor a
+
+-- Representation for occurrences of other types in a data type definition.
+data K a = K a
+
+-- The Generic class asserts the existence of a type function from "real" types
+-- to representation types, and an isomorphism between them.
+class Generic a repr | a -> repr where
+ to :: a -> repr
+ from :: repr -> a
+
+-- We can write an instance for the (recursive) type of lists. Note that these
+-- instances would be generated by the compiler ideally.
+data List a = Nil | Cons a (List a)
+
+instance genericList :: Generic (List a) (Ctor "Nil" U1 + Ctor "Cons" (K a * K (List a))) where
+ to Nil = Inl (Ctor U1)
+ to (Cons x xs) = Inr (Ctor (Product (K x) (K xs)))
+ from (Inl (Ctor U1)) = Nil
+ from (Inr (Ctor (Product (K x) (K xs)))) = Cons x xs
+
+-- We'd like to refect type level strings (for data constructor names) at the value
+-- level, so that we can "show" them. Again, these instances would ideally be derived
+-- for us.
+class KnownSymbol (sym :: Symbol) where
+ symbol :: forall proxy. proxy sym -> String
+
+instance knownSymbolNil :: KnownSymbol "Nil" where
+ symbol _ = "Nil"
+
+instance knownSymbolCons :: KnownSymbol "Cons" where
+ symbol _ = "Cons"
+
+-- A proxy for a type-level string.
+data SProxy (sym :: Symbol) = SProxy
+
+-- To write generic functions, we create a corresponding type class, and use the
+-- type class machinery to infer the correct function based on the representation
+-- type.
+class GShow a where
+ gShow :: a -> String
+
+-- Now provide instances for GShow for the appropriate representation types.
+-- Note: we don't have to implement all instances here.
+
+instance gShowU1 :: GShow U1 where
+ gShow _ = ""
+
+instance gShowSum :: (GShow a, GShow b) => GShow (a + b) where
+ gShow (Inl a) = gShow a
+ gShow (Inr b) = gShow b
+
+instance gShowProduct :: (GShow a, GShow b) => GShow (a * b) where
+ gShow (Product a b) = gShow a <> gShow b
+
+instance gShowCtor :: (KnownSymbol ctor, GShow a) => GShow (Ctor ctor a) where
+ gShow (Ctor a) = "(" <> symbol (SProxy :: SProxy ctor) <> gShow a <> ")"
+
+instance gShowK :: Show a => GShow (K a) where
+ gShow (K a) = " " <> show a
+
+-- Now we can implement a generic show function which uses the GShow instance
+-- on the representation type.
+genericShow :: forall a repr. (Generic a repr, GShow repr) => a -> String
+genericShow x = gShow (to x)
+
+-- Note how the required instance here is Show a, and not Generic a.
+-- This allows us to use generic programming on a wider variety of types
+-- (including types which contain foreign types) than we can use now.
+instance showList :: Show a => Show (List a) where
+ show xs = genericShow xs -- (we need to eta expand here to avoid stack overflow
+ -- due to recursion implicit in the instance lookup)
+
+-- Another example: Eq
+
+class GEq a where
+ gEq :: a -> a -> Boolean
+
+instance gEqU1 :: GEq U1 where
+ gEq _ _ = true
+
+instance gEqSum :: (GEq a, GEq b) => GEq (a + b) where
+ gEq (Inl a1) (Inl a2) = gEq a1 a2
+ gEq (Inr b1) (Inr b2) = gEq b1 b2
+ gEq _ _ = false
+
+instance gEqProduct :: (GEq a, GEq b) => GEq (a * b) where
+ gEq (Product a1 b1) (Product a2 b2) = gEq a1 a2 && gEq b1 b2
+
+instance gEqCtor :: (KnownSymbol ctor, GEq a) => GEq (Ctor ctor a) where
+ gEq (Ctor a1) (Ctor a2) = gEq a1 a2
+
+instance gEqK :: Eq a => GEq (K a) where
+ gEq (K a1) (K a2) = a1 == a2
+
+genericEq :: forall a repr. (Generic a repr, GEq repr) => a -> a -> Boolean
+genericEq x y = gEq (to x) (to y)
+
+instance eqList :: Eq a => Eq (List a) where
+ eq xs ys = genericEq xs ys
+
+main :: Eff (console :: CONSOLE) Unit
+main = do
+ logShow (Cons 1 Nil)
+ logShow (Cons 1 (Cons 2 Nil))
+ logShow (Cons 'x' (Cons 'y' (Cons 'z' Nil)))
+
+ logShow (Cons 1 (Cons 2 Nil) == Cons 1 (Cons 2 Nil))
+ logShow (Cons 1 (Cons 2 Nil) == Cons 1 Nil)
+
+ log "Done"
diff --git a/examples/passing/NewtypeClass.purs b/examples/passing/NewtypeClass.purs
new file mode 100644
index 0000000..1352339
--- /dev/null
+++ b/examples/passing/NewtypeClass.purs
@@ -0,0 +1,39 @@
+module Main where
+
+import Prelude
+import Control.Monad.Eff
+import Control.Monad.Eff.Console
+
+class Newtype t a | t -> a where
+ wrap :: a -> t
+ unwrap :: t -> a
+
+instance newtypeMultiplicative :: Newtype (Multiplicative a) a where
+ wrap = Multiplicative
+ unwrap (Multiplicative a) = a
+
+data Multiplicative a = Multiplicative a
+
+instance semiringMultiplicative :: Semiring a => Semigroup (Multiplicative a) where
+ append (Multiplicative a) (Multiplicative b) = Multiplicative (a * b)
+
+data Pair a = Pair a a
+
+foldPair :: forall a s. Semigroup s => (a -> s) -> Pair a -> s
+foldPair f (Pair a b) = f a <> f b
+
+ala
+ :: forall f t a
+ . (Functor f, Newtype t a)
+ => (a -> t)
+ -> ((a -> t) -> f t)
+ -> f a
+ala _ f = map unwrap (f wrap)
+
+test = ala Multiplicative foldPair
+
+test1 = ala Multiplicative foldPair (Pair 2 3)
+
+main = do
+ logShow (test (Pair 2 3))
+ log "Done"
diff --git a/examples/passing/NewtypeInstance.purs b/examples/passing/NewtypeInstance.purs
new file mode 100644
index 0000000..416405a
--- /dev/null
+++ b/examples/passing/NewtypeInstance.purs
@@ -0,0 +1,30 @@
+module Main where
+
+import Prelude
+import Control.Monad.Eff
+import Control.Monad.Eff.Console
+
+newtype X = X String
+
+derive newtype instance showX :: Show X
+
+derive newtype instance eqX :: Eq X
+
+derive newtype instance ordX :: Ord X
+
+newtype Y a = Y (Array a)
+
+derive newtype instance showY :: Show (Y String)
+
+class Singleton a b where
+ singleton :: a -> b
+
+instance singletonArray :: Singleton a (Array a) where
+ singleton x = [x]
+
+derive newtype instance singletonY :: Singleton a (Y a)
+
+main = do
+ logShow (X "test")
+ logShow (singleton "test" :: Y String)
+ log "Done"
diff --git a/examples/passing/NumberLiterals.purs b/examples/passing/NumberLiterals.purs
index 46b789d..b827179 100644
--- a/examples/passing/NumberLiterals.purs
+++ b/examples/passing/NumberLiterals.purs
@@ -19,8 +19,8 @@ main = do
test "32.96176575630599" 32.96176575630599
test "38.47735512322269" 38.47735512322269
- test "10000000000" 1e10
- test "10000000000" 1.0e10
+ test "10000000000.0" 1e10
+ test "10000000000.0" 1.0e10
test "0.00001" 1e-5
test "0.00001" 1.0e-5
test "1.5339794352098402e-118" 1.5339794352098402e-118
diff --git a/examples/passing/RowPolyInstanceContext.purs b/examples/passing/RowPolyInstanceContext.purs
index 0641de0..caefb72 100644
--- a/examples/passing/RowPolyInstanceContext.purs
+++ b/examples/passing/RowPolyInstanceContext.purs
@@ -3,7 +3,7 @@ module Main where
import Prelude
import Control.Monad.Eff.Console (log)
-class T s m where
+class T s m | m -> s where
state :: (s -> s) -> m Unit
data S s a = S (s -> { new :: s, ret :: a })
diff --git a/examples/passing/Stream.purs b/examples/passing/Stream.purs
new file mode 100644
index 0000000..cc62a39
--- /dev/null
+++ b/examples/passing/Stream.purs
@@ -0,0 +1,26 @@
+module Main where
+
+import Prelude
+
+import Control.Monad.Eff (Eff)
+import Control.Monad.Eff.Console (CONSOLE, log)
+
+class IsStream el s | s -> el where
+ cons :: el -> (Unit -> s) -> s
+ uncons :: s -> { head :: el, tail :: s }
+
+data Stream a = Stream a (Unit -> Stream a)
+
+instance streamIsStream :: IsStream a (Stream a) where
+ cons x xs = Stream x xs
+ uncons (Stream x f) = { head: x, tail: f unit }
+
+test :: forall el s. IsStream el s => s -> s
+test s = case uncons s of
+ { head, tail } -> cons head \_ -> tail
+
+main :: Eff (console :: CONSOLE) Unit
+main = do
+ let dones :: Stream String
+ dones = cons "Done" \_ -> dones
+ log (uncons (test dones)).head
diff --git a/examples/passing/UnifyInTypeInstanceLookup.purs b/examples/passing/UnifyInTypeInstanceLookup.purs
new file mode 100644
index 0000000..a1920b8
--- /dev/null
+++ b/examples/passing/UnifyInTypeInstanceLookup.purs
@@ -0,0 +1,25 @@
+module Main where
+
+import Control.Monad.Eff.Console (log)
+
+data Z = Z
+data S n = S n
+
+data T
+data F
+
+class EQ x y b
+instance eqT :: EQ x x T
+instance eqF :: EQ x y F
+
+test :: forall a b. (EQ a b T) => a -> b -> a
+test a _ = a
+
+spin :: forall a b. a -> b
+spin a = spin a
+
+-- Expected type:
+-- forall t. (EQ t (S Z) T) => t
+test1 = test (spin 1) (S Z)
+
+main = log "Done"
diff --git a/examples/passing/WildcardInInstance.purs b/examples/passing/WildcardInInstance.purs
new file mode 100644
index 0000000..4b2d5ab
--- /dev/null
+++ b/examples/passing/WildcardInInstance.purs
@@ -0,0 +1,23 @@
+module Main where
+
+import Prelude
+import Control.Monad.Eff
+import Control.Monad.Eff.Console
+
+-- Until the functional dependency gets added to purescript-eff,
+-- we need this here.
+class Monad m <= MonadEff eff m | m -> eff where
+ liftEff :: forall a. Eff eff a -> m a
+
+instance monadEffEff :: MonadEff eff (Eff eff) where
+ liftEff = id
+
+-- This should generate a warning with the correct inferred type.
+test :: forall m. MonadEff _ m => m Unit
+test = liftEff $ log "Done"
+
+test1 :: Eff _ Unit
+test1 = liftEff $ log "Done"
+
+main :: forall eff. Eff (console :: CONSOLE | eff) Unit
+main = test
diff --git a/hierarchy/Main.hs b/hierarchy/Main.hs
index a6d7b07..d40e661 100644
--- a/hierarchy/Main.hs
+++ b/hierarchy/Main.hs
@@ -18,13 +18,16 @@
module Main where
+import Control.Applicative (optional)
import Control.Monad (unless)
import Data.List (intercalate,nub,sort)
import Data.Foldable (for_)
import Data.Version (showVersion)
+import Data.Monoid ((<>))
-import Options.Applicative
+import Options.Applicative (Parser)
+import qualified Options.Applicative as Opts
import System.Directory (createDirectoryIfMissing)
import System.FilePath ((</>))
import System.FilePath.Glob (glob)
@@ -40,7 +43,7 @@ data HierarchyOptions = HierarchyOptions
, hierarchyOutput :: Maybe FilePath
}
-newtype SuperMap = SuperMap { unSuperMap :: Either (P.ProperName 'P.ClassName) ((P.ProperName 'P.ClassName), (P.ProperName 'P.ClassName)) }
+newtype SuperMap = SuperMap { unSuperMap :: Either (P.ProperName 'P.ClassName) (P.ProperName 'P.ClassName, P.ProperName 'P.ClassName) }
deriving Eq
instance Show SuperMap where
@@ -83,33 +86,33 @@ compile (HierarchyOptions inputGlob mOutput) = do
exitSuccess
superClasses :: P.Declaration -> [SuperMap]
-superClasses (P.TypeClassDeclaration sub _ supers@(_:_) _) =
+superClasses (P.TypeClassDeclaration sub _ supers@(_:_) _ _) =
fmap (\(P.Constraint (P.Qualified _ super) _ _) -> SuperMap (Right (super, sub))) supers
-superClasses (P.TypeClassDeclaration sub _ _ _) = [SuperMap (Left sub)]
+superClasses (P.TypeClassDeclaration sub _ _ _ _) = [SuperMap (Left sub)]
superClasses (P.PositionedDeclaration _ _ decl) = superClasses decl
superClasses _ = []
inputFile :: Parser FilePath
-inputFile = strArgument $
- metavar "FILE"
- <> value "main.purs"
- <> showDefault
- <> help "The input file to generate a hierarchy from"
+inputFile = Opts.strArgument $
+ Opts.metavar "FILE"
+ <> Opts.value "main.purs"
+ <> Opts.showDefault
+ <> Opts.help "The input file to generate a hierarchy from"
outputFile :: Parser (Maybe FilePath)
-outputFile = optional . strOption $
- short 'o'
- <> long "output"
- <> help "The output directory"
+outputFile = optional . Opts.strOption $
+ Opts.short 'o'
+ <> Opts.long "output"
+ <> Opts.help "The output directory"
pscOptions :: Parser HierarchyOptions
pscOptions = HierarchyOptions <$> inputFile
<*> outputFile
main :: IO ()
-main = execParser opts >>= compile
+main = Opts.execParser opts >>= compile
where
- opts = info (helper <*> pscOptions) infoModList
- infoModList = fullDesc <> headerInfo <> footerInfo
- headerInfo = header "hierarchy - Creates a GraphViz directed graph of PureScript TypeClasses"
- footerInfo = footer $ "hierarchy " ++ showVersion Paths.version
+ opts = Opts.info (Opts.helper <*> pscOptions) infoModList
+ infoModList = Opts.fullDesc <> headerInfo <> footerInfo
+ headerInfo = Opts.header "hierarchy - Creates a GraphViz directed graph of PureScript TypeClasses"
+ footerInfo = Opts.footer $ "hierarchy " ++ showVersion Paths.version
diff --git a/psc-bundle/Main.hs b/psc-bundle/Main.hs
index 92ff4f2..7caeac3 100644
--- a/psc-bundle/Main.hs
+++ b/psc-bundle/Main.hs
@@ -8,6 +8,7 @@ module Main (main) where
import Data.Traversable (for)
import Data.Version (showVersion)
+import Data.Monoid ((<>))
import Control.Applicative
import Control.Monad
@@ -24,7 +25,8 @@ import System.Directory (createDirectoryIfMissing)
import Language.PureScript.Bundle
-import Options.Applicative as Opts
+import Options.Applicative (Parser, ParseError (..))
+import qualified Options.Applicative as Opts
import qualified Paths_purescript as Paths
@@ -64,41 +66,41 @@ options = Options <$> some inputFile
<*> namespace
where
inputFile :: Parser FilePath
- inputFile = strArgument $
- metavar "FILE"
- <> help "The input .js file(s)"
+ inputFile = Opts.strArgument $
+ Opts.metavar "FILE"
+ <> Opts.help "The input .js file(s)"
outputFile :: Parser FilePath
- outputFile = strOption $
- short 'o'
- <> long "output"
- <> help "The output .js file"
+ outputFile = Opts.strOption $
+ Opts.short 'o'
+ <> Opts.long "output"
+ <> Opts.help "The output .js file"
entryPoint :: Parser String
- entryPoint = strOption $
- short 'm'
- <> long "module"
- <> help "Entry point module name(s). All code which is not a transitive dependency of an entry point module will be removed."
+ entryPoint = Opts.strOption $
+ Opts.short 'm'
+ <> Opts.long "module"
+ <> Opts.help "Entry point module name(s). All code which is not a transitive dependency of an entry point module will be removed."
mainModule :: Parser String
- mainModule = strOption $
- long "main"
- <> help "Generate code to run the main method in the specified module."
+ mainModule = Opts.strOption $
+ Opts.long "main"
+ <> Opts.help "Generate code to run the main method in the specified module."
namespace :: Parser String
- namespace = strOption $
- short 'n'
- <> long "namespace"
+ namespace = Opts.strOption $
+ Opts.short 'n'
+ <> Opts.long "namespace"
<> Opts.value "PS"
- <> showDefault
- <> help "Specify the namespace that PureScript modules will be exported to when running in the browser."
+ <> Opts.showDefault
+ <> Opts.help "Specify the namespace that PureScript modules will be exported to when running in the browser."
-- | Make it go.
main :: IO ()
main = do
hSetEncoding stdout utf8
hSetEncoding stderr utf8
- opts <- execParser (info (version <*> helper <*> options) infoModList)
+ opts <- Opts.execParser (Opts.info (version <*> Opts.helper <*> options) infoModList)
output <- runExceptT (app opts)
case output of
Left err -> do
@@ -111,9 +113,10 @@ main = do
writeFile outputFile js
Nothing -> putStrLn js
where
- infoModList = fullDesc <> headerInfo <> footerInfo
- headerInfo = header "psc-bundle - Bundles compiled PureScript modules for the browser"
- footerInfo = footer $ "psc-bundle " ++ showVersion Paths.version
+ infoModList = Opts.fullDesc <> headerInfo <> footerInfo
+ headerInfo = Opts.header "psc-bundle - Bundles compiled PureScript modules for the browser"
+ footerInfo = Opts.footer $ "psc-bundle " ++ showVersion Paths.version
version :: Parser (a -> a)
- version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> help "Show the version number" <> hidden
+ version = Opts.abortOption (InfoMsg (showVersion Paths.version)) $
+ Opts.long "version" <> Opts.help "Show the version number" <> Opts.hidden
diff --git a/psc-docs/Tags.hs b/psc-docs/Tags.hs
index d370f05..eb17442 100644
--- a/psc-docs/Tags.hs
+++ b/psc-docs/Tags.hs
@@ -13,6 +13,6 @@ tags = concatMap dtags . P.exportedDeclarations
names (P.TypeDeclaration ident _) = [P.showIdent ident]
names (P.ExternDeclaration ident _) = [P.showIdent ident]
names (P.TypeSynonymDeclaration name _ _) = [P.runProperName name]
- names (P.TypeClassDeclaration name _ _ _) = [P.runProperName name]
+ names (P.TypeClassDeclaration name _ _ _ _) = [P.runProperName name]
names (P.TypeInstanceDeclaration name _ _ _ _) = [P.showIdent name]
names _ = []
diff --git a/psc-ide-client/Main.hs b/psc-ide-client/Main.hs
index ec4c761..85d56a6 100644
--- a/psc-ide-client/Main.hs
+++ b/psc-ide-client/Main.hs
@@ -8,8 +8,10 @@ import Control.Exception
import qualified Data.ByteString.Char8 as BS8
import qualified Data.Text.IO as T
import Data.Version (showVersion)
+import Data.Monoid ((<>))
import Network
-import Options.Applicative
+import Options.Applicative (ParseError (..))
+import qualified Options.Applicative as Opts
import System.Exit
import System.IO
@@ -21,15 +23,16 @@ data Options = Options
main :: IO ()
main = do
- Options port <- execParser opts
+ Options port <- Opts.execParser opts
client port
where
parser =
Options <$>
(PortNumber . fromIntegral <$>
- option auto (long "port" <> short 'p' <> value (4242 :: Integer)))
- opts = info (version <*> helper <*> parser) mempty
- version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> help "Show the version number" <> hidden
+ Opts.option Opts.auto (Opts.long "port" <> Opts.short 'p' <> Opts.value (4242 :: Integer)))
+ opts = Opts.info (version <*> Opts.helper <*> parser) mempty
+ version = Opts.abortOption (InfoMsg (showVersion Paths.version)) $
+ Opts.long "version" <> Opts.help "Show the version number" <> Opts.hidden
client :: PortID -> IO ()
client port = do
diff --git a/psc-ide-server/Main.hs b/psc-ide-server/Main.hs
index ce51302..675966a 100644
--- a/psc-ide-server/Main.hs
+++ b/psc-ide-server/Main.hs
@@ -38,7 +38,8 @@ import Network hiding (socketPort, accept)
import Network.BSD (getProtocolNumber)
import Network.Socket hiding (PortNumber, Type,
sClose)
-import Options.Applicative hiding ((<>))
+import Options.Applicative (ParseError (..))
+import qualified Options.Applicative as Opts
import System.Directory
import System.FilePath
import System.IO hiding (putStrLn, print)
@@ -55,7 +56,7 @@ listenOnLocalhost port = do
sClose
(\sock -> do
setSocketOption sock ReuseAddr 1
- bindSocket sock (SockAddrInet port localhost)
+ bind sock (SockAddrInet port localhost)
listen sock maxListenQueue
pure sock)
@@ -70,7 +71,7 @@ data Options = Options
main :: IO ()
main = do
- Options dir globs outputPath port noWatch debug <- execParser opts
+ Options dir globs outputPath port noWatch debug <- Opts.execParser opts
maybe (pure ()) setCurrentDirectory dir
ideState <- newTVarIO emptyIdeState
cwd <- getCurrentDirectory
@@ -91,17 +92,17 @@ main = do
where
parser =
Options
- <$> optional (strOption (long "directory" `mappend` short 'd'))
- <*> many (argument str (metavar "Source GLOBS..."))
- <*> strOption (long "output-directory" `mappend` value "output/")
+ <$> optional (Opts.strOption (Opts.long "directory" `mappend` Opts.short 'd'))
+ <*> many (Opts.argument Opts.str (Opts.metavar "Source GLOBS..."))
+ <*> Opts.strOption (Opts.long "output-directory" `mappend` Opts.value "output/")
<*> (fromIntegral <$>
- option auto (long "port" `mappend` short 'p' `mappend` value (4242 :: Integer)))
- <*> switch (long "no-watch")
- <*> switch (long "debug")
- opts = info (version <*> helper <*> parser) mempty
- version = abortOption
+ Opts.option Opts.auto (Opts.long "port" `mappend` Opts.short 'p' `mappend` Opts.value (4242 :: Integer)))
+ <*> Opts.switch (Opts.long "no-watch")
+ <*> Opts.switch (Opts.long "debug")
+ opts = Opts.info (version <*> Opts.helper <*> parser) mempty
+ version = Opts.abortOption
(InfoMsg (showVersion Paths.version))
- (long "version" `mappend` help "Show the version number")
+ (Opts.long "version" `mappend` Opts.help "Show the version number")
startServer :: PortNumber -> IdeEnvironment -> IO ()
startServer port env = withSocketsDo $ do
diff --git a/psc-publish/Main.hs b/psc-publish/Main.hs
index 7242235..dd8f663 100644
--- a/psc-publish/Main.hs
+++ b/psc-publish/Main.hs
@@ -4,8 +4,10 @@ module Main where
import Data.Version (Version(..), showVersion)
import qualified Data.Aeson as A
import qualified Data.ByteString.Lazy.Char8 as BL
+import Data.Monoid ((<>))
-import Options.Applicative hiding (str)
+import Options.Applicative (Parser, ParseError (..))
+import qualified Options.Applicative as Opts
import System.IO (hSetEncoding, stderr, stdout, utf8)
@@ -14,9 +16,9 @@ import Language.PureScript.Publish
import Language.PureScript.Publish.ErrorsWarnings
dryRun :: Parser Bool
-dryRun = switch $
- long "dry-run"
- <> help "Produce no output, and don't require a tagged version to be checked out."
+dryRun = Opts.switch $
+ Opts.long "dry-run"
+ <> Opts.help "Produce no output, and don't require a tagged version to be checked out."
dryRunOptions :: PublishOptions
dryRunOptions = defaultPublishOptions
@@ -29,15 +31,16 @@ main :: IO ()
main = do
hSetEncoding stdout utf8
hSetEncoding stderr utf8
- execParser opts >>= publish
+ Opts.execParser opts >>= publish
where
- opts = info (version <*> helper <*> dryRun) infoModList
- infoModList = fullDesc <> headerInfo <> footerInfo
- headerInfo = header "psc-publish - Generates documentation packages for upload to http://pursuit.purescript.org"
- footerInfo = footer $ "psc-publish " ++ showVersion Paths.version
+ opts = Opts.info (version <*> Opts.helper <*> dryRun) infoModList
+ infoModList = Opts.fullDesc <> headerInfo <> footerInfo
+ headerInfo = Opts.header "psc-publish - Generates documentation packages for upload to http://pursuit.purescript.org"
+ footerInfo = Opts.footer $ "psc-publish " ++ showVersion Paths.version
version :: Parser (a -> a)
- version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> help "Show the version number" <> hidden
+ version = Opts.abortOption (InfoMsg (showVersion Paths.version)) $
+ Opts.long "version" <> Opts.help "Show the version number" <> Opts.hidden
publish :: Bool -> IO ()
publish isDryRun =
diff --git a/psc/Main.hs b/psc/Main.hs
index e99c13e..47ae898 100644
--- a/psc/Main.hs
+++ b/psc/Main.hs
@@ -79,11 +79,11 @@ warnFileTypeNotFound = hPutStrLn stderr . ("psc: No files found using pattern: "
globWarningOnMisses :: (String -> IO ()) -> [FilePath] -> IO [FilePath]
globWarningOnMisses warn = concatMapM globWithWarning
where
- globWithWarning pattern = do
- paths <- glob pattern
- when (null paths) $ warn pattern
+ globWithWarning pattern' = do
+ paths <- glob pattern'
+ when (null paths) $ warn pattern'
return paths
- concatMapM f = liftM concat . mapM f
+ concatMapM f = fmap concat . mapM f
readInput :: [FilePath] -> IO [(FilePath, String)]
readInput inputFiles = forM inputFiles $ \inFile -> (inFile, ) <$> readUTF8File inFile
@@ -143,6 +143,11 @@ sourceMaps = switch $
long "source-maps"
<> help "Generate source maps"
+dumpCoreFn :: Parser Bool
+dumpCoreFn = switch $
+ long "dump-corefn"
+ <> help "Dump the (functional) core representation of the compiled code at output/*/corefn.json"
+
options :: Parser P.Options
options = P.Options <$> noTco
@@ -152,6 +157,7 @@ options = P.Options <$> noTco
<*> verboseErrors
<*> (not <$> comments)
<*> sourceMaps
+ <*> dumpCoreFn
pscMakeOptions :: Parser PSCMakeOptions
pscMakeOptions = PSCMakeOptions <$> many inputFile
diff --git a/psci/Main.hs b/psci/Main.hs
index 8dc6c9d..9bd3096 100644
--- a/psci/Main.hs
+++ b/psci/Main.hs
@@ -207,7 +207,7 @@ browserBackend serverPort = Backend setup evaluate reload shutdown
-- With many connected clients, all but one of
-- these attempts will fail.
tryPutMVar resultVar (unpack result)
- Reload -> do
+ Reload ->
WS.sendTextData conn ("reload" :: Text)
shutdownHandler :: IO () -> IO ()
@@ -278,7 +278,7 @@ browserBackend serverPort = Backend setup evaluate reload shutdown
Left err -> do
putStrLn (unlines (Bundle.printErrorMessage err))
exitFailure
- Right js -> do
+ Right js ->
atomically $ writeTVar (browserBundleJS state) (Just js)
reload :: BrowserState -> IO ()
@@ -335,7 +335,7 @@ main = getOpt >>= loop
(externs, env) <- ExceptT . runMake . make $ modules
return (modules, externs, env)
case psciBackend of
- Backend setup eval reload (shutdown :: state -> IO ()) -> do
+ Backend setup eval reload (shutdown :: state -> IO ()) ->
case e of
Left errs -> putStrLn (P.prettyPrintMultipleErrors P.defaultPPEOptions errs) >> exitFailure
Right (modules, externs, env) -> do
diff --git a/purescript.cabal b/purescript.cabal
index 14c70e8..4c07045 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,5 +1,5 @@
name: purescript
-version: 0.9.3
+version: 0.10.0
cabal-version: >=1.8
build-type: Simple
license: MIT
@@ -100,7 +100,7 @@ source-repository head
library
build-depends: base >=4.8 && <5,
- aeson >= 0.8 && < 0.12,
+ aeson >= 0.8 && < 1.1,
aeson-better-errors >= 0.8,
ansi-terminal >= 0.6.2 && < 0.7,
base-compat >=0.6.0,
@@ -109,6 +109,7 @@ library
bytestring -any,
containers -any,
clock -any,
+ data-ordlist >= 0.4.7.0,
directory >= 1.2,
dlist -any,
edit-distance -any,
@@ -116,7 +117,7 @@ library
fsnotify >= 0.2.1,
Glob >= 0.7 && < 0.8,
haskeline >= 0.7.0.0,
- http-client >= 0.4.30 && <0.5,
+ http-client >= 0.4.30 && <0.6,
http-types -any,
language-javascript == 0.6.*,
lifted-base >= 0.2.3 && < 0.2.4,
@@ -179,6 +180,7 @@ library
Language.PureScript.CoreFn.Meta
Language.PureScript.CoreFn.Module
Language.PureScript.CoreFn.Traversals
+ Language.PureScript.CoreFn.ToJSON
Language.PureScript.Comments
Language.PureScript.Environment
Language.PureScript.Errors
@@ -315,7 +317,7 @@ library
executable psc
build-depends: base >=4 && <5,
purescript -any,
- aeson >= 0.8 && < 0.12,
+ aeson >= 0.8 && < 1.1,
ansi-terminal >= 0.6.2 && < 0.7,
base-compat >=0.6.0,
bytestring -any,
@@ -440,7 +442,7 @@ executable psc-ide-server
other-modules: Paths_purescript
other-extensions:
build-depends: base >=4 && <5,
- aeson >= 0.8 && < 0.12,
+ aeson >= 0.8 && < 1.1,
bytestring -any,
purescript -any,
base-compat >=0.6.0,
@@ -520,5 +522,6 @@ test-suite tests
Language.PureScript.Ide.ReexportsSpec
Language.PureScript.Ide.SourceFile.IntegrationSpec
Language.PureScript.Ide.SourceFileSpec
+ Language.PureScript.Ide.StateSpec
buildable: True
hs-source-dirs: tests
diff --git a/src/Control/Monad/Supply/Class.hs b/src/Control/Monad/Supply/Class.hs
index 524225c..88fc979 100644
--- a/src/Control/Monad/Supply/Class.hs
+++ b/src/Control/Monad/Supply/Class.hs
@@ -7,6 +7,7 @@ import Prelude.Compat
import Control.Monad.Supply
import Control.Monad.State
+import Control.Monad.Writer
class Monad m => MonadSupply m where
fresh :: m Integer
@@ -20,5 +21,8 @@ instance Monad m => MonadSupply (SupplyT m) where
instance MonadSupply m => MonadSupply (StateT s m) where
fresh = lift fresh
+instance (Monoid w, MonadSupply m) => MonadSupply (WriterT w m) where
+ fresh = lift fresh
+
freshName :: MonadSupply m => m String
freshName = fmap (('$' :) . show) fresh
diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs
index a9ba39e..6a68cfa 100644
--- a/src/Language/PureScript/AST/Declarations.hs
+++ b/src/Language/PureScript/AST/Declarations.hs
@@ -77,6 +77,7 @@ data SimpleErrorMessage
| NoInstanceFound Constraint
| PossiblyInfiniteInstance (Qualified (ProperName 'ClassName)) [Type]
| CannotDerive (Qualified (ProperName 'ClassName)) [Type]
+ | InvalidNewtypeInstance (Qualified (ProperName 'ClassName)) [Type]
| CannotFindDerivingType (ProperName 'TypeName)
| DuplicateLabel String (Maybe Expr)
| DuplicateValueDeclaration Ident
@@ -89,7 +90,6 @@ data SimpleErrorMessage
| ExprDoesNotHaveType Expr Type
| PropertyIsMissing String
| AdditionalProperty String
- | CannotApplyFunction Type Expr
| TypeSynonymInstance
| OrphanInstance Ident (Qualified (ProperName 'ClassName)) [Type]
| InvalidNewtype (ProperName 'TypeName)
@@ -108,8 +108,8 @@ data SimpleErrorMessage
| ImportHidingModule ModuleName
| UnusedImport ModuleName
| UnusedExplicitImport ModuleName [String] (Maybe ModuleName) [DeclarationRef]
- | UnusedDctorImport (ProperName 'TypeName)
- | UnusedDctorExplicitImport (ProperName 'TypeName) [ProperName 'ConstructorName]
+ | UnusedDctorImport ModuleName (ProperName 'TypeName) (Maybe ModuleName) [DeclarationRef]
+ | UnusedDctorExplicitImport ModuleName (ProperName 'TypeName) [ProperName 'ConstructorName] (Maybe ModuleName) [DeclarationRef]
| DuplicateSelectiveImport ModuleName
| DuplicateImport ModuleName ImportDeclarationType (Maybe ModuleName)
| DuplicateImportRef Name
@@ -123,6 +123,8 @@ data SimpleErrorMessage
| InvalidOperatorInBinder (Qualified (OpName 'ValueOpName)) (Qualified Ident)
| DeprecatedRequirePath
| CannotGeneralizeRecursiveFunction Ident Type
+ | CannotDeriveNewtypeForData (ProperName 'TypeName)
+ | NonWildcardNewtypeInstance (ProperName 'TypeName)
deriving (Show)
-- | Error message hints, providing more detailed information about failure.
@@ -348,7 +350,7 @@ data Declaration
-- |
-- A type class declaration (name, argument, implies, member declarations)
--
- | TypeClassDeclaration (ProperName 'ClassName) [(String, Maybe Kind)] [Constraint] [Declaration]
+ | TypeClassDeclaration (ProperName 'ClassName) [(String, Maybe Kind)] [Constraint] [FunctionalDependency] [Declaration]
-- |
-- A type instance declaration (name, dependencies, class name, instance types, member
-- declarations)
@@ -374,10 +376,15 @@ pattern TypeFixityDeclaration fixity name op = FixityDeclaration (Right (TypeFix
-- | The members of a type class instance declaration
data TypeInstanceBody
- -- | This is a derived instance
= DerivedInstance
- -- | This is a regular (explicit) instance
+ -- ^ This is a derived instance
+ | NewtypeInstance
+ -- ^ This is an instance derived from a newtype
+ | NewtypeInstanceWithDictionary Expr
+ -- ^ This is an instance derived from a newtype, desugared to include a
+ -- dictionary for the type under the newtype.
| ExplicitInstance [Declaration]
+ -- ^ This is a regular (explicit) instance
deriving (Show)
mapTypeInstanceBody :: ([Declaration] -> [Declaration]) -> TypeInstanceBody -> TypeInstanceBody
@@ -385,8 +392,8 @@ mapTypeInstanceBody f = runIdentity . traverseTypeInstanceBody (Identity . f)
-- | A traversal for TypeInstanceBody
traverseTypeInstanceBody :: (Applicative f) => ([Declaration] -> f [Declaration]) -> TypeInstanceBody -> f TypeInstanceBody
-traverseTypeInstanceBody _ DerivedInstance = pure DerivedInstance
traverseTypeInstanceBody f (ExplicitInstance ds) = ExplicitInstance <$> f ds
+traverseTypeInstanceBody _ other = pure other
-- |
-- Test if a declaration is a value declaration
@@ -497,12 +504,9 @@ data Expr
--
| Parens Expr
-- |
- -- A record property getter (e.g. `_.x`). This will be removed during
- -- desugaring and expanded into a lambda that reads a property from a record.
- --
- | ObjectGetter String
- -- |
- -- An record property accessor expression
+ -- An record property accessor expression (e.g. `obj.x` or `_.x`).
+ -- Anonymous arguments will be removed during desugaring and expanded
+ -- into a lambda that reads a property from a record.
--
| Accessor String Expr
-- |
@@ -573,7 +577,7 @@ data Expr
-- |
-- A placeholder for a superclass dictionary to be turned into a TypeClassDictionary during typechecking
--
- | SuperClassDictionary (Qualified (ProperName 'ClassName)) [Type]
+ | DeferredDictionary (Qualified (ProperName 'ClassName)) [Type]
-- |
-- A placeholder for an anonymous function argument
--
diff --git a/src/Language/PureScript/AST/Exported.hs b/src/Language/PureScript/AST/Exported.hs
index 93e9585..ab9a2f3 100644
--- a/src/Language/PureScript/AST/Exported.hs
+++ b/src/Language/PureScript/AST/Exported.hs
@@ -133,7 +133,7 @@ isExported (Just exps) decl = any (matches decl) exps
matches (DataDeclaration _ ident _ _) (TypeRef ident' _) = ident == ident'
matches (ExternDataDeclaration ident _) (TypeRef ident' _) = ident == ident'
matches (TypeSynonymDeclaration ident _ _) (TypeRef ident' _) = ident == ident'
- matches (TypeClassDeclaration ident _ _ _) (TypeClassRef ident') = ident == ident'
+ matches (TypeClassDeclaration ident _ _ _ _) (TypeClassRef ident') = ident == ident'
matches (ValueFixityDeclaration _ _ op) (ValueOpRef op') = op == op'
matches (TypeFixityDeclaration _ _ op) (TypeOpRef op') = op == op'
matches (PositionedDeclaration _ _ d) r = d `matches` r
diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs
index 7a851fb..b1ce9fb 100644
--- a/src/Language/PureScript/AST/Traversals.hs
+++ b/src/Language/PureScript/AST/Traversals.hs
@@ -34,7 +34,7 @@ everywhereOnValues f g h = (f', g', h')
f' (DataBindingGroupDeclaration ds) = f (DataBindingGroupDeclaration (map f' ds))
f' (ValueDeclaration name nameKind bs val) = f (ValueDeclaration name nameKind (map h' bs) ((map (g' *** g') +++ g') val))
f' (BindingGroupDeclaration ds) = f (BindingGroupDeclaration (map (\(name, nameKind, val) -> (name, nameKind, g' val)) ds))
- f' (TypeClassDeclaration name args implies ds) = f (TypeClassDeclaration name args implies (map f' ds))
+ f' (TypeClassDeclaration name args implies deps ds) = f (TypeClassDeclaration name args implies deps (map f' ds))
f' (TypeInstanceDeclaration name cs className args ds) = f (TypeInstanceDeclaration name cs className args (mapTypeInstanceBody (map f') ds))
f' (PositionedDeclaration pos com d) = f (PositionedDeclaration pos com (f' d))
f' other = f other
@@ -101,7 +101,7 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)
f' (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> traverse (f' <=< f) ds
f' (ValueDeclaration name nameKind bs val) = ValueDeclaration name nameKind <$> traverse (h' <=< h) bs <*> eitherM (traverse (pairM (g' <=< g) (g' <=< g))) (g' <=< g) val
f' (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> traverse (\(name, nameKind, val) -> (,,) name nameKind <$> (g val >>= g')) ds
- f' (TypeClassDeclaration name args implies ds) = TypeClassDeclaration name args implies <$> traverse (f' <=< f) ds
+ f' (TypeClassDeclaration name args implies deps ds) = TypeClassDeclaration name args implies deps <$> traverse (f' <=< f) ds
f' (TypeInstanceDeclaration name cs className args ds) = TypeInstanceDeclaration name cs className args <$> traverseTypeInstanceBody (traverse (f' <=< f)) ds
f' (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> (f d >>= f')
f' other = f other
@@ -168,7 +168,7 @@ everywhereOnValuesM f g h = (f', g', h')
f' (DataBindingGroupDeclaration ds) = (DataBindingGroupDeclaration <$> traverse f' ds) >>= f
f' (ValueDeclaration name nameKind bs val) = (ValueDeclaration name nameKind <$> traverse h' bs <*> eitherM (traverse (pairM g' g')) g' val) >>= f
f' (BindingGroupDeclaration ds) = (BindingGroupDeclaration <$> traverse (\(name, nameKind, val) -> (,,) name nameKind <$> g' val) ds) >>= f
- f' (TypeClassDeclaration name args implies ds) = (TypeClassDeclaration name args implies <$> traverse f' ds) >>= f
+ f' (TypeClassDeclaration name args implies deps ds) = (TypeClassDeclaration name args implies deps <$> traverse f' ds) >>= f
f' (TypeInstanceDeclaration name cs className args ds) = (TypeInstanceDeclaration name cs className args <$> traverseTypeInstanceBody (traverse f') ds) >>= f
f' (PositionedDeclaration pos com d) = (PositionedDeclaration pos com <$> f' d) >>= f
f' other = f other
@@ -240,7 +240,7 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j')
f' d@(ValueDeclaration _ _ bs (Right val)) = foldl (<>) (f d) (map h' bs) <> g' val
f' d@(ValueDeclaration _ _ bs (Left gs)) = foldl (<>) (f d) (map h' bs ++ concatMap (\(grd, val) -> [g' grd, g' val]) gs)
f' d@(BindingGroupDeclaration ds) = foldl (<>) (f d) (map (\(_, _, val) -> g' val) ds)
- f' d@(TypeClassDeclaration _ _ _ ds) = foldl (<>) (f d) (map f' ds)
+ f' d@(TypeClassDeclaration _ _ _ _ ds) = foldl (<>) (f d) (map f' ds)
f' d@(TypeInstanceDeclaration _ _ _ _ (ExplicitInstance ds)) = foldl (<>) (f d) (map f' ds)
f' d@(PositionedDeclaration _ _ d1) = f d <> f' d1
f' d = f d
@@ -314,7 +314,7 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'
f' s (ValueDeclaration _ _ bs (Right val)) = foldl (<>) r0 (map (h'' s) bs) <> g'' s val
f' s (ValueDeclaration _ _ bs (Left gs)) = foldl (<>) r0 (map (h'' s) bs ++ concatMap (\(grd, val) -> [g'' s grd, g'' s val]) gs)
f' s (BindingGroupDeclaration ds) = foldl (<>) r0 (map (\(_, _, val) -> g'' s val) ds)
- f' s (TypeClassDeclaration _ _ _ ds) = foldl (<>) r0 (map (f'' s) ds)
+ f' s (TypeClassDeclaration _ _ _ _ ds) = foldl (<>) r0 (map (f'' s) ds)
f' s (TypeInstanceDeclaration _ _ _ _ (ExplicitInstance ds)) = foldl (<>) r0 (map (f'' s) ds)
f' s (PositionedDeclaration _ _ d1) = f'' s d1
f' _ _ = r0
@@ -395,7 +395,7 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j
f' s (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> traverse (f'' s) ds
f' s (ValueDeclaration name nameKind bs val) = ValueDeclaration name nameKind <$> traverse (h'' s) bs <*> eitherM (traverse (pairM (g'' s) (g'' s))) (g'' s) val
f' s (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> traverse (thirdM (g'' s)) ds
- f' s (TypeClassDeclaration name args implies ds) = TypeClassDeclaration name args implies <$> traverse (f'' s) ds
+ f' s (TypeClassDeclaration name args implies deps ds) = TypeClassDeclaration name args implies deps <$> traverse (f'' s) ds
f' s (TypeInstanceDeclaration name cs className args ds) = TypeInstanceDeclaration name cs className args <$> traverseTypeInstanceBody (traverse (f'' s)) ds
f' s (PositionedDeclaration pos com d1) = PositionedDeclaration pos com <$> f'' s d1
f' _ other = return other
@@ -482,7 +482,7 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)
f' s (BindingGroupDeclaration ds) =
let s' = S.union s (S.fromList (map (\(name, _, _) -> name) ds))
in foldMap (\(_, _, val) -> g'' s' val) ds
- f' s (TypeClassDeclaration _ _ _ ds) = foldMap (f'' s) ds
+ f' s (TypeClassDeclaration _ _ _ _ ds) = foldMap (f'' s) ds
f' s (TypeInstanceDeclaration _ _ _ _ (ExplicitInstance ds)) = foldMap (f'' s) ds
f' s (PositionedDeclaration _ _ d) = f'' s d
f' _ _ = mempty
@@ -576,13 +576,13 @@ accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (con
where
forDecls (DataDeclaration _ _ _ dctors) = mconcat (concatMap (map f . snd) dctors)
forDecls (ExternDeclaration _ ty) = f ty
- forDecls (TypeClassDeclaration _ _ implies _) = mconcat (concatMap (map f . constraintArgs) implies)
+ forDecls (TypeClassDeclaration _ _ implies _ _) = mconcat (concatMap (map f . constraintArgs) implies)
forDecls (TypeInstanceDeclaration _ cs _ tys _) = mconcat (concatMap (map f . constraintArgs) cs) `mappend` mconcat (map f tys)
forDecls (TypeSynonymDeclaration _ _ ty) = f ty
forDecls (TypeDeclaration _ ty) = f ty
forDecls _ = mempty
forValues (TypeClassDictionary c _ _) = mconcat (map f (constraintArgs c))
- forValues (SuperClassDictionary _ tys) = mconcat (map f tys)
+ forValues (DeferredDictionary _ tys) = mconcat (map f tys)
forValues (TypedValue _ _ ty) = f ty
forValues _ = mempty
diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs
index 1d94066..1ef4953 100644
--- a/src/Language/PureScript/Bundle.hs
+++ b/src/Language/PureScript/Bundle.hs
@@ -43,6 +43,8 @@ data ErrorMessage
| UnableToParseModule String
| UnsupportedExport
| ErrorInModule ModuleIdentifier ErrorMessage
+ | MissingEntryPoint String
+ | MissingMainModule String
deriving (Show)
-- | Modules are either "regular modules" (i.e. those generated by psc) or foreign modules.
@@ -125,8 +127,14 @@ printErrorMessage (ErrorInModule mid e) =
: ""
: map (" " ++) (printErrorMessage e)
where
- displayIdentifier (ModuleIdentifier name ty) =
- name ++ " (" ++ showModuleType ty ++ ")"
+ displayIdentifier (ModuleIdentifier name ty) =
+ name ++ " (" ++ showModuleType ty ++ ")"
+printErrorMessage (MissingEntryPoint mName) =
+ [ "Couldn't find a CommonJS module for the specified entry point: " ++ mName
+ ]
+printErrorMessage (MissingMainModule mName) =
+ [ "Couldn't find a CommonJS module for the specified main module: " ++ mName
+ ]
-- | Calculate the ModuleIdentifier which a require(...) statement imports.
checkImportPath :: String -> ModuleIdentifier -> S.Set String -> Either String ModuleIdentifier
@@ -256,7 +264,7 @@ toModule mids mid top
= pure (Member stmt exported name decl [])
toModuleElement stmt
| Just props <- matchExportsAssignment stmt
- = (ExportsList <$> traverse toExport (trailingCommaList props))
+ = ExportsList <$> traverse toExport (trailingCommaList props)
where
toExport :: JSObjectProperty -> m (ExportType, String, JSExpression, [Key])
toExport (JSPropertyNameandValue name _ [val]) =
@@ -524,7 +532,7 @@ codeGen optionsMainModule optionsNamespace ms = renderToString (JSAstProgram (p
indent :: [JSStatement] -> [JSStatement]
indent = everywhere (mkT squash)
where
- squash JSNoAnnot = (JSAnnot (TokenPn 0 0 2) [])
+ squash JSNoAnnot = JSAnnot (TokenPn 0 0 2) []
squash (JSAnnot pos ann) = JSAnnot (keepCol pos) (map splat ann)
splat (CommentA pos s) = CommentA (keepCol pos) s
@@ -571,15 +579,15 @@ codeGen optionsMainModule optionsNamespace ms = renderToString (JSAstProgram (p
(JSSemi JSNoAnnot)
]
where
- lfHead (h:t) = (addAnn (WhiteSpace tokenPosnEmpty "\n ") h) : t
+ lfHead (h:t) = addAnn (WhiteSpace tokenPosnEmpty "\n ") h : t
lfHead x = x
addAnn :: CommentAnnotation -> JSStatement -> JSStatement
addAnn a (JSExpressionStatement (JSStringLiteral ann s) _) =
- (JSExpressionStatement (JSStringLiteral (appendAnn a ann) s) (JSSemi JSNoAnnot))
+ JSExpressionStatement (JSStringLiteral (appendAnn a ann) s) (JSSemi JSNoAnnot)
addAnn _ x = x
- appendAnn a JSNoAnnot = (JSAnnot tokenPosnEmpty [a])
+ appendAnn a JSNoAnnot = JSAnnot tokenPosnEmpty [a]
appendAnn a (JSAnnot _ anns) = JSAnnot tokenPosnEmpty (a:anns ++ [WhiteSpace tokenPosnEmpty " "])
runMain :: String -> [JSStatement]
@@ -609,6 +617,10 @@ bundle :: (MonadError ErrorMessage m)
-> String -- ^ The namespace (e.g. PS).
-> m String
bundle inputStrs entryPoints mainModule namespace = do
+ forM_ mainModule $ \mname ->
+ when (mname `notElem` map (moduleName . fst) inputStrs) (throwError (MissingMainModule mname))
+ forM_ entryPoints $ \mIdent ->
+ when (mIdent `notElem` map fst inputStrs) (throwError (MissingEntryPoint (moduleName mIdent)))
input <- forM inputStrs $ \(ident, js) -> do
ast <- either (throwError . ErrorInModule ident . UnableToParseModule) pure $ parse js (moduleName ident)
return (ident, ast)
diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index ba682c1..db1ea96 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -15,7 +15,7 @@ import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.Reader (MonadReader, asks)
import Control.Monad.Supply.Class
-import Data.List ((\\), delete, intersect)
+import Data.List ((\\), delete, intersect, nub)
import Data.Maybe (isNothing, fromMaybe)
import qualified Data.Foldable as F
import qualified Data.Map as M
@@ -51,7 +51,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
rethrow (addHint (ErrorInModule mn)) $ do
let usedNames = concatMap getNames decls
let mnLookup = renameImports usedNames imps
- jsImports <- T.traverse (importToJs mnLookup) . delete (ModuleName [ProperName C.prim]) . (\\ [mn]) $ map snd imps
+ jsImports <- T.traverse (importToJs mnLookup) . delete (ModuleName [ProperName C.prim]) . (\\ [mn]) $ nub $ map snd imps
let decls' = renameModules mnLookup decls
jsDecls <- mapM bindToJs decls'
optimized <- T.traverse (T.traverse optimize) jsDecls
@@ -89,7 +89,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
in if mn' /= mn && mni `elem` used
then let newName = freshModuleName 1 mn' used
in go (M.insert mn' (ann, newName) acc) (Ident (runModuleName newName) : used) mns'
- else go (M.insert mn' (ann, mn') acc) (mni : used) mns'
+ else go (M.insert mn' (ann, mn') acc) used mns'
go acc _ [] = acc
freshModuleName :: Integer -> ModuleName -> [Ident] -> ModuleName
@@ -367,7 +367,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
-- binder.
--
binderToJs' :: String -> [JS] -> Binder Ann -> m [JS]
- binderToJs' _ done (NullBinder{}) = return done
+ binderToJs' _ done NullBinder{} = return done
binderToJs' varName done (LiteralBinder _ l) =
literalToBinderJS varName done l
binderToJs' varName done (VarBinder _ ident) =
diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer.hs b/src/Language/PureScript/CodeGen/JS/Optimizer.hs
index fd045b0..c504a77 100644
--- a/src/Language/PureScript/CodeGen/JS/Optimizer.hs
+++ b/src/Language/PureScript/CodeGen/JS/Optimizer.hs
@@ -34,7 +34,6 @@ import Language.PureScript.CodeGen.JS.Optimizer.MagicDo
import Language.PureScript.CodeGen.JS.Optimizer.TCO
import Language.PureScript.CodeGen.JS.Optimizer.Unused
import Language.PureScript.Options
-import qualified Language.PureScript.Constants as C
-- |
-- Apply a series of optimizer passes to simplified Javascript code
@@ -49,11 +48,6 @@ optimize' js = do
opts <- ask
js' <- untilFixedPoint (inlineFnComposition . tidyUp . applyAll
[ inlineCommonValues
- , inlineOperator (C.prelude, (C.$)) $ \f x -> JSApp Nothing f [x]
- , inlineOperator (C.dataFunction, C.apply) $ \f x -> JSApp Nothing f [x]
- , inlineOperator (C.prelude, (C.#)) $ \x f -> JSApp Nothing f [x]
- , inlineOperator (C.dataFunction, C.applyFlipped) $ \x f -> JSApp Nothing f [x]
- , inlineOperator (C.dataArrayUnsafe, C.unsafeIndex) $ flip (JSIndexer Nothing)
, inlineCommonOperators
]) js
untilFixedPoint (return . tidyUp) . tco opts . magicDo opts $ js'
diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs
index 5ac1104..7f953e9 100644
--- a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs
+++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs
@@ -4,7 +4,6 @@
module Language.PureScript.CodeGen.JS.Optimizer.Inliner
( inlineVariables
, inlineCommonValues
- , inlineOperator
, inlineCommonOperators
, inlineFnComposition
, etaConvert
@@ -100,13 +99,13 @@ inlineCommonValues = everywhereOnJS convert
fnSubtract = (C.dataRing, C.sub)
intOp ss op x y = JSBinary ss BitwiseOr (JSBinary ss op x y) (JSNumericLiteral ss (Left 0))
-inlineOperator :: (String, String) -> (JS -> JS -> JS) -> JS -> JS
-inlineOperator (m, op) f = everywhereOnJS convert
+inlineNonClassFunction :: (String, String) -> (JS -> JS -> JS) -> JS -> JS
+inlineNonClassFunction (m, op) f = everywhereOnJS convert
where
convert :: JS -> JS
convert (JSApp _ (JSApp _ op' [x]) [y]) | isOp op' = f x y
convert other = other
- isOp (JSIndexer _ (JSStringLiteral _ op') (JSVar _ m')) = m == m' && op == op'
+ isOp (JSAccessor _ op' (JSVar _ m')) = m == m' && op == op'
isOp _ = False
inlineCommonOperators :: JS -> JS
@@ -167,6 +166,10 @@ inlineCommonOperators = applyAll $
, binary' C.dataIntBits C.shr ShiftRight
, binary' C.dataIntBits C.zshr ZeroFillShiftRight
, unary' C.dataIntBits C.complement BitwiseNot
+
+ , inlineNonClassFunction (C.dataFunction, C.apply) $ \f x -> JSApp Nothing f [x]
+ , inlineNonClassFunction (C.dataFunction, C.applyFlipped) $ \x f -> JSApp Nothing f [x]
+ , inlineNonClassFunction (C.dataArrayUnsafe, C.unsafeIndex) $ flip (JSIndexer Nothing)
] ++
[ fn | i <- [0..10], fn <- [ mkFn i, runFn i ] ]
where
diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs
index e36d07d..af03744 100644
--- a/src/Language/PureScript/CoreFn/Desugar.hs
+++ b/src/Language/PureScript/CoreFn/Desugar.hs
@@ -72,7 +72,7 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =
[NonRec (ssA ss) name (exprToCoreFn ss com Nothing e)]
declToCoreFn ss _ (A.BindingGroupDeclaration ds) =
[Rec $ map (\(name, _, e) -> ((ssA ss, name), exprToCoreFn ss [] Nothing e)) ds]
- declToCoreFn ss com (A.TypeClassDeclaration name _ supers members) =
+ declToCoreFn ss com (A.TypeClassDeclaration name _ supers _ members) =
[NonRec (ssA ss) (properToIdent name) $ mkTypeClassConstructor ss com supers members]
declToCoreFn _ com (A.PositionedDeclaration ss com1 d) =
declToCoreFn (Just ss) (com ++ com1) d
diff --git a/src/Language/PureScript/CoreFn/ToJSON.hs b/src/Language/PureScript/CoreFn/ToJSON.hs
new file mode 100644
index 0000000..69ef3eb
--- /dev/null
+++ b/src/Language/PureScript/CoreFn/ToJSON.hs
@@ -0,0 +1,116 @@
+-- |
+-- Dump the core functional representation in JSON format for consumption
+-- by third-party code generators
+--
+module Language.PureScript.CoreFn.ToJSON
+ ( moduleToJSON
+ ) where
+
+import Prelude.Compat
+
+import Data.Aeson
+import Data.Version (Version, showVersion)
+import Data.Text (pack)
+
+import Language.PureScript.AST.Literals
+import Language.PureScript.CoreFn
+import Language.PureScript.Names
+
+literalToJSON :: (a -> Value) -> Literal a -> Value
+literalToJSON _ (NumericLiteral (Left n)) = toJSON ("IntLiteral", n)
+literalToJSON _ (NumericLiteral (Right n)) = toJSON ("NumberLiteral", n)
+literalToJSON _ (StringLiteral s) = toJSON ("StringLiteral", s)
+literalToJSON _ (CharLiteral c) = toJSON ("CharLiteral", c)
+literalToJSON _ (BooleanLiteral b) = toJSON ("BooleanLiteral", b)
+literalToJSON t (ArrayLiteral xs) = toJSON ("ArrayLiteral", map t xs)
+literalToJSON t (ObjectLiteral xs) = toJSON ("ObjectLiteral", recordToJSON t xs)
+
+identToJSON :: Ident -> Value
+identToJSON = toJSON . runIdent
+
+properNameToJSON :: ProperName a -> Value
+properNameToJSON = toJSON . runProperName
+
+qualifiedToJSON :: (a -> String) -> Qualified a -> Value
+qualifiedToJSON f = toJSON . showQualified f
+
+moduleNameToJSON :: ModuleName -> Value
+moduleNameToJSON = toJSON . runModuleName
+
+moduleToJSON :: Version -> Module a -> Value
+moduleToJSON v m = object [ pack "imports" .= map (moduleNameToJSON . snd) (moduleImports m)
+ , pack "exports" .= map identToJSON (moduleExports m)
+ , pack "foreign" .= map (identToJSON . fst) (moduleForeign m)
+ , pack "decls" .= map bindToJSON (moduleDecls m)
+ , pack "builtWith" .= toJSON (showVersion v)
+ ]
+
+bindToJSON :: Bind a -> Value
+bindToJSON (NonRec _ n e) = object [ pack (runIdent n) .= exprToJSON e ]
+bindToJSON (Rec bs) = object $ map (\((_, n), e) -> pack (runIdent n) .= exprToJSON e) bs
+
+recordToJSON :: (a -> Value) -> [(String, a)] -> Value
+recordToJSON f = object . map (\(label, a) -> pack label .= f a)
+
+exprToJSON :: Expr a -> Value
+exprToJSON (Var _ i) = toJSON ( "Var"
+ , qualifiedToJSON runIdent i
+ )
+exprToJSON (Literal _ l) = toJSON ( "Literal"
+ , literalToJSON (exprToJSON) l
+ )
+exprToJSON (Constructor _ d c is) = toJSON ( "Constructor"
+ , properNameToJSON d
+ , properNameToJSON c
+ , map identToJSON is
+ )
+exprToJSON (Accessor _ f r) = toJSON ( "Accessor"
+ , f
+ , exprToJSON r
+ )
+exprToJSON (ObjectUpdate _ r fs) = toJSON ( "ObjectUpdate"
+ , exprToJSON r
+ , recordToJSON exprToJSON fs
+ )
+exprToJSON (Abs _ p b) = toJSON ( "Abs"
+ , identToJSON p
+ , exprToJSON b
+ )
+exprToJSON (App _ f x) = toJSON ( "App"
+ , exprToJSON f
+ , exprToJSON x
+ )
+exprToJSON (Case _ ss cs) = toJSON ( "Case"
+ , map exprToJSON ss
+ , map caseAlternativeToJSON cs
+ )
+exprToJSON (Let _ bs e) = toJSON ( "Let"
+ , map bindToJSON bs
+ , exprToJSON e
+ )
+
+caseAlternativeToJSON :: CaseAlternative a -> Value
+caseAlternativeToJSON (CaseAlternative bs r') =
+ toJSON [ toJSON (map binderToJSON bs)
+ , case r' of
+ Left rs -> toJSON $ map (\(g, e) -> (exprToJSON g, exprToJSON e)) rs
+ Right r -> exprToJSON r
+ ]
+
+binderToJSON :: Binder a -> Value
+binderToJSON (VarBinder _ v) = toJSON ( "VarBinder"
+ , identToJSON v
+ )
+binderToJSON (NullBinder _) = toJSON "NullBinder"
+binderToJSON (LiteralBinder _ l) = toJSON ( "LiteralBinder"
+ , literalToJSON binderToJSON l
+ )
+binderToJSON (ConstructorBinder _ d c bs) = toJSON ( "ConstructorBinder"
+ , qualifiedToJSON runProperName d
+ , qualifiedToJSON runProperName c
+ , map binderToJSON bs
+ )
+binderToJSON (NamedBinder _ n b) = toJSON ( "NamedBinder"
+ , identToJSON n
+ , binderToJSON b
+ )
diff --git a/src/Language/PureScript/Docs/Convert/Single.hs b/src/Language/PureScript/Docs/Convert/Single.hs
index ef61b37..d34df2e 100644
--- a/src/Language/PureScript/Docs/Convert/Single.hs
+++ b/src/Language/PureScript/Docs/Convert/Single.hs
@@ -81,7 +81,7 @@ 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.TypeClassDeclaration name _ _ _ _) = Just (P.runProperName name)
getDeclarationTitle (P.TypeInstanceDeclaration name _ _ _ _) = Just (P.showIdent name)
getDeclarationTitle (P.TypeFixityDeclaration _ _ op) = Just ("type " ++ P.showOp op)
getDeclarationTitle (P.ValueFixityDeclaration _ _ op) = Just (P.showOp op)
@@ -121,7 +121,7 @@ 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 =
+convertDeclaration (P.TypeClassDeclaration _ args implies _ ds) title = -- TODO: include fundep info
Just (Right (mkDeclaration title info) { declChildren = children })
where
info = TypeClassDeclaration args implies
diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs
index d67f771..fbd665d 100644
--- a/src/Language/PureScript/Environment.hs
+++ b/src/Language/PureScript/Environment.hs
@@ -18,35 +18,46 @@ import Language.PureScript.TypeClassDictionaries
import Language.PureScript.Types
import qualified Language.PureScript.Constants as C
--- |
--- The @Environment@ defines all values and types which are currently in scope:
---
-data Environment = Environment {
- -- |
- -- Value names currently in scope
- --
- names :: M.Map (Qualified Ident) (Type, NameKind, NameVisibility)
- -- |
- -- Type names currently in scope
- --
+-- | The @Environment@ defines all values and types which are currently in scope:
+data Environment = Environment
+ { names :: M.Map (Qualified Ident) (Type, NameKind, NameVisibility)
+ -- ^ Values currently in scope
, types :: M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind)
- -- |
- -- Data constructors currently in scope, along with their associated type
- -- constructor name, argument types and return type.
+ -- ^ Type names currently in scope
, dataConstructors :: M.Map (Qualified (ProperName 'ConstructorName)) (DataDeclType, ProperName 'TypeName, Type, [Ident])
- -- |
- -- Type synonyms currently in scope
- --
+ -- ^ Data constructors currently in scope, along with their associated type
+ -- constructor name, argument types and return type.
, typeSynonyms :: M.Map (Qualified (ProperName 'TypeName)) ([(String, Maybe Kind)], Type)
- -- |
- -- Available type class dictionaries
- --
+ -- ^ Type synonyms currently in scope
, typeClassDictionaries :: M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope))
- -- |
- -- Type classes
- --
- , typeClasses :: M.Map (Qualified (ProperName 'ClassName)) ([(String, Maybe Kind)], [(Ident, Type)], [Constraint])
- } deriving (Show)
+ -- ^ Available type class dictionaries
+ , typeClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData
+ -- ^ Type classes
+ } deriving Show
+
+-- | Information about a type class
+data TypeClassData = TypeClassData
+ { typeClassArguments :: [(String, Maybe Kind)]
+ -- ^ A list of type argument names, and their kinds, where kind annotations
+ -- were provided.
+ , typeClassMembers :: [(Ident, Type)]
+ -- ^ A list of type class members and their types. Type arguments listed above
+ -- are considered bound in these types.
+ , typeClassSuperclasses :: [Constraint]
+ -- ^ A list of superclasses of this type class. Type arguments listed above
+ -- are considered bound in the types appearing in these constraints.
+ , typeClassDependencies :: [FunctionalDependency]
+ -- ^ A list of functional dependencies for the type arguments of this class.
+ } deriving Show
+
+-- | A functional dependency indicates a relationship between two sets of
+-- type arguments in a class declaration.
+data FunctionalDependency = FunctionalDependency
+ { fdDeterminers :: [Int]
+ -- ^ the type arguments which determine the determined type arguments
+ , fdDetermined :: [Int]
+ -- ^ the determined type arguments
+ } deriving Show
-- |
-- The initial environment with no values and only the default javascript types defined
@@ -241,17 +252,19 @@ primTypes =
, (primName "Boolean", (Star, ExternData))
, (primName "Partial", (Star, ExternData))
, (primName "Fail", (FunKind Symbol Star, ExternData))
+ , (primName "TypeString", (FunKind Star Symbol, ExternData))
+ , (primName "TypeConcat", (FunKind Symbol (FunKind Symbol Symbol), ExternData))
]
-- |
-- The primitive class map. This just contains to `Partial` class, used as a
-- kind of magic constraint for partial functions.
--
-primClasses :: M.Map (Qualified (ProperName 'ClassName)) ([(String, Maybe Kind)], [(Ident, Type)], [Constraint])
+primClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData
primClasses =
M.fromList
- [ (primName "Partial", ([], [], []))
- , (primName "Fail", ([("message", Just Symbol)], [], []))
+ [ (primName "Partial", (TypeClassData [] [] [] []))
+ , (primName "Fail", (TypeClassData [("message", Just Symbol)] [] [] []))
]
-- |
@@ -276,3 +289,4 @@ lookupValue :: Environment -> Qualified Ident -> Maybe (Type, NameKind, NameVisi
lookupValue env ident = ident `M.lookup` names env
$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''TypeKind)
+$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''FunctionalDependency)
diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs
index b0c2d0f..b176f11 100644
--- a/src/Language/PureScript/Errors.hs
+++ b/src/Language/PureScript/Errors.hs
@@ -25,6 +25,7 @@ import qualified Data.Map as M
import Language.PureScript.AST
import Language.PureScript.Crash
+import Language.PureScript.Environment
import Language.PureScript.Names
import Language.PureScript.Pretty
import Language.PureScript.Traversals
@@ -32,6 +33,7 @@ import Language.PureScript.Types
import Language.PureScript.Pretty.Common (endWith)
import qualified Language.PureScript.Bundle as Bundle
import qualified Language.PureScript.Constants as C
+import Language.PureScript.Pretty.Common (before)
import qualified System.Console.ANSI as ANSI
@@ -118,6 +120,7 @@ errorCode em = case unwrapErrorMessage em of
NoInstanceFound{} -> "NoInstanceFound"
PossiblyInfiniteInstance{} -> "PossiblyInfiniteInstance"
CannotDerive{} -> "CannotDerive"
+ InvalidNewtypeInstance{} -> "InvalidNewtypeInstance"
CannotFindDerivingType{} -> "CannotFindDerivingType"
DuplicateLabel{} -> "DuplicateLabel"
DuplicateValueDeclaration{} -> "DuplicateValueDeclaration"
@@ -130,7 +133,6 @@ errorCode em = case unwrapErrorMessage em of
ExprDoesNotHaveType{} -> "ExprDoesNotHaveType"
PropertyIsMissing{} -> "PropertyIsMissing"
AdditionalProperty{} -> "AdditionalProperty"
- CannotApplyFunction{} -> "CannotApplyFunction"
TypeSynonymInstance -> "TypeSynonymInstance"
OrphanInstance{} -> "OrphanInstance"
InvalidNewtype{} -> "InvalidNewtype"
@@ -164,6 +166,8 @@ errorCode em = case unwrapErrorMessage em of
InvalidOperatorInBinder{} -> "InvalidOperatorInBinder"
DeprecatedRequirePath{} -> "DeprecatedRequirePath"
CannotGeneralizeRecursiveFunction{} -> "CannotGeneralizeRecursiveFunction"
+ CannotDeriveNewtypeForData{} -> "CannotDeriveNewtypeForData"
+ NonWildcardNewtypeInstance{} -> "NonWildcardNewtypeInstance"
-- |
-- A stack trace for an error
@@ -254,12 +258,12 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse
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 (CannotApplyFunction t e) = CannotApplyFunction <$> f t <*> pure e
gSimple (InvalidInstanceHead t) = InvalidInstanceHead <$> f t
gSimple (NoInstanceFound con) = NoInstanceFound <$> overConstraintArgs (traverse f) con
gSimple (OverlappingInstances cl ts insts) = OverlappingInstances cl <$> traverse f ts <*> pure insts
gSimple (PossiblyInfiniteInstance cl ts) = PossiblyInfiniteInstance cl <$> traverse f ts
gSimple (CannotDerive cl ts) = CannotDerive cl <$> traverse f ts
+ gSimple (InvalidNewtypeInstance cl ts) = InvalidNewtypeInstance cl <$> traverse f ts
gSimple (ExpectedType ty k) = ExpectedType <$> f ty <*> pure k
gSimple (OrphanInstance nm cl ts) = OrphanInstance nm cl <$> traverse f ts
gSimple (WildcardInferredType ty ctx) = WildcardInferredType <$> f ty <*> traverse (sndM f) ctx
@@ -288,6 +292,8 @@ errorSuggestion err = case err of
UnusedImport{} -> emptySuggestion
DuplicateImport{} -> emptySuggestion
UnusedExplicitImport mn _ qual refs -> suggest $ importSuggestion mn refs qual
+ UnusedDctorImport mn _ qual refs -> suggest $ importSuggestion mn refs qual
+ UnusedDctorExplicitImport mn _ _ qual refs -> suggest $ importSuggestion mn refs qual
ImplicitImport mn refs -> suggest $ importSuggestion mn refs Nothing
ImplicitQualifiedImport mn asModule refs -> suggest $ importSuggestion mn refs (Just asModule)
HidingImport mn refs -> suggest $ importSuggestion mn refs Nothing
@@ -592,9 +598,9 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS
, line "They may be disallowed completely in a future version of the compiler."
]
renderSimpleErrorMessage OverlappingInstances{} = internalError "OverlappingInstances: empty instance list"
- renderSimpleErrorMessage (NoInstanceFound (Constraint C.Fail [ TypeLevelString message ] _)) =
+ renderSimpleErrorMessage (NoInstanceFound (Constraint C.Fail [ ty ] _)) | Just box <- toTypelevelString ty =
paras [ line "A custom type error occurred while solving type class constraints:"
- , indent . paras . map line . lines $ message
+ , indent box
]
renderSimpleErrorMessage (NoInstanceFound (Constraint C.Partial
_
@@ -638,6 +644,14 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS
, Box.vcat Box.left (map typeAtomAsBox ts)
]
]
+ renderSimpleErrorMessage (InvalidNewtypeInstance nm ts) =
+ paras [ line "Cannot derive newtype instance for"
+ , markCodeBox $ indent $ Box.hsep 1 Box.left
+ [ line (showQualified runProperName nm)
+ , Box.vcat Box.left (map typeAtomAsBox ts)
+ ]
+ , line "Make sure this is a newtype."
+ ]
renderSimpleErrorMessage (CannotFindDerivingType nm) =
line $ "Cannot derive a type class instance, because the type declaration for " ++ markCode (runProperName nm) ++ " could not be found."
renderSimpleErrorMessage (DuplicateLabel l expr) =
@@ -677,12 +691,6 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS
line $ "Type of expression lacks required label " ++ markCode prop ++ "."
renderSimpleErrorMessage (AdditionalProperty prop) =
line $ "Type of expression contains additional label " ++ markCode prop ++ "."
- renderSimpleErrorMessage (CannotApplyFunction fn arg) =
- paras [ line "A function of type"
- , markCodeBox $ indent $ typeAsBox fn
- , line "can not be applied to the argument"
- , markCodeBox $ indent $ prettyPrintValue valueDepth arg
- ]
renderSimpleErrorMessage TypeSynonymInstance =
line "Type class instances for type synonyms are disallowed."
renderSimpleErrorMessage (OrphanInstance nm cnm ts) =
@@ -756,12 +764,18 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS
, line "It could be replaced with:"
, indent $ line $ markCode $ showSuggestion msg ]
- renderSimpleErrorMessage (UnusedDctorImport name) =
- line $ "The import of type " ++ markCode (runProperName name) ++ " includes data constructors but only the type is used"
+ renderSimpleErrorMessage msg@(UnusedDctorImport mn name _ _) =
+ paras [line $ "The import of type " ++ markCode (runProperName name)
+ ++ " from module " ++ markCode (runModuleName mn) ++ " includes data constructors but only the type is used"
+ , line "It could be replaced with:"
+ , indent $ line $ markCode $ showSuggestion msg ]
- renderSimpleErrorMessage (UnusedDctorExplicitImport name names) =
- paras [ line $ "The import of type " ++ markCode (runProperName name) ++ " includes the following unused data constructors:"
- , indent $ paras $ map (line . markCode . runProperName) names ]
+ renderSimpleErrorMessage msg@(UnusedDctorExplicitImport mn name names _ _) =
+ paras [ line $ "The import of type " ++ markCode (runProperName name)
+ ++ " from module " ++ markCode (runModuleName mn) ++ " includes the following unused data constructors:"
+ , indent $ paras $ map (line . markCode . runProperName) names
+ , line "It could be replaced with:"
+ , indent $ line $ markCode $ showSuggestion msg ]
renderSimpleErrorMessage (DuplicateSelectiveImport name) =
line $ "There is an existing import of " ++ markCode (runModuleName name) ++ ", consider merging the import lists"
@@ -819,6 +833,14 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS
, line "Try adding a type signature."
]
+ renderSimpleErrorMessage (CannotDeriveNewtypeForData tyName) =
+ paras [ line $ "Cannot derive an instance of the " ++ markCode "Newtype" ++ " class for non-newtype " ++ markCode (runProperName tyName) ++ "."
+ ]
+
+ renderSimpleErrorMessage (NonWildcardNewtypeInstance tyName) =
+ paras [ line $ "A type wildcard (_) should be used for the inner type when deriving the " ++ markCode "Newtype" ++ " instance for " ++ markCode (runProperName tyName) ++ "."
+ ]
+
renderHint :: ErrorMessageHint -> Box.Box -> Box.Box
renderHint (ErrorUnifyingTypes t1 t2) detail =
paras [ detail
@@ -933,7 +955,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS
]
renderHint (ErrorSolvingConstraint (Constraint nm ts _)) detail =
paras [ detail
- , line "while solving type class constriant"
+ , line "while solving type class constraint"
, markCodeBox $ indent $ Box.hsep 1 Box.left
[ line (showQualified runProperName nm)
, Box.vcat Box.left (map typeAtomAsBox ts)
@@ -1016,10 +1038,6 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS
-- | See https://github.com/purescript/purescript/issues/1802
stripRedudantHints :: SimpleErrorMessage -> [ErrorMessageHint] -> [ErrorMessageHint]
- stripRedudantHints CannotApplyFunction{} = stripFirst isApplicationHint
- where
- isApplicationHint ErrorInApplication{} = True
- isApplicationHint _ = False
stripRedudantHints ExprDoesNotHaveType{} = stripFirst isCheckHint
where
isCheckHint ErrorCheckingType{} = True
@@ -1043,16 +1061,16 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS
stripFirst _ [] = []
hintCategory :: ErrorMessageHint -> HintCategory
- hintCategory ErrorCheckingType{} = ExprHint
- hintCategory ErrorInferringType{} = ExprHint
- hintCategory ErrorInExpression{} = ExprHint
- hintCategory ErrorUnifyingTypes{} = CheckHint
- hintCategory ErrorInSubsumption{} = CheckHint
- hintCategory ErrorInApplication{} = CheckHint
- hintCategory ErrorCheckingKind{} = CheckHint
- hintCategory ErrorSolvingConstraint{} = SolverHint
- hintCategory PositionedError{} = PositionHint
- hintCategory _ = OtherHint
+ hintCategory ErrorCheckingType{} = ExprHint
+ hintCategory ErrorInferringType{} = ExprHint
+ hintCategory ErrorInExpression{} = ExprHint
+ hintCategory ErrorUnifyingTypes{} = CheckHint
+ hintCategory ErrorInSubsumption{} = CheckHint
+ hintCategory ErrorInApplication{} = CheckHint
+ hintCategory ErrorCheckingKind{} = CheckHint
+ hintCategory ErrorSolvingConstraint{} = SolverHint
+ hintCategory PositionedError{} = PositionHint
+ hintCategory _ = OtherHint
-- Pretty print and export declaration
prettyPrintExport :: DeclarationRef -> String
@@ -1195,6 +1213,14 @@ renderBox = unlines
dropWhileEnd p = reverse . dropWhile p . reverse
whiteSpace = all isSpace
+toTypelevelString :: Type -> Maybe Box.Box
+toTypelevelString (TypeLevelString s) = Just $ Box.text s
+toTypelevelString (TypeApp (TypeConstructor f) x)
+ | f == primName "TypeString" = Just $ typeAsBox x
+toTypelevelString (TypeApp (TypeApp (TypeConstructor f) x) ret)
+ | f == primName "TypeConcat" = before <$> (toTypelevelString x) <*> (toTypelevelString ret)
+toTypelevelString _ = Nothing
+
-- |
-- Rethrow an error with a more detailed error message in the case of failure
--
diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs
index f1b2f83..16a70ad 100644
--- a/src/Language/PureScript/Externs.hs
+++ b/src/Language/PureScript/Externs.hs
@@ -93,44 +93,45 @@ data ExternsTypeFixity = ExternsTypeFixity
data ExternsDeclaration =
-- | A type declaration
EDType
- { edTypeName :: ProperName 'TypeName
- , edTypeKind :: Kind
- , edTypeDeclarationKind :: TypeKind
+ { edTypeName :: ProperName 'TypeName
+ , edTypeKind :: Kind
+ , edTypeDeclarationKind :: TypeKind
}
-- | A type synonym
| EDTypeSynonym
- { edTypeSynonymName :: ProperName 'TypeName
- , edTypeSynonymArguments :: [(String, Maybe Kind)]
- , edTypeSynonymType :: Type
+ { edTypeSynonymName :: ProperName 'TypeName
+ , edTypeSynonymArguments :: [(String, Maybe Kind)]
+ , edTypeSynonymType :: Type
}
-- | A data construtor
| EDDataConstructor
- { edDataCtorName :: ProperName 'ConstructorName
- , edDataCtorOrigin :: DataDeclType
- , edDataCtorTypeCtor :: ProperName 'TypeName
- , edDataCtorType :: Type
- , edDataCtorFields :: [Ident]
+ { edDataCtorName :: ProperName 'ConstructorName
+ , edDataCtorOrigin :: DataDeclType
+ , edDataCtorTypeCtor :: ProperName 'TypeName
+ , edDataCtorType :: Type
+ , edDataCtorFields :: [Ident]
}
-- | A value declaration
| EDValue
- { edValueName :: Ident
- , edValueType :: Type
+ { edValueName :: Ident
+ , edValueType :: Type
}
-- | A type class declaration
| EDClass
- { edClassName :: ProperName 'ClassName
- , edClassTypeArguments :: [(String, Maybe Kind)]
- , edClassMembers :: [(Ident, Type)]
- , edClassConstraints :: [Constraint]
+ { edClassName :: ProperName 'ClassName
+ , edClassTypeArguments :: [(String, Maybe Kind)]
+ , edClassMembers :: [(Ident, Type)]
+ , edClassConstraints :: [Constraint]
+ , edFunctionalDependencies :: [FunctionalDependency]
}
-- | An instance declaration
| EDInstance
- { edInstanceClassName :: Qualified (ProperName 'ClassName)
- , edInstanceName :: Ident
- , edInstanceTypes :: [Type]
- , edInstanceConstraints :: Maybe [Constraint]
+ { edInstanceClassName :: Qualified (ProperName 'ClassName)
+ , edInstanceName :: Ident
+ , edInstanceTypes :: [Type]
+ , edInstanceConstraints :: Maybe [Constraint]
}
- deriving (Show)
+ deriving Show
-- | Convert an externs file back into a module
applyExternsFileToEnvironment :: ExternsFile -> Environment -> Environment
@@ -141,7 +142,7 @@ applyExternsFileToEnvironment ExternsFile{..} = flip (foldl' applyDecl) efDeclar
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 (Qualified (Just 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 (EDClass pn args members cs deps) = env { typeClasses = M.insert (qual pn) (TypeClassData args members cs deps) (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
@@ -204,12 +205,12 @@ moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..}
| Just (ty, _, _) <- Qualified (Just 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 TypeClassData{..} <- Qualified (Just mn) className `M.lookup` typeClasses env
, Just (kind, TypeSynonym) <- Qualified (Just mn) (coerceProperName className) `M.lookup` types env
, Just (_, synTy) <- Qualified (Just mn) (coerceProperName className) `M.lookup` typeSynonyms env
= [ EDType (coerceProperName className) kind TypeSynonym
- , EDTypeSynonym (coerceProperName className) args synTy
- , EDClass className args members implies
+ , EDTypeSynonym (coerceProperName className) typeClassArguments synTy
+ , EDClass className typeClassArguments typeClassMembers typeClassSuperclasses typeClassDependencies
]
toExternsDeclaration (TypeInstanceRef ident)
= [ EDInstance tcdClassName ident tcdInstanceTypes tcdDependencies
diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs
index 697215a..0c466ca 100644
--- a/src/Language/PureScript/Ide.hs
+++ b/src/Language/PureScript/Ide.hs
@@ -38,9 +38,9 @@ import Language.PureScript.Ide.SourceFile
import Language.PureScript.Ide.State
import Language.PureScript.Ide.Types
import Language.PureScript.Ide.Util
-import System.Directory
-import System.FilePath
-import System.FilePath.Glob
+import System.Directory (getCurrentDirectory, getDirectoryContents, doesDirectoryExist, doesFileExist)
+import System.FilePath ((</>))
+import System.FilePath.Glob (glob)
-- | Accepts a Commmand and runs it against psc-ide's State. This is the main
-- entry point for the server.
@@ -77,7 +77,7 @@ handleCommand c = case c of
case rs of
Right rs' -> answerRequest outfp rs'
Left question ->
- pure (CompletionResult (map completionFromMatch question))
+ pure (CompletionResult (map (completionFromMatch . map withEmptyAnn) question))
Rebuild file ->
rebuildFile file
Cwd ->
@@ -88,7 +88,7 @@ handleCommand c = case c of
liftIO exitSuccess
findCompletions :: Ide m =>
- [Filter] -> Matcher IdeDeclaration -> Maybe P.ModuleName -> m Success
+ [Filter] -> Matcher IdeDeclarationAnn -> Maybe P.ModuleName -> m Success
findCompletions filters matcher currentModule = do
modules <- getAllModules currentModule
pure . CompletionResult . map completionFromMatch . getCompletions filters matcher $ modules
@@ -97,7 +97,7 @@ findType :: Ide m =>
Text -> [Filter] -> Maybe P.ModuleName -> m Success
findType search filters currentModule = do
modules <- getAllModules currentModule
- pure . InfoResult . map infoFromMatch . getExactMatches search filters $ modules
+ pure . CompletionResult . map completionFromMatch . getExactMatches search filters $ modules
findPursuitCompletions :: MonadIO m =>
PursuitQuery -> m Success
diff --git a/src/Language/PureScript/Ide/Command.hs b/src/Language/PureScript/Ide/Command.hs
index 0d6e48c..966afd2 100644
--- a/src/Language/PureScript/Ide/Command.hs
+++ b/src/Language/PureScript/Ide/Command.hs
@@ -34,7 +34,7 @@ data Command
}
| Complete
{ completeFilters :: [Filter]
- , completeMatcher :: Matcher IdeDeclaration
+ , completeMatcher :: Matcher IdeDeclarationAnn
, completeCurrentModule :: Maybe P.ModuleName
}
| Pursuit
diff --git a/src/Language/PureScript/Ide/Completion.hs b/src/Language/PureScript/Ide/Completion.hs
index 04c0e7d..acb6675 100644
--- a/src/Language/PureScript/Ide/Completion.hs
+++ b/src/Language/PureScript/Ide/Completion.hs
@@ -9,24 +9,23 @@ import Protolude
import Language.PureScript.Ide.Filter
import Language.PureScript.Ide.Matcher
import Language.PureScript.Ide.Types
-import Language.PureScript.Ide.Util
-- | Applies the CompletionFilters and the Matcher to the given Modules
-- and sorts the found Completions according to the Matching Score
getCompletions
:: [Filter]
- -> Matcher IdeDeclaration
+ -> Matcher IdeDeclarationAnn
-> [Module]
- -> [Match IdeDeclaration]
+ -> [Match IdeDeclarationAnn]
getCompletions filters matcher modules =
- runMatcher matcher (completionsFromModules discardAnn (applyFilters filters modules))
+ runMatcher matcher (completionsFromModules (applyFilters filters modules))
getExactMatches :: Text -> [Filter] -> [Module] -> [Match IdeDeclarationAnn]
getExactMatches search filters modules =
- completionsFromModules identity (applyFilters (equalityFilter search : filters) modules)
+ completionsFromModules (applyFilters (equalityFilter search : filters) modules)
-completionsFromModules :: (IdeDeclarationAnn -> a) -> [Module] -> [Match a]
-completionsFromModules f = foldMap completionFromModule
+completionsFromModules :: [Module] -> [Match IdeDeclarationAnn]
+completionsFromModules = foldMap completionFromModule
where
completionFromModule (moduleName, decls) =
- map (\x -> Match (moduleName, f x)) decls
+ map (\x -> Match (moduleName, x)) decls
diff --git a/src/Language/PureScript/Ide/Externs.hs b/src/Language/PureScript/Ide/Externs.hs
index 0e83745..4e00d8c 100644
--- a/src/Language/PureScript/Ide/Externs.hs
+++ b/src/Language/PureScript/Ide/Externs.hs
@@ -17,9 +17,9 @@
{-# LANGUAGE FlexibleContexts #-}
module Language.PureScript.Ide.Externs
- ( readExternFile,
- convertExterns,
- annotateLocations
+ ( readExternFile
+ , convertExterns
+ , annotateModule
) where
import Protolude
@@ -87,26 +87,31 @@ convertOperator :: P.ExternsFixity -> IdeDeclaration
convertOperator P.ExternsFixity{..} =
IdeValueOperator
efOperator
- (toS (P.showQualified (either P.runIdent P.runProperName) efAlias))
+ efAlias
efPrecedence
efAssociativity
+ Nothing
convertTypeOperator :: P.ExternsTypeFixity -> IdeDeclaration
convertTypeOperator P.ExternsTypeFixity{..} =
IdeTypeOperator
efTypeOperator
- (toS (P.showQualified P.runProperName efTypeAlias))
+ efTypeAlias
efTypePrecedence
efTypeAssociativity
+ Nothing
-annotateLocations :: Map (Either Text Text) P.SourceSpan -> Module -> Module
-annotateLocations ast (moduleName, decls) =
+annotateModule
+ :: (DefinitionSites P.SourceSpan, TypeAnnotations)
+ -> Module
+ -> Module
+annotateModule (defs, types) (moduleName, decls) =
(moduleName, map convertDeclaration decls)
where
convertDeclaration :: IdeDeclarationAnn -> IdeDeclarationAnn
convertDeclaration (IdeDeclarationAnn ann d) = case d of
IdeValue i t ->
- annotateValue (runIdentT i) (IdeValue i t)
+ annotateFunction i (IdeValue i t)
IdeType i k ->
annotateType (runProperNameT i) (IdeType i k)
IdeTypeSynonym i t ->
@@ -115,10 +120,13 @@ annotateLocations ast (moduleName, decls) =
annotateValue (runProperNameT i) (IdeDataConstructor i tn t)
IdeTypeClass i ->
annotateType (runProperNameT i) (IdeTypeClass i)
- IdeValueOperator n i p a ->
- annotateValue i (IdeValueOperator n i p a)
- IdeTypeOperator n i p a ->
- annotateType i (IdeTypeOperator n i p a)
+ IdeValueOperator n i p a t ->
+ annotateValue (valueOperatorAliasT i) (IdeValueOperator n i p a t)
+ IdeTypeOperator n i p a k ->
+ annotateType (typeOperatorAliasT i) (IdeTypeOperator n i p a k)
where
- annotateValue x = IdeDeclarationAnn (ann {annLocation = Map.lookup (Left x) ast})
- annotateType x = IdeDeclarationAnn (ann {annLocation = Map.lookup (Right x) ast})
+ annotateFunction x = IdeDeclarationAnn (ann { annLocation = Map.lookup (Left (runIdentT x)) defs
+ , annTypeAnnotation = Map.lookup x types
+ })
+ annotateValue x = IdeDeclarationAnn (ann {annLocation = Map.lookup (Left x) defs})
+ annotateType x = IdeDeclarationAnn (ann {annLocation = Map.lookup (Right x) defs})
diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs
index 8c64aa1..e9065e9 100644
--- a/src/Language/PureScript/Ide/Imports.hs
+++ b/src/Language/PureScript/Ide/Imports.hs
@@ -203,9 +203,9 @@ addExplicitImport' decl moduleName imports =
P.TypeRef tn (Just [n])
refFromDeclaration (IdeType n _) =
P.TypeRef n (Just [])
- refFromDeclaration (IdeValueOperator op _ _ _) =
+ refFromDeclaration (IdeValueOperator op _ _ _ _) =
P.ValueOpRef op
- refFromDeclaration (IdeTypeOperator op _ _ _) =
+ refFromDeclaration (IdeTypeOperator op _ _ _ _) =
P.TypeOpRef op
refFromDeclaration d =
P.ValueRef $ P.Ident $ T.unpack (identifierFromIdeDeclaration d)
diff --git a/src/Language/PureScript/Ide/Matcher.hs b/src/Language/PureScript/Ide/Matcher.hs
index a2fb0db..254ac55 100644
--- a/src/Language/PureScript/Ide/Matcher.hs
+++ b/src/Language/PureScript/Ide/Matcher.hs
@@ -38,7 +38,7 @@ type ScoredMatch a = (Match a, Double)
newtype Matcher a = Matcher (Endo [Match a]) deriving (Monoid)
-instance FromJSON (Matcher IdeDeclaration) where
+instance FromJSON (Matcher IdeDeclarationAnn) where
parseJSON = withObject "matcher" $ \o -> do
(matcher :: Maybe Text) <- o .:? "matcher"
case matcher of
@@ -60,17 +60,17 @@ instance FromJSON (Matcher IdeDeclaration) where
-- Examples:
-- flMa matches flexMatcher. Score: 14.28
-- sons matches sortCompletions. Score: 6.25
-flexMatcher :: Text -> Matcher IdeDeclaration
+flexMatcher :: Text -> Matcher IdeDeclarationAnn
flexMatcher p = mkMatcher (flexMatch p)
-distanceMatcher :: Text -> Int -> Matcher IdeDeclaration
+distanceMatcher :: Text -> Int -> Matcher IdeDeclarationAnn
distanceMatcher q maxDist = mkMatcher (distanceMatcher' q maxDist)
-distanceMatcher' :: Text -> Int -> [Match IdeDeclaration] -> [ScoredMatch IdeDeclaration]
+distanceMatcher' :: Text -> Int -> [Match IdeDeclarationAnn] -> [ScoredMatch IdeDeclarationAnn]
distanceMatcher' q maxDist = mapMaybe go
where
go m = let d = dist (T.unpack y)
- y = identifierFromIdeDeclaration (unwrapMatch m)
+ y = identifierFromIdeDeclaration (discardAnn (unwrapMatch m))
in if d <= maxDist
then Just (m, 1 / fromIntegral d)
else Nothing
@@ -85,12 +85,12 @@ runMatcher (Matcher m)= appEndo m
sortCompletions :: [ScoredMatch a] -> [ScoredMatch a]
sortCompletions = sortBy (flip compare `on` snd)
-flexMatch :: Text -> [Match IdeDeclaration] -> [ScoredMatch IdeDeclaration]
+flexMatch :: Text -> [Match IdeDeclarationAnn] -> [ScoredMatch IdeDeclarationAnn]
flexMatch = mapMaybe . flexRate
-flexRate :: Text -> Match IdeDeclaration -> Maybe (ScoredMatch IdeDeclaration)
+flexRate :: Text -> Match IdeDeclarationAnn -> Maybe (ScoredMatch IdeDeclarationAnn)
flexRate p c = do
- score <- flexScore p (identifierFromIdeDeclaration (unwrapMatch c))
+ score <- flexScore p (identifierFromIdeDeclaration (discardAnn (unwrapMatch c)))
return (c, score)
-- FlexMatching ala Sublime.
diff --git a/src/Language/PureScript/Ide/Pursuit.hs b/src/Language/PureScript/Ide/Pursuit.hs
index 962f573..ae40238 100644
--- a/src/Language/PureScript/Ide/Pursuit.hs
+++ b/src/Language/PureScript/Ide/Pursuit.hs
@@ -35,41 +35,37 @@ import qualified Pipes.Prelude as P
-- TODO: remove this when the issue is fixed at Pursuit
queryPursuit :: Text -> IO ByteString
queryPursuit q = do
- let qClean = T.dropWhileEnd (== '.') q
- req' <- parseRequest "http://pursuit.purescript.org/search"
- let req = req'
- { queryString= "q=" <> (fromString . T.unpack) qClean
- , requestHeaders=[(hAccept, "application/json")]
- }
- m <- newManager tlsManagerSettings
- withHTTP req m $ \resp ->
- P.fold (<>) "" identity (responseBody resp)
-
+ let qClean = T.dropWhileEnd (== '.') q
+ req' <- parseRequest "http://pursuit.purescript.org/search"
+ let req = req'
+ { queryString= "q=" <> (fromString . T.unpack) qClean
+ , requestHeaders=[(hAccept, "application/json")]
+ }
+ m <- newManager tlsManagerSettings
+ withHTTP req m $ \resp ->
+ P.fold (<>) "" identity (responseBody resp)
handler :: HttpException -> IO [a]
-handler StatusCodeException{} = pure []
handler _ = pure []
searchPursuitForDeclarations :: Text -> IO [PursuitResponse]
-searchPursuitForDeclarations query =
- (do r <- queryPursuit query
- let results' = decode (fromStrict r) :: Maybe Array
- case results' of
- Nothing -> pure []
- Just results -> pure (mapMaybe (isDeclarationResponse . fromJSON) (toList results))) `E.catch`
- handler
+searchPursuitForDeclarations query = E.handle handler $ do
+ r <- queryPursuit query
+ let results' = decode (fromStrict r) :: Maybe Array
+ case results' of
+ Nothing -> pure []
+ Just results -> pure (mapMaybe (isDeclarationResponse . fromJSON) (toList results))
where
isDeclarationResponse (Success a@DeclarationResponse{}) = Just a
isDeclarationResponse _ = Nothing
findPackagesForModuleIdent :: Text -> IO [PursuitResponse]
-findPackagesForModuleIdent query =
- (do r <- queryPursuit query
- let results' = decode (fromStrict r) :: Maybe Array
- case results' of
+findPackagesForModuleIdent query = E.handle handler $ do
+ r <- queryPursuit query
+ let results' = decode (fromStrict r) :: Maybe Array
+ case results' of
Nothing -> pure []
- Just results -> pure (mapMaybe (isModuleResponse . fromJSON) (toList results))) `E.catch`
- handler
+ Just results -> pure (mapMaybe (isModuleResponse . fromJSON) (toList results))
where
isModuleResponse (Success a@ModuleResponse{}) = Just a
isModuleResponse _ = Nothing
diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs
index f543dbb..f9b9d18 100644
--- a/src/Language/PureScript/Ide/Rebuild.hs
+++ b/src/Language/PureScript/Ide/Rebuild.hs
@@ -144,7 +144,8 @@ sortExterns m ex = do
. M.elems
. M.delete (P.getModuleName m) $ ex
case sorted' of
- Left _ -> throwError (GeneralError "There was a cycle in the dependencies")
+ Left err ->
+ throwError (RebuildError (toJSONErrors False P.Error err))
Right (sorted, graph) -> do
let deps = fromJust (List.lookup (P.getModuleName m) graph)
pure $ mapMaybe getExtern (deps `inOrderOf` map P.getModuleName sorted)
diff --git a/src/Language/PureScript/Ide/Reexports.hs b/src/Language/PureScript/Ide/Reexports.hs
index 807f3d7..dd56994 100644
--- a/src/Language/PureScript/Ide/Reexports.hs
+++ b/src/Language/PureScript/Ide/Reexports.hs
@@ -14,8 +14,6 @@
-----------------------------------------------------------------------------
{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PackageImports #-}
-{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE RecordWildCards #-}
module Language.PureScript.Ide.Reexports
@@ -93,9 +91,9 @@ resolveRef decls ref = case ref of
P.ValueRef i ->
findWrapped (\case IdeValue i' _ -> i' == i; _ -> False)
P.TypeOpRef name ->
- findWrapped (\case IdeTypeOperator n _ _ _ -> n == name; _ -> False)
+ findWrapped (\case IdeTypeOperator n _ _ _ _ -> n == name; _ -> False)
P.ValueOpRef name ->
- findWrapped (\case IdeValueOperator n _ _ _ -> n == name; _ -> False)
+ findWrapped (\case IdeValueOperator n _ _ _ _ -> n == name; _ -> False)
P.TypeClassRef name ->
findWrapped (\case IdeTypeClass n -> n == name; _ -> False)
_ ->
diff --git a/src/Language/PureScript/Ide/SourceFile.hs b/src/Language/PureScript/Ide/SourceFile.hs
index ccca612..80bd30e 100644
--- a/src/Language/PureScript/Ide/SourceFile.hs
+++ b/src/Language/PureScript/Ide/SourceFile.hs
@@ -17,11 +17,15 @@
module Language.PureScript.Ide.SourceFile
( parseModule
, getImportsForFile
+ , extractAstInformation
+ -- for tests
, extractSpans
+ , extractTypeAnnotations
) where
import Protolude
+import qualified Data.Map as Map
import qualified Language.PureScript as P
import Language.PureScript.Ide.Error
import Language.PureScript.Ide.Util
@@ -64,6 +68,25 @@ getImportsForFile fp = do
unwrapImportType (P.Hiding decls) = P.Hiding (map unwrapPositionedRef decls)
unwrapImportType P.Implicit = P.Implicit
+-- | Extracts AST information from a parsed module
+extractAstInformation
+ :: P.Module
+ -> (DefinitionSites P.SourceSpan, TypeAnnotations)
+extractAstInformation (P.Module ss _ _ decls _) =
+ let definitions = Map.fromList (concatMap (extractSpans ss) decls)
+ typeAnnotations = Map.fromList (extractTypeAnnotations decls)
+ in (definitions, typeAnnotations)
+
+-- | Extracts type annotations for functions from a given Module
+extractTypeAnnotations
+ :: [P.Declaration]
+ -> [(P.Ident, P.Type)]
+extractTypeAnnotations = mapMaybe extract
+ where
+ extract d = case unwrapPositioned d of
+ P.TypeDeclaration ident ty -> Just (ident, ty)
+ _ -> Nothing
+
-- | Given a surrounding Sourcespan and a Declaration from the PS AST, extracts
-- definition sites inside that Declaration.
extractSpans
@@ -81,7 +104,7 @@ extractSpans ss d = case d of
[(Left (runIdentT i), ss)]
P.TypeSynonymDeclaration name _ _ ->
[(Right (runProperNameT name), ss)]
- P.TypeClassDeclaration name _ _ members ->
+ P.TypeClassDeclaration name _ _ _ members ->
(Right (runProperNameT name), ss) : concatMap (extractSpans' ss) members
P.DataDeclaration _ name _ ctors ->
(Right (runProperNameT name), ss)
diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs
index 55b2255..d20f045 100644
--- a/src/Language/PureScript/Ide/State.hs
+++ b/src/Language/PureScript/Ide/State.hs
@@ -28,6 +28,8 @@ module Language.PureScript.Ide.State
, populateStage2
, populateStage3
, populateStage3STM
+ -- for tests
+ , resolveOperatorsForModule
) where
import Protolude
@@ -35,7 +37,8 @@ import qualified Prelude
import Control.Concurrent.STM
import "monad-logger" Control.Monad.Logger
-import qualified Data.Map.Lazy as M
+import qualified Data.Map.Lazy as Map
+import qualified Data.List as List
import Language.PureScript.Externs
import Language.PureScript.Ide.Externs
import Language.PureScript.Ide.Reexports
@@ -55,10 +58,10 @@ resetIdeState = do
-- | Gets the loaded Modulenames
getLoadedModulenames :: Ide m => m [P.ModuleName]
-getLoadedModulenames = M.keys <$> getExternFiles
+getLoadedModulenames = Map.keys <$> getExternFiles
-- | Gets all loaded ExternFiles
-getExternFiles :: Ide m => m (M.Map P.ModuleName ExternsFile)
+getExternFiles :: Ide m => m (Map P.ModuleName ExternsFile)
getExternFiles = s1Externs <$> getStage1
-- | Insert a Module into Stage1 of the State
@@ -72,7 +75,7 @@ insertModuleSTM :: TVar IdeState -> (FilePath, P.Module) -> STM ()
insertModuleSTM ref (fp, module') =
modifyTVar ref $ \x ->
x { ideStage1 = (ideStage1 x) {
- s1Modules = M.insert
+ s1Modules = Map.insert
(P.getModuleName module')
(module', fp)
(s1Modules (ideStage1 x))}}
@@ -126,17 +129,24 @@ getAllModules mmoduleName = do
declarations <- s3Declarations <$> getStage3
rebuild <- cachedRebuild
case mmoduleName of
- Nothing -> pure (M.toList declarations)
+ Nothing -> pure (Map.toList declarations)
Just moduleName ->
case rebuild of
Just (cachedModulename, ef)
| cachedModulename == moduleName -> do
(AstData asts) <- s2AstData <$> getStage2
- let ast = fromMaybe M.empty (M.lookup moduleName asts)
- pure . M.toList $
- M.insert moduleName
- (snd . annotateLocations ast . fst . convertExterns $ ef) declarations
- _ -> pure (M.toList declarations)
+ let
+ ast =
+ fromMaybe (Map.empty, Map.empty) (Map.lookup moduleName asts)
+ cachedModule =
+ snd . annotateModule ast . fst . convertExterns $ ef
+ tmp =
+ Map.insert moduleName cachedModule declarations
+ resolved =
+ Map.adjust (resolveOperatorsForModule tmp) moduleName tmp
+
+ pure (Map.toList resolved)
+ _ -> pure (Map.toList declarations)
-- | Adds an ExternsFile into psc-ide's State Stage1. This does not populate the
-- following Stages, which needs to be done after all the necessary Exterms have
@@ -151,7 +161,7 @@ insertExternsSTM :: TVar IdeState -> ExternsFile -> STM ()
insertExternsSTM ref ef =
modifyTVar ref $ \x ->
x { ideStage1 = (ideStage1 x) {
- s1Externs = M.insert (efModuleName ef) ef (s1Externs (ideStage1 x))}}
+ s1Externs = Map.insert (efModuleName ef) ef (s1Externs (ideStage1 x))}}
-- | Sets rebuild cache to the given ExternsFile
cacheRebuild :: Ide m => ExternsFile -> m ()
@@ -180,8 +190,8 @@ populateStage2 = do
populateStage2STM :: TVar IdeState -> STM ()
populateStage2STM ref = do
modules <- s1Modules <$> getStage1STM ref
- let spans = map (\((P.Module ss _ _ decls _), _) -> M.fromList (concatMap (extractSpans ss) decls)) modules
- setStage2STM ref (Stage2 (AstData spans))
+ let astData = map (extractAstInformation . fst) modules
+ setStage2STM ref (Stage2 (AstData astData))
-- | Resolves reexports and populates Stage3 with data to be used in queries.
populateStage3 :: (Ide m, MonadLogger m) => m ()
@@ -202,12 +212,70 @@ populateStage3STM :: TVar IdeState -> STM [ReexportResult Module]
populateStage3STM ref = do
externs <- s1Externs <$> getStage1STM ref
(AstData asts) <- s2AstData <$> getStage2STM ref
- let modules = M.map convertExterns externs
+ let modules = Map.map convertExterns externs
nModules :: Map P.ModuleName (Module, [(P.ModuleName, P.DeclarationRef)])
- nModules = M.mapWithKey
+ nModules = Map.mapWithKey
(\moduleName (m, refs) ->
- (fromMaybe m $ annotateLocations <$> M.lookup moduleName asts <*> pure m, refs)) modules
+ (fromMaybe m $ annotateModule <$> Map.lookup moduleName asts <*> pure m, refs)) modules
-- resolves reexports and discards load failures for now
- result = resolveReexports (M.map (snd . fst) nModules) <$> M.elems nModules
- setStage3STM ref (Stage3 (M.fromList (map reResolved result)) Nothing)
+ result = resolveReexports (map (snd . fst) nModules) <$> Map.elems nModules
+ resultP = resolveOperators (Map.fromList (reResolved <$> result))
+ setStage3STM ref (Stage3 resultP Nothing)
pure result
+
+resolveOperators
+ :: Map P.ModuleName [IdeDeclarationAnn]
+ -> Map P.ModuleName [IdeDeclarationAnn]
+resolveOperators modules =
+ map (resolveOperatorsForModule modules) modules
+
+-- | Looks up the types and kinds for operators and assigns them to their
+-- declarations
+resolveOperatorsForModule
+ :: Map P.ModuleName [IdeDeclarationAnn]
+ -> [IdeDeclarationAnn]
+ -> [IdeDeclarationAnn]
+resolveOperatorsForModule modules = map (mapIdeDeclaration resolveOperator)
+ where
+ resolveOperator (IdeValueOperator
+ opName
+ i@(P.Qualified (Just moduleName)
+ (Left ident)) precedence assoc _) =
+ let t = do
+ sourceModule <- Map.lookup moduleName modules
+ IdeValue _ tP <-
+ List.find (\case
+ IdeValue iP _ -> iP == ident
+ _ -> False) (discardAnn <$> sourceModule)
+ pure tP
+
+ in IdeValueOperator opName i precedence assoc t
+ resolveOperator (IdeValueOperator
+ opName
+ i@(P.Qualified (Just moduleName)
+ (Right ctor)) precedence assoc _) =
+ let t = do
+ sourceModule <- Map.lookup moduleName modules
+ IdeDataConstructor _ _ tP <-
+ List.find (\case
+ IdeDataConstructor cname _ _ -> ctor == cname
+ _ -> False) (discardAnn <$> sourceModule)
+ pure tP
+
+ in IdeValueOperator opName i precedence assoc t
+ resolveOperator (IdeTypeOperator
+ opName
+ i@(P.Qualified (Just moduleName) properName) precedence assoc _) =
+ let k = do
+ sourceModule <- Map.lookup moduleName modules
+ IdeType _ kP <-
+ List.find (\case
+ IdeType name _ -> name == properName
+ _ -> False) (discardAnn <$> sourceModule)
+ pure kP
+
+ in IdeTypeOperator opName i precedence assoc k
+ resolveOperator x = x
+
+mapIdeDeclaration :: (IdeDeclaration -> IdeDeclaration) -> IdeDeclarationAnn -> IdeDeclarationAnn
+mapIdeDeclaration f (IdeDeclarationAnn ann decl) = IdeDeclarationAnn ann (f decl)
diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs
index c8c3758..56b7550 100644
--- a/src/Language/PureScript/Ide/Types.hs
+++ b/src/Language/PureScript/Ide/Types.hs
@@ -21,12 +21,10 @@ import Protolude
import Control.Concurrent.STM
import Data.Aeson
-import Data.Map.Lazy as M
+import qualified Data.Map.Lazy as M
import qualified Language.PureScript.Errors.JSON as P
import qualified Language.PureScript as P
import Language.PureScript.Ide.Conversions
-import Text.Parsec as Parsec
-import Text.Parsec.Text
type ModuleIdent = Text
@@ -36,8 +34,8 @@ data IdeDeclaration
| IdeTypeSynonym (P.ProperName 'P.TypeName) P.Type
| IdeDataConstructor (P.ProperName 'P.ConstructorName) (P.ProperName 'P.TypeName) P.Type
| IdeTypeClass (P.ProperName 'P.ClassName)
- | IdeValueOperator (P.OpName 'P.ValueOpName) Text P.Precedence P.Associativity
- | IdeTypeOperator (P.OpName 'P.TypeOpName) Text P.Precedence P.Associativity
+ | IdeValueOperator (P.OpName 'P.ValueOpName) (P.Qualified (Either P.Ident (P.ProperName 'P.ConstructorName))) P.Precedence P.Associativity (Maybe P.Type)
+ | IdeTypeOperator (P.OpName 'P.TypeOpName) (P.Qualified (P.ProperName 'P.TypeName)) P.Precedence P.Associativity (Maybe P.Kind)
deriving (Show, Eq, Ord)
data IdeDeclarationAnn = IdeDeclarationAnn Annotation IdeDeclaration
@@ -47,15 +45,19 @@ data Annotation
= Annotation
{ annLocation :: Maybe P.SourceSpan
, annExportedFrom :: Maybe P.ModuleName
+ , annTypeAnnotation :: Maybe P.Type
} deriving (Show, Eq, Ord)
emptyAnn :: Annotation
-emptyAnn = Annotation Nothing Nothing
+emptyAnn = Annotation Nothing Nothing Nothing
type Module = (P.ModuleName, [IdeDeclarationAnn])
-newtype AstData a =
- AstData (Map P.ModuleName (Map (Either Text Text) a))
+type DefinitionSites a = Map (Either Text Text) a
+type TypeAnnotations = Map P.Ident P.Type
+newtype AstData a = AstData (Map P.ModuleName (DefinitionSites a, TypeAnnotations))
+ -- ^ SourceSpans for the definition sites of Values and Types aswell as type
+ -- annotations found in a module
deriving (Show, Eq, Ord, Functor, Foldable)
data Configuration =
@@ -108,21 +110,25 @@ data Stage3 = Stage3
newtype Match a = Match (P.ModuleName, a)
deriving (Show, Eq, Functor)
-newtype Completion =
- Completion (Text, Text, Text)
- deriving (Show,Eq)
-
-newtype Info =
- Info (Text, Text, Text, Maybe P.SourceSpan)
- deriving (Show,Eq)
-
-instance ToJSON Info where
- toJSON (Info (m, d, t, sourceSpan)) =
- object ["module" .= m, "identifier" .= d, "type" .= t, "definedAt" .= sourceSpan]
+-- | A completion as it gets sent to the editors
+data Completion = Completion
+ { complModule :: Text
+ , complIdentifier :: Text
+ , complType :: Text
+ , complExpandedType :: Text
+ , complLocation :: Maybe P.SourceSpan
+ , complDocumentation :: Maybe Text
+ } deriving (Show, Eq)
instance ToJSON Completion where
- toJSON (Completion (m, d, t)) =
- object ["module" .= m, "identifier" .= d, "type" .= t]
+ toJSON (Completion {..}) =
+ object [ "module" .= complModule
+ , "identifier" .= complIdentifier
+ , "type" .= complType
+ , "expandedType" .= complExpandedType
+ , "definedAt" .= complLocation
+ , "documentation" .= complDocumentation
+ ]
data ModuleImport =
ModuleImport
@@ -140,17 +146,17 @@ instance ToJSON ModuleImport where
toJSON (ModuleImport mn P.Implicit qualifier) =
object $ [ "module" .= mn
, "importType" .= ("implicit" :: Text)
- ] ++ fmap (\x -> "qualifier" .= x) (maybeToList qualifier)
- toJSON (ModuleImport mn (P.Explicit refs) _) =
- object [ "module" .= mn
- , "importType" .= ("explicit" :: Text)
- , "identifiers" .= (identifierFromDeclarationRef <$> refs)
- ]
- toJSON (ModuleImport mn (P.Hiding refs) _) =
- object [ "module" .= mn
- , "importType" .= ("hiding" :: Text)
- , "identifiers" .= (identifierFromDeclarationRef <$> refs)
- ]
+ ] ++ map (\x -> "qualifier" .= x) (maybeToList qualifier)
+ toJSON (ModuleImport mn (P.Explicit refs) qualifier) =
+ object $ [ "module" .= mn
+ , "importType" .= ("explicit" :: Text)
+ , "identifiers" .= (identifierFromDeclarationRef <$> refs)
+ ] ++ map (\x -> "qualifier" .= x) (maybeToList qualifier)
+ toJSON (ModuleImport mn (P.Hiding refs) qualifier) =
+ object $ [ "module" .= mn
+ , "importType" .= ("hiding" :: Text)
+ , "identifiers" .= (identifierFromDeclarationRef <$> refs)
+ ] ++ map (\x -> "qualifier" .= x) (maybeToList qualifier)
identifierFromDeclarationRef :: P.DeclarationRef -> Text
identifierFromDeclarationRef (P.TypeRef name _) = runProperNameT name
@@ -160,14 +166,13 @@ identifierFromDeclarationRef _ = ""
data Success =
CompletionResult [Completion]
- | InfoResult [Info]
| TextResult Text
| MultilineTextResult [Text]
| PursuitResult [PursuitResponse]
| ImportList [ModuleImport]
| ModuleList [ModuleIdent]
| RebuildSuccess [P.JSONError]
- deriving(Show, Eq)
+ deriving (Show, Eq)
encodeSuccess :: (ToJSON a) => a -> Value
encodeSuccess res =
@@ -175,7 +180,6 @@ encodeSuccess res =
instance ToJSON Success where
toJSON (CompletionResult cs) = encodeSuccess cs
- toJSON (InfoResult i) = encodeSuccess i
toJSON (TextResult t) = encodeSuccess t
toJSON (MultilineTextResult ts) = encodeSuccess ts
toJSON (PursuitResult resp) = encodeSuccess resp
@@ -203,9 +207,9 @@ data PursuitResponse =
-- | A Pursuit Response for a module. Consists of the modules name and the
-- package it belongs to
ModuleResponse ModuleIdent Text
- -- | A Pursuit Response for a declaration. Consist of the declarations type,
- -- module, name and package
- | DeclarationResponse Text ModuleIdent Text Text
+ -- | A Pursuit Response for a declaration. Consist of the declaration's
+ -- module, name, package, type summary text
+ | DeclarationResponse Text ModuleIdent Text (Maybe Text) Text
deriving (Show,Eq)
instance FromJSON PursuitResponse where
@@ -219,42 +223,21 @@ instance FromJSON PursuitResponse where
pure (ModuleResponse name package)
"declaration" -> do
moduleName <- info .: "module"
- Right (ident, declType) <- typeParse <$> o .: "text"
- pure (DeclarationResponse declType moduleName ident package)
+ ident <- info .: "title"
+ (text :: Text) <- o .: "text"
+ typ <- info .:? "typeText"
+ pure (DeclarationResponse moduleName ident package typ text)
_ -> mzero
parseJSON _ = mzero
-
-typeParse :: Text -> Either Text (Text, Text)
-typeParse t = case parse parseType "" t of
- Right (x,y) -> Right (x, y)
- Left err -> Left (show err)
- where
- parseType :: Parser (Text, Text)
- parseType = do
- name <- identifier
- _ <- string "::"
- spaces
- type' <- many1 anyChar
- pure (name, toS type')
-
- identifier :: Parser Text
- identifier = do
- spaces
- ident <-
- -- necessary for being able to parse the following ((++), concat)
- between (char '(') (char ')') (many1 (noneOf ", )")) Parsec.<|>
- many1 (noneOf ", )")
- spaces
- pure (toS ident)
-
instance ToJSON PursuitResponse where
toJSON (ModuleResponse name package) =
object ["module" .= name, "package" .= package]
- toJSON (DeclarationResponse module' ident type' package) =
+ toJSON (DeclarationResponse module' ident package type' text) =
object
[ "module" .= module'
, "ident" .= ident
, "type" .= type'
, "package" .= package
+ , "text" .= text
]
diff --git a/src/Language/PureScript/Ide/Util.hs b/src/Language/PureScript/Ide/Util.hs
index 548e1f4..b0bcc30 100644
--- a/src/Language/PureScript/Ide/Util.hs
+++ b/src/Language/PureScript/Ide/Util.hs
@@ -20,10 +20,12 @@ module Language.PureScript.Ide.Util
, unwrapPositioned
, unwrapPositionedRef
, completionFromMatch
- , infoFromMatch
, encodeT
, decodeT
, discardAnn
+ , withEmptyAnn
+ , valueOperatorAliasT
+ , typeOperatorAliasT
, module Language.PureScript.Ide.Conversions
) where
@@ -42,31 +44,41 @@ identifierFromIdeDeclaration d = case d of
IdeTypeSynonym name _ -> runProperNameT name
IdeDataConstructor name _ _ -> runProperNameT name
IdeTypeClass name -> runProperNameT name
- IdeValueOperator op _ _ _ -> runOpNameT op
- IdeTypeOperator op _ _ _ -> runOpNameT op
+ IdeValueOperator op _ _ _ _ -> runOpNameT op
+ IdeTypeOperator op _ _ _ _ -> runOpNameT op
discardAnn :: IdeDeclarationAnn -> IdeDeclaration
discardAnn (IdeDeclarationAnn _ d) = d
+withEmptyAnn :: IdeDeclaration -> IdeDeclarationAnn
+withEmptyAnn = IdeDeclarationAnn emptyAnn
+
unwrapMatch :: Match a -> a
unwrapMatch (Match (_, ed)) = ed
-completionFromMatch :: Match IdeDeclaration -> Completion
-completionFromMatch = Completion . completionFromMatch'
-
-completionFromMatch' :: Match IdeDeclaration -> (Text, Text, Text)
-completionFromMatch' (Match (m', d)) = case d of
- IdeValue name type' -> (m, runIdentT name, prettyTypeT type')
- IdeType name kind -> (m, runProperNameT name, toS (P.prettyPrintKind kind))
- IdeTypeSynonym name kind -> (m, runProperNameT name, prettyTypeT kind)
- IdeDataConstructor name _ type' -> (m, runProperNameT name, prettyTypeT type')
- IdeTypeClass name -> (m, runProperNameT name, "class")
- IdeValueOperator op ref precedence associativity ->
- (m, runOpNameT op, showFixity precedence associativity ref op)
- IdeTypeOperator op ref precedence associativity ->
- (m, runOpNameT op, showFixity precedence associativity ref op)
+completionFromMatch :: Match IdeDeclarationAnn -> Completion
+completionFromMatch (Match (m, IdeDeclarationAnn ann decl)) =
+ Completion {..}
where
- m = runModuleNameT m'
+ (complIdentifier, complExpandedType) = case decl of
+ IdeValue name type' -> (runIdentT name, prettyTypeT type')
+ IdeType name kind -> (runProperNameT name, toS (P.prettyPrintKind kind))
+ IdeTypeSynonym name kind -> (runProperNameT name, prettyTypeT kind)
+ IdeDataConstructor name _ type' -> (runProperNameT name, prettyTypeT type')
+ IdeTypeClass name -> (runProperNameT name, "class")
+ IdeValueOperator op ref precedence associativity typeP ->
+ (runOpNameT op, maybe (showFixity precedence associativity (valueOperatorAliasT ref) op) prettyTypeT typeP)
+ IdeTypeOperator op ref precedence associativity kind ->
+ (runOpNameT op, maybe (showFixity precedence associativity (typeOperatorAliasT ref) op) (toS . P.prettyPrintKind) kind)
+
+ complModule = runModuleNameT m
+
+ complType = maybe complExpandedType prettyTypeT (annTypeAnnotation ann)
+
+ complLocation = annLocation ann
+
+ complDocumentation = Nothing
+
showFixity p a r o =
let asso = case a of
P.Infix -> "infix"
@@ -74,12 +86,16 @@ completionFromMatch' (Match (m', d)) = case d of
P.Infixr -> "infixr"
in T.unwords [asso, show p, r, "as", runOpNameT o]
-infoFromMatch :: Match IdeDeclarationAnn -> Info
-infoFromMatch (Match (m, (IdeDeclarationAnn ann d))) =
- Info (a, b, c, annLocation ann)
- where
- (a, b, c) = completionFromMatch' (Match (m, d))
+valueOperatorAliasT
+ :: P.Qualified (Either P.Ident (P.ProperName 'P.ConstructorName)) -> Text
+valueOperatorAliasT i =
+ toS (P.showQualified (either P.runIdent P.runProperName) i)
+typeOperatorAliasT
+ :: P.Qualified (P.ProperName 'P.TypeName) -> Text
+typeOperatorAliasT i =
+ toS (P.showQualified P.runProperName i)
+
encodeT :: (ToJSON a) => a -> Text
encodeT = toS . decodeUtf8 . encode
@@ -87,9 +103,9 @@ decodeT :: (FromJSON a) => Text -> Maybe a
decodeT = decode . encodeUtf8 . toS
unwrapPositioned :: P.Declaration -> P.Declaration
-unwrapPositioned (P.PositionedDeclaration _ _ x) = x
+unwrapPositioned (P.PositionedDeclaration _ _ x) = unwrapPositioned x
unwrapPositioned x = x
unwrapPositionedRef :: P.DeclarationRef -> P.DeclarationRef
-unwrapPositionedRef (P.PositionedDeclarationRef _ _ x) = x
+unwrapPositionedRef (P.PositionedDeclarationRef _ _ x) = unwrapPositionedRef x
unwrapPositionedRef x = x
diff --git a/src/Language/PureScript/Interactive/Completion.hs b/src/Language/PureScript/Interactive/Completion.hs
index c332f05..f08f9fb 100644
--- a/src/Language/PureScript/Interactive/Completion.hs
+++ b/src/Language/PureScript/Interactive/Completion.hs
@@ -206,7 +206,7 @@ identNames = nubOnFst . concatMap getDeclNames . P.exportedDeclarations
getDeclNames d@(P.ValueDeclaration ident _ _ _) = [(ident, d)]
getDeclNames d@(P.TypeDeclaration ident _ ) = [(ident, d)]
getDeclNames d@(P.ExternDeclaration ident _) = [(ident, d)]
- getDeclNames d@(P.TypeClassDeclaration _ _ _ ds) = map (second (const d)) $ concatMap getDeclNames ds
+ getDeclNames d@(P.TypeClassDeclaration _ _ _ _ ds) = map (second (const d)) $ concatMap getDeclNames ds
getDeclNames (P.PositionedDeclaration _ _ d) = getDeclNames d
getDeclNames _ = []
@@ -214,7 +214,7 @@ dctorNames :: P.Module -> [(N.ProperName 'N.ConstructorName, P.Declaration)]
dctorNames = nubOnFst . concatMap go . P.exportedDeclarations
where
go :: P.Declaration -> [(N.ProperName 'N.ConstructorName, P.Declaration)]
- go decl@(P.DataDeclaration _ _ _ ctors) = map (\n -> (n, decl)) (map fst ctors)
+ go decl@(P.DataDeclaration _ _ _ ctors) = map ((\n -> (n, decl)) . fst) ctors
go (P.PositionedDeclaration _ _ d) = go d
go _ = []
diff --git a/src/Language/PureScript/Interactive/Printer.hs b/src/Language/PureScript/Interactive/Printer.hs
index 9f33522..14889e8 100644
--- a/src/Language/PureScript/Interactive/Printer.hs
+++ b/src/Language/PureScript/Interactive/Printer.hs
@@ -17,7 +17,7 @@ import qualified Text.PrettyPrint.Boxes as Box
-- Pretty print a module's signatures
--
printModuleSignatures :: P.ModuleName -> P.Environment -> String
-printModuleSignatures moduleName (P.Environment {..}) =
+printModuleSignatures moduleName P.Environment{..} =
-- get relevant components of a module from environment
let moduleNamesIdent = byModuleName names
moduleTypeClasses = byModuleName typeClasses
@@ -44,34 +44,34 @@ printModuleSignatures moduleName (P.Environment {..}) =
showNameType _ = P.internalError "The impossible happened in printModuleSignatures."
findTypeClass
- :: M.Map (P.Qualified (P.ProperName 'P.ClassName)) ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint])
+ :: M.Map (P.Qualified (P.ProperName 'P.ClassName)) P.TypeClassData
-> P.Qualified (P.ProperName 'P.ClassName)
- -> (P.Qualified (P.ProperName 'P.ClassName), Maybe ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint]))
+ -> (P.Qualified (P.ProperName 'P.ClassName), Maybe P.TypeClassData)
findTypeClass envTypeClasses name = (name, M.lookup name envTypeClasses)
showTypeClass
- :: (P.Qualified (P.ProperName 'P.ClassName), Maybe ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint]))
+ :: (P.Qualified (P.ProperName 'P.ClassName), Maybe P.TypeClassData)
-> Maybe Box.Box
showTypeClass (_, Nothing) = Nothing
- showTypeClass (P.Qualified _ name, Just (vars, body, constrs)) =
+ showTypeClass (P.Qualified _ name, Just P.TypeClassData{..}) =
let constraints =
- if null constrs
+ if null typeClassSuperclasses
then Box.text ""
else Box.text "("
- Box.<> Box.hcat Box.left (intersperse (Box.text ", ") $ map (\(P.Constraint (P.Qualified _ pn) lt _) -> Box.text (P.runProperName pn) Box.<+> Box.hcat Box.left (map P.typeAtomAsBox lt)) constrs)
+ Box.<> Box.hcat Box.left (intersperse (Box.text ", ") $ map (\(P.Constraint (P.Qualified _ pn) lt _) -> Box.text (P.runProperName pn) Box.<+> Box.hcat Box.left (map P.typeAtomAsBox lt)) typeClassSuperclasses)
Box.<> Box.text ") <= "
className =
Box.text (P.runProperName name)
- Box.<> Box.text (concatMap ((' ':) . fst) vars)
+ Box.<> Box.text (concatMap ((' ':) . fst) typeClassArguments)
classBody =
- Box.vcat Box.top (map (\(i, t) -> Box.text (P.showIdent i ++ " ::") Box.<+> P.typeAsBox t) body)
+ Box.vcat Box.top (map (\(i, t) -> Box.text (P.showIdent i ++ " ::") Box.<+> P.typeAsBox t) typeClassMembers)
in
Just $
(Box.text "class "
Box.<> constraints
Box.<> className
- Box.<+> if null body then Box.text "" else Box.text "where")
+ Box.<+> if null typeClassMembers then Box.text "" else Box.text "where")
Box.// Box.moveRight 2 classBody
@@ -82,7 +82,7 @@ printModuleSignatures moduleName (P.Environment {..}) =
findType envTypes name = (name, M.lookup name envTypes)
showType
- :: M.Map (P.Qualified (P.ProperName 'P.ClassName)) ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint])
+ :: M.Map (P.Qualified (P.ProperName 'P.ClassName)) P.TypeClassData
-> M.Map (P.Qualified (P.ProperName 'P.ConstructorName)) (P.DataDeclType, P.ProperName 'P.TypeName, P.Type, [P.Ident])
-> M.Map (P.Qualified (P.ProperName 'P.TypeName)) ([(String, Maybe P.Kind)], P.Type)
-> (P.Qualified (P.ProperName 'P.TypeName), Maybe (P.Kind, P.TypeKind))
diff --git a/src/Language/PureScript/Interactive/Types.hs b/src/Language/PureScript/Interactive/Types.hs
index deae8c6..f2449df 100644
--- a/src/Language/PureScript/Interactive/Types.hs
+++ b/src/Language/PureScript/Interactive/Types.hs
@@ -42,11 +42,11 @@ initialPSCiState = PSCiState [] [] []
type ImportedModule = (P.ModuleName, P.ImportDeclarationType, Maybe P.ModuleName)
psciImportedModuleNames :: PSCiState -> [P.ModuleName]
-psciImportedModuleNames (PSCiState{psciImportedModules = is}) =
+psciImportedModuleNames PSCiState{psciImportedModules = is} =
map (\(mn, _, _) -> mn) is
allImportsOf :: P.Module -> PSCiState -> [ImportedModule]
-allImportsOf m (PSCiState{psciImportedModules = is}) =
+allImportsOf m PSCiState{psciImportedModules = is} =
filter isImportOfThis is
where
name = P.getModuleName m
diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs
index 41def96..6bec467 100644
--- a/src/Language/PureScript/Linter/Imports.hs
+++ b/src/Language/PureScript/Linter/Imports.hs
@@ -245,10 +245,10 @@ lintImportDecl env mni qualifierName names declType allowImplicit =
-- If we've not already warned a type is unused, check its data constructors
unless' (runProperName tn `notElem` usedNames) $
case (c, dctors `intersect` allCtors) of
- (_, []) | c /= Just [] -> warn (UnusedDctorImport tn)
+ (_, []) | c /= Just [] -> warn (UnusedDctorImport mni tn qualifierName allRefs)
(Just ctors, dctors') ->
let ddiff = ctors \\ dctors'
- in unless' (null ddiff) $ warn $ UnusedDctorExplicitImport tn ddiff
+ in unless' (null ddiff) $ warn $ UnusedDctorExplicitImport mni tn ddiff qualifierName allRefs
_ -> return False
return (didWarn || or didWarn')
diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs
index b4f928a..5e68831 100644
--- a/src/Language/PureScript/Make.hs
+++ b/src/Language/PureScript/Make.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE OverloadedStrings #-}
module Language.PureScript.Make
(
@@ -36,6 +37,7 @@ import Control.Monad.Trans.Except
import Control.Monad.Writer.Class (MonadWriter(..))
import Data.Aeson (encode, decode)
+import qualified Data.Aeson as Aeson
import Data.ByteString.Builder (toLazyByteString, stringUtf8)
import Data.Either (partitionEithers)
import Data.Foldable (for_)
@@ -69,6 +71,7 @@ import qualified Language.PureScript.Bundle as Bundle
import qualified Language.PureScript.CodeGen.JS as J
import qualified Language.PureScript.Constants as C
import qualified Language.PureScript.CoreFn as CF
+import qualified Language.PureScript.CoreFn.ToJSON as CFJ
import qualified Language.PureScript.Parser as PSParser
import qualified Paths_purescript as Paths
@@ -369,6 +372,12 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
for_ (mn `M.lookup` foreigns) (readTextFile >=> writeTextFile foreignFile)
writeTextFile externsFile exts
lift $ when sourceMaps $ genSourceMap dir mapFile (length prefix) mappings
+ dumpCoreFn <- lift $ asks optionsDumpCoreFn
+ when dumpCoreFn $ do
+ let coreFnFile = outputDir </> filePath </> "corefn.json"
+ let jsonPayload = CFJ.moduleToJSON Paths.version m
+ let json = Aeson.object [ (fromString (runModuleName mn), jsonPayload) ]
+ lift $ writeTextFile coreFnFile (BU8.toString . B.toStrict . encode $ json)
genSourceMap :: String -> String -> Int -> [SMap] -> Make ()
genSourceMap dir mapFile extraLines mappings = do
diff --git a/src/Language/PureScript/Options.hs b/src/Language/PureScript/Options.hs
index 5fb0fdc..62040a8 100644
--- a/src/Language/PureScript/Options.hs
+++ b/src/Language/PureScript/Options.hs
@@ -31,9 +31,12 @@ data Options = Options {
-- |
-- Generate soure maps
, optionsSourceMaps :: Bool
+ -- |
+ -- Dump CoreFn
+ , optionsDumpCoreFn :: Bool
} deriving Show
-- |
-- Default make options
defaultOptions :: Options
-defaultOptions = Options False False Nothing False False False False
+defaultOptions = Options False False Nothing False False False False False
diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs
index 227981d..e192eee 100644
--- a/src/Language/PureScript/Parser/Declarations.hs
+++ b/src/Language/PureScript/Parser/Declarations.hs
@@ -17,6 +17,7 @@ module Language.PureScript.Parser.Declarations
import Prelude hiding (lex)
+import Data.Functor (($>))
import Data.Maybe (fromMaybe)
import Control.Applicative
@@ -183,10 +184,15 @@ parseTypeClassDeclaration = do
return implies
className <- indented *> properName
idents <- P.many (indented *> kindedIdent)
+ let parseNamedIdent = foldl (<|>) empty (zipWith (\(name, _) index -> lname' name $> index) idents [0..])
+ parseFunctionalDependency =
+ FunctionalDependency <$> P.many parseNamedIdent <* rarrow
+ <*> P.many parseNamedIdent
+ dependencies <- P.option [] (indented *> pipe *> commaSep1 parseFunctionalDependency)
members <- P.option [] $ do
indented *> reserved "where"
indented *> mark (P.many (same *> positioned parseTypeDeclaration))
- return $ TypeClassDeclaration className idents implies members
+ return $ TypeClassDeclaration className idents implies dependencies members
parseConstraint :: TokenParser Constraint
parseConstraint = Constraint <$> parseQualified properName
@@ -203,7 +209,7 @@ parseInstanceDeclaration = do
rfatArrow
return deps
className <- indented *> parseQualified properName
- ty <- P.many (indented *> noWildcards parseTypeAtom)
+ ty <- P.many (indented *> parseTypeAtom)
return $ TypeInstanceDeclaration name (fromMaybe [] deps) className ty
parseTypeInstanceDeclaration :: TokenParser Declaration
@@ -217,8 +223,9 @@ parseTypeInstanceDeclaration = do
parseDerivingInstanceDeclaration :: TokenParser Declaration
parseDerivingInstanceDeclaration = do
reserved "derive"
+ ty <- P.option DerivedInstance (reserved "newtype" $> NewtypeInstance)
instanceDecl <- parseInstanceDeclaration
- return $ instanceDecl DerivedInstance
+ return $ instanceDecl ty
positioned :: TokenParser Declaration -> TokenParser Declaration
positioned = withSourceSpan PositionedDeclaration
diff --git a/src/Language/PureScript/Parser/Lexer.hs b/src/Language/PureScript/Parser/Lexer.hs
index 4944861..2962fe1 100644
--- a/src/Language/PureScript/Parser/Lexer.hs
+++ b/src/Language/PureScript/Parser/Lexer.hs
@@ -40,6 +40,7 @@ module Language.PureScript.Parser.Lexer
, commaSep
, commaSep1
, lname
+ , lname'
, qualifier
, tyname
, uname
@@ -414,6 +415,12 @@ lname = token go P.<?> "identifier"
go (LName s) = Just s
go _ = Nothing
+lname' :: String -> TokenParser ()
+lname' s = token go P.<?> show s
+ where
+ go (LName s') | s == s' = Just ()
+ go _ = Nothing
+
qualifier :: TokenParser String
qualifier = token go P.<?> "qualifier"
where
diff --git a/src/Language/PureScript/Parser/Types.hs b/src/Language/PureScript/Parser/Types.hs
index da155f7..6bb1e14 100644
--- a/src/Language/PureScript/Parser/Types.hs
+++ b/src/Language/PureScript/Parser/Types.hs
@@ -54,8 +54,7 @@ parseForAll = mkForAll <$> ((reserved "forall" <|> reserved "∀") *> P.many1 (i
--
parseTypeAtom :: TokenParser Type
parseTypeAtom = indented *> P.choice
- [ P.try parseConstrainedType
- , P.try parseFunction
+ [ P.try parseFunction
, parseTypeLevelString
, parseObject
, parseTypeWildcard
@@ -81,9 +80,8 @@ parseConstrainedType = do
ty <- P.many parseTypeAtom
return (Constraint className ty Nothing)
-
parseAnyType :: TokenParser Type
-parseAnyType = P.buildExpressionParser operators (buildPostfixParser postfixTable parseTypeAtom) P.<?> "type"
+parseAnyType = P.buildExpressionParser operators (buildPostfixParser postfixTable (P.try parseConstrainedType <|> parseTypeAtom)) P.<?> "type"
where
operators = [ [ P.Infix (return TypeApp) P.AssocLeft ]
, [ P.Infix (P.try (parseQualified parseOperator) >>= \ident ->
diff --git a/src/Language/PureScript/Pretty/Common.hs b/src/Language/PureScript/Pretty/Common.hs
index ea526ca..2436a16 100644
--- a/src/Language/PureScript/Pretty/Common.hs
+++ b/src/Language/PureScript/Pretty/Common.hs
@@ -74,7 +74,7 @@ instance Emit StrPos where
-- |
-- Add a new mapping entry for given source position with initially zero generated position
--
- addMapping (SourceSpan { spanName = file, spanStart = startPos }) = StrPos (zeroPos, mempty, [mapping])
+ addMapping SourceSpan { spanName = file, spanStart = startPos } = StrPos (zeroPos, mempty, [mapping])
where
mapping = SMap file startPos zeroPos
zeroPos = SourcePos 0 0
diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs
index 593f3a1..8583450 100644
--- a/src/Language/PureScript/Pretty/Types.hs
+++ b/src/Language/PureScript/Pretty/Types.hs
@@ -45,11 +45,11 @@ typeLiterals = mkPattern match
match _ = Nothing
constraintsAsBox :: [Constraint] -> Box -> Box
-constraintsAsBox [(Constraint pn tys _)] ty = text "(" <> constraintAsBox pn tys <> text ") => " <> ty
-constraintsAsBox xs ty = vcat left (zipWith (\i (Constraint pn tys _) -> text (if i == 0 then "( " else ", ") <> constraintAsBox pn tys) [0 :: Int ..] xs) `before` (text ") => " <> ty)
+constraintsAsBox [con] ty = text "(" <> constraintAsBox con `before` (text ") => " <> ty)
+constraintsAsBox xs ty = vcat left (zipWith (\i con -> text (if i == 0 then "( " else ", ") <> constraintAsBox con) [0 :: Int ..] xs) `before` (text ") => " <> ty)
-constraintAsBox :: Qualified (ProperName a) -> [Type] -> Box
-constraintAsBox pn tys = hsep 1 left (text (runProperName (disqualify pn)) : map typeAtomAsBox tys)
+constraintAsBox :: Constraint -> Box
+constraintAsBox (Constraint pn tys _) = typeAsBox (foldl TypeApp (TypeConstructor (fmap coerceProperName pn)) tys)
-- |
-- Generate a pretty-printed string representing a Row
diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs
index 6a8ea61..bd36555 100644
--- a/src/Language/PureScript/Pretty/Values.hs
+++ b/src/Language/PureScript/Pretty/Values.hs
@@ -61,7 +61,7 @@ prettyPrintValue d (Let ds val) =
prettyPrintValue d (Do els) =
text "do " <> vcat left (map (prettyPrintDoNotationElement (d - 1)) els)
prettyPrintValue _ (TypeClassDictionary (Constraint name tys _) _ _) = foldl1 beforeWithSpace $ text ("#dict " ++ runProperName (disqualify name)) : map typeAtomAsBox tys
-prettyPrintValue _ (SuperClassDictionary name _) = text $ "#dict " ++ runProperName (disqualify name)
+prettyPrintValue _ (DeferredDictionary name _) = text $ "#dict " ++ runProperName (disqualify name)
prettyPrintValue _ (TypeClassDictionaryAccessor className ident) =
text "#dict-accessor " <> text (runProperName (disqualify className)) <> text "." <> text (showIdent ident) <> text ">"
prettyPrintValue d (TypedValue _ val _) = prettyPrintValue d val
@@ -75,7 +75,6 @@ prettyPrintValue d expr@Op{} = prettyPrintValueAtom d expr
prettyPrintValue d expr@BinaryNoParens{} = prettyPrintValueAtom d expr
prettyPrintValue d expr@Parens{} = prettyPrintValueAtom d expr
prettyPrintValue d expr@UnaryMinus{} = prettyPrintValueAtom d expr
-prettyPrintValue d expr@ObjectGetter{} = prettyPrintValueAtom d expr
-- | Pretty-print an atomic expression, adding parentheses if necessary.
prettyPrintValueAtom :: Int -> Expr -> Box
@@ -92,7 +91,6 @@ prettyPrintValueAtom d (TypedValue _ val _) = prettyPrintValueAtom d val
prettyPrintValueAtom d (PositionedValue _ _ val) = prettyPrintValueAtom d val
prettyPrintValueAtom d (Parens expr) = (text "(" <> prettyPrintValue d expr) `before` text ")"
prettyPrintValueAtom d (UnaryMinus expr) = text "(-" <> prettyPrintValue d expr <> text ")"
-prettyPrintValueAtom _ (ObjectGetter field) = text "_." <> text field
prettyPrintValueAtom d expr = (text "(" <> prettyPrintValue d expr) `before` text ")"
prettyPrintLiteralValue :: Int -> Literal Expr -> Box
diff --git a/src/Language/PureScript/Publish/ErrorsWarnings.hs b/src/Language/PureScript/Publish/ErrorsWarnings.hs
index be5ebe5..e1c8ed7 100644
--- a/src/Language/PureScript/Publish/ErrorsWarnings.hs
+++ b/src/Language/PureScript/Publish/ErrorsWarnings.hs
@@ -182,10 +182,10 @@ displayUserError e = case e of
, spacer
] ++ spdxExamples ++
[ spacer
- , para (concat
- [ "Note that distributing code without a license means that nobody "
- , "will (legally) be able to use it."
- ])
+ , para (
+ "Note that distributing code without a license means that nobody "
+ ++ "will (legally) be able to use it."
+ )
, spacer
, para (concat
[ "It is also recommended to add a LICENSE file to the repository, "
@@ -420,10 +420,10 @@ warnUnacceptableVersions pkgs =
warnDirtyWorkingTree :: Box
warnDirtyWorkingTree =
- para (concat
- [ "Your working tree is dirty. (Note: this would be an error if it "
- , "were not a dry run)"
- ])
+ para (
+ "Your working tree is dirty. (Note: this would be an error if it "
+ ++ "were not a dry run)"
+ )
printWarnings :: [PackageWarning] -> IO ()
printWarnings = printToStderr . renderWarnings
diff --git a/src/Language/PureScript/Renamer.hs b/src/Language/PureScript/Renamer.hs
index 6ec0b34..7dfc873 100644
--- a/src/Language/PureScript/Renamer.hs
+++ b/src/Language/PureScript/Renamer.hs
@@ -142,7 +142,7 @@ renameInDecl isTopLevel (Rec ds) = do
renameInValue :: Expr Ann -> Rename (Expr Ann)
renameInValue (Literal ann l) =
Literal ann <$> renameInLiteral renameInValue l
-renameInValue c@(Constructor{}) = return c
+renameInValue c@Constructor{} = return c
renameInValue (Accessor ann prop v) =
Accessor ann prop <$> renameInValue v
renameInValue (ObjectUpdate ann obj vs) =
@@ -154,7 +154,7 @@ renameInValue (App ann v1 v2) =
App ann <$> renameInValue v1 <*> renameInValue v2
renameInValue (Var ann (Qualified Nothing name)) =
Var ann . Qualified Nothing <$> lookupIdent name
-renameInValue v@(Var{}) = return v
+renameInValue v@Var{} = return v
renameInValue (Case ann vs alts) =
newScope $ Case ann <$> traverse renameInValue vs <*> traverse renameInCaseAlternative alts
renameInValue (Let ann ds v) =
@@ -180,7 +180,7 @@ renameInCaseAlternative (CaseAlternative bs v) = newScope $
-- Renames within binders.
--
renameInBinder :: Binder a -> Rename (Binder a)
-renameInBinder n@(NullBinder{}) = return n
+renameInBinder n@NullBinder{} = return n
renameInBinder (LiteralBinder ann b) =
LiteralBinder ann <$> renameInLiteral renameInBinder b
renameInBinder (VarBinder ann name) =
diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs
index 052934a..1ccd283 100644
--- a/src/Language/PureScript/Sugar/Names.hs
+++ b/src/Language/PureScript/Sugar/Names.hs
@@ -171,8 +171,8 @@ renameInModule imports (Module ss coms mn decls exps) =
(,) (pos, bound) <$> (DataDeclaration dtype name args <$> traverse (sndM (traverse (updateTypesEverywhere pos))) dctors)
updateDecl (pos, bound) (TypeSynonymDeclaration name ps ty) =
(,) (pos, bound) <$> (TypeSynonymDeclaration name ps <$> updateTypesEverywhere pos ty)
- updateDecl (pos, bound) (TypeClassDeclaration className args implies ds) =
- (,) (pos, bound) <$> (TypeClassDeclaration className args <$> updateConstraints pos implies <*> pure ds)
+ updateDecl (pos, bound) (TypeClassDeclaration className args implies deps ds) =
+ (,) (pos, bound) <$> (TypeClassDeclaration className args <$> updateConstraints pos implies <*> pure deps <*> pure ds)
updateDecl (pos, bound) (TypeInstanceDeclaration name cs cn ts ds) =
(,) (pos, bound) <$> (TypeInstanceDeclaration name <$> updateConstraints pos cs <*> updateClassName cn pos <*> traverse (updateTypesEverywhere pos) ts <*> pure ds)
updateDecl (pos, bound) (TypeDeclaration name ty) =
diff --git a/src/Language/PureScript/Sugar/Names/Exports.hs b/src/Language/PureScript/Sugar/Names/Exports.hs
index b210b00..51facc0 100644
--- a/src/Language/PureScript/Sugar/Names/Exports.hs
+++ b/src/Language/PureScript/Sugar/Names/Exports.hs
@@ -30,7 +30,7 @@ findExportable (Module _ _ mn ds _) =
rethrow (addHint (ErrorInModule mn)) $ foldM updateExports nullExports ds
where
updateExports :: Exports -> Declaration -> m Exports
- updateExports exps (TypeClassDeclaration tcn _ _ ds') = do
+ updateExports exps (TypeClassDeclaration tcn _ _ _ ds') = do
exps' <- exportTypeClass Internal exps tcn mn
foldM go exps' ds'
where
diff --git a/src/Language/PureScript/Sugar/ObjectWildcards.hs b/src/Language/PureScript/Sugar/ObjectWildcards.hs
index 23ac6b2..d6d3600 100644
--- a/src/Language/PureScript/Sugar/ObjectWildcards.hs
+++ b/src/Language/PureScript/Sugar/ObjectWildcards.hs
@@ -1,5 +1,6 @@
module Language.PureScript.Sugar.ObjectWildcards
( desugarObjectConstructors
+ , desugarDecl
) where
import Prelude.Compat
@@ -21,13 +22,12 @@ desugarObjectConstructors
=> Module
-> m Module
desugarObjectConstructors (Module ss coms mn ds exts) = Module ss coms mn <$> mapM desugarDecl ds <*> pure exts
- where
- desugarDecl :: Declaration -> m Declaration
- desugarDecl (PositionedDeclaration pos com d) = rethrowWithPosition pos $ PositionedDeclaration pos com <$> desugarDecl d
- desugarDecl other = f other
- where
- (f, _, _) = everywhereOnValuesTopDownM return desugarExpr return
+desugarDecl :: forall m. (MonadSupply m, MonadError MultipleErrors m) => Declaration -> m Declaration
+desugarDecl (PositionedDeclaration pos com d) = rethrowWithPosition pos $ PositionedDeclaration pos com <$> desugarDecl d
+desugarDecl other = fn other
+ where
+ (fn, _, _) = everywhereOnValuesTopDownM return desugarExpr return
desugarExpr :: Expr -> m Expr
desugarExpr AnonymousArgument = throwError . errorMessage $ IncorrectAnonymousArgument
@@ -45,12 +45,13 @@ desugarObjectConstructors (Module ss coms mn ds exts) = Module ss coms mn <$> ma
obj <- freshIdent'
Abs (Left obj) <$> wrapLambda (ObjectUpdate (argToExpr obj)) ps
desugarExpr (ObjectUpdate obj ps) = wrapLambda (ObjectUpdate obj) ps
- desugarExpr (Accessor prop u) | isAnonymousArgument u = do
- arg <- freshIdent'
- return $ Abs (Left arg) (Accessor prop (argToExpr arg))
+ desugarExpr (Accessor prop u)
+ | Just props <- peelAnonAccessorChain u = do
+ arg <- freshIdent'
+ return $ Abs (Left arg) $ foldr Accessor (argToExpr arg) (prop:props)
desugarExpr (Case args cas) | any isAnonymousArgument args = do
argIdents <- forM args freshIfAnon
- let args' = zipWith (\p -> maybe p argToExpr) args argIdents
+ let args' = zipWith (`maybe` argToExpr) args argIdents
return $ foldr (Abs . Left) (Case args' cas) (catMaybes argIdents)
desugarExpr (IfThenElse u t f) | any isAnonymousArgument [u, t, f] = do
u' <- freshIfAnon u
@@ -73,6 +74,12 @@ desugarObjectConstructors (Module ss coms mn ds exts) = Module ss coms mn <$> ma
stripPositionInfo (PositionedValue _ _ e) = stripPositionInfo e
stripPositionInfo e = e
+ peelAnonAccessorChain :: Expr -> Maybe [String]
+ peelAnonAccessorChain (Accessor p e) = (p :) <$> peelAnonAccessorChain e
+ peelAnonAccessorChain (PositionedValue _ _ e) = peelAnonAccessorChain e
+ peelAnonAccessorChain AnonymousArgument = Just []
+ peelAnonAccessorChain _ = Nothing
+
isAnonymousArgument :: Expr -> Bool
isAnonymousArgument AnonymousArgument = True
isAnonymousArgument (PositionedValue _ _ e) = isAnonymousArgument e
diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs
index 10d09d2..82af60f 100644
--- a/src/Language/PureScript/Sugar/Operators.hs
+++ b/src/Language/PureScript/Sugar/Operators.hs
@@ -312,9 +312,9 @@ updateTypes goType = (goDecl, goExpr, goBinder)
goDecl pos (ExternDeclaration name ty) = do
ty' <- goType' pos ty
return (pos, ExternDeclaration name ty')
- goDecl pos (TypeClassDeclaration name args implies decls) = do
+ goDecl pos (TypeClassDeclaration name args implies deps decls) = do
implies' <- traverse (overConstraintArgs (traverse (goType' pos))) implies
- return (pos, TypeClassDeclaration name args implies' decls)
+ return (pos, TypeClassDeclaration name args implies' deps decls)
goDecl pos (TypeInstanceDeclaration name cs className tys impls) = do
cs' <- traverse (overConstraintArgs (traverse (goType' pos))) cs
tys' <- traverse (goType' pos) tys
@@ -332,9 +332,9 @@ updateTypes goType = (goDecl, goExpr, goBinder)
goExpr pos (TypeClassDictionary (Constraint name tys info) dicts hints) = do
tys' <- traverse (goType' pos) tys
return (pos, TypeClassDictionary (Constraint name tys' info) dicts hints)
- goExpr pos (SuperClassDictionary cls tys) = do
+ goExpr pos (DeferredDictionary cls tys) = do
tys' <- traverse (goType' pos) tys
- return (pos, SuperClassDictionary cls tys')
+ return (pos, DeferredDictionary cls tys')
goExpr pos (TypedValue check v ty) = do
ty' <- goType' pos ty
return (pos, TypedValue check v ty')
diff --git a/src/Language/PureScript/Sugar/Operators/Common.hs b/src/Language/PureScript/Sugar/Operators/Common.hs
index 26ac5ae..dd0e43d 100644
--- a/src/Language/PureScript/Sugar/Operators/Common.hs
+++ b/src/Language/PureScript/Sugar/Operators/Common.hs
@@ -28,12 +28,12 @@ parseValue :: P.Parsec (Chain a) () a
parseValue = token (either Just (const Nothing)) P.<?> "expression"
parseOp
- :: (a -> (Maybe (Qualified (OpName nameType))))
+ :: (a -> Maybe (Qualified (OpName nameType)))
-> P.Parsec (Chain a) () (Qualified (OpName nameType))
parseOp fromOp = token (either (const Nothing) fromOp) P.<?> "operator"
matchOp
- :: (a -> (Maybe (Qualified (OpName nameType))))
+ :: (a -> Maybe (Qualified (OpName nameType)))
-> Qualified (OpName nameType)
-> P.Parsec (Chain a) () ()
matchOp fromOp op = do
diff --git a/src/Language/PureScript/Sugar/Operators/Expr.hs b/src/Language/PureScript/Sugar/Operators/Expr.hs
index f938406..0c9c2b3 100644
--- a/src/Language/PureScript/Sugar/Operators/Expr.hs
+++ b/src/Language/PureScript/Sugar/Operators/Expr.hs
@@ -28,7 +28,7 @@ matchExprOperators = matchOperators isBinOp extractOp fromOp reapply modOpTable
fromOp _ = Nothing
reapply :: Qualified (OpName 'ValueOpName) -> Expr -> Expr -> Expr
- reapply op t1 t2 = App (App (Op op) t1) t2
+ reapply op t1 = App (App (Op op) t1)
modOpTable
:: [[P.Operator (Chain Expr) () Identity Expr]]
diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs
index 7262224..4d91324 100644
--- a/src/Language/PureScript/Sugar/TypeClasses.hs
+++ b/src/Language/PureScript/Sugar/TypeClasses.hs
@@ -30,7 +30,7 @@ import Data.Maybe (catMaybes, mapMaybe, isJust)
import qualified Data.Map as M
-type MemberMap = M.Map (ModuleName, ProperName 'ClassName) ([(String, Maybe Kind)], [Constraint], [Declaration])
+type MemberMap = M.Map (ModuleName, ProperName 'ClassName) TypeClassData
type Desugar = StateT MemberMap
@@ -46,14 +46,20 @@ desugarTypeClasses
desugarTypeClasses externs = flip evalStateT initialState . traverse desugarModule
where
initialState :: MemberMap
- initialState = M.singleton (ModuleName [ProperName C.prim], ProperName C.partial) ([], [], [])
- `M.union` M.fromList (externs >>= \ExternsFile{..} -> mapMaybe (fromExternsDecl efModuleName) efDeclarations)
+ initialState =
+ M.mapKeys (qualify (ModuleName [ProperName C.prim])) primClasses
+ `M.union` M.fromList (externs >>= \ExternsFile{..} -> mapMaybe (fromExternsDecl efModuleName) efDeclarations)
fromExternsDecl
:: ModuleName
-> ExternsDeclaration
- -> Maybe ((ModuleName, ProperName 'ClassName), ([(String, Maybe Kind)], [Constraint], [Declaration]))
- fromExternsDecl mn (EDClass name args members implies) = Just ((mn, name), (args, implies, map (uncurry TypeDeclaration) members))
+ -> Maybe ((ModuleName, ProperName 'ClassName), TypeClassData)
+ fromExternsDecl mn (EDClass name args members implies deps) = Just ((mn, name), typeClass) where
+ typeClass = TypeClassData { typeClassArguments = args
+ , typeClassMembers = members
+ , typeClassSuperclasses = implies
+ , typeClassDependencies = deps
+ }
fromExternsDecl _ _ = Nothing
desugarModule
@@ -129,7 +135,7 @@ desugarModule _ = internalError "Exports should have been elaborated in name des
--
-- subString :: {} -> Sub String
-- subString _ = { sub: "",
--- , "__superclass_Foo_0": \_ -> <SuperClassDictionary Foo String>
+-- , "__superclass_Foo_0": \_ -> <DeferredDictionary Foo String>
-- }
--
-- and finally as the generated javascript:
@@ -173,14 +179,18 @@ desugarDecl
-> Desugar m (Maybe DeclarationRef, [Declaration])
desugarDecl mn exps = go
where
- go d@(TypeClassDeclaration name args implies members) = do
- modify (M.insert (mn, name) (args, implies, members))
+ go d@(TypeClassDeclaration name args implies deps members) = do
+ modify (M.insert (mn, name) (TypeClassData args (map memberToNameAndType members) implies deps))
return (Nothing, d : typeClassDictionaryDeclaration name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members)
go (TypeInstanceDeclaration _ _ _ _ DerivedInstance) = internalError "Derived instanced should have been desugared"
go d@(TypeInstanceDeclaration name deps className tys (ExplicitInstance members)) = do
desugared <- desugarCases members
dictDecl <- typeInstanceDictionaryDeclaration name mn deps className tys desugared
return (expRef name className tys, [d, dictDecl])
+ go d@(TypeInstanceDeclaration name deps className tys (NewtypeInstanceWithDictionary dict)) = do
+ let dictTy = foldl TypeApp (TypeConstructor (fmap coerceProperName className)) tys
+ constrainedTy = quantify (if null deps then dictTy else ConstrainedType deps dictTy)
+ return (expRef name className tys, [d, ValueDeclaration name Private [] (Right (TypedValue True dict constrainedTy))])
go (PositionedDeclaration pos com d) = do
(dr, ds) <- rethrowWithPosition pos $ desugarDecl mn exps d
return (dr, map (PositionedDeclaration pos com) ds)
@@ -267,18 +277,15 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =
m <- get
-- Lookup the type arguments and member types for the type class
- (args, implies, tyDecls) <-
+ TypeClassData{..} <-
maybe (throwError . errorMessage . UnknownName $ fmap TyClassName className) return $
M.lookup (qualify mn className) m
- case mapMaybe declName tyDecls \\ mapMaybe declName decls of
+ case map fst typeClassMembers \\ mapMaybe declName decls of
member : _ -> throwError . errorMessage $ MissingClassMember member
[] -> do
-
- let instanceTys = map memberToNameAndType tyDecls
-
-- Replace the type arguments with the appropriate types in the member types
- let memberTypes = map (second (replaceAllTypeVars (zip (map fst args) tys))) instanceTys
+ let memberTypes = map (second (replaceAllTypeVars (zip (map fst typeClassArguments) tys))) typeClassMembers
-- Create values for the type instance members
members <- zip (map typeClassMemberName decls) <$> traverse (memberToValue memberTypes) decls
@@ -286,10 +293,10 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =
-- Create the type of the dictionary
-- The type is a record type, but depending on type instance dependencies, may be constrained.
-- The dictionary itself is a record literal.
- let superclasses = superClassDictionaryNames implies `zip`
- [ Abs (Left (Ident C.__unused)) (SuperClassDictionary superclass tyArgs)
- | (Constraint superclass suTyArgs _) <- implies
- , let tyArgs = map (replaceAllTypeVars (zip (map fst args) tys)) suTyArgs
+ let superclasses = superClassDictionaryNames typeClassSuperclasses `zip`
+ [ Abs (Left (Ident C.__unused)) (DeferredDictionary superclass tyArgs)
+ | (Constraint superclass suTyArgs _) <- typeClassSuperclasses
+ , let tyArgs = map (replaceAllTypeVars (zip (map fst typeClassArguments) tys)) suTyArgs
]
let props = Literal $ ObjectLiteral (members ++ superclasses)
diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs
index eef4a85..2dcceef 100755
--- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs
+++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs
@@ -22,6 +22,7 @@ import Language.PureScript.Environment
import Language.PureScript.Errors
import Language.PureScript.Names
import Language.PureScript.Types
+import Language.PureScript.TypeChecker (checkNewtype)
import qualified Language.PureScript.Constants as C
-- | Elaborates deriving instance declarations by code generation.
@@ -44,16 +45,29 @@ deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@[ty] Derived
, Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor ty
, mn == fromMaybe mn mn'
= TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveGeneric mn ds tyCon args
- | className == Qualified (Just (ModuleName [ ProperName "Data", ProperName "Eq" ])) (ProperName "Eq")
+ | className == Qualified (Just dataEq) (ProperName "Eq")
, Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty
, mn == fromMaybe mn mn'
= TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveEq mn ds tyCon
- | className == Qualified (Just (ModuleName [ ProperName "Data", ProperName "Ord" ])) (ProperName "Ord")
+ | className == Qualified (Just dataOrd) (ProperName "Ord")
, Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty
, mn == fromMaybe mn mn'
= TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveOrd mn ds tyCon
+deriveInstance mn ds (TypeInstanceDeclaration nm deps className [wrappedTy, unwrappedTy] DerivedInstance)
+ | className == Qualified (Just dataNewtype) (ProperName "Newtype")
+ , Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor wrappedTy
+ , mn == fromMaybe mn mn'
+ = do
+ (inst, actualUnwrappedTy) <- deriveNewtype mn ds tyCon unwrappedTy
+ return $ TypeInstanceDeclaration nm deps className [wrappedTy, actualUnwrappedTy] (ExplicitInstance inst)
deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance)
= throwError . errorMessage $ CannotDerive className tys
+deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@(_ : _) NewtypeInstance)
+ | Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor (last tys)
+ , mn == fromMaybe mn mn'
+ = TypeInstanceDeclaration nm deps className tys . NewtypeInstanceWithDictionary <$> deriveNewtypeInstance className ds tys tyCon args
+deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys NewtypeInstance)
+ = throwError . errorMessage $ InvalidNewtypeInstance className tys
deriveInstance mn ds (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> deriveInstance mn ds d
deriveInstance _ _ e = return e
@@ -66,6 +80,25 @@ unwrapTypeConstructor = fmap (second reverse) . go
return (tyCon, arg : args)
go _ = Nothing
+deriveNewtypeInstance
+ :: forall m
+ . MonadError MultipleErrors m
+ => Qualified (ProperName 'ClassName)
+ -> [Declaration]
+ -> [Type]
+ -> ProperName 'TypeName
+ -> [Type]
+ -> m Expr
+deriveNewtypeInstance className ds tys tyConNm dargs = do
+ tyCon <- findTypeDecl tyConNm ds
+ go tyCon
+ where
+ go (DataDeclaration Newtype _ tyArgNames [(_, [wrapped])]) = do
+ let subst = zipWith (\(name, _) t -> (name, t)) tyArgNames dargs
+ return (DeferredDictionary className (init tys ++ [replaceAllTypeVars subst wrapped]))
+ go (PositionedDeclaration _ _ d) = go d
+ go _ = throwError . errorMessage $ InvalidNewtypeInstance className tys
+
dataGeneric :: ModuleName
dataGeneric = ModuleName [ ProperName "Data", ProperName "Generic" ]
@@ -75,6 +108,15 @@ dataMaybe = ModuleName [ ProperName "Data", ProperName "Maybe" ]
typesProxy :: ModuleName
typesProxy = ModuleName [ ProperName "Type", ProperName "Proxy" ]
+dataEq :: ModuleName
+dataEq = ModuleName [ ProperName "Data", ProperName "Eq" ]
+
+dataOrd :: ModuleName
+dataOrd = ModuleName [ ProperName "Data", ProperName "Ord" ]
+
+dataNewtype :: ModuleName
+dataNewtype = ModuleName [ ProperName "Data", ProperName "Newtype" ]
+
deriveGeneric
:: forall m. (MonadError MultipleErrors m, MonadSupply m)
=> ModuleName
@@ -223,7 +265,7 @@ deriveGeneric mn ds tyConNm dargs = do
$ liftApplicative (mkRecFun rs) (map (\(x, y) -> fromSpineFun (Accessor "recValue" (mkVar (Ident x))) y) rs)
mkRecFun :: [(String, Type)] -> Expr
- mkRecFun xs = mkJust $ foldr lam recLiteral (map (Ident . fst) xs)
+ mkRecFun xs = mkJust $ foldr (lam . Ident . fst) recLiteral xs
where recLiteral = Literal . ObjectLiteral $ map (\(s,_) -> (s, mkVar (Ident s))) xs
mkFromSpineFunction (PositionedDeclaration _ _ d) = mkFromSpineFunction d
mkFromSpineFunction _ = internalError "mkFromSpineFunction: expected DataDeclaration"
@@ -265,7 +307,7 @@ deriveEq mn ds tyConNm = do
preludeConj = App . App (Var (Qualified (Just (ModuleName [ProperName "Data", ProperName "HeytingAlgebra"])) (Ident C.conj)))
preludeEq :: Expr -> Expr -> Expr
- preludeEq = App . App (Var (Qualified (Just (ModuleName [ProperName "Data", ProperName "Eq"])) (Ident C.eq)))
+ preludeEq = App . App (Var (Qualified (Just dataEq) (Ident C.eq)))
addCatch :: [CaseAlternative] -> [CaseAlternative]
addCatch xs
@@ -335,7 +377,7 @@ deriveOrd mn ds tyConNm = do
orderingBinder name = ConstructorBinder (orderingName name) []
ordCompare :: Expr -> Expr -> Expr
- ordCompare = App . App (Var (Qualified (Just (ModuleName [ProperName "Data", ProperName "Ord"])) (Ident C.compare)))
+ ordCompare = App . App (Var (Qualified (Just dataOrd) (Ident C.compare)))
mkCtorClauses :: ((ProperName 'ConstructorName, [Type]), Bool) -> m [CaseAlternative]
mkCtorClauses ((ctorName, tys), isLast) = do
@@ -379,6 +421,47 @@ deriveOrd mn ds tyConNm = do
$ decomposeRec rec
toOrdering l r _ = ordCompare l r
+deriveNewtype
+ :: forall m
+ . (MonadError MultipleErrors m, MonadSupply m)
+ => ModuleName
+ -> [Declaration]
+ -> ProperName 'TypeName
+ -> Type
+ -> m ([Declaration], Type)
+deriveNewtype mn ds tyConNm unwrappedTy = do
+ checkIsWildcard unwrappedTy
+ go =<< findTypeDecl tyConNm ds
+ where
+
+ go :: Declaration -> m ([Declaration], Type)
+ go (DataDeclaration Data name _ _) =
+ throwError . errorMessage $ CannotDeriveNewtypeForData name
+ go (DataDeclaration Newtype name _ dctors) = do
+ checkNewtype name dctors
+ let (ctorName, [ty]) = head dctors
+ wrappedIdent <- freshIdent "n"
+ unwrappedIdent <- freshIdent "a"
+ let inst =
+ [ ValueDeclaration (Ident "wrap") Public [] $ Right $
+ Constructor (Qualified (Just mn) ctorName)
+ , ValueDeclaration (Ident "unwrap") Public [] $ Right $
+ lamCase wrappedIdent
+ [ CaseAlternative
+ [ConstructorBinder (Qualified (Just mn) ctorName) [VarBinder unwrappedIdent]]
+ (Right (Var (Qualified Nothing unwrappedIdent)))
+ ]
+ ]
+ return (inst, ty)
+ go (PositionedDeclaration _ _ d) = go d
+ go _ = internalError "deriveNewtype go: expected DataDeclaration"
+
+ checkIsWildcard :: Type -> m ()
+ checkIsWildcard (TypeWildcard _) =
+ return ()
+ checkIsWildcard _ =
+ throwError . errorMessage $ NonWildcardNewtypeInstance tyConNm
+
findTypeDecl
:: (MonadError MultipleErrors m)
=> ProperName 'TypeName
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
index bfadcdd..62e4559 100644
--- a/src/Language/PureScript/TypeChecker.hs
+++ b/src/Language/PureScript/TypeChecker.hs
@@ -6,6 +6,7 @@
module Language.PureScript.TypeChecker
( module T
, typeCheckModule
+ , checkNewtype
) where
import Prelude.Compat
@@ -112,15 +113,23 @@ addTypeClass
-> ProperName 'ClassName
-> [(String, Maybe Kind)]
-> [Constraint]
+ -> [FunctionalDependency]
-> [Declaration]
-> m ()
-addTypeClass moduleName pn args implies ds =
- let members = map toPair ds in
- modify $ \st -> st { checkEnv = (checkEnv st) { typeClasses = M.insert (Qualified (Just moduleName) pn) (args, members, implies) (typeClasses . checkEnv $ st) } }
+addTypeClass moduleName pn args implies dependencies ds =
+ modify $ \st -> st { checkEnv = (checkEnv st) { typeClasses = M.insert (Qualified (Just moduleName) pn) newClass (typeClasses . checkEnv $ st) } }
where
- toPair (TypeDeclaration ident ty) = (ident, ty)
- toPair (PositionedDeclaration _ _ d) = toPair d
- toPair _ = internalError "Invalid declaration in TypeClassDeclaration"
+ newClass :: TypeClassData
+ newClass =
+ TypeClassData { typeClassArguments = args
+ , typeClassMembers = map toPair ds
+ , typeClassSuperclasses = implies
+ , typeClassDependencies = dependencies
+ }
+
+ toPair (TypeDeclaration ident ty) = (ident, ty)
+ toPair (PositionedDeclaration _ _ d) = toPair d
+ toPair _ = internalError "Invalid declaration in TypeClassDeclaration"
addTypeClassDictionaries
:: (MonadState CheckState m)
@@ -265,8 +274,8 @@ typeCheckAll moduleName _ = traverse go
return d
go d@FixityDeclaration{} = return d
go d@ImportDeclaration{} = return d
- go d@(TypeClassDeclaration pn args implies tys) = do
- addTypeClass moduleName pn args implies tys
+ go d@(TypeClassDeclaration pn args implies deps tys) = do
+ addTypeClass moduleName pn args implies deps tys
return d
go (d@(TypeInstanceDeclaration dictName deps className tys body)) = rethrow (addHint (ErrorInInstance className tys)) $ do
traverse_ (checkTypeClassInstance moduleName) tys
@@ -310,10 +319,6 @@ typeCheckAll moduleName _ = traverse go
checkType _ = internalError "Invalid type in instance in checkOrphanInstance"
checkOrphanInstance _ _ _ = internalError "Unqualified class name in checkOrphanInstance"
- checkNewtype :: ProperName 'TypeName -> [(ProperName 'ConstructorName, [Type])] -> m ()
- checkNewtype _ [(_, [_])] = return ()
- checkNewtype name _ = throwError . errorMessage $ InvalidNewtype name
-
-- |
-- 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.
@@ -324,6 +329,15 @@ typeCheckAll moduleName _ = traverse go
withKinds ( (s, Nothing):ss) (FunKind k1 k2) = (s, Just k1) : withKinds ss k2
withKinds _ _ = internalError "Invalid arguments to peelKinds"
+checkNewtype
+ :: forall m
+ . MonadError MultipleErrors m
+ => ProperName 'TypeName
+ -> [(ProperName 'ConstructorName, [Type])]
+ -> m ()
+checkNewtype _ [(_, [_])] = return ()
+checkNewtype name _ = throwError . errorMessage $ InvalidNewtype name
+
-- |
-- Type check an entire module and ensure all types and classes defined within the module that are
-- required by exported members are also exported.
@@ -414,7 +428,7 @@ typeCheckModule (Module ss coms mn decls (Just exps)) =
unless (null missingMembers) $ throwError . errorMessage $ TransitiveExportError dr members
where
findClassMembers :: Declaration -> Maybe [Ident]
- findClassMembers (TypeClassDeclaration name' _ _ ds) | name == name' = Just $ map extractMemberName ds
+ findClassMembers (TypeClassDeclaration name' _ _ _ ds) | name == name' = Just $ map extractMemberName ds
findClassMembers (PositionedDeclaration _ _ d) = findClassMembers d
findClassMembers _ = Nothing
extractMemberName :: Declaration -> Ident
diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs
index c15d628..7b03c70 100644
--- a/src/Language/PureScript/TypeChecker/Entailment.hs
+++ b/src/Language/PureScript/TypeChecker/Entailment.hs
@@ -1,28 +1,35 @@
+{-# LANGUAGE NamedFieldPuns #-}
+
-- |
-- Type class entailment
--
module Language.PureScript.TypeChecker.Entailment
( InstanceContext
, replaceTypeClassDictionaries
+ , newDictionaries
) where
import Prelude.Compat
+import Control.Arrow (second)
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.State
import Control.Monad.Supply.Class (MonadSupply(..))
import Control.Monad.Writer
+import Data.Foldable (for_)
import Data.Function (on)
-import Data.List (minimumBy, sortBy, groupBy)
-import Data.Maybe (maybeToList, mapMaybe)
+import Data.List (minimumBy, nub)
+import Data.Maybe (fromMaybe, maybeToList, mapMaybe)
import qualified Data.Map as M
+import qualified Data.Set as S
import Language.PureScript.AST
import Language.PureScript.Crash
+import Language.PureScript.Environment
import Language.PureScript.Errors
import Language.PureScript.Names
-import Language.PureScript.TypeChecker.Monad (CheckState, withErrorMessageHint)
+import Language.PureScript.TypeChecker.Monad
import Language.PureScript.TypeChecker.Unify
import Language.PureScript.TypeClassDictionaries
import Language.PureScript.Types
@@ -34,24 +41,57 @@ type InstanceContext = M.Map (Maybe ModuleName)
(M.Map (Qualified Ident)
TypeClassDictionaryInScope))
--- | Merge two type class contexts
+-- | A type substitution which makes an instance head match a list of types.
+--
+-- Note: we store many types per type variable name. For any name, all types
+-- should unify if we are going to commit to an instance.
+type Matching a = M.Map String a
+
combineContexts :: InstanceContext -> InstanceContext -> InstanceContext
combineContexts = M.unionWith (M.unionWith M.union)
-- | Replace type class dictionary placeholders with inferred type class dictionaries
replaceTypeClassDictionaries
- :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m)
+ :: forall m
+ . (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m)
=> Bool
- -> ModuleName
-> Expr
-> m (Expr, [(Ident, Constraint)])
-replaceTypeClassDictionaries shouldGeneralize mn =
- let (_, f, _) = everywhereOnValuesTopDownM return (WriterT . go) return
- in flip evalStateT M.empty . runWriterT . f
+replaceTypeClassDictionaries shouldGeneralize expr = flip evalStateT M.empty $ do
+ -- Loop, deferring any unsolved constraints, until there are no more
+ -- constraints which can be solved, then make a generalization pass.
+ let loop e = do
+ (e', solved) <- deferPass e
+ if getAny solved
+ then loop e'
+ else return e'
+ loop expr >>= generalizePass
where
- go (TypeClassDictionary constraint dicts hints) =
- rethrow (addHints hints) $ entails shouldGeneralize mn dicts constraint
- go other = return (other, [])
+ -- This pass solves constraints where possible, deferring constraints if not.
+ deferPass :: Expr -> StateT InstanceContext m (Expr, Any)
+ deferPass = fmap (second fst) . runWriterT . f where
+ f :: Expr -> WriterT (Any, [(Ident, Constraint)]) (StateT InstanceContext m) Expr
+ (_, f, _) = everywhereOnValuesTopDownM return (go True) return
+
+ -- This pass generalizes any remaining constraints
+ generalizePass :: Expr -> StateT InstanceContext m (Expr, [(Ident, Constraint)])
+ generalizePass = fmap (second snd) . runWriterT . f where
+ f :: Expr -> WriterT (Any, [(Ident, Constraint)]) (StateT InstanceContext m) Expr
+ (_, f, _) = everywhereOnValuesTopDownM return (go False) return
+
+ go :: Bool -> Expr -> WriterT (Any, [(Ident, Constraint)]) (StateT InstanceContext m) Expr
+ go deferErrors dict@(TypeClassDictionary _ _ hints) =
+ rethrow (addHints hints) $ entails shouldGeneralize deferErrors dict
+ go _ other = return other
+
+-- | Three options for how we can handle a constraint, depending on the mode we're in.
+data EntailsResult a
+ = Solved a TypeClassDictionaryInScope
+ -- ^ We solved this constraint
+ | Unsolved Constraint
+ -- ^ We couldn't solve this constraint right now, it will be generalized
+ | Deferred
+ -- ^ We couldn't solve this constraint right now, so it has been deferred
-- |
-- Check that the current set of type class dictionaries entail the specified type class goal, and, if so,
@@ -61,14 +101,14 @@ entails
:: forall m
. (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m)
=> Bool
- -> ModuleName
- -> InstanceContext
- -> Constraint
- -> StateT InstanceContext m (Expr, [(Ident, Constraint)])
-entails shouldGeneralize moduleName context = solve
+ -> Bool
+ -> Expr
+ -> WriterT (Any, [(Ident, Constraint)]) (StateT InstanceContext m) Expr
+entails shouldGeneralize deferErrors (TypeClassDictionary constraint context hints) =
+ solve constraint
where
forClassName :: InstanceContext -> Qualified (ProperName 'ClassName) -> [Type] -> [TypeClassDictionaryInScope]
- forClassName ctx cn@(Qualified (Just mn) _) tys = concatMap (findDicts ctx cn) (Nothing : Just mn : map Just (mapMaybe ctorModules tys))
+ forClassName ctx cn@(Qualified (Just mn) _) tys = concatMap (findDicts ctx cn) (nub (Nothing : Just mn : map Just (mapMaybe ctorModules tys)))
forClassName _ _ _ = internalError "forClassName: expected qualified class name"
ctorModules :: Type -> Maybe ModuleName
@@ -80,139 +120,306 @@ entails shouldGeneralize moduleName context = solve
findDicts :: InstanceContext -> Qualified (ProperName 'ClassName) -> Maybe ModuleName -> [TypeClassDictionaryInScope]
findDicts ctx cn = maybe [] M.elems . (>>= M.lookup cn) . flip M.lookup ctx
- solve :: Constraint -> StateT InstanceContext m (Expr, [(Ident, Constraint)])
- solve con = StateT . (withErrorMessageHint (ErrorSolvingConstraint con) .) . runStateT $ do
- (dict, unsolved) <- go 0 con
- return (dictionaryValueToValue dict, unsolved)
+ valUndefined :: Expr
+ valUndefined = Var (Qualified (Just (ModuleName [ProperName C.prim])) (Ident C.undefined))
+
+ solve :: Constraint -> WriterT (Any, [(Ident, Constraint)]) (StateT InstanceContext m) Expr
+ solve con = go 0 con
where
- go :: Int -> Constraint -> StateT InstanceContext m (DictionaryValue, [(Ident, Constraint)])
- go work (Constraint className' tys' _) | work > 1000 = throwError . errorMessage $ PossiblyInfiniteInstance className' tys'
- go work con'@(Constraint className' tys' _) = do
- -- Get the inferred constraint context so far, and merge it with the global context
- inferred <- get
- let instances = do
- tcd <- forClassName (combineContexts context inferred) className' tys'
- -- Make sure the type unifies with the type in the type instance definition
- subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName) tys' (tcdInstanceTypes tcd)
- return (subst, tcd)
- solution <- lift $ unique instances
- case solution of
- Left (subst, tcd) -> do
- -- Solve any necessary subgoals
- (args, unsolved) <- solveSubgoals subst (tcdDependencies tcd)
- let match = foldr (\(superclassName, index) dict -> SubclassDictionaryValue dict superclassName index)
- (mkDictionary (tcdName tcd) args)
- (tcdPath tcd)
- return (match, unsolved)
- Right unsolved@(Constraint unsolvedClassName@(Qualified _ pn) unsolvedTys _) -> do
- -- Generate a fresh name for the unsolved constraint's new dictionary
- ident <- freshIdent ("dict" ++ runProperName pn)
- let qident = Qualified Nothing ident
- -- Store the new dictionary in the InstanceContext so that we can solve this goal in
- -- future.
- let newDict = TypeClassDictionaryInScope qident [] unsolvedClassName unsolvedTys Nothing
- newContext = M.singleton Nothing (M.singleton unsolvedClassName (M.singleton qident newDict))
- modify (combineContexts newContext)
- return (LocalDictionaryValue qident, [(ident, unsolved)])
- where
+ go :: Int -> Constraint -> WriterT (Any, [(Ident, Constraint)]) (StateT InstanceContext m) Expr
+ go work (Constraint className' tys' _) | work > 1000 = throwError . errorMessage $ PossiblyInfiniteInstance className' tys'
+ go work con'@(Constraint className' tys' conInfo) = WriterT . StateT . (withErrorMessageHint (ErrorSolvingConstraint con') .) . runStateT . runWriterT $ do
+ -- We might have unified types by solving other constraints, so we need to
+ -- apply the latest substitution.
+ latestSubst <- lift . lift $ gets checkSubstitution
+ let tys'' = map (substituteType latestSubst) tys'
+ -- Get the inferred constraint context so far, and merge it with the global context
+ inferred <- lift get
+ -- We need information about functional dependencies, so we have to look up the class
+ -- name in the environment:
+ let findClass = fromMaybe (internalError "entails: type class not found in environment") . M.lookup className'
+ TypeClassData{ typeClassDependencies } <- lift . lift $ gets (findClass . typeClasses . checkEnv)
+ let instances =
+ [ (substs, tcd)
+ | tcd <- forClassName (combineContexts context inferred) className' tys''
+ -- Make sure the type unifies with the type in the type instance definition
+ , substs <- maybeToList (matches typeClassDependencies tcd tys'')
+ ]
+ solution <- lift . lift $ unique tys'' instances
+ case solution of
+ Solved substs tcd -> do
+ -- Note that we solved something.
+ tell (Any True, mempty)
+ -- Make sure the substitution is valid:
+ lift . lift . for_ substs $ pairwiseM unifyTypes
+ -- Now enforce any functional dependencies, using unification
+ -- Note: we need to generate fresh types for any unconstrained
+ -- type variables before unifying.
+ let subst = fmap head substs
+ currentSubst <- lift . lift $ gets checkSubstitution
+ subst' <- lift . lift $ withFreshTypes tcd (fmap (substituteType currentSubst) subst)
+ lift . lift $ zipWithM_ (\t1 t2 -> do
+ let inferredType = replaceAllTypeVars (M.toList subst') t1
+ unifyTypes inferredType t2) (tcdInstanceTypes tcd) tys''
+ currentSubst' <- lift . lift $ gets checkSubstitution
+ let subst'' = fmap (substituteType currentSubst') subst'
+ -- Solve any necessary subgoals
+ args <- solveSubgoals subst'' (tcdDependencies tcd)
+ let match = foldr (\(superclassName, index) dict -> subclassDictionaryValue dict superclassName index)
+ (mkDictionary (tcdName tcd) args)
+ (tcdPath tcd)
+ return match
+ Unsolved unsolved -> do
+ -- Generate a fresh name for the unsolved constraint's new dictionary
+ ident <- freshIdent ("dict" ++ runProperName (disqualify (constraintClass unsolved)))
+ let qident = Qualified Nothing ident
+ -- Store the new dictionary in the InstanceContext so that we can solve this goal in
+ -- future.
+ newDicts <- lift . lift $ newDictionaries [] qident unsolved
+ let newContext = mkContext newDicts
+ modify (combineContexts newContext)
+ -- Mark this constraint for generalization
+ tell (mempty, [(ident, unsolved)])
+ return (Var qident)
+ Deferred ->
+ -- Constraint was deferred, just return the dictionary unchanged,
+ -- with no unsolved constraints. Hopefully, we can solve this later.
+ return (TypeClassDictionary (Constraint className' tys'' conInfo) context hints)
+ where
+ -- | When checking functional dependencies, we need to use unification to make
+ -- sure it is safe to use the selected instance. We will unify the solved type with
+ -- the type in the instance head under the substition inferred from its instantiation.
+ -- As an example, when solving MonadState t0 (State Int), we choose the
+ -- MonadState s (State s) instance, and we unify t0 with Int, since the functional
+ -- dependency from MonadState dictates that t0 should unify with s\[s -> Int], which is
+ -- Int. This is fine, but in some cases, the substitution does not remove all TypeVars
+ -- from the type, so we end up with a unification error. So, any type arguments which
+ -- appear in the instance head, but not in the substitution need to be replaced with
+ -- fresh type variables. This function extends a substitution with fresh type variables
+ -- as necessary, based on the types in the instance head.
+ withFreshTypes
+ :: TypeClassDictionaryInScope
+ -> Matching Type
+ -> m (Matching Type)
+ withFreshTypes TypeClassDictionaryInScope{..} subst = do
+ let onType = everythingOnTypes S.union fromTypeVar
+ typeVarsInHead = foldMap onType tcdInstanceTypes
+ <> foldMap (foldMap (foldMap onType . constraintArgs)) tcdDependencies
+ typeVarsInSubst = S.fromList (M.keys subst)
+ uninstantiatedTypeVars = typeVarsInHead S.\\ typeVarsInSubst
+ newSubst <- traverse withFreshType (S.toList uninstantiatedTypeVars)
+ return (subst <> M.fromList newSubst)
+ where
+ fromTypeVar (TypeVar v) = S.singleton v
+ fromTypeVar _ = S.empty
- unique :: [(a, TypeClassDictionaryInScope)] -> m (Either (a, TypeClassDictionaryInScope) Constraint)
- unique [] | shouldGeneralize && all canBeGeneralized tys' = return (Right con')
- | otherwise = throwError . errorMessage $ NoInstanceFound con'
- unique [a] = return $ Left a
- unique tcds | pairwise overlapping (map snd tcds) = do
- tell . errorMessage $ OverlappingInstances className' tys' (map (tcdName . snd) tcds)
- return $ Left (head tcds)
- | otherwise = return $ Left (minimumBy (compare `on` length . tcdPath . snd) tcds)
-
- canBeGeneralized :: Type -> Bool
- canBeGeneralized TUnknown{} = True
- canBeGeneralized Skolem{} = True
- canBeGeneralized _ = False
-
- -- |
- -- Check if two dictionaries are overlapping
- --
- -- Dictionaries which are subclass dictionaries cannot overlap, since otherwise the overlap would have
- -- been caught when constructing superclass dictionaries.
- overlapping :: TypeClassDictionaryInScope -> TypeClassDictionaryInScope -> Bool
- overlapping TypeClassDictionaryInScope{ tcdPath = _ : _ } _ = False
- overlapping _ TypeClassDictionaryInScope{ tcdPath = _ : _ } = False
- overlapping TypeClassDictionaryInScope{ tcdDependencies = Nothing } _ = False
- overlapping _ TypeClassDictionaryInScope{ tcdDependencies = Nothing } = False
- overlapping tcd1 tcd2 = tcdName tcd1 /= tcdName tcd2
-
- -- Create dictionaries for subgoals which still need to be solved by calling go recursively
- -- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type
- -- unifies with Either a b, and we can satisfy the subgoals Show a and Show b recursively.
- solveSubgoals :: [(String, Type)] -> Maybe [Constraint] -> StateT InstanceContext m (Maybe [DictionaryValue], [(Ident, Constraint)])
- solveSubgoals _ Nothing = return (Nothing, [])
- solveSubgoals subst (Just subgoals) = do
- zipped <- traverse (go (work + 1) . mapConstraintArgs (map (replaceAllTypeVars subst))) subgoals
- let (dicts, unsolved) = unzip zipped
- return (Just dicts, concat unsolved)
-
- -- 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_ ++ 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) . sortBy (compare `on` fst) $ subst
- guard (all (pairwise unifiesWith . map snd) grps)
- return $ map head grps
+ withFreshType s = do
+ t <- freshType
+ return (s, t)
- valUndefined :: Expr
- valUndefined = Var (Qualified (Just (ModuleName [ProperName C.prim])) (Ident C.undefined))
+ unique :: [Type] -> [(a, TypeClassDictionaryInScope)] -> m (EntailsResult a)
+ unique tyArgs []
+ | deferErrors = return Deferred
+ -- We need a special case for nullary type classes, since we want
+ -- to generalize over Partial constraints.
+ | shouldGeneralize && (null tyArgs || any canBeGeneralized tyArgs) = return (Unsolved (Constraint className' tyArgs conInfo))
+ | otherwise = throwError . errorMessage $ NoInstanceFound (Constraint className' tyArgs conInfo)
+ unique _ [(a, dict)] = return $ Solved a dict
+ unique tyArgs tcds
+ | pairwiseAny overlapping (map snd tcds) = do
+ tell . errorMessage $ OverlappingInstances className' tyArgs (map (tcdName . snd) tcds)
+ return $ uncurry Solved (head tcds)
+ | otherwise = return $ uncurry Solved (minimumBy (compare `on` length . tcdPath . snd) tcds)
--- |
--- 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 -> Type -> Type -> Maybe [(String, Type)]
-typeHeadsAreEqual _ (TUnknown u1) (TUnknown u2) | u1 == u2 = Just []
-typeHeadsAreEqual _ (Skolem _ s1 _ _) (Skolem _ s2 _ _) | s1 == s2 = Just []
-typeHeadsAreEqual _ t (TypeVar v) = Just [(v, t)]
-typeHeadsAreEqual _ (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = Just []
-typeHeadsAreEqual _ (TypeLevelString s1) (TypeLevelString s2) | s1 == s2 = 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 (uncurry (typeHeadsAreEqual m)) int
- <*> go sd1 r1' sd2 r2'
+ canBeGeneralized :: Type -> Bool
+ canBeGeneralized TUnknown{} = True
+ canBeGeneralized Skolem{} = True
+ canBeGeneralized _ = False
+
+ -- |
+ -- Check if two dictionaries are overlapping
+ --
+ -- Dictionaries which are subclass dictionaries cannot overlap, since otherwise the overlap would have
+ -- been caught when constructing superclass dictionaries.
+ overlapping :: TypeClassDictionaryInScope -> TypeClassDictionaryInScope -> Bool
+ overlapping TypeClassDictionaryInScope{ tcdPath = _ : _ } _ = False
+ overlapping _ TypeClassDictionaryInScope{ tcdPath = _ : _ } = False
+ overlapping TypeClassDictionaryInScope{ tcdDependencies = Nothing } _ = False
+ overlapping _ TypeClassDictionaryInScope{ tcdDependencies = Nothing } = False
+ overlapping tcd1 tcd2 = tcdName tcd1 /= tcdName tcd2
+
+ -- Create dictionaries for subgoals which still need to be solved by calling go recursively
+ -- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type
+ -- unifies with Either a b, and we can satisfy the subgoals Show a and Show b recursively.
+ solveSubgoals :: Matching Type -> Maybe [Constraint] -> WriterT (Any, [(Ident, Constraint)]) (StateT InstanceContext m) (Maybe [Expr])
+ solveSubgoals _ Nothing = return Nothing
+ solveSubgoals subst (Just subgoals) =
+ Just <$> traverse (go (work + 1) . mapConstraintArgs (map (replaceAllTypeVars (M.toList subst)))) subgoals
+
+ -- Make a dictionary from subgoal dictionaries by applying the correct function
+ mkDictionary :: Qualified Ident -> Maybe [Expr] -> Expr
+ mkDictionary fnName Nothing = Var fnName
+ mkDictionary fnName (Just []) = Var fnName
+ mkDictionary fnName (Just dicts) = foldl App (Var fnName) dicts
+
+ -- Turn a DictionaryValue into a Expr
+ subclassDictionaryValue :: Expr -> Qualified (ProperName a) -> Integer -> Expr
+ subclassDictionaryValue dict superclassName index =
+ App (Accessor (C.__superclass_ ++ showQualified runProperName superclassName ++ "_" ++ show index)
+ dict)
+ valUndefined
+entails _ _ _ = internalError "entails: expected TypeClassDictionary"
+
+-- Check if an instance matches our list of types, allowing for types
+-- to be solved via functional dependencies. If the types match, we return a
+-- substitution which makes them match. If not, we return 'Nothing'.
+matches :: [FunctionalDependency] -> TypeClassDictionaryInScope -> [Type] -> Maybe (Matching [Type])
+matches deps TypeClassDictionaryInScope{..} tys = do
+ -- First, find those types which match exactly
+ let matched = zipWith typeHeadsAreEqual tys tcdInstanceTypes
+ -- Now, use any functional dependencies to infer any remaining types
+ guard $ covers matched
+ -- Verify that any repeated type variables are unifiable
+ let determinedSet = foldMap (S.fromList . fdDetermined) deps
+ solved = map snd . filter ((`S.notMember` determinedSet) . fst) $ zipWith (\(_, ts) i -> (i, ts)) matched [0..]
+ verifySubstitution (M.unionsWith (++) solved)
where
- go :: [(String, Type)] -> Type -> [(String, Type)] -> Type -> Maybe [(String, Type)]
- 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
+ -- | Find the closure of a set of functional dependencies.
+ covers :: [(Bool, subst)] -> Bool
+ covers ms = finalSet == S.fromList [0..length ms - 1]
+ where
+ initialSet :: S.Set Int
+ initialSet = S.fromList . map snd . filter (fst . fst) $ zip ms [0..]
--- |
--- Check all values in a list pairwise match a predicate
---
-pairwise :: (a -> a -> Bool) -> [a] -> Bool
-pairwise _ [] = True
-pairwise _ [_] = True
-pairwise p (x : xs) = all (p x) xs && pairwise p xs
+ finalSet :: S.Set Int
+ finalSet = untilFixedPoint applyAll initialSet
+
+ untilFixedPoint :: Eq a => (a -> a) -> a -> a
+ untilFixedPoint f = go
+ where
+ go a | a' == a = a'
+ | otherwise = go a'
+ where a' = f a
+
+ applyAll :: S.Set Int -> S.Set Int
+ applyAll s = foldr applyDependency s deps
+
+ applyDependency :: FunctionalDependency -> S.Set Int -> S.Set Int
+ applyDependency FunctionalDependency{..} xs
+ | S.fromList fdDeterminers `S.isSubsetOf` xs = xs <> S.fromList fdDetermined
+ | otherwise = xs
+
+ --
+ -- 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 :: Type -> Type -> (Bool, Matching [Type])
+ typeHeadsAreEqual (TUnknown u1) (TUnknown u2) | u1 == u2 = (True, M.empty)
+ typeHeadsAreEqual (Skolem _ s1 _ _) (Skolem _ s2 _ _) | s1 == s2 = (True, M.empty)
+ typeHeadsAreEqual t (TypeVar v) = (True, M.singleton v [t])
+ typeHeadsAreEqual (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = (True, M.empty)
+ typeHeadsAreEqual (TypeLevelString s1) (TypeLevelString s2) | s1 == s2 = (True, M.empty)
+ typeHeadsAreEqual (TypeApp h1 t1) (TypeApp h2 t2) =
+ both (typeHeadsAreEqual h1 h2) (typeHeadsAreEqual t1 t2)
+ typeHeadsAreEqual REmpty REmpty = (True, M.empty)
+ typeHeadsAreEqual r1@RCons{} r2@RCons{} =
+ foldr both (go sd1 r1' sd2 r2') (map (uncurry typeHeadsAreEqual) int)
+ where
+ (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 ]
+
+ go :: [(String, Type)] -> Type -> [(String, Type)] -> Type -> (Bool, Matching [Type])
+ go [] REmpty [] REmpty = (True, M.empty)
+ go [] (TUnknown u1) [] (TUnknown u2) | u1 == u2 = (True, M.empty)
+ go [] (TypeVar v1) [] (TypeVar v2) | v1 == v2 = (True, M.empty)
+ go [] (Skolem _ sk1 _ _) [] (Skolem _ sk2 _ _) | sk1 == sk2 = (True, M.empty)
+ go sd r [] (TypeVar v) = (True, M.singleton v [rowFromList (sd, r)])
+ go _ _ _ _ = (False, M.empty)
+ typeHeadsAreEqual _ _ = (False, M.empty)
+
+ both :: (Bool, Matching [Type]) -> (Bool, Matching [Type]) -> (Bool, Matching [Type])
+ both (b1, m1) (b2, m2) = (b1 && b2, M.unionWith (++) m1 m2)
+
+ -- Ensure that a substitution is valid
+ verifySubstitution :: Matching [Type] -> Maybe (Matching [Type])
+ verifySubstitution = traverse meet where
+ meet ts | pairwiseAll typesAreEqual ts = Just ts
+ | otherwise = Nothing
+
+ -- Note that unknowns are only allowed to unify if they came from a type
+ -- which was _not_ solved, i.e. one which was inferred by a functional
+ -- dependency.
+ typesAreEqual :: Type -> Type -> Bool
+ typesAreEqual (TUnknown u1) (TUnknown u2) | u1 == u2 = True
+ typesAreEqual (Skolem _ s1 _ _) (Skolem _ s2 _ _) = s1 == s2
+ typesAreEqual (TypeVar v1) (TypeVar v2) = v1 == v2
+ typesAreEqual (TypeLevelString s1) (TypeLevelString s2) = s1 == s2
+ typesAreEqual (TypeConstructor c1) (TypeConstructor c2) = c1 == c2
+ typesAreEqual (TypeApp h1 t1) (TypeApp h2 t2) = typesAreEqual h1 h2 && typesAreEqual t1 t2
+ typesAreEqual REmpty REmpty = True
+ typesAreEqual r1 r2 | isRCons r1 || isRCons r2 =
+ 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 (uncurry typesAreEqual) int && go sd1 r1' sd2 r2'
+ where
+ go :: [(String, Type)] -> Type -> [(String, Type)] -> Type -> Bool
+ go [] (TUnknown u1) [] (TUnknown u2) | u1 == u2 = True
+ go [] (Skolem _ s1 _ _) [] (Skolem _ s2 _ _) = s1 == s2
+ go [] REmpty [] REmpty = True
+ go [] (TypeVar v1) [] (TypeVar v2) = v1 == v2
+ go _ _ _ _ = False
+ typesAreEqual _ _ = False
+
+ isRCons :: Type -> Bool
+ isRCons RCons{} = True
+ isRCons _ = False
+
+-- | Add a dictionary for the constraint to the scope, and dictionaries
+-- for all implied superclass instances.
+newDictionaries
+ :: MonadState CheckState m
+ => [(Qualified (ProperName 'ClassName), Integer)]
+ -> Qualified Ident
+ -> Constraint
+ -> m [TypeClassDictionaryInScope]
+newDictionaries path name (Constraint className instanceTy _) = do
+ tcs <- gets (typeClasses . checkEnv)
+ let TypeClassData{..} = fromMaybe (internalError "newDictionaries: type class lookup failed") $ M.lookup className tcs
+ supDicts <- join <$> zipWithM (\(Constraint supName supArgs _) index ->
+ newDictionaries ((supName, index) : path)
+ name
+ (Constraint supName (instantiateSuperclass (map fst typeClassArguments) supArgs instanceTy) Nothing)
+ ) typeClassSuperclasses [0..]
+ return (TypeClassDictionaryInScope name path className instanceTy Nothing : supDicts)
+ where
+ instantiateSuperclass :: [String] -> [Type] -> [Type] -> [Type]
+ instantiateSuperclass args supArgs tys = map (replaceAllTypeVars (zip args tys)) supArgs
+
+mkContext :: [TypeClassDictionaryInScope] -> InstanceContext
+mkContext = foldr combineContexts M.empty . map fromDict where
+ fromDict d = M.singleton Nothing (M.singleton (tcdClassName d) (M.singleton (tcdName d) d))
+
+-- | Check all pairs of values in a list match a predicate
+pairwiseAll :: (a -> a -> Bool) -> [a] -> Bool
+pairwiseAll _ [] = True
+pairwiseAll _ [_] = True
+pairwiseAll p (x : xs) = all (p x) xs && pairwiseAll p xs
+
+-- | Check any pair of values in a list match a predicate
+pairwiseAny :: (a -> a -> Bool) -> [a] -> Bool
+pairwiseAny _ [] = False
+pairwiseAny _ [_] = False
+pairwiseAny p (x : xs) = any (p x) xs || pairwiseAny p xs
+
+pairwiseM :: Applicative m => (a -> a -> m ()) -> [a] -> m ()
+pairwiseM _ [] = pure ()
+pairwiseM _ [_] = pure ()
+pairwiseM p (x : xs) = traverse (p x) xs *> pairwiseM p xs
diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs
index 3d35684..8138837 100644
--- a/src/Language/PureScript/TypeChecker/Kinds.hs
+++ b/src/Language/PureScript/TypeChecker/Kinds.hs
@@ -16,7 +16,6 @@ import Control.Arrow (second)
import Control.Monad
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.State
-import Control.Monad.Writer.Class (MonadWriter(..))
import qualified Data.Map as M
@@ -96,19 +95,19 @@ unifyKinds k1 k2 = do
-- | Infer the kind of a single type
kindOf
- :: (MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m)
+ :: (MonadError MultipleErrors m, MonadState CheckState m)
=> Type
-> m Kind
kindOf ty = fst <$> kindOfWithScopedVars ty
-- | Infer the kind of a single type, returning the kinds of any scoped type variables
kindOfWithScopedVars ::
- (MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m) =>
+ (MonadError MultipleErrors m, MonadState CheckState m) =>
Type ->
m (Kind, [(String, Kind)])
kindOfWithScopedVars ty =
withErrorMessageHint (ErrorCheckingKind ty) $
- fmap tidyUp . liftUnify $ infer ty
+ fmap tidyUp . withFreshSubstitution . captureSubstitution $ infer ty
where
tidyUp ((k, args), sub) = ( starIfUnknown (substituteKind sub k)
, map (second (starIfUnknown . substituteKind sub)) args
@@ -116,14 +115,14 @@ kindOfWithScopedVars ty =
-- | Infer the kind of a type constructor with a collection of arguments and a collection of associated data constructors
kindsOf
- :: (MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m)
+ :: (MonadError MultipleErrors m, MonadState CheckState m)
=> Bool
-> ModuleName
-> ProperName 'TypeName
-> [(String, Maybe Kind)]
-> [Type]
-> m Kind
-kindsOf isData moduleName name args ts = fmap tidyUp . liftUnify $ do
+kindsOf isData moduleName name args ts = fmap tidyUp . withFreshSubstitution . captureSubstitution $ do
tyCon <- freshKind
kargs <- replicateM (length args) freshKind
rest <- zipWithM freshKindVar args kargs
@@ -145,12 +144,12 @@ freshKindVar (arg, Just kind') kind = do
-- | Simultaneously infer the kinds of several mutually recursive type constructors
kindsOfAll
- :: (MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m)
+ :: (MonadError MultipleErrors m, MonadState CheckState m)
=> ModuleName
-> [(ProperName 'TypeName, [(String, Maybe Kind)], Type)]
-> [(ProperName 'TypeName, [(String, Maybe Kind)], [Type])]
-> m ([Kind], [Kind])
-kindsOfAll moduleName syns tys = fmap tidyUp . liftUnify $ do
+kindsOfAll moduleName syns tys = fmap tidyUp . withFreshSubstitution . captureSubstitution $ do
synVars <- replicateM (length syns) freshKind
let dict = zipWith (\(name, _, _) var -> (name, var)) syns synVars
bindLocalTypeVariables moduleName dict $ do
diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs
index b229ca3..554a56c 100644
--- a/src/Language/PureScript/TypeChecker/Monad.hs
+++ b/src/Language/PureScript/TypeChecker/Monad.hs
@@ -11,7 +11,7 @@ import Prelude.Compat
import Control.Arrow (second)
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.State
-import Control.Monad.Writer.Class (MonadWriter(..), listen, censor)
+import Control.Monad.Writer.Class (MonadWriter(..), censor)
import Data.Maybe
import qualified Data.Map as M
@@ -245,7 +245,7 @@ getEnv = checkEnv <$> get
getLocalContext :: MonadState CheckState m => m Context
getLocalContext = do
env <- getEnv
- return [ (ident, ty') | ((Qualified Nothing ident@Ident{}), (ty', _, Defined)) <- M.toList (names env) ]
+ return [ (ident, ty') | (Qualified Nothing ident@Ident{}, (ty', _, Defined)) <- M.toList (names env) ]
-- | Update the @Environment@
putEnv :: (MonadState CheckState m) => Environment -> m ()
@@ -269,23 +269,35 @@ guardWith _ True = return ()
guardWith e False = throwError e
-- | Run a computation in the substitution monad, generating a return value and the final substitution.
-liftUnify ::
- (MonadState CheckState m, MonadWriter MultipleErrors m, MonadError MultipleErrors m) =>
- m a ->
- m (a, Substitution)
-liftUnify = liftUnifyWarnings (const id)
-
--- | Run a computation in the substitution monad, generating a return value, the final substitution and updating warnings values.
-liftUnifyWarnings ::
- (MonadState CheckState m, MonadWriter MultipleErrors m, MonadError MultipleErrors m) =>
- (Substitution -> ErrorMessage -> ErrorMessage) ->
- m a ->
- m (a, Substitution)
-liftUnifyWarnings replace ma = do
+captureSubstitution
+ :: MonadState CheckState m
+ => m a
+ -> m (a, Substitution)
+captureSubstitution = capturingSubstitution (,)
+
+capturingSubstitution
+ :: MonadState CheckState m
+ => (a -> Substitution -> b)
+ -> m a
+ -> m b
+capturingSubstitution f ma = do
+ a <- ma
+ subst <- gets checkSubstitution
+ return (f a subst)
+
+withFreshSubstitution
+ :: MonadState CheckState m
+ => m a
+ -> m a
+withFreshSubstitution ma = do
orig <- get
modify $ \st -> st { checkSubstitution = emptySubstitution }
- (a, w) <- reflectErrors . censor (const mempty) . reifyErrors . listen $ ma
- subst <- gets checkSubstitution
- tell . onErrorMessages (replace subst) $ w
+ a <- ma
modify $ \st -> st { checkSubstitution = checkSubstitution orig }
- return (a, subst)
+ return a
+
+withoutWarnings
+ :: MonadWriter w m
+ => m a
+ -> m (a, w)
+withoutWarnings = censor (const mempty) . listen
diff --git a/src/Language/PureScript/TypeChecker/Skolems.hs b/src/Language/PureScript/TypeChecker/Skolems.hs
index 62d6108..b0ca42f 100644
--- a/src/Language/PureScript/TypeChecker/Skolems.hs
+++ b/src/Language/PureScript/TypeChecker/Skolems.hs
@@ -61,7 +61,7 @@ skolemize ident sko scope ss = replaceTypeVars ident (Skolem ident sko scope ss)
-- |
-- This function has one purpose - to skolemize type variables appearing in a
--- SuperClassDictionary placeholder. These type variables are somewhat unique since they are the
+-- DeferredDictionary placeholder. These type variables are somewhat unique since they are the
-- only example of scoped type variables.
--
skolemizeTypesInValue :: String -> Int -> SkolemScope -> Maybe SourceSpan -> Expr -> Expr
@@ -71,8 +71,8 @@ skolemizeTypesInValue ident sko scope ss =
in runIdentity . f
where
onExpr :: [String] -> Expr -> Identity ([String], Expr)
- onExpr sco (SuperClassDictionary c ts)
- | ident `notElem` sco = return (sco, SuperClassDictionary c (map (skolemize ident sko scope ss) ts))
+ onExpr sco (DeferredDictionary c ts)
+ | ident `notElem` sco = return (sco, DeferredDictionary c (map (skolemize ident sko scope ss) ts))
onExpr sco (TypedValue check val ty)
| ident `notElem` sco = return (sco ++ peelTypeVars ty, TypedValue check val (skolemize ident sko scope ss ty))
onExpr sco other = return (sco, other)
diff --git a/src/Language/PureScript/TypeChecker/Subsumption.hs b/src/Language/PureScript/TypeChecker/Subsumption.hs
index 148ca45..0db3767 100644
--- a/src/Language/PureScript/TypeChecker/Subsumption.hs
+++ b/src/Language/PureScript/TypeChecker/Subsumption.hs
@@ -7,10 +7,13 @@ module Language.PureScript.TypeChecker.Subsumption
import Prelude.Compat
+import Control.Monad (when)
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.State.Class (MonadState(..), gets)
-import Data.List (sortBy)
+import Data.Foldable (for_)
+import Data.List (sortBy, uncons)
+import Data.List.Ordered (minusBy')
import Data.Ord (comparing)
import Language.PureScript.AST
@@ -26,7 +29,7 @@ import Language.PureScript.Types
subsumes :: (MonadError MultipleErrors m, MonadState CheckState m) => Maybe Expr -> Type -> Type -> m (Maybe Expr)
subsumes val ty1 ty2 = withErrorMessageHint (ErrorInSubsumption ty1 ty2) $ subsumes' val ty1 ty2
--- | Check tahat one type subsumes another
+-- | Check that one type subsumes another
subsumes' :: (MonadError MultipleErrors m, MonadState CheckState m) =>
Maybe Expr ->
Type ->
@@ -60,6 +63,14 @@ subsumes' val (TypeApp f1 r1) (TypeApp f2 r2) | f1 == tyRecord && f2 == tyRecord
(ts2, r2') = rowToList r2
ts1' = sortBy (comparing fst) ts1
ts2' = sortBy (comparing fst) ts2
+ -- For { ts1 | r1 } to subsume { ts2 | r2 } when r1 is empty (= we're working with a closed row),
+ -- every property in ts2 must appear in ts1. If not, then the candidate expression is missing a required property.
+ -- Conversely, when r2 is empty, every property in ts1 must appear in ts2, or else the expression has
+ -- an additional property which is not allowed.
+ when (r1' == REmpty)
+ (for_ (firstMissingProp ts2' ts1') (throwError . errorMessage . PropertyIsMissing . fst))
+ when (r2' == REmpty)
+ (for_ (firstMissingProp ts1' ts2') (throwError . errorMessage . AdditionalProperty . fst))
go ts1' ts2' r1' r2'
return val
where
@@ -72,15 +83,13 @@ subsumes' val (TypeApp f1 r1) (TypeApp f2 r2) | f1 == tyRecord && f2 == tyRecord
-- What happens next is a bit of a hack.
-- TODO: in the new type checker, object properties will probably be restricted to being monotypes
-- in which case, this branch of the subsumes function should not even be necessary.
- case r2' of
- REmpty -> throwError . errorMessage $ AdditionalProperty p1
- _ -> unifyTypes r2' (RCons p1 ty1 rest)
+ unifyTypes r2' (RCons p1 ty1 rest)
go ts1 ((p2, ty2) : ts2) r1' rest
| otherwise = do rest <- freshType
- case r1' of
- REmpty -> throwError . errorMessage $ PropertyIsMissing p2
- _ -> unifyTypes r1' (RCons p2 ty2 rest)
+ unifyTypes r1' (RCons p2 ty2 rest)
go ((p1, ty1) : ts1) ts2 rest r2'
+ -- Find the first property that's in the first list (of tuples) but not in the second
+ firstMissingProp t1 t2 = fst <$> uncons (minusBy' (comparing fst) t1 t2)
subsumes' val ty1 ty2@(TypeApp obj _) | obj == tyRecord = subsumes val ty2 ty1
subsumes' val ty1 ty2 = do
unifyTypes ty1 ty2
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index 0804db3..3135148 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NamedFieldPuns #-}
-- |
-- This module implements the type checker
@@ -36,6 +37,7 @@ import Data.Either (lefts, rights)
import Data.List (transpose, nub, (\\), partition, delete)
import Data.Maybe (fromMaybe)
import qualified Data.Map as M
+import qualified Data.Set as S
import Language.PureScript.AST
import Language.PureScript.Crash
@@ -52,7 +54,6 @@ import Language.PureScript.TypeChecker.Skolems
import Language.PureScript.TypeChecker.Subsumption
import Language.PureScript.TypeChecker.Synonyms
import Language.PureScript.TypeChecker.Unify
-import Language.PureScript.TypeClassDictionaries
import Language.PureScript.Types
data BindingGroupType
@@ -62,65 +63,78 @@ data BindingGroupType
-- | Infer the types of multiple mutually-recursive values, and return elaborated values including
-- type class dictionaries and type annotations.
-typesOf ::
- (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
- BindingGroupType ->
- ModuleName ->
- [(Ident, Expr)] ->
- m [(Ident, (Expr, Type))]
-typesOf bindingGroupType moduleName vals = do
- tys <- fmap tidyUp . escalateWarningWhen isHoleError . liftUnifyWarnings replace $ do
- (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup (Just moduleName) vals
- ds1 <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict
- ds2 <- forM untyped $ \e -> typeForBindingGroupElement e dict untypedDict
- return (map (\x -> (False, x)) ds1 ++ map (\x -> (True, x)) ds2)
-
- forM tys $ \(shouldGeneralize, (ident, (val, ty))) -> do
- -- Replace type class dictionary placeholders with actual dictionaries
- (val', unsolved) <- replaceTypeClassDictionaries shouldGeneralize moduleName val
- let unsolvedTypeVars = nub $ unknownsInType ty
- -- Generalize and constrain the type
- let generalized = generalize unsolved ty
-
- when shouldGeneralize $ do
- -- Show the inferred type in a warning
- tell . errorMessage $ MissingTypeDeclaration ident generalized
- -- For non-recursive binding groups, can generalize over constraints.
- -- For recursive binding groups, we throw an error here for now.
- when (bindingGroupType == RecursiveBindingGroup && not (null unsolved))
- . throwError
- . errorMessage
- $ CannotGeneralizeRecursiveFunction ident generalized
- -- Make sure any unsolved type constraints only use type variables which appear
- -- unknown in the inferred type.
- forM_ unsolved $ \(_, con) -> do
- let constraintTypeVars = nub $ foldMap unknownsInType (constraintArgs con)
- when (any (`notElem` unsolvedTypeVars) constraintTypeVars) $
- throwError . errorMessage $ NoInstanceFound con
-
- -- Check skolem variables did not escape their scope
- skolemEscapeCheck val'
- -- Check rows do not contain duplicate labels
- checkDuplicateLabels val'
- return (ident, (foldr (Abs . Left . fst) val' unsolved, generalized))
+typesOf
+ :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+ => BindingGroupType
+ -> ModuleName
+ -> [(Ident, Expr)]
+ -> m [(Ident, (Expr, Type))]
+typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do
+ (tys, w) <- withoutWarnings . capturingSubstitution tidyUp $ do
+ (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup (Just moduleName) vals
+ ds1 <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict
+ ds2 <- forM untyped $ \e -> typeForBindingGroupElement e dict untypedDict
+ return (map (\x -> (False, x)) ds1 ++ map (\x -> (True, x)) ds2)
+
+ inferred <- forM tys $ \(shouldGeneralize, (ident, (val, ty))) -> do
+ -- Replace type class dictionary placeholders with actual dictionaries
+ (val', unsolved) <- replaceTypeClassDictionaries shouldGeneralize val
+ -- Generalize and constrain the type
+ currentSubst <- gets checkSubstitution
+ let ty' = substituteType currentSubst ty
+ unsolvedTypeVars = nub $ unknownsInType ty'
+ generalized = generalize unsolved ty'
+
+ when shouldGeneralize $ do
+ -- Show the inferred type in a warning
+ tell . errorMessage $ MissingTypeDeclaration ident generalized
+ -- For non-recursive binding groups, can generalize over constraints.
+ -- For recursive binding groups, we throw an error here for now.
+ when (bindingGroupType == RecursiveBindingGroup && not (null unsolved))
+ . throwError
+ . errorMessage
+ $ CannotGeneralizeRecursiveFunction ident generalized
+ -- Make sure any unsolved type constraints only use type variables which appear
+ -- unknown in the inferred type.
+ forM_ unsolved $ \(_, con) -> do
+ -- We need information about functional dependencies, since we allow
+ -- ambiguous types to be inferred if they can be solved by some functional
+ -- dependency.
+ let findClass = fromMaybe (internalError "entails: type class not found in environment") . M.lookup (constraintClass con)
+ TypeClassData{ typeClassDependencies } <- gets (findClass . typeClasses . checkEnv)
+ let solved = foldMap (S.fromList . fdDetermined) typeClassDependencies
+ let constraintTypeVars = nub . foldMap (unknownsInType . fst) . filter ((`notElem` solved) . snd) $ zip (constraintArgs con) [0..]
+ when (any (`notElem` unsolvedTypeVars) constraintTypeVars) $
+ throwError . onErrorMessages (replaceTypes currentSubst) . errorMessage $ NoInstanceFound con
+
+ -- Check skolem variables did not escape their scope
+ skolemEscapeCheck val'
+ -- Check rows do not contain duplicate labels
+ checkDuplicateLabels val'
+ return (ident, (foldr (Abs . Left . fst) val' unsolved, generalized))
+
+ -- Show warnings here, since types in wildcards might have been solved during
+ -- instance resolution (by functional dependencies).
+ finalSubst <- gets checkSubstitution
+ escalateWarningWhen isHoleError . tell . onErrorMessages (replaceTypes finalSubst) $ w
+
+ return inferred
where
+ replaceTypes subst = onTypesInErrorMessage (substituteType subst)
- -- | Generalize type vars using forall and add inferred constraints
- generalize unsolved = varIfUnknown . constrain unsolved
+ -- | Generalize type vars using forall and add inferred constraints
+ generalize unsolved = varIfUnknown . constrain unsolved
- -- | Add any unsolved constraints
- constrain [] = id
- constrain cs = ConstrainedType (map snd cs)
+ -- | Add any unsolved constraints
+ constrain [] = id
+ constrain cs = ConstrainedType (map snd cs)
- -- Apply the substitution that was returned from runUnify to both types and (type-annotated) values
- tidyUp (ts, sub) = map (\(b, (i, (val, ty))) -> (b, (i, (overTypes (substituteType sub) val, substituteType sub ty)))) ts
+ -- Apply the substitution that was returned from runUnify to both types and (type-annotated) values
+ tidyUp ts sub = map (\(b, (i, (val, ty))) -> (b, (i, (overTypes (substituteType sub) val, substituteType sub ty)))) ts
- -- Replace all the wildcards types with their inferred types
- replace sub = onTypesInErrorMessage (substituteType sub)
-
- isHoleError :: ErrorMessage -> Bool
- isHoleError (ErrorMessage _ HoleInferredType{}) = True
- isHoleError _ = False
+ isHoleError :: ErrorMessage -> Bool
+ isHoleError (ErrorMessage _ HoleInferredType{}) = True
+ isHoleError _ = False
type TypeData = M.Map (Qualified Ident) (Type, NameKind, NameVisibility)
@@ -148,7 +162,7 @@ typeDictionaryForBindingGroup moduleName vals = do
-- Make a map of names to the unification variables of untyped declarations
untypedDict = zip (map fst untyped) untypedNames
-- Create the dictionary of all name/type pairs, which will be added to the environment during type checking
- dict = M.fromList (map (\(ident, ty) -> ((Qualified moduleName ident), (ty, Private, Undefined))) $ typedDict ++ untypedDict)
+ dict = M.fromList (map (\(ident, ty) -> (Qualified moduleName ident, (ty, Private, Undefined))) $ typedDict ++ untypedDict)
return (untyped, typed, dict, untypedDict)
checkTypedBindingGroupElement
@@ -278,7 +292,7 @@ infer' (Abs (Left arg) ret) = do
infer' (Abs (Right _) _) = internalError "Binder was not desugared"
infer' (App f arg) = do
f'@(TypedValue _ _ ft) <- infer f
- (ret, app) <- checkFunctionApplication f' ft arg Nothing
+ (ret, app) <- checkFunctionApplication f' ft arg
return $ TypedValue True app ret
infer' (Var var) = do
checkVisibility var
@@ -311,7 +325,7 @@ infer' (IfThenElse cond th el) = do
infer' (Let ds val) = do
(ds', val'@(TypedValue _ _ valTy)) <- inferLetBinding [] ds val infer
return $ TypedValue True (Let ds' val') valTy
-infer' (SuperClassDictionary className tys) = do
+infer' (DeferredDictionary className tys) = do
dicts <- getTypeClassDictionaries
hints <- gets checkHints
return $ TypeClassDictionary (Constraint className tys Nothing) dicts hints
@@ -526,26 +540,6 @@ check' val t@(ConstrainedType constraints ty) = do
dicts <- join <$> zipWithM (newDictionaries []) (map (Qualified Nothing) dictNames) constraints
val' <- withBindingGroupVisible $ withTypeClassDictionaries dicts $ check val ty
return $ TypedValue True (foldr (Abs . Left) val' dictNames) t
- where
- -- | Add a dictionary for the constraint to the scope, and dictionaries
- -- for all implied superclass instances.
- newDictionaries
- :: [(Qualified (ProperName 'ClassName), Integer)]
- -> Qualified Ident
- -> Constraint
- -> m [TypeClassDictionaryInScope]
- newDictionaries path name (Constraint className instanceTy _) = do
- tcs <- gets (typeClasses . checkEnv)
- let (args, _, superclasses) = fromMaybe (internalError "newDictionaries: type class lookup failed") $ M.lookup className tcs
- supDicts <- join <$> zipWithM (\(Constraint supName supArgs _) index ->
- newDictionaries ((supName, index) : path)
- name
- (Constraint supName (instantiateSuperclass (map fst args) supArgs instanceTy) Nothing)
- ) superclasses [0..]
- 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 u@(TUnknown _) = do
val'@(TypedValue _ _ ty) <- infer val
-- Don't unify an unknown with an inferred polytype
@@ -573,8 +567,11 @@ check' (Abs (Left arg) ret) ty@(TypeApp (TypeApp t argTy) retTy) = do
check' (Abs (Right _) _) _ = internalError "Binder was not desugared"
check' (App f arg) ret = do
f'@(TypedValue _ _ ft) <- infer f
- (_, app) <- checkFunctionApplication f' ft arg (Just ret)
- return $ TypedValue True app ret
+ (retTy, app) <- checkFunctionApplication f' ft arg
+ v' <- subsumes (Just app) retTy ret
+ case v' of
+ Nothing -> internalError "check: unable to check the subsumes relation."
+ Just app' -> return $ TypedValue True app' ret
check' v@(Var var) ty = do
checkVisibility var
repl <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< lookupVariable $ var
@@ -583,7 +580,7 @@ check' v@(Var var) ty = do
case v' of
Nothing -> internalError "check: unable to check the subsumes relation."
Just v'' -> return $ TypedValue True v'' ty'
-check' (SuperClassDictionary className tys) _ = do
+check' (DeferredDictionary className tys) _ = do
{-
-- Here, we replace a placeholder for a superclass dictionary with a regular
-- TypeClassDictionary placeholder. The reason we do this is that it is necessary to have the
@@ -698,55 +695,64 @@ checkProperties expr ps row lax = let (ts, r') = rowToList row in go ps ts r' wh
return $ (p, v') : ps''
go _ _ _ = throwError . errorMessage $ ExprDoesNotHaveType expr (TypeApp tyRecord row)
--- | Check the type of a function application, rethrowing errors to provide a better error message
-checkFunctionApplication ::
- (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
- Expr ->
- Type ->
- Expr ->
- Maybe Type ->
- m (Type, Expr)
-checkFunctionApplication fn fnTy arg ret = withErrorMessageHint (ErrorInApplication fn fnTy arg) $ do
+-- | Check the type of a function application, rethrowing errors to provide a better error message.
+--
+-- This judgment takes three inputs:
+--
+-- * The expression of the function we are applying
+-- * The type of that function
+-- * The expression we are applying it to
+--
+-- and synthesizes two outputs:
+--
+-- * The return type
+-- * The elaborated expression for the function application (since we might need to
+-- insert type class dictionaries, etc.)
+checkFunctionApplication
+ :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+ => Expr
+ -- ^ The function expression
+ -> Type
+ -- ^ The type of the function
+ -> Expr
+ -- ^ The argument expression
+ -> m (Type, Expr)
+ -- ^ The result type, and the elaborated term
+checkFunctionApplication fn fnTy arg = withErrorMessageHint (ErrorInApplication fn fnTy arg) $ do
subst <- gets checkSubstitution
- checkFunctionApplication' fn (substituteType subst fnTy) arg (substituteType subst <$> ret)
+ checkFunctionApplication' fn (substituteType subst fnTy) arg
-- | Check the type of a function application
-checkFunctionApplication' ::
- (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
- Expr ->
- Type ->
- Expr ->
- Maybe Type ->
- m (Type, Expr)
-checkFunctionApplication' fn (TypeApp (TypeApp tyFunction' argTy) retTy) arg ret = do
+checkFunctionApplication'
+ :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+ => Expr
+ -> Type
+ -> Expr
+ -> m (Type, Expr)
+checkFunctionApplication' fn (TypeApp (TypeApp tyFunction' argTy) retTy) arg = do
unifyTypes tyFunction' tyFunction
arg' <- check arg argTy
- case ret of
- Nothing -> return (retTy, App fn arg')
- Just ret' -> do
- Just app' <- subsumes (Just (App fn arg')) retTy ret'
- return (retTy, app')
-checkFunctionApplication' fn (ForAll ident ty _) arg ret = do
+ return (retTy, App fn arg')
+checkFunctionApplication' fn (ForAll ident ty _) arg = do
replaced <- replaceVarWithUnknown ident ty
- checkFunctionApplication fn replaced arg ret
-checkFunctionApplication' fn u@(TUnknown _) arg ret = do
+ checkFunctionApplication fn replaced arg
+checkFunctionApplication' fn (KindedType ty _) arg =
+ checkFunctionApplication fn ty arg
+checkFunctionApplication' fn (ConstrainedType constraints fnTy) arg = do
+ dicts <- getTypeClassDictionaries
+ hints <- gets checkHints
+ checkFunctionApplication' (foldl App fn (map (\cs -> TypeClassDictionary cs dicts hints) constraints)) fnTy arg
+checkFunctionApplication' fn fnTy dict@TypeClassDictionary{} =
+ return (fnTy, App fn dict)
+checkFunctionApplication' fn u arg = do
arg' <- do
TypedValue _ arg' t <- infer arg
(arg'', t') <- instantiatePolyTypeWithUnknowns arg' t
return $ TypedValue True arg'' t'
let ty = (\(TypedValue _ _ t) -> t) arg'
- ret' <- maybe freshType return ret
- unifyTypes u (function ty ret')
- return (ret', App fn arg')
-checkFunctionApplication' fn (KindedType ty _) arg ret =
- checkFunctionApplication fn ty arg ret
-checkFunctionApplication' fn (ConstrainedType constraints fnTy) arg ret = do
- dicts <- getTypeClassDictionaries
- hints <- gets checkHints
- checkFunctionApplication' (foldl App fn (map (\cs -> TypeClassDictionary cs dicts hints) constraints)) fnTy arg ret
-checkFunctionApplication' fn fnTy dict@TypeClassDictionary{} _ =
- return (fnTy, App fn dict)
-checkFunctionApplication' _ fnTy arg _ = throwError . errorMessage $ CannotApplyFunction fnTy arg
+ ret <- freshType
+ unifyTypes u (function ty ret)
+ return (ret, App fn arg')
-- |
-- Ensure a set of property names and value does not contain duplicate labels
diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs
index 86e2c0a..5d0584b 100644
--- a/src/Language/PureScript/TypeChecker/Unify.hs
+++ b/src/Language/PureScript/TypeChecker/Unify.hs
@@ -10,7 +10,6 @@ module Language.PureScript.TypeChecker.Unify
, unknownsInType
, unifyTypes
, unifyRows
- , unifiesWith
, replaceVarWithUnknown
, replaceTypeWildcards
, varIfUnknown
@@ -102,6 +101,7 @@ unifyTypes t1 t2 = do
unifyTypes' (TypeVar v1) (TypeVar v2) | v1 == v2 = return ()
unifyTypes' ty1@(TypeConstructor c1) ty2@(TypeConstructor c2) =
guardWith (errorMessage (TypesDoNotUnify ty1 ty2)) (c1 == c2)
+ unifyTypes' (TypeLevelString s1) (TypeLevelString s2) | s1 == s2 = return ()
unifyTypes' (TypeApp t3 t4) (TypeApp t5 t6) = do
t3 `unifyTypes` t5
t4 `unifyTypes` t6
@@ -153,36 +153,6 @@ unifyRows r1 r2 =
throwError . errorMessage $ TypesDoNotUnify r1 r2
-- |
--- Check that two types unify
---
-unifiesWith :: Type -> Type -> Bool
-unifiesWith (TUnknown u1) (TUnknown u2) = u1 == u2
-unifiesWith (Skolem _ s1 _ _) (Skolem _ s2 _ _) = s1 == s2
-unifiesWith (TypeVar v1) (TypeVar v2) = v1 == v2
-unifiesWith (TypeLevelString s1) (TypeLevelString s2) = s1 == s2
-unifiesWith (TypeConstructor c1) (TypeConstructor c2) = c1 == c2
-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 (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 _) _ (TUnknown _) = True
- go _ _ _ _ = False
-unifiesWith _ _ = False
-
--- |
-- Replace a single type variable with a new unification variable
--
replaceVarWithUnknown :: (MonadState CheckState m) => String -> Type -> m Type
diff --git a/src/Language/PureScript/TypeClassDictionaries.hs b/src/Language/PureScript/TypeClassDictionaries.hs
index 5d2af00..59becfd 100644
--- a/src/Language/PureScript/TypeClassDictionaries.hs
+++ b/src/Language/PureScript/TypeClassDictionaries.hs
@@ -22,26 +22,3 @@ data TypeClassDictionaryInScope
, tcdDependencies :: Maybe [Constraint]
}
deriving (Show)
-
--- |
--- A simplified representation of expressions which are used to represent type
--- class dictionaries at runtime, which can be compared for equality
---
-data DictionaryValue
- -- |
- -- A dictionary which is brought into scope by a local constraint
- --
- = LocalDictionaryValue (Qualified Ident)
- -- |
- -- A dictionary which is brought into scope by an instance declaration
- --
- | GlobalDictionaryValue (Qualified Ident)
- -- |
- -- A dictionary which depends on other dictionaries
- --
- | DependentDictionaryValue (Qualified Ident) [DictionaryValue]
- -- |
- -- A subclass dictionary
- --
- | SubclassDictionaryValue DictionaryValue (Qualified (ProperName 'ClassName)) Integer
- deriving (Show, Ord, Eq)
diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs
index f9d7a60..a38300c 100644
--- a/src/Language/PureScript/Types.hs
+++ b/src/Language/PureScript/Types.hs
@@ -257,8 +257,8 @@ everywhereOnTypesTopDown f = go . f
go (PrettyPrintFunction t1 t2) = PrettyPrintFunction (go (f t1)) (go (f t2))
go (PrettyPrintObject t) = PrettyPrintObject (go (f t))
go (PrettyPrintForAll args t) = PrettyPrintForAll args (go (f t))
- go (BinaryNoParensType t1 t2 t3) = BinaryNoParensType (f (go t1)) (f (go t2)) (f (go t3))
- go (ParensInType t) = ParensInType (f (go t))
+ go (BinaryNoParensType t1 t2 t3) = BinaryNoParensType (go (f t1)) (go (f t2)) (go (f t3))
+ go (ParensInType t) = ParensInType (go (f t))
go other = f other
everywhereOnTypesM :: Monad m => (Type -> m Type) -> Type -> m Type
diff --git a/stack.yaml b/stack.yaml
index e40e931..e86fae5 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -1,5 +1,12 @@
-resolver: lts-6.9
+resolver: lts-6.13
packages:
- '.'
-extra-deps: []
-flags: {}
+extra-deps:
+- aeson-1.0.0.0
+- http-client-0.5.1
+- http-client-tls-0.3.0
+- pipes-http-1.0.4
+- semigroups-0.18.2
+flags:
+ semigroups:
+ bytestring-builder: false
diff --git a/tests/Language/PureScript/Ide/ImportsSpec.hs b/tests/Language/PureScript/Ide/ImportsSpec.hs
index 5680020..7cea546 100644
--- a/tests/Language/PureScript/Ide/ImportsSpec.hs
+++ b/tests/Language/PureScript/Ide/ImportsSpec.hs
@@ -70,7 +70,7 @@ spec = do
addValueImport i mn is =
prettyPrintImportSection (addExplicitImport' (IdeValue (P.Ident i) wildcard) mn is)
addOpImport op mn is =
- prettyPrintImportSection (addExplicitImport' (IdeValueOperator op "" 2 P.Infix) mn is)
+ prettyPrintImportSection (addExplicitImport' (IdeValueOperator op (P.Qualified Nothing (Left (P.Ident ""))) 2 P.Infix Nothing) mn is)
addDtorImport i t mn is =
prettyPrintImportSection (addExplicitImport' (IdeDataConstructor (P.ProperName i) t wildcard) mn is)
it "adds an implicit unqualified import" $
diff --git a/tests/Language/PureScript/Ide/Integration.hs b/tests/Language/PureScript/Ide/Integration.hs
index f733959..92569d0 100644
--- a/tests/Language/PureScript/Ide/Integration.hs
+++ b/tests/Language/PureScript/Ide/Integration.hs
@@ -37,13 +37,11 @@ module Language.PureScript.Ide.Integration
, getFlexCompletions
, getFlexCompletionsInModule
, getType
- , getInfo
, rebuildModule
, reset
-- checking results
, resultIsSuccess
, parseCompletions
- , parseInfo
, parseTextResult
) where
@@ -95,7 +93,7 @@ compileTestProject = do
pdir <- projectDirectory
(_, _, _, procHandle) <- createProcess $
(shell . toS $ "psc " <> fileGlob) { cwd = Just pdir }
- r <- tryNTimes 5 (getProcessExitCode procHandle)
+ r <- tryNTimes 10 (getProcessExitCode procHandle)
pure (fromMaybe False (isSuccess <$> r))
tryNTimes :: Int -> IO (Maybe a) -> IO (Maybe a)
@@ -158,18 +156,15 @@ loadModules = sendCommand . load
loadAll :: IO Text
loadAll = sendCommand (load [])
-getFlexCompletions :: Text -> IO [(Text, Text, Text)]
+getFlexCompletions :: Text -> IO [(Text, Text, Text, Maybe P.SourceSpan)]
getFlexCompletions q = parseCompletions <$> sendCommand (completion [] (Just (flexMatcher q)) Nothing)
-getFlexCompletionsInModule :: Text -> Text -> IO [(Text, Text, Text)]
+getFlexCompletionsInModule :: Text -> Text -> IO [(Text, Text, Text, Maybe P.SourceSpan)]
getFlexCompletionsInModule q m = parseCompletions <$> sendCommand (completion [] (Just (flexMatcher q)) (Just m))
-getType :: Text -> IO [(Text, Text, Text)]
+getType :: Text -> IO [(Text, Text, Text, Maybe P.SourceSpan)]
getType q = parseCompletions <$> sendCommand (typeC q [])
-getInfo :: Text -> IO [P.SourceSpan]
-getInfo q = parseInfo <$> sendCommand (typeC q [])
-
addImport :: Text -> FilePath -> FilePath -> IO Text
addImport identifier fp outfp = sendCommand (addImportC identifier fp outfp)
@@ -254,17 +249,14 @@ withResult p v = do
Left err -> pure (Left err)
Right res -> Right <$> p res
-completionParser :: Value -> Parser [(Text, Text, Text)]
+completionParser :: Value -> Parser [(Text, Text, Text, Maybe P.SourceSpan)]
completionParser = withArray "res" $ \cs ->
mapM (withObject "completion" $ \o -> do
ident <- o .: "identifier"
module' <- o .: "module"
ty <- o .: "type"
- pure (module', ident, ty)) (V.toList cs)
-
-infoParser :: Value -> Parser [P.SourceSpan]
-infoParser = withArray "res" $ \cs ->
- mapM (withObject "info" $ \o -> o .: "definedAt") (V.toList cs)
+ ss <- o .: "definedAt"
+ pure (module', ident, ty, ss)) (V.toList cs)
valueFromText :: Text -> Value
valueFromText = fromJust . decode . toS
@@ -272,14 +264,10 @@ valueFromText = fromJust . decode . toS
resultIsSuccess :: Text -> Bool
resultIsSuccess = isRight . join . first toS . parseEither unwrapResult . valueFromText
-parseCompletions :: Text -> [(Text, Text, Text)]
+parseCompletions :: Text -> [(Text, Text, Text, Maybe P.SourceSpan)]
parseCompletions s =
fromJust $ join (rightToMaybe <$> parseMaybe (withResult completionParser) (valueFromText s))
-parseInfo :: Text -> [P.SourceSpan]
-parseInfo s =
- fromJust $ join (rightToMaybe <$> parseMaybe (withResult infoParser) (valueFromText s))
-
parseTextResult :: Text -> Text
parseTextResult s =
fromJust $ join (rightToMaybe <$> parseMaybe (withResult (withText "tr" pure)) (valueFromText s))
diff --git a/tests/Language/PureScript/Ide/MatcherSpec.hs b/tests/Language/PureScript/Ide/MatcherSpec.hs
index 04d0ae5..6a8b2df 100644
--- a/tests/Language/PureScript/Ide/MatcherSpec.hs
+++ b/tests/Language/PureScript/Ide/MatcherSpec.hs
@@ -9,20 +9,21 @@ import qualified Language.PureScript as P
import Language.PureScript.Ide.Integration
import Language.PureScript.Ide.Matcher
import Language.PureScript.Ide.Types
+import Language.PureScript.Ide.Util
import Test.Hspec
-value :: Text -> IdeDeclaration
-value s = IdeValue (P.Ident (toS s)) P.REmpty
+value :: Text -> IdeDeclarationAnn
+value s = withEmptyAnn (IdeValue (P.Ident (toS s)) P.REmpty)
-firstResult, secondResult, fiult :: Match IdeDeclaration
+firstResult, secondResult, fiult :: Match IdeDeclarationAnn
firstResult = Match (P.moduleNameFromString "Match", value "firstResult")
secondResult = Match (P.moduleNameFromString "Match", value "secondResult")
fiult = Match (P.moduleNameFromString "Match", value "fiult")
-completions :: [Match IdeDeclaration]
+completions :: [Match IdeDeclarationAnn]
completions = [firstResult, secondResult, fiult]
-runFlex :: Text -> [Match IdeDeclaration]
+runFlex :: Text -> [Match IdeDeclarationAnn]
runFlex s = runMatcher (flexMatcher s) completions
setup :: IO ()
@@ -43,5 +44,6 @@ spec = do
cs <- getFlexCompletions ""
cs `shouldBe` []
it "matches on equality" $ do
- cs <- getFlexCompletions "const"
- cs `shouldBe` [("MatcherSpec", "const", "forall a b. a -> b -> a")]
+ -- ignore any position information
+ (m, i, t, _) : _ <- getFlexCompletions "const"
+ (m, i, t) `shouldBe` ("MatcherSpec", "const", "forall a b. a -> b -> a")
diff --git a/tests/Language/PureScript/Ide/ReexportsSpec.hs b/tests/Language/PureScript/Ide/ReexportsSpec.hs
index c9a59ff..f0e03c4 100644
--- a/tests/Language/PureScript/Ide/ReexportsSpec.hs
+++ b/tests/Language/PureScript/Ide/ReexportsSpec.hs
@@ -2,7 +2,7 @@
{-# LANGUAGE NoImplicitPrelude #-}
module Language.PureScript.Ide.ReexportsSpec where
-import qualified Prelude as Prelude
+import qualified Prelude
import Protolude
import qualified Data.Map as Map
diff --git a/tests/Language/PureScript/Ide/SourceFile/IntegrationSpec.hs b/tests/Language/PureScript/Ide/SourceFile/IntegrationSpec.hs
index a16a9b5..4fd6056 100644
--- a/tests/Language/PureScript/Ide/SourceFile/IntegrationSpec.hs
+++ b/tests/Language/PureScript/Ide/SourceFile/IntegrationSpec.hs
@@ -14,23 +14,28 @@ setup :: IO ()
setup = void (Integration.reset *> Integration.loadAll)
spec :: Spec
-spec = beforeAll_ setup $ do
+spec = beforeAll_ setup $
describe "Sourcefile Integration" $ do
- it "finds a value declaration" $ do
+ it "finds a value declaration" $
testCase "sfValue" (3, 1)
- it "finds a type declaration" $ do
+ it "finds a type declaration" $
testCase "SFType" (5, 1)
- it "finds a data declaration" $ do
+ it "finds a data declaration" $
testCase "SFData" (7, 1)
- it "finds a data constructor" $ do
+ it "finds a data constructor" $
testCase "SFOne" (7, 1)
- it "finds a typeclass" $ do
+ it "finds a typeclass" $
testCase "SFClass" (9, 1)
- it "finds a typeclass member" $ do
+ it "finds a typeclass member" $
testCase "sfShow" (10, 3)
testCase :: Text -> (Int, Int) -> IO ()
testCase s (x, y) = do
- (P.SourceSpan f (P.SourcePos l c) _):_ <- Integration.getInfo s
+ P.SourceSpan f (P.SourcePos l c) _ <- getLocation s
toS f `shouldSatisfy` T.isSuffixOf "SourceFileSpec.purs"
(l, c) `shouldBe` (x, y)
+
+getLocation :: Text -> IO P.SourceSpan
+getLocation s = do
+ (_, _, _, Just location) : _ <- Integration.getType s
+ pure location
diff --git a/tests/Language/PureScript/Ide/SourceFileSpec.hs b/tests/Language/PureScript/Ide/SourceFileSpec.hs
index 26a2dba..ac53dde 100644
--- a/tests/Language/PureScript/Ide/SourceFileSpec.hs
+++ b/tests/Language/PureScript/Ide/SourceFileSpec.hs
@@ -13,11 +13,12 @@ span0 = P.SourceSpan "ModuleLevel" (P.SourcePos 0 0) (P.SourcePos 1 1)
span1 = P.SourceSpan "" (P.SourcePos 1 1) (P.SourcePos 2 2)
span2 = P.SourceSpan "" (P.SourcePos 2 2) (P.SourcePos 3 3)
-value1, synonym1, class1, class2, data1, data2, foreign1, foreign2, member1 :: P.Declaration
+typeAnnotation1, value1, synonym1, class1, class2, data1, data2, foreign1, foreign2, member1 :: P.Declaration
+typeAnnotation1 = P.TypeDeclaration (P.Ident "value1") P.REmpty
value1 = P.ValueDeclaration (P.Ident "value1") P.Public [] (Left [])
synonym1 = P.TypeSynonymDeclaration (P.ProperName "Synonym1") [] P.REmpty
-class1 = P.TypeClassDeclaration (P.ProperName "Class1") [] [] []
-class2 = P.TypeClassDeclaration (P.ProperName "Class2") [] []
+class1 = P.TypeClassDeclaration (P.ProperName "Class1") [] [] [] []
+class2 = P.TypeClassDeclaration (P.ProperName "Class2") [] [] []
[P.PositionedDeclaration span2 [] member1]
data1 = P.DataDeclaration P.Newtype (P.ProperName "Data1") [] []
data2 = P.DataDeclaration P.Data (P.ProperName "Data2") [] [(P.ProperName "Cons1", [])]
@@ -44,3 +45,6 @@ spec = do
extractSpans span0 (P.PositionedDeclaration span1 [] foreign1) `shouldBe` [(Left "foreign1", span1)]
it "extracts a span for a data foreign declaration" $
extractSpans span0 (P.PositionedDeclaration span1 [] foreign2) `shouldBe` [(Right "Foreign2", span1)]
+ describe "Type annotations" $ do
+ it "extracts a type annotation" $
+ extractTypeAnnotations [typeAnnotation1] `shouldBe` [(P.Ident "value1", P.REmpty)]
diff --git a/tests/Language/PureScript/Ide/StateSpec.hs b/tests/Language/PureScript/Ide/StateSpec.hs
new file mode 100644
index 0000000..87b50d2
--- /dev/null
+++ b/tests/Language/PureScript/Ide/StateSpec.hs
@@ -0,0 +1,51 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+module Language.PureScript.Ide.StateSpec where
+
+import Protolude
+import Language.PureScript.Ide.Types
+import Language.PureScript.Ide.State
+import qualified Language.PureScript as P
+import Test.Hspec
+import qualified Data.Map as Map
+
+valueOperator :: Maybe P.Type -> IdeDeclarationAnn
+valueOperator =
+ d . IdeValueOperator (P.OpName "<$>") (P.Qualified (Just (mn "Test")) (Left (P.Ident "function"))) 2 P.Infix
+
+ctorOperator :: Maybe P.Type -> IdeDeclarationAnn
+ctorOperator =
+ d . IdeValueOperator (P.OpName ":") (P.Qualified (Just (mn "Test")) (Right (P.ProperName "Cons"))) 2 P.Infix
+
+typeOperator :: Maybe P.Kind -> IdeDeclarationAnn
+typeOperator =
+ d . IdeTypeOperator (P.OpName ":") (P.Qualified (Just (mn "Test")) (P.ProperName "List")) 2 P.Infix
+
+testModule :: Module
+testModule = (mn "Test", [ d (IdeValue (P.Ident "function") P.REmpty)
+ , d (IdeDataConstructor (P.ProperName "Cons") (P.ProperName "List") (P.REmpty))
+ , d (IdeType (P.ProperName "List") P.Star)
+ , valueOperator Nothing
+ , ctorOperator Nothing
+ , typeOperator Nothing
+ ])
+
+d :: IdeDeclaration -> IdeDeclarationAnn
+d = IdeDeclarationAnn emptyAnn
+
+mn :: Text -> P.ModuleName
+mn = P.moduleNameFromString . toS
+
+testState :: Map P.ModuleName [IdeDeclarationAnn]
+testState = Map.fromList
+ [ testModule
+ ]
+
+spec :: Spec
+spec = describe "resolving operators" $ do
+ it "resolves the type for a value operator" $
+ resolveOperatorsForModule testState (snd testModule) `shouldSatisfy` elem (valueOperator (Just P.REmpty))
+ it "resolves the type for a constructor operator" $
+ resolveOperatorsForModule testState (snd testModule) `shouldSatisfy` elem (ctorOperator (Just P.REmpty))
+ it "resolves the kind for a type operator" $
+ resolveOperatorsForModule testState (snd testModule) `shouldSatisfy` elem (typeOperator (Just P.Star))
diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs
index 6a645c1..1d56293 100644
--- a/tests/TestDocs.hs
+++ b/tests/TestDocs.hs
@@ -278,6 +278,7 @@ testCases =
[ ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "explicit" (ShowFn (hasTypeVar "something"))
, ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "anInt" (ShowFn (P.tyInt ==))
, ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "aNumber" (ShowFn (P.tyNumber ==))
+ , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "nestedForAll" (renderedType "forall c. (forall a b. c)")
])
, ("ConstrainedArgument",
diff --git a/tests/TestPscIde.hs b/tests/TestPscIde.hs
index d90b9d2..bf9e62c 100644
--- a/tests/TestPscIde.hs
+++ b/tests/TestPscIde.hs
@@ -11,4 +11,5 @@ main = do
s <- compileTestProject
unless s $ fail "Failed to compile .purs sources"
+ quitServer -- shuts down any left over server (primarily happens during development)
withServer (hspec PscIdeSpec.spec)
diff --git a/tests/TestPsci.hs b/tests/TestPsci.hs
index 1047607..19eb961 100644
--- a/tests/TestPsci.hs
+++ b/tests/TestPsci.hs
@@ -102,7 +102,6 @@ completionTestData =
, ("ST.new", ["ST.newSTRef"])
, ("Control.Monad.ST.new", ["Control.Monad.ST.newSTRef"])
]
- where
assertCompletedOk :: (String, [String]) -> Assertion
assertCompletedOk (line, expecteds) = do
diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs
index 49e9c2a..f1a2522 100644
--- a/tests/TestUtils.hs
+++ b/tests/TestUtils.hs
@@ -75,6 +75,8 @@ supportModules =
, "Data.Function"
, "Data.Functor"
, "Data.HeytingAlgebra"
+ , "Data.NaturalTransformation"
+ , "Data.Newtype"
, "Data.Ord.Unsafe"
, "Data.Ord"
, "Data.Ordering"
diff --git a/tests/support/bower.json b/tests/support/bower.json
index ca9d449..7bbaebd 100644
--- a/tests/support/bower.json
+++ b/tests/support/bower.json
@@ -5,8 +5,9 @@
"purescript-console": "1.0.0-rc.1",
"purescript-eff": "1.0.0-rc.1",
"purescript-functions": "1.0.0-rc.1",
- "purescript-prelude": "1.0.0-rc.3",
+ "purescript-prelude": "1.1.0",
"purescript-st": "1.0.0-rc.1",
- "purescript-partial": "1.1.2"
+ "purescript-partial": "1.1.2",
+ "purescript-newtype": "0.1.0"
}
}