git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Merge remote-tracking branch 'upstream/master' into pure11
64e8cd9Andy Arvanitis
CONTRIBUTING.md+2−3
@@ -11,9 +11,8 @@ If you would like to contribute, please consider the issues in the current miles
11Please follow the following guidelines:
11Please follow the following guidelines:
12
12
13- Add at least a test to `examples/passing/` and possibly to `examples/failing`.
13- Add at least a test to `examples/passing/` and possibly to `examples/failing`.
14−- Build the binaries and libs with `cabal build`
14+- Build the binaries and libs with `stack build`
15−- Install the binaries and libs with `cabal install`.
16−- 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.
15+- Run the test suite with `stack test`. You will need `npm` and `node` on your PATH to run the tests.
17- Build the core libraries by running the script in `core-tests`.
16- Build the core libraries by running the script in `core-tests`.
18
17
19## Code Review
18## Code Review
CONTRIBUTORS.md+6
@@ -5,6 +5,7 @@ This file lists the contributors to the PureScript compiler project, and the ter
5### Individuals
5### Individuals
6
6
7- [@5outh](https://github.com/5outh) (Benjamin Kovach) - My existing contributions and all future contributions until further notice are Copyright Benjamin Kovach, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license.
7- [@5outh](https://github.com/5outh) (Benjamin Kovach) - My existing contributions and all future contributions until further notice are Copyright Benjamin Kovach, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license.
8+- [@andreypopp](https://github.com/andreypopp) (Andrey Popp) My existing contributions and all future contributions until further notice are Copyright Andrey Popp, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license.
8- [@andyarvanitis](https://github.com/andyarvanitis) (Andy Arvanitis) My existing contributions and all future contributions until further notice are Copyright Andy Arvanitis, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
9- [@andyarvanitis](https://github.com/andyarvanitis) (Andy Arvanitis) My existing contributions and all future contributions until further notice are Copyright Andy Arvanitis, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
9- [@anthok88](https://github.com/anthoq88) - My existing contributions and all future contributions until further notice are Copyright anthoq88, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license
10- [@anthok88](https://github.com/anthoq88) - My existing contributions and all future contributions until further notice are Copyright anthoq88, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license
10- [@ardumont](https://github.com/ardumont) (Antoine R. Dumont) My existing contributions and all future contributions until further notice are Copyright Antoine R. Dumont, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
11- [@ardumont](https://github.com/ardumont) (Antoine R. Dumont) My existing contributions and all future contributions until further notice are Copyright Antoine R. Dumont, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
@@ -16,6 +17,8 @@ This file lists the contributors to the PureScript compiler project, and the ter
16- [@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).
17- [@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).
17- [@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).
18- [@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).
18- [@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).
19- [@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).
20+- [@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).
21+- [@chrisdone](https://github.com/chrisdone) (Chris Done) - My existing contributions and all future contributions until further notice are Copyright Chris Done, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license.
19- [@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).
22- [@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).
20- [@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).
23- [@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).
21- [@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).
24- [@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).
@@ -28,8 +31,10 @@ This file lists the contributors to the PureScript compiler project, and the ter
28- [@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).
31- [@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).
29- [@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).
32- [@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).
30- [@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).
33- [@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).
34+- [@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).
31- [@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).
35- [@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).
32- [@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).
36- [@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).
37+- [@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).
33- [@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
38- [@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
34- [@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).
39- [@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).
35- [@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).
40- [@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).
@@ -61,6 +66,7 @@ This file lists the contributors to the PureScript compiler project, and the ter
61- [@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).
66- [@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).
62- [@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).
67- [@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).
63- [@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.
68- [@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.
69+- [@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).
64- [@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).
70- [@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).
65- [@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).
71- [@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).
66- [@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).
72- [@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).
INSTALL.md+6−3
@@ -27,16 +27,19 @@ GHC 7.10.1 or newer is required to compile from source. The easiest way is to
27use stack:
27use stack:
28
28
29```
29```
30−$ stack install --resolver=nightly purescript
30+$ stack update
31+$ stack unpack purescript
32+$ cd purescript-x.y.z # (replace x.y.z with whichever version you just downloaded)
33+$ stack install
31```
34```
32
35
33This will then copy the compiler and utilities into `~/.local/bin`.
36This will then copy the compiler and utilities into `~/.local/bin`.
34
37
35
38
36−If you don't have stack installed yet there are install instructions
39+If you don't have stack installed, there are install instructions
37[here](https://github.com/commercialhaskell/stack/blob/master/doc/install_and_upgrade.md).
40[here](https://github.com/commercialhaskell/stack/blob/master/doc/install_and_upgrade.md).
38
41
39−If you don't have ghc installed yet, stack will prompt you to run `stack setup`
42+If you don't have ghc installed, stack will prompt you to run `stack setup`
40which will install ghc for you.
43which will install ghc for you.
41
44
42## The "curses" library
45## The "curses" library
LICENSE+810−100
@@ -23,10 +23,13 @@ CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
23PureScript uses the following Haskell library packages. Their license files follow.
23PureScript uses the following Haskell library packages. Their license files follow.
24
24
25 Glob
25 Glob
26+ SHA
26 aeson
27 aeson
27 aeson-better-errors
28 aeson-better-errors
29+ aeson-pretty
28 ansi-terminal
30 ansi-terminal
29 ansi-wl-pprint
31 ansi-wl-pprint
32+ appar
30 array
33 array
31 asn1-encoding
34 asn1-encoding
32 asn1-parse
35 asn1-parse
@@ -39,14 +42,18 @@ PureScript uses the following Haskell library packages. Their license files foll
39 base64-bytestring
42 base64-bytestring
40 binary
43 binary
41 blaze-builder
44 blaze-builder
45+ blaze-html
46+ blaze-markup
42 bower-json
47 bower-json
43 boxes
48 boxes
44 byteable
49 byteable
50+ byteorder
45 bytestring
51 bytestring
46 bytestring-builder
52 bytestring-builder
47 case-insensitive
53 case-insensitive
48 cereal
54 cereal
49 clock
55 clock
56+ cmdargs
50 conduit
57 conduit
51 conduit-extra
58 conduit-extra
52 connection
59 connection
@@ -54,25 +61,32 @@ PureScript uses the following Haskell library packages. Their license files foll
54 cookie
61 cookie
55 cryptonite
62 cryptonite
56 data-default-class
63 data-default-class
64+ data-ordlist
57 deepseq
65 deepseq
58 directory
66 directory
59 dlist
67 dlist
60 easy-file
68 easy-file
61 edit-distance
69 edit-distance
70+ entropy
62 exceptions
71 exceptions
63 fail
72 fail
64 fast-logger
73 fast-logger
74+ file-embed
65 filepath
75 filepath
66 fsnotify
76 fsnotify
67 ghc-prim
77 ghc-prim
68 hashable
78 hashable
69 haskeline
79 haskeline
70− hinotify
80+ hex
81+ hfsevents
71 hourglass
82 hourglass
72 http-client
83 http-client
73 http-client-tls
84 http-client-tls
85+ http-date
74 http-types
86 http-types
87+ http2
75 integer-gmp
88 integer-gmp
89+ iproute
76 language-javascript
90 language-javascript
77 lifted-base
91 lifted-base
78 memory
92 memory
@@ -96,6 +110,7 @@ PureScript uses the following Haskell library packages. Their license files foll
96 primitive
110 primitive
97 process
111 process
98 protolude
112 protolude
113+ psqueues
99 random
114 random
100 regex-base
115 regex-base
101 regex-tdfa
116 regex-tdfa
@@ -103,6 +118,7 @@ PureScript uses the following Haskell library packages. Their license files foll
103 safe
118 safe
104 scientific
119 scientific
105 semigroups
120 semigroups
121+ simple-sendfile
106 socks
122 socks
107 sourcemap
123 sourcemap
108 spdx
124 spdx
@@ -110,13 +126,14 @@ PureScript uses the following Haskell library packages. Their license files foll
110 stm
126 stm
111 stm-chans
127 stm-chans
112 streaming-commons
128 streaming-commons
113− string-conv
129+ stringsearch
114 syb
130 syb
115 tagged
131 tagged
116 template-haskell
132 template-haskell
117 terminfo
133 terminfo
118 text
134 text
119 time
135 time
136+ time-locale-compat
120 tls
137 tls
121 transformers
138 transformers
122 transformers-base
139 transformers-base
@@ -126,8 +143,17 @@ PureScript uses the following Haskell library packages. Their license files foll
126 unix-time
143 unix-time
127 unordered-containers
144 unordered-containers
128 utf8-string
145 utf8-string
146+ vault
129 vector
147 vector
130 void
148 void
149+ wai
150+ wai-app-static
151+ wai-extra
152+ wai-logger
153+ wai-websockets
154+ warp
155+ websockets
156+ word8
131 x509
157 x509
132 x509-store
158 x509-store
133 x509-system
159 x509-system
@@ -140,7 +166,7 @@ Glob LICENSE file:
140 the code are held by whoever wrote the code in question: see CREDITS.txt for a
166 the code are held by whoever wrote the code in question: see CREDITS.txt for a
141 list of authors.
167 list of authors.
142
168
143− Copyright (c) 2008-2012 <authors>
169+ Copyright (c) 2008-2016 <authors>
144 All rights reserved.
170 All rights reserved.
145
171
146 Redistribution and use in source and binary forms, with or without
172 Redistribution and use in source and binary forms, with or without
@@ -165,6 +191,38 @@ Glob LICENSE file:
165 OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
191 OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
166 ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
192 ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
167
193
194+SHA LICENSE file:
195+
196+ Copyright (c) 2008, Galois, Inc.
197+ All rights reserved.
198+
199+ Redistribution and use in source and binary forms, with or without
200+ modification, are permitted provided that the following conditions
201+ are met:
202+
203+ * Redistributions of source code must retain the above copyright
204+ notice, this list of conditions and the following disclaimer.
205+ * Redistributions in binary form must reproduce the above copyright
206+ notice, this list of conditions and the following disclaimer in
207+ the documentation and/or other materials provided with the
208+ distribution.
209+ * Neither the name of the Galois, Inc. nor the names of its
210+ contributors may be used to endorse or promote products derived
211+ from this software without specific prior written permission.
212+
213+ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
214+ "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
215+ LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
216+ FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
217+ COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
218+ INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
219+ BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
220+ LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
221+ CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
222+ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
223+ ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
224+ POSSIBILITY OF SUCH DAMAGE.
225+
168aeson LICENSE file:
226aeson LICENSE file:
169
227
170 Copyright (c) 2011, MailRank, Inc.
228 Copyright (c) 2011, MailRank, Inc.
@@ -221,6 +279,39 @@ aeson-better-errors LICENSE file:
221 TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
279 TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
222 SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
280 SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
223
281
282+aeson-pretty LICENSE file:
283+
284+ Copyright (c)2011, Falko Peters
285+
286+ All rights reserved.
287+
288+ Redistribution and use in source and binary forms, with or without
289+ modification, are permitted provided that the following conditions are met:
290+
291+ * Redistributions of source code must retain the above copyright
292+ notice, this list of conditions and the following disclaimer.
293+
294+ * Redistributions in binary form must reproduce the above
295+ copyright notice, this list of conditions and the following
296+ disclaimer in the documentation and/or other materials provided
297+ with the distribution.
298+
299+ * Neither the name of Falko Peters nor the names of other
300+ contributors may be used to endorse or promote products derived
301+ from this software without specific prior written permission.
302+
303+ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
304+ "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
305+ LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
306+ A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
307+ OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
308+ SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
309+ LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
310+ DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
311+ THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
312+ (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
313+ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
314+
224ansi-terminal LICENSE file:
315ansi-terminal LICENSE file:
225
316
226 Copyright (c) 2008, Maximilian Bolingbroke
317 Copyright (c) 2008, Maximilian Bolingbroke
@@ -274,6 +365,38 @@ ansi-wl-pprint LICENSE file:
274 or otherwise) arising in any way out of the use of this software, even
365 or otherwise) arising in any way out of the use of this software, even
275 if advised of the possibility of such damage.
366 if advised of the possibility of such damage.
276
367
368+appar LICENSE file:
369+
370+ Copyright (c) 2009, IIJ Innovation Institute Inc.
371+ All rights reserved.
372+
373+ Redistribution and use in source and binary forms, with or without
374+ modification, are permitted provided that the following conditions
375+ are met:
376+
377+ * Redistributions of source code must retain the above copyright
378+ notice, this list of conditions and the following disclaimer.
379+ * Redistributions in binary form must reproduce the above copyright
380+ notice, this list of conditions and the following disclaimer in
381+ the documentation and/or other materials provided with the
382+ distribution.
383+ * Neither the name of the copyright holders nor the names of its
384+ contributors may be used to endorse or promote products derived
385+ from this software without specific prior written permission.
386+
387+ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
388+ "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
389+ LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
390+ FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
391+ COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
392+ INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
393+ BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
394+ LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
395+ CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
396+ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
397+ ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
398+ POSSIBILITY OF SUCH DAMAGE.
399+
277array LICENSE file:
400array LICENSE file:
278
401
279 This library (libraries/base) is derived from code from several
402 This library (libraries/base) is derived from code from several
@@ -746,6 +869,72 @@ blaze-builder LICENSE file:
746 (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
869 (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
747 OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
870 OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
748
871
872+blaze-html LICENSE file:
873+
874+ Copyright Jasper Van der Jeugt 2010
875+
876+ All rights reserved.
877+
878+ Redistribution and use in source and binary forms, with or without
879+ modification, are permitted provided that the following conditions are met:
880+
881+ * Redistributions of source code must retain the above copyright
882+ notice, this list of conditions and the following disclaimer.
883+
884+ * Redistributions in binary form must reproduce the above
885+ copyright notice, this list of conditions and the following
886+ disclaimer in the documentation and/or other materials provided
887+ with the distribution.
888+
889+ * Neither the name of Jasper Van der Jeugt nor the names of other
890+ contributors may be used to endorse or promote products derived
891+ from this software without specific prior written permission.
892+
893+ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
894+ "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
895+ LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
896+ A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
897+ OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
898+ SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
899+ LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
900+ DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
901+ THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
902+ (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
903+ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
904+
905+blaze-markup LICENSE file:
906+
907+ Copyright Jasper Van der Jeugt 2010
908+
909+ All rights reserved.
910+
911+ Redistribution and use in source and binary forms, with or without
912+ modification, are permitted provided that the following conditions are met:
913+
914+ * Redistributions of source code must retain the above copyright
915+ notice, this list of conditions and the following disclaimer.
916+
917+ * Redistributions in binary form must reproduce the above
918+ copyright notice, this list of conditions and the following
919+ disclaimer in the documentation and/or other materials provided
920+ with the distribution.
921+
922+ * Neither the name of Jasper Van der Jeugt nor the names of other
923+ contributors may be used to endorse or promote products derived
924+ from this software without specific prior written permission.
925+
926+ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
927+ "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
928+ LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
929+ A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
930+ OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
931+ SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
932+ LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
933+ DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
934+ THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
935+ (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
936+ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
937+
749bower-json LICENSE file:
938bower-json LICENSE file:
750
939
751 Copyright (c) 2015 Harry Garrood
940 Copyright (c) 2015 Harry Garrood
@@ -829,6 +1018,39 @@ byteable LICENSE file:
829 OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
1018 OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
830 SUCH DAMAGE.
1019 SUCH DAMAGE.
831
1020
1021+byteorder LICENSE file:
1022+
1023+ Copyright 2009, Antoine Latter
1024+
1025+ All rights reserved.
1026+
1027+ Redistribution and use in source and binary forms, with or without
1028+ modification, are permitted provided that the following conditions are met:
1029+
1030+ * Redistributions of source code must retain the above copyright
1031+ notice, this list of conditions and the following disclaimer.
1032+
1033+ * Redistributions in binary form must reproduce the above
1034+ copyright notice, this list of conditions and the following
1035+ disclaimer in the documentation and/or other materials provided
1036+ with the distribution.
1037+
1038+ * Neither the name of the author nor the names of other
1039+ contributors may be used to endorse or promote products derived
1040+ from this software without specific prior written permission.
1041+
1042+ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
1043+ "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
1044+ LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
1045+ A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
1046+ OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
1047+ SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
1048+ LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
1049+ DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
1050+ THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
1051+ (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
1052+ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
1053+
832bytestring LICENSE file:
1054bytestring LICENSE file:
833
1055
834 Copyright (c) Don Stewart 2005-2009
1056 Copyright (c) Don Stewart 2005-2009
@@ -997,6 +1219,39 @@ clock LICENSE file:
997 (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
1219 (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
998 OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
1220 OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
999
1221
1222+cmdargs LICENSE file:
1223+
1224+ Copyright Neil Mitchell 2009-2016.
1225+ All rights reserved.
1226+
1227+ Redistribution and use in source and binary forms, with or without
1228+ modification, are permitted provided that the following conditions are
1229+ met:
1230+
1231+ * Redistributions of source code must retain the above copyright
1232+ notice, this list of conditions and the following disclaimer.
1233+
1234+ * Redistributions in binary form must reproduce the above
1235+ copyright notice, this list of conditions and the following
1236+ disclaimer in the documentation and/or other materials provided
1237+ with the distribution.
1238+
1239+ * Neither the name of Neil Mitchell nor the names of other
1240+ contributors may be used to endorse or promote products derived
1241+ from this software without specific prior written permission.
1242+
1243+ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
1244+ "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
1245+ LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
1246+ A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
1247+ OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
1248+ SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
1249+ LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
1250+ DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
1251+ THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
1252+ (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
1253+ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
1254+
1000conduit LICENSE file:
1255conduit LICENSE file:
1001
1256
1002 Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/
1257 Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/
@@ -1109,31 +1364,26 @@ containers LICENSE file:
1109
1364
1110cookie LICENSE file:
1365cookie LICENSE file:
1111
1366
1112− The following license covers this documentation, and the source code, except
1113− where otherwise indicated.
1114−
1115− Copyright 2010, Michael Snoyman. All rights reserved.
1367+ Copyright (c) 2010 Michael Snoyman, http://www.yesodweb.com/
1116
1368
1117− Redistribution and use in source and binary forms, with or without
1369+ Permission is hereby granted, free of charge, to any person obtaining
1370+ a copy of this software and associated documentation files (the
1371+ "Software"), to deal in the Software without restriction, including
1372+ without limitation the rights to use, copy, modify, merge, publish,
1373+ distribute, sublicense, and/or sell copies of the Software, and to
1374+ permit persons to whom the Software is furnished to do so, subject to
1118− modification, are permitted provided that the following conditions are met:
1375+ the following conditions:
1119−
1120− * Redistributions of source code must retain the above copyright notice, this
1121− list of conditions and the following disclaimer.
1122
1376
1123− * Redistributions in binary form must reproduce the above copyright notice,
1377+ The above copyright notice and this permission notice shall be
1124− this list of conditions and the following disclaimer in the documentation
1378+ included in all copies or substantial portions of the Software.
1125− and/or other materials provided with the distribution.
1126
1379
1127− THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR
1380+ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
1128− IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
1381+ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
1129− MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO
1382+ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
1130− EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,
1383+ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
1131− INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
1384+ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
1132− NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,
1133− OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
1134− LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
1135− OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
1385+ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
1136− ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
1386+ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
1137
1387
1138cryptonite LICENSE file:
1388cryptonite LICENSE file:
1139
1389
@@ -1195,13 +1445,26 @@ data-default-class LICENSE file:
1195 OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
1445 OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
1196 OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
1446 OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
1197
1447
1198−deepseq LICENSE file:
1448+data-ordlist LICENSE file:
1199
1449
1200− This library (deepseq) is derived from code from the GHC project which
1450+ Copyright (c) 2009-2010, Melding Monads
1201− is largely (c) The University of Glasgow, and distributable under a
1451+ All rights reserved.
1202− BSD-style license (see below).
1203
1452
1453+ Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
1454+
1455+ * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.
1456+ * 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.
1457+ * 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.
1458+
1459+ 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.
1460+
1461+deepseq LICENSE file:
1462+
1463+ This library (deepseq) is derived from code from the GHC project which
1464+ is largely (c) The University of Glasgow, and distributable under a
1465+ BSD-style license (see below).
1466+
1204− -----------------------------------------------------------------------------
1467+ -----------------------------------------------------------------------------
1205
1468
1206 The Glasgow Haskell Compiler License
1469 The Glasgow Haskell Compiler License
1207
1470
@@ -1305,7 +1568,7 @@ directory LICENSE file:
1305
1568
1306dlist LICENSE file:
1569dlist LICENSE file:
1307
1570
1308− Copyright (c) 2006-2009 Don Stewart, 2013-2014 Sean Leather
1571+ Copyright (c) 2006-2009 Don Stewart, 2013-2016 Sean Leather
1309
1572
1310 All rights reserved.
1573 All rights reserved.
1311
1574
@@ -1394,6 +1657,39 @@ edit-distance LICENSE file:
1394 IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT
1657 IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT
1395 OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
1658 OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
1396
1659
1660+entropy LICENSE file:
1661+
1662+ Copyright (c) Thomas DuBuisson
1663+
1664+ All rights reserved.
1665+
1666+ Redistribution and use in source and binary forms, with or without
1667+ modification, are permitted provided that the following conditions
1668+ are met:
1669+
1670+ 1. Redistributions of source code must retain the above copyright
1671+ notice, this list of conditions and the following disclaimer.
1672+
1673+ 2. Redistributions in binary form must reproduce the above copyright
1674+ notice, this list of conditions and the following disclaimer in the
1675+ documentation and/or other materials provided with the distribution.
1676+
1677+ 3. Neither the name of the author nor the names of his contributors
1678+ may be used to endorse or promote products derived from this software
1679+ without specific prior written permission.
1680+
1681+ THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS
1682+ OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
1683+ WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
1684+ DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
1685+ ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
1686+ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
1687+ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
1688+ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
1689+ STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
1690+ ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
1691+ POSSIBILITY OF SUCH DAMAGE.
1692+
1397exceptions LICENSE file:
1693exceptions LICENSE file:
1398
1694
1399 Copyright 2013-2015 Edward Kmett
1695 Copyright 2013-2015 Edward Kmett
@@ -1493,6 +1789,34 @@ fast-logger LICENSE file:
1493 ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
1789 ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
1494 POSSIBILITY OF SUCH DAMAGE.
1790 POSSIBILITY OF SUCH DAMAGE.
1495
1791
1792+file-embed LICENSE file:
1793+
1794+ The following license covers this documentation, and the source code, except
1795+ where otherwise indicated.
1796+
1797+ Copyright 2008, Michael Snoyman. All rights reserved.
1798+
1799+ Redistribution and use in source and binary forms, with or without
1800+ modification, are permitted provided that the following conditions are met:
1801+
1802+ * Redistributions of source code must retain the above copyright notice, this
1803+ list of conditions and the following disclaimer.
1804+
1805+ * Redistributions in binary form must reproduce the above copyright notice,
1806+ this list of conditions and the following disclaimer in the documentation
1807+ and/or other materials provided with the distribution.
1808+
1809+ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR
1810+ IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
1811+ MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO
1812+ EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,
1813+ INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
1814+ NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,
1815+ OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
1816+ LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
1817+ OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
1818+ ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
1819+
1496filepath LICENSE file:
1820filepath LICENSE file:
1497
1821
1498 Copyright Neil Mitchell 2005-2015.
1822 Copyright Neil Mitchell 2005-2015.
@@ -1683,38 +2007,42 @@ haskeline LICENSE file:
1683 OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
2007 OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
1684 USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
2008 USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
1685
2009
1686−hinotify LICENSE file:
2010+hex LICENSE file:
1687
2011
1688− Copyright (c) Lennart Kolmodin
2012+ Page not found: Sorry, it's just not here.
2013+
2014+hfsevents LICENSE file:
2015+
2016+ Copyright (c) 2012, Luite Stegeman
1689
2017
1690 All rights reserved.
2018 All rights reserved.
1691
2019
1692 Redistribution and use in source and binary forms, with or without
2020 Redistribution and use in source and binary forms, with or without
1693− modification, are permitted provided that the following conditions
2021+ modification, are permitted provided that the following conditions are met:
1694− are met:
1695
2022
1696− 1. Redistributions of source code must retain the above copyright
2023+ * Redistributions of source code must retain the above copyright
1697− notice, this list of conditions and the following disclaimer.
2024+ notice, this list of conditions and the following disclaimer.
1698
2025
1699− 2. Redistributions in binary form must reproduce the above copyright
2026+ * Redistributions in binary form must reproduce the above
1700− notice, this list of conditions and the following disclaimer in the
2027+ copyright notice, this list of conditions and the following
1701− documentation and/or other materials provided with the distribution.
2028+ disclaimer in the documentation and/or other materials provided
2029+ with the distribution.
1702
2030
1703− 3. Neither the name of the author nor the names of his contributors
2031+ * Neither the name of Luite Stegeman nor the names of other
1704− may be used to endorse or promote products derived from this software
2032+ contributors may be used to endorse or promote products derived
1705− without specific prior written permission.
2033+ from this software without specific prior written permission.
1706
2034
1707− THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS
2035+ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
1708− OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
2036+ "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
1709− WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
2037+ LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
1710− DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
2038+ A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
2039+ OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
1711− ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
2040+ SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
1712− DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
2041+ LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
1713− OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
2042+ DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
1714− HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
2043+ THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
1715− STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
2044+ (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
1716− ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
2045+ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
1717− POSSIBILITY OF SUCH DAMAGE.
1718
2046
1719hourglass LICENSE file:
2047hourglass LICENSE file:
1720
2048
@@ -1792,6 +2120,38 @@ http-client-tls LICENSE file:
1792 IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
2120 IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
1793 CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
2121 CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
1794
2122
2123+http-date LICENSE file:
2124+
2125+ Copyright (c) 2009, IIJ Innovation Institute Inc.
2126+ All rights reserved.
2127+
2128+ Redistribution and use in source and binary forms, with or without
2129+ modification, are permitted provided that the following conditions
2130+ are met:
2131+
2132+ * Redistributions of source code must retain the above copyright
2133+ notice, this list of conditions and the following disclaimer.
2134+ * Redistributions in binary form must reproduce the above copyright
2135+ notice, this list of conditions and the following disclaimer in
2136+ the documentation and/or other materials provided with the
2137+ distribution.
2138+ * Neither the name of the copyright holders nor the names of its
2139+ contributors may be used to endorse or promote products derived
2140+ from this software without specific prior written permission.
2141+
2142+ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
2143+ "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
2144+ LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
2145+ FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
2146+ COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
2147+ INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
2148+ BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
2149+ LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
2150+ CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
2151+ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
2152+ ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
2153+ POSSIBILITY OF SUCH DAMAGE.
2154+
1795http-types LICENSE file:
2155http-types LICENSE file:
1796
2156
1797 Copyright (c) 2011, Aristid Breitkreuz
2157 Copyright (c) 2011, Aristid Breitkreuz
@@ -1826,6 +2186,38 @@ http-types LICENSE file:
1826 (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
2186 (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
1827 OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
2187 OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
1828
2188
2189+http2 LICENSE file:
2190+
2191+ Copyright (c) 2013, IIJ Innovation Institute Inc.
2192+ All rights reserved.
2193+
2194+ Redistribution and use in source and binary forms, with or without
2195+ modification, are permitted provided that the following conditions
2196+ are met:
2197+
2198+ * Redistributions of source code must retain the above copyright
2199+ notice, this list of conditions and the following disclaimer.
2200+ * Redistributions in binary form must reproduce the above copyright
2201+ notice, this list of conditions and the following disclaimer in
2202+ the documentation and/or other materials provided with the
2203+ distribution.
2204+ * Neither the name of the copyright holders nor the names of its
2205+ contributors may be used to endorse or promote products derived
2206+ from this software without specific prior written permission.
2207+
2208+ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
2209+ "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
2210+ LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
2211+ FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
2212+ COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
2213+ INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
2214+ BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
2215+ LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
2216+ CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
2217+ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
2218+ ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
2219+ POSSIBILITY OF SUCH DAMAGE.
2220+
1829integer-gmp LICENSE file:
2221integer-gmp LICENSE file:
1830
2222
1831 Copyright (c) 2014, Herbert Valerio Riedel
2223 Copyright (c) 2014, Herbert Valerio Riedel
@@ -1859,6 +2251,38 @@ integer-gmp LICENSE file:
1859 (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
2251 (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
1860 OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
2252 OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
1861
2253
2254+iproute LICENSE file:
2255+
2256+ Copyright (c) 2009, IIJ Innovation Institute Inc.
2257+ All rights reserved.
2258+
2259+ Redistribution and use in source and binary forms, with or without
2260+ modification, are permitted provided that the following conditions
2261+ are met:
2262+
2263+ * Redistributions of source code must retain the above copyright
2264+ notice, this list of conditions and the following disclaimer.
2265+ * Redistributions in binary form must reproduce the above copyright
2266+ notice, this list of conditions and the following disclaimer in
2267+ the documentation and/or other materials provided with the
2268+ distribution.
2269+ * Neither the name of the copyright holders nor the names of its
2270+ contributors may be used to endorse or promote products derived
2271+ from this software without specific prior written permission.
2272+
2273+ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
2274+ "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
2275+ LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
2276+ FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
2277+ COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
2278+ INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
2279+ BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
2280+ LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
2281+ CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
2282+ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
2283+ ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
2284+ POSSIBILITY OF SUCH DAMAGE.
2285+
1862language-javascript LICENSE file:
2286language-javascript LICENSE file:
1863
2287
1864 Copyright (c)2010, Alan Zimmerman
2288 Copyright (c)2010, Alan Zimmerman
@@ -2622,6 +3046,40 @@ protolude LICENSE file:
2622 FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
3046 FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
2623 IN THE SOFTWARE.
3047 IN THE SOFTWARE.
2624
3048
3049+psqueues LICENSE file:
3050+
3051+ The Glasgow Haskell Compiler License
3052+
3053+ Copyright 2004, The University Court of the University of Glasgow.
3054+ All rights reserved.
3055+
3056+ Redistribution and use in source and binary forms, with or without
3057+ modification, are permitted provided that the following conditions are met:
3058+
3059+ - Redistributions of source code must retain the above copyright notice,
3060+ this list of conditions and the following disclaimer.
3061+
3062+ - Redistributions in binary form must reproduce the above copyright notice,
3063+ this list of conditions and the following disclaimer in the documentation
3064+ and/or other materials provided with the distribution.
3065+
3066+ - Neither name of the University nor the names of its contributors may be
3067+ used to endorse or promote products derived from this software without
3068+ specific prior written permission.
3069+
3070+ THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF
3071+ GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
3072+ INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
3073+ FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
3074+ UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE
3075+ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
3076+ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
3077+ SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
3078+ CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
3079+ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
3080+ OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
3081+ DAMAGE.
3082+
2625random LICENSE file:
3083random LICENSE file:
2626
3084
2627 This library (libraries/base) is derived from code from two
3085 This library (libraries/base) is derived from code from two
@@ -2846,28 +3304,60 @@ semigroups LICENSE file:
2846 ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
3304 ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
2847 POSSIBILITY OF SUCH DAMAGE.
3305 POSSIBILITY OF SUCH DAMAGE.
2848
3306
2849−socks LICENSE file:
3307+simple-sendfile LICENSE file:
2850−
2851− Copyright (c) 2010-2011 Vincent Hanquez <vincent@snarc.org>
2852
3308
3309+ Copyright (c) 2009, IIJ Innovation Institute Inc.
2853 All rights reserved.
3310 All rights reserved.
2854
3311
2855 Redistribution and use in source and binary forms, with or without
3312 Redistribution and use in source and binary forms, with or without
2856 modification, are permitted provided that the following conditions
3313 modification, are permitted provided that the following conditions
2857 are met:
3314 are met:
2858− 1. Redistributions of source code must retain the above copyright
2859− notice, this list of conditions and the following disclaimer.
2860− 2. Redistributions in binary form must reproduce the above copyright
2861− notice, this list of conditions and the following disclaimer in the
2862− documentation and/or other materials provided with the distribution.
2863− 3. Neither the name of the author nor the names of his contributors
2864− may be used to endorse or promote products derived from this software
2865− without specific prior written permission.
2866
3315
3316+ * Redistributions of source code must retain the above copyright
3317+ notice, this list of conditions and the following disclaimer.
3318+ * Redistributions in binary form must reproduce the above copyright
3319+ notice, this list of conditions and the following disclaimer in
3320+ the documentation and/or other materials provided with the
3321+ distribution.
3322+ * Neither the name of the copyright holders nor the names of its
3323+ contributors may be used to endorse or promote products derived
3324+ from this software without specific prior written permission.
3325+
3326+ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
3327+ "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
3328+ LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
3329+ FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
3330+ COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
3331+ INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
3332+ BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
3333+ LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
3334+ CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
3335+ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
3336+ ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
3337+ POSSIBILITY OF SUCH DAMAGE.
3338+
3339+socks LICENSE file:
3340+
3341+ Copyright (c) 2010-2011 Vincent Hanquez <vincent@snarc.org>
3342+
3343+ All rights reserved.
3344+
3345+ Redistribution and use in source and binary forms, with or without
3346+ modification, are permitted provided that the following conditions
3347+ are met:
3348+ 1. Redistributions of source code must retain the above copyright
3349+ notice, this list of conditions and the following disclaimer.
3350+ 2. Redistributions in binary form must reproduce the above copyright
3351+ notice, this list of conditions and the following disclaimer in the
3352+ documentation and/or other materials provided with the distribution.
3353+ 3. Neither the name of the author nor the names of his contributors
3354+ may be used to endorse or promote products derived from this software
3355+ without specific prior written permission.
3356+
2867− THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
3357+ THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
2868− ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
3358+ ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
2869− IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
3359+ IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
2870− ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE
3360+ ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE
2871 FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
3361 FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
2872 DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
3362 DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
2873 OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
3363 OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
@@ -3068,38 +3558,9 @@ streaming-commons LICENSE file:
3068 OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
3558 OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
3069 SOFTWARE.
3559 SOFTWARE.
3070
3560
3071−string-conv LICENSE file:
3561+stringsearch LICENSE file:
3072−
3073− Copyright (c) 2012, Ozgun Ataman
3074−
3075− All rights reserved.
3076−
3077− Redistribution and use in source and binary forms, with or without
3078− modification, are permitted provided that the following conditions are met:
3079−
3080− * Redistributions of source code must retain the above copyright
3081− notice, this list of conditions and the following disclaimer.
3082−
3083− * Redistributions in binary form must reproduce the above
3084− copyright notice, this list of conditions and the following
3085− disclaimer in the documentation and/or other materials provided
3086− with the distribution.
3087−
3088− * Neither the name of Ozgun Ataman nor the names of other
3089− contributors may be used to endorse or promote products derived
3090− from this software without specific prior written permission.
3091
3562
3092− THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
3563+ Page not found: Sorry, it's just not here.
3093− "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
3094− LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
3095− A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
3096− OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
3097− SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
3098− LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
3099− DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
3100− THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
3101− (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
3102− OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
3103
3564
3104syb LICENSE file:
3565syb LICENSE file:
3105
3566
@@ -3324,6 +3785,39 @@ time LICENSE file:
3324
3785
3325 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.
3786 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.
3326
3787
3788+time-locale-compat LICENSE file:
3789+
3790+ Copyright (c) 2014, Kei Hibino
3791+
3792+ All rights reserved.
3793+
3794+ Redistribution and use in source and binary forms, with or without
3795+ modification, are permitted provided that the following conditions are met:
3796+
3797+ * Redistributions of source code must retain the above copyright
3798+ notice, this list of conditions and the following disclaimer.
3799+
3800+ * Redistributions in binary form must reproduce the above
3801+ copyright notice, this list of conditions and the following
3802+ disclaimer in the documentation and/or other materials provided
3803+ with the distribution.
3804+
3805+ * Neither the name of Kei Hibino nor the names of other
3806+ contributors may be used to endorse or promote products derived
3807+ from this software without specific prior written permission.
3808+
3809+ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
3810+ "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
3811+ LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
3812+ A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
3813+ OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
3814+ SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
3815+ LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
3816+ DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
3817+ THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
3818+ (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
3819+ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
3820+
3327tls LICENSE file:
3821tls LICENSE file:
3328
3822
3329 Copyright (c) 2010-2015 Vincent Hanquez <vincent@snarc.org>
3823 Copyright (c) 2010-2015 Vincent Hanquez <vincent@snarc.org>
@@ -3609,6 +4103,39 @@ utf8-string LICENSE file:
3609 * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
4103 * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
3610 * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
4104 * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
3611
4105
4106+vault LICENSE file:
4107+
4108+ Copyright (c)2011, Heinrich Apfelmus
4109+
4110+ All rights reserved.
4111+
4112+ Redistribution and use in source and binary forms, with or without
4113+ modification, are permitted provided that the following conditions are met:
4114+
4115+ * Redistributions of source code must retain the above copyright
4116+ notice, this list of conditions and the following disclaimer.
4117+
4118+ * Redistributions in binary form must reproduce the above
4119+ copyright notice, this list of conditions and the following
4120+ disclaimer in the documentation and/or other materials provided
4121+ with the distribution.
4122+
4123+ * Neither the name of Heinrich Apfelmus nor the names of other
4124+ contributors may be used to endorse or promote products derived
4125+ from this software without specific prior written permission.
4126+
4127+ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
4128+ "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
4129+ LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
4130+ A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
4131+ OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
4132+ SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
4133+ LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
4134+ DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
4135+ THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
4136+ (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
4137+ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
4138+
3612vector LICENSE file:
4139vector LICENSE file:
3613
4140
3614 Copyright (c) 2008-2012, Roman Leshchinskiy
4141 Copyright (c) 2008-2012, Roman Leshchinskiy
@@ -3675,6 +4202,189 @@ void LICENSE file:
3675 ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
4202 ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
3676 POSSIBILITY OF SUCH DAMAGE.
4203 POSSIBILITY OF SUCH DAMAGE.
3677
4204
4205+wai LICENSE file:
4206+
4207+ Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/
4208+
4209+ Permission is hereby granted, free of charge, to any person obtaining
4210+ a copy of this software and associated documentation files (the
4211+ "Software"), to deal in the Software without restriction, including
4212+ without limitation the rights to use, copy, modify, merge, publish,
4213+ distribute, sublicense, and/or sell copies of the Software, and to
4214+ permit persons to whom the Software is furnished to do so, subject to
4215+ the following conditions:
4216+
4217+ The above copyright notice and this permission notice shall be
4218+ included in all copies or substantial portions of the Software.
4219+
4220+ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
4221+ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
4222+ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
4223+ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
4224+ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
4225+ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
4226+ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
4227+
4228+wai-app-static LICENSE file:
4229+
4230+ Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/
4231+
4232+ Permission is hereby granted, free of charge, to any person obtaining
4233+ a copy of this software and associated documentation files (the
4234+ "Software"), to deal in the Software without restriction, including
4235+ without limitation the rights to use, copy, modify, merge, publish,
4236+ distribute, sublicense, and/or sell copies of the Software, and to
4237+ permit persons to whom the Software is furnished to do so, subject to
4238+ the following conditions:
4239+
4240+ The above copyright notice and this permission notice shall be
4241+ included in all copies or substantial portions of the Software.
4242+
4243+ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
4244+ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
4245+ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
4246+ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
4247+ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
4248+ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
4249+ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
4250+
4251+wai-extra LICENSE file:
4252+
4253+ Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/
4254+
4255+ Permission is hereby granted, free of charge, to any person obtaining
4256+ a copy of this software and associated documentation files (the
4257+ "Software"), to deal in the Software without restriction, including
4258+ without limitation the rights to use, copy, modify, merge, publish,
4259+ distribute, sublicense, and/or sell copies of the Software, and to
4260+ permit persons to whom the Software is furnished to do so, subject to
4261+ the following conditions:
4262+
4263+ The above copyright notice and this permission notice shall be
4264+ included in all copies or substantial portions of the Software.
4265+
4266+ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
4267+ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
4268+ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
4269+ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
4270+ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
4271+ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
4272+ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
4273+
4274+wai-logger LICENSE file:
4275+
4276+ Copyright (c) 2009, IIJ Innovation Institute Inc.
4277+ All rights reserved.
4278+
4279+ Redistribution and use in source and binary forms, with or without
4280+ modification, are permitted provided that the following conditions
4281+ are met:
4282+
4283+ * Redistributions of source code must retain the above copyright
4284+ notice, this list of conditions and the following disclaimer.
4285+ * Redistributions in binary form must reproduce the above copyright
4286+ notice, this list of conditions and the following disclaimer in
4287+ the documentation and/or other materials provided with the
4288+ distribution.
4289+ * Neither the name of the copyright holders nor the names of its
4290+ contributors may be used to endorse or promote products derived
4291+ from this software without specific prior written permission.
4292+
4293+ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
4294+ "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
4295+ LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
4296+ FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
4297+ COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
4298+ INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
4299+ BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
4300+ LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
4301+ CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
4302+ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
4303+ ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
4304+ POSSIBILITY OF SUCH DAMAGE.
4305+
4306+wai-websockets LICENSE file:
4307+
4308+ Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/
4309+
4310+ Permission is hereby granted, free of charge, to any person obtaining
4311+ a copy of this software and associated documentation files (the
4312+ "Software"), to deal in the Software without restriction, including
4313+ without limitation the rights to use, copy, modify, merge, publish,
4314+ distribute, sublicense, and/or sell copies of the Software, and to
4315+ permit persons to whom the Software is furnished to do so, subject to
4316+ the following conditions:
4317+
4318+ The above copyright notice and this permission notice shall be
4319+ included in all copies or substantial portions of the Software.
4320+
4321+ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
4322+ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
4323+ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
4324+ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
4325+ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
4326+ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
4327+ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
4328+
4329+warp LICENSE file:
4330+
4331+ Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/
4332+
4333+ Permission is hereby granted, free of charge, to any person obtaining
4334+ a copy of this software and associated documentation files (the
4335+ "Software"), to deal in the Software without restriction, including
4336+ without limitation the rights to use, copy, modify, merge, publish,
4337+ distribute, sublicense, and/or sell copies of the Software, and to
4338+ permit persons to whom the Software is furnished to do so, subject to
4339+ the following conditions:
4340+
4341+ The above copyright notice and this permission notice shall be
4342+ included in all copies or substantial portions of the Software.
4343+
4344+ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
4345+ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
4346+ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
4347+ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
4348+ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
4349+ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
4350+ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
4351+
4352+websockets LICENSE file:
4353+
4354+ Page not found: Sorry, it's just not here.
4355+
4356+word8 LICENSE file:
4357+
4358+ Copyright (c) 2012, IIJ Innovation Institute Inc.
4359+ All rights reserved.
4360+
4361+ Redistribution and use in source and binary forms, with or without
4362+ modification, are permitted provided that the following conditions
4363+ are met:
4364+
4365+ * Redistributions of source code must retain the above copyright
4366+ notice, this list of conditions and the following disclaimer.
4367+ * Redistributions in binary form must reproduce the above copyright
4368+ notice, this list of conditions and the following disclaimer in
4369+ the documentation and/or other materials provided with the
4370+ distribution.
4371+ * Neither the name of the copyright holders nor the names of its
4372+ contributors may be used to endorse or promote products derived
4373+ from this software without specific prior written permission.
4374+
4375+ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
4376+ "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
4377+ LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
4378+ FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
4379+ COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
4380+ INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
4381+ BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
4382+ LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
4383+ CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
4384+ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
4385+ ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
4386+ POSSIBILITY OF SUCH DAMAGE.
4387+
3678x509 LICENSE file:
4388x509 LICENSE file:
3679
4389
3680 Copyright (c) 2010-2013 Vincent Hanquez <vincent@snarc.org>
4390 Copyright (c) 2010-2013 Vincent Hanquez <vincent@snarc.org>
examples/docs/src/ExplicitTypeSignatures.purs+2
@@ -14,3 +14,5 @@ anInt = 0
14
14
15-- This should infer a type.
15-- This should infer a type.
16aNumber = 1.0
16aNumber = 1.0
17+
18+foreign import nestedForAll :: forall c. (forall a b. c)
examples/failing/CannotDeriveNewtypeForData.pursnew file+8
@@ -0,0 +1,8 @@
1+-- @shouldFailWith CannotDeriveNewtypeForData
2+module CannotDeriveNewtypeForData where
3+
4+import Data.Newtype
5+
6+data Test = Test String
7+
8+derive instance newtypeTest :: Newtype Test _
examples/failing/DoNotSuggestComposition2.purs+1−1
@@ -1,4 +1,4 @@
1−-- @shouldFailWith CannotApplyFunction
1+-- @shouldFailWith TypesDoNotUnify
2-- TODO: Check that this does not produce a "function composition is (<<<)"
2-- TODO: Check that this does not produce a "function composition is (<<<)"
3-- suggestion.
3-- suggestion.
4
4
examples/failing/DuplicateModule.pursnew file+2
@@ -0,0 +1,2 @@
1+-- @shouldFailWith DuplicateModule
2+module M1 where
examples/failing/DuplicateModule/M1.pursnew file+1
@@ -0,0 +1 @@
1+module M1 where
examples/failing/NewtypeInstance.pursnew file+8
@@ -0,0 +1,8 @@
1+-- @shouldFailWith InvalidNewtypeInstance
2+module Main where
3+
4+import Prelude
5+
6+data X = X
7+
8+derive newtype instance showX :: Show X
examples/failing/NewtypeInstance2.pursnew file+8
@@ -0,0 +1,8 @@
1+-- @shouldFailWith InvalidNewtypeInstance
2+module Main where
3+
4+import Prelude
5+
6+data X a = X a a
7+
8+derive newtype instance showX :: Show a => Show (X a)
examples/failing/NewtypeInstance3.pursnew file+8
@@ -0,0 +1,8 @@
1+-- @shouldFailWith InvalidNewtypeInstance
2+module Main where
3+
4+import Prelude
5+
6+class Nullary
7+
8+derive newtype instance nullary :: Nullary
examples/failing/NewtypeInstance4.pursnew file+8
@@ -0,0 +1,8 @@
1+-- @shouldFailWith InvalidNewtypeInstance
2+module Main where
3+
4+import Prelude
5+
6+data X = X | Y
7+
8+derive newtype instance showX :: Show X
examples/failing/NewtypeInstance5.pursnew file+8
@@ -0,0 +1,8 @@
1+-- @shouldFailWith InvalidNewtypeInstance
2+module Main where
3+
4+import Prelude
5+
6+newtype X a = X a
7+
8+derive newtype instance functorX :: Functor X
examples/failing/NewtypeInstance6.pursnew file+8
@@ -0,0 +1,8 @@
1+-- @shouldFailWith InvalidNewtypeInstance
2+module Main where
3+
4+import Prelude
5+
6+newtype X a b = X (Array b)
7+
8+derive newtype instance functorX :: Functor X
examples/failing/NonWildcardNewtypeInstance.pursnew file+8
@@ -0,0 +1,8 @@
1+-- @shouldFailWith NonWildcardNewtypeInstance
2+module NonWildcardNewtypeInstance where
3+
4+import Data.Newtype
5+
6+data Test = Test String
7+
8+derive instance newtypeTest :: Newtype Test String
examples/failing/OperatorSections.purs+1−2
@@ -1,8 +1,7 @@
1−-- @shouldFailWith CannotApplyFunction
1+-- @shouldFailWith TypesDoNotUnify
2module Main where
2module Main where
3
3
4import Prelude
4import Prelude
5
5
6main = do
6main = do
7 (true `not` _)
7 (true `not` _)
8−
examples/failing/OverlappingVars.purs−1
@@ -12,4 +12,3 @@ instance overlappingVarsFoo :: OverlappingVars (Foo a a) where
12 f a = a
12 f a = a
13
13
14test = f (Foo "" 0)
14test = f (Foo "" 0)
15−
examples/failing/ProgrammableTypeErrorsTypeString.pursnew file+18
@@ -0,0 +1,18 @@
1+-- @shouldFailWith NoInstanceFound
2+
3+module Main where
4+
5+import Prelude
6+import Control.Monad.Eff (Eff)
7+import Control.Monad.Eff.Console (log)
8+
9+newtype MyType a = MyType a
10+
11+instance cannotShowFunctions :: Fail ("Don't want to show " <> TypeString (MyType a) <> " because.") => Show (MyType a) where
12+ show _ = "unreachable"
13+
14+infixl 6 type TypeConcat as <>
15+
16+main :: Eff _ _
17+main = do
18+ log $ show (MyType 2)
examples/failing/TypeWildcards3.purs+1−2
@@ -1,4 +1,4 @@
1−-- @shouldFailWith ErrorParsingModule
1+-- @shouldFailWith InvalidInstanceHead
2module TypeWildcards where
2module TypeWildcards where
3
3
4import Prelude
4import Prelude
@@ -7,4 +7,3 @@ data Foo a = Foo
7
7
8instance showFoo :: Show (Foo _) where
8instance showFoo :: Show (Foo _) where
9 show Foo = "Foo"
9 show Foo = "Foo"
10−
examples/failing/UnifyInTypeInstanceLookup.pursdeleted−22
@@ -1,22 +0,0 @@
1−-- @shouldFailWith NoInstanceFound
2−-- See issue #390.
3−-- TODO: Improve this error.
4−module Main where
5−
6−import Prelude
7−
8−data Z = Z
9−data S n = S n
10−
11−data T
12−data F
13−
14−class EQ x y b
15−instance eqT :: EQ x x T
16−instance eqF :: EQ x y F
17−
18−foreign import test :: forall a b. (EQ a b T) => a -> b -> a
19−
20−foreign import anyNat :: forall a. a
21−
22−test1 = test anyNat (S Z)
examples/passing/1807.pursnew file+14
@@ -0,0 +1,14 @@
1+module Main where
2+
3+import Prelude
4+import Control.Monad.Eff.Console (log)
5+
6+fn = _.b.c.d
7+a = {b:{c:{d:2}}}
8+
9+d :: Int
10+d = fn a + a.b.c.d
11+
12+main = if fn a + a.b.c.d == 4
13+ then log "Done"
14+ else log "Fail"
examples/passing/ConstraintParsingIssue.pursnew file+9
@@ -0,0 +1,9 @@
1+module Main where
2+
3+import Control.Monad.Eff.Console
4+
5+class X a
6+
7+instance x :: X (Array (Array a)) => X (Array a)
8+
9+main = log "Done"
examples/passing/DeriveNewtype.pursnew file+27
@@ -0,0 +1,27 @@
1+module Main where
2+
3+import Control.Monad.Eff.Console (log)
4+
5+import Data.Newtype
6+
7+newtype Test = Test String
8+
9+derive instance newtypeTest :: Newtype Test _
10+
11+t :: Test
12+t = wrap "hello"
13+
14+a :: String
15+a = unwrap t
16+
17+newtype First a = First a
18+
19+derive instance newtypeFirst :: Newtype (First b) _
20+
21+f :: First Int
22+f = wrap 1
23+
24+i :: Int
25+i = unwrap f
26+
27+main = log "Done"
examples/passing/FunWithFunDeps.jsnew file+32
@@ -0,0 +1,32 @@
1+
2+//: forall e. FVect Z e
3+exports.fnil = [];
4+
5+//: forall n e. e -> FVect n e -> FVect (S n) e
6+exports.fcons = function (hd) {
7+ return function (tl) {
8+ return [hd].concat(tl);
9+ };
10+};
11+
12+exports.fappend = function (dict) {
13+ return function (left) {
14+ return function (right) {
15+ return left.concat(right);
16+ };
17+ };
18+};
19+
20+exports.fflatten = function (dict) {
21+ return function (v) {
22+ var accRef = [];
23+ for (var indexRef = 0; indexRef < v.length; indexRef += 1) {
24+ accRef = accRef.concat(v[indexRef]);
25+ }
26+ return accRef;
27+ };
28+};
29+
30+exports.ftoArray = function (vect) {
31+ return vect;
32+};
examples/passing/FunWithFunDeps.pursnew file+41
@@ -0,0 +1,41 @@
1+-- Taken from https://github.com/LiamGoodacre/purescript-fun-with-fundeps
2+
3+module Main where
4+
5+import Control.Monad.Eff.Console (log)
6+
7+-- Nat : Type
8+data Z
9+data S n
10+
11+type S2 n = S (S n)
12+type S3 n = S (S2 n)
13+type S4 n = S (S3 n)
14+type S5 n = S (S4 n)
15+type S15 n = S5 (S5 (S5 n))
16+
17+class NatPlus l r o | l r -> o
18+instance natPlusZ :: NatPlus Z r r
19+instance natPlusS :: (NatPlus l r o) => NatPlus (S l) r (S o)
20+
21+class NatMult l r o | l r -> o
22+instance natMultZ :: NatMult Z n Z
23+instance natMultS :: (NatMult m n r, NatPlus n r s) => NatMult (S m) n s
24+
25+-- Foreign Vect
26+foreign import data FVect :: * -> * -> *
27+foreign import fnil :: forall e. FVect Z e
28+foreign import fcons :: forall n e. e -> FVect n e -> FVect (S n) e
29+foreign import fappend :: forall l r o e. (NatPlus l r o) => FVect l e -> FVect r e -> FVect o e
30+foreign import fflatten :: forall f s t o. (NatMult f s o) => FVect f (FVect s t) -> FVect o t
31+foreign import ftoArray :: forall n e. FVect n e -> Array e
32+
33+-- should be able to figure these out
34+fsingleton x = fcons x fnil
35+fexample = fcons 1 (fsingleton 2) `fappend` fsingleton 3 `fappend` fcons 4 (fsingleton 5)
36+fexample2 = fexample `fappend` fexample `fappend` fexample
37+fexample3 = fsingleton fexample `fappend` fsingleton fexample `fappend` fsingleton fexample
38+
39+fexample4 = fflatten fexample3
40+
41+main = log "Done"
examples/passing/FunctionalDependencies.pursnew file+21
@@ -0,0 +1,21 @@
1+module Main where
2+
3+import Control.Monad.Eff.Console (log)
4+
5+data Nil
6+data Cons x xs
7+
8+class Append a b c | a b -> c
9+
10+instance appendNil :: Append Nil b b
11+
12+instance appendCons :: Append xs b c => Append (Cons x xs) b (Cons x c)
13+
14+data Proxy a = Proxy
15+
16+appendProxy :: forall a b c. Append a b c => Proxy a -> Proxy b -> Proxy c
17+appendProxy Proxy Proxy = Proxy
18+
19+test = appendProxy (Proxy :: Proxy (Cons Int Nil)) (Proxy :: Proxy (Cons String Nil))
20+
21+main = log "Done"
examples/passing/GHCGenerics.pursnew file+140
@@ -0,0 +1,140 @@
1+-- An example to show how we could implement GHC-style Generics using
2+-- functional dependencies.
3+--
4+-- See https://hackage.haskell.org/package/base-4.9.0.0/docs/GHC-Generics.html
5+
6+module Main where
7+
8+import Prelude
9+import Control.Monad.Eff (Eff)
10+import Control.Monad.Eff.Console (CONSOLE, log, logShow)
11+
12+-- Representation for types with no constructors
13+data V1
14+
15+-- Representation for constructors with no arguments
16+data U1 = U1
17+
18+-- Representation for sum types
19+data Sum a b = Inl a | Inr b
20+
21+infixr 5 type Sum as +
22+
23+-- Representation for product types
24+data Product a b = Product a b
25+
26+infixr 6 type Product as *
27+
28+-- Representation for data constructors, with the data constructor name indicated
29+-- at the type level.
30+data Ctor (name :: Symbol) a = Ctor a
31+
32+-- Representation for occurrences of other types in a data type definition.
33+data K a = K a
34+
35+-- The Generic class asserts the existence of a type function from "real" types
36+-- to representation types, and an isomorphism between them.
37+class Generic a repr | a -> repr where
38+ to :: a -> repr
39+ from :: repr -> a
40+
41+-- We can write an instance for the (recursive) type of lists. Note that these
42+-- instances would be generated by the compiler ideally.
43+data List a = Nil | Cons a (List a)
44+
45+instance genericList :: Generic (List a) (Ctor "Nil" U1 + Ctor "Cons" (K a * K (List a))) where
46+ to Nil = Inl (Ctor U1)
47+ to (Cons x xs) = Inr (Ctor (Product (K x) (K xs)))
48+ from (Inl (Ctor U1)) = Nil
49+ from (Inr (Ctor (Product (K x) (K xs)))) = Cons x xs
50+
51+-- We'd like to refect type level strings (for data constructor names) at the value
52+-- level, so that we can "show" them. Again, these instances would ideally be derived
53+-- for us.
54+class KnownSymbol (sym :: Symbol) where
55+ symbol :: forall proxy. proxy sym -> String
56+
57+instance knownSymbolNil :: KnownSymbol "Nil" where
58+ symbol _ = "Nil"
59+
60+instance knownSymbolCons :: KnownSymbol "Cons" where
61+ symbol _ = "Cons"
62+
63+-- A proxy for a type-level string.
64+data SProxy (sym :: Symbol) = SProxy
65+
66+-- To write generic functions, we create a corresponding type class, and use the
67+-- type class machinery to infer the correct function based on the representation
68+-- type.
69+class GShow a where
70+ gShow :: a -> String
71+
72+-- Now provide instances for GShow for the appropriate representation types.
73+-- Note: we don't have to implement all instances here.
74+
75+instance gShowU1 :: GShow U1 where
76+ gShow _ = ""
77+
78+instance gShowSum :: (GShow a, GShow b) => GShow (a + b) where
79+ gShow (Inl a) = gShow a
80+ gShow (Inr b) = gShow b
81+
82+instance gShowProduct :: (GShow a, GShow b) => GShow (a * b) where
83+ gShow (Product a b) = gShow a <> gShow b
84+
85+instance gShowCtor :: (KnownSymbol ctor, GShow a) => GShow (Ctor ctor a) where
86+ gShow (Ctor a) = "(" <> symbol (SProxy :: SProxy ctor) <> gShow a <> ")"
87+
88+instance gShowK :: Show a => GShow (K a) where
89+ gShow (K a) = " " <> show a
90+
91+-- Now we can implement a generic show function which uses the GShow instance
92+-- on the representation type.
93+genericShow :: forall a repr. (Generic a repr, GShow repr) => a -> String
94+genericShow x = gShow (to x)
95+
96+-- Note how the required instance here is Show a, and not Generic a.
97+-- This allows us to use generic programming on a wider variety of types
98+-- (including types which contain foreign types) than we can use now.
99+instance showList :: Show a => Show (List a) where
100+ show xs = genericShow xs -- (we need to eta expand here to avoid stack overflow
101+ -- due to recursion implicit in the instance lookup)
102+
103+-- Another example: Eq
104+
105+class GEq a where
106+ gEq :: a -> a -> Boolean
107+
108+instance gEqU1 :: GEq U1 where
109+ gEq _ _ = true
110+
111+instance gEqSum :: (GEq a, GEq b) => GEq (a + b) where
112+ gEq (Inl a1) (Inl a2) = gEq a1 a2
113+ gEq (Inr b1) (Inr b2) = gEq b1 b2
114+ gEq _ _ = false
115+
116+instance gEqProduct :: (GEq a, GEq b) => GEq (a * b) where
117+ gEq (Product a1 b1) (Product a2 b2) = gEq a1 a2 && gEq b1 b2
118+
119+instance gEqCtor :: (KnownSymbol ctor, GEq a) => GEq (Ctor ctor a) where
120+ gEq (Ctor a1) (Ctor a2) = gEq a1 a2
121+
122+instance gEqK :: Eq a => GEq (K a) where
123+ gEq (K a1) (K a2) = a1 == a2
124+
125+genericEq :: forall a repr. (Generic a repr, GEq repr) => a -> a -> Boolean
126+genericEq x y = gEq (to x) (to y)
127+
128+instance eqList :: Eq a => Eq (List a) where
129+ eq xs ys = genericEq xs ys
130+
131+main :: Eff (console :: CONSOLE) Unit
132+main = do
133+ logShow (Cons 1 Nil)
134+ logShow (Cons 1 (Cons 2 Nil))
135+ logShow (Cons 'x' (Cons 'y' (Cons 'z' Nil)))
136+
137+ logShow (Cons 1 (Cons 2 Nil) == Cons 1 (Cons 2 Nil))
138+ logShow (Cons 1 (Cons 2 Nil) == Cons 1 Nil)
139+
140+ log "Done"
examples/passing/NewtypeClass.pursnew file+39
@@ -0,0 +1,39 @@
1+module Main where
2+
3+import Prelude
4+import Control.Monad.Eff
5+import Control.Monad.Eff.Console
6+
7+class Newtype t a | t -> a where
8+ wrap :: a -> t
9+ unwrap :: t -> a
10+
11+instance newtypeMultiplicative :: Newtype (Multiplicative a) a where
12+ wrap = Multiplicative
13+ unwrap (Multiplicative a) = a
14+
15+data Multiplicative a = Multiplicative a
16+
17+instance semiringMultiplicative :: Semiring a => Semigroup (Multiplicative a) where
18+ append (Multiplicative a) (Multiplicative b) = Multiplicative (a * b)
19+
20+data Pair a = Pair a a
21+
22+foldPair :: forall a s. Semigroup s => (a -> s) -> Pair a -> s
23+foldPair f (Pair a b) = f a <> f b
24+
25+ala
26+ :: forall f t a
27+ . (Functor f, Newtype t a)
28+ => (a -> t)
29+ -> ((a -> t) -> f t)
30+ -> f a
31+ala _ f = map unwrap (f wrap)
32+
33+test = ala Multiplicative foldPair
34+
35+test1 = ala Multiplicative foldPair (Pair 2 3)
36+
37+main = do
38+ logShow (test (Pair 2 3))
39+ log "Done"
examples/passing/NewtypeInstance.pursnew file+41
@@ -0,0 +1,41 @@
1+module Main where
2+
3+import Prelude
4+import Control.Monad.Eff
5+import Control.Monad.Eff.Console
6+
7+newtype X = X String
8+
9+derive newtype instance showX :: Show X
10+
11+derive newtype instance eqX :: Eq X
12+
13+derive newtype instance ordX :: Ord X
14+
15+newtype Y a = Y (Array a)
16+
17+derive newtype instance showY :: Show (Y String)
18+
19+class Singleton a b where
20+ singleton :: a -> b
21+
22+instance singletonArray :: Singleton a (Array a) where
23+ singleton x = [x]
24+
25+derive newtype instance singletonY :: Singleton a (Y a)
26+
27+newtype MyArray a = MyArray (Array a)
28+
29+derive newtype instance showMyArray :: Show a => Show (MyArray a)
30+
31+derive newtype instance functorMyArray :: Functor MyArray
32+
33+newtype ProxyArray x a = ProxyArray (Array a)
34+
35+derive newtype instance functorProxyArray :: Functor (ProxyArray x)
36+
37+main = do
38+ logShow (X "test")
39+ logShow (singleton "test" :: Y String)
40+ logShow (map show (MyArray [1, 2, 3]))
41+ log "Done"
examples/passing/NumberLiterals.purs+2−2
@@ -19,8 +19,8 @@ main = do
19 test "32.96176575630599" 32.96176575630599
19 test "32.96176575630599" 32.96176575630599
20 test "38.47735512322269" 38.47735512322269
20 test "38.47735512322269" 38.47735512322269
21
21
22− test "10000000000" 1e10
22+ test "10000000000.0" 1e10
23− test "10000000000" 1.0e10
23+ test "10000000000.0" 1.0e10
24 test "0.00001" 1e-5
24 test "0.00001" 1e-5
25 test "0.00001" 1.0e-5
25 test "0.00001" 1.0e-5
26 test "1.5339794352098402e-118" 1.5339794352098402e-118
26 test "1.5339794352098402e-118" 1.5339794352098402e-118
examples/passing/RowPolyInstanceContext.purs+1−1
@@ -3,7 +3,7 @@ module Main where
3import Prelude
3import Prelude
4import Control.Monad.Eff.Console (log)
4import Control.Monad.Eff.Console (log)
5
5
6−class T s m where
6+class T s m | m -> s where
7 state :: (s -> s) -> m Unit
7 state :: (s -> s) -> m Unit
8
8
9data S s a = S (s -> { new :: s, ret :: a })
9data S s a = S (s -> { new :: s, ret :: a })
examples/passing/Stream.pursnew file+26
@@ -0,0 +1,26 @@
1+module Main where
2+
3+import Prelude
4+
5+import Control.Monad.Eff (Eff)
6+import Control.Monad.Eff.Console (CONSOLE, log)
7+
8+class IsStream el s | s -> el where
9+ cons :: el -> (Unit -> s) -> s
10+ uncons :: s -> { head :: el, tail :: s }
11+
12+data Stream a = Stream a (Unit -> Stream a)
13+
14+instance streamIsStream :: IsStream a (Stream a) where
15+ cons x xs = Stream x xs
16+ uncons (Stream x f) = { head: x, tail: f unit }
17+
18+test :: forall el s. IsStream el s => s -> s
19+test s = case uncons s of
20+ { head, tail } -> cons head \_ -> tail
21+
22+main :: Eff (console :: CONSOLE) Unit
23+main = do
24+ let dones :: Stream String
25+ dones = cons "Done" \_ -> dones
26+ log (uncons (test dones)).head
examples/passing/UnifyInTypeInstanceLookup.pursnew file+25
@@ -0,0 +1,25 @@
1+module Main where
2+
3+import Control.Monad.Eff.Console (log)
4+
5+data Z = Z
6+data S n = S n
7+
8+data T
9+data F
10+
11+class EQ x y b
12+instance eqT :: EQ x x T
13+instance eqF :: EQ x y F
14+
15+test :: forall a b. (EQ a b T) => a -> b -> a
16+test a _ = a
17+
18+spin :: forall a b. a -> b
19+spin a = spin a
20+
21+-- Expected type:
22+-- forall t. (EQ t (S Z) T) => t
23+test1 = test (spin 1) (S Z)
24+
25+main = log "Done"
examples/passing/WildcardInInstance.pursnew file+23
@@ -0,0 +1,23 @@
1+module Main where
2+
3+import Prelude
4+import Control.Monad.Eff
5+import Control.Monad.Eff.Console
6+
7+-- Until the functional dependency gets added to purescript-eff,
8+-- we need this here.
9+class Monad m <= MonadEff eff m | m -> eff where
10+ liftEff :: forall a. Eff eff a -> m a
11+
12+instance monadEffEff :: MonadEff eff (Eff eff) where
13+ liftEff = id
14+
15+-- This should generate a warning with the correct inferred type.
16+test :: forall m. MonadEff _ m => m Unit
17+test = liftEff $ log "Done"
18+
19+test1 :: Eff _ Unit
20+test1 = liftEff $ log "Done"
21+
22+main :: forall eff. Eff (console :: CONSOLE | eff) Unit
23+main = test
examples/warning/UnusedExplicitImportTypeOp.pursnew file+9
@@ -0,0 +1,9 @@
1+-- @shouldWarnWith UnusedExplicitImport
2+module Main where
3+
4+import Prelude (Unit, unit, pure)
5+import Control.Monad.Eff (Eff)
6+import Lib (type (~>), natId)
7+
8+main :: Eff () Unit
9+main = natId (pure unit)
examples/warning/UnusedExplicitImportTypeOp/Lib.pursnew file+8
@@ -0,0 +1,8 @@
1+module Lib where
2+
3+type Nat f g = ∀ x. f x → g x
4+
5+infixr 4 type Nat as ~>
6+
7+natId ∷ ∀ f. f ~> f
8+natId x = x
examples/warning/UnusedExplicitImportValOp.pursnew file+8
@@ -0,0 +1,8 @@
1+-- @shouldWarnWith UnusedExplicitImport
2+module Main where
3+
4+import Prelude (Unit, unit, pure, (+))
5+import Control.Monad.Eff (Eff)
6+
7+main :: Eff () Unit
8+main = pure unit
hierarchy/Main.hs+21−18
@@ -18,13 +18,16 @@
18
18
19module Main where
19module Main where
20
20
21+import Control.Applicative (optional)
21import Control.Monad (unless)
22import Control.Monad (unless)
22
23
23import Data.List (intercalate,nub,sort)
24import Data.List (intercalate,nub,sort)
24import Data.Foldable (for_)
25import Data.Foldable (for_)
25import Data.Version (showVersion)
26import Data.Version (showVersion)
27+import Data.Monoid ((<>))
26
28
27−import Options.Applicative
29+import Options.Applicative (Parser)
30+import qualified Options.Applicative as Opts
28import System.Directory (createDirectoryIfMissing)
31import System.Directory (createDirectoryIfMissing)
29import System.FilePath ((</>))
32import System.FilePath ((</>))
30import System.FilePath.Glob (glob)
33import System.FilePath.Glob (glob)
@@ -40,7 +43,7 @@ data HierarchyOptions = HierarchyOptions
40 , hierarchyOutput :: Maybe FilePath
43 , hierarchyOutput :: Maybe FilePath
41 }
44 }
42
45
43−newtype SuperMap = SuperMap { unSuperMap :: Either (P.ProperName 'P.ClassName) ((P.ProperName 'P.ClassName), (P.ProperName 'P.ClassName)) }
46+newtype SuperMap = SuperMap { unSuperMap :: Either (P.ProperName 'P.ClassName) (P.ProperName 'P.ClassName, P.ProperName 'P.ClassName) }
44 deriving Eq
47 deriving Eq
45
48
46instance Show SuperMap where
49instance Show SuperMap where
@@ -83,33 +86,33 @@ compile (HierarchyOptions inputGlob mOutput) = do
83 exitSuccess
86 exitSuccess
84
87
85superClasses :: P.Declaration -> [SuperMap]
88superClasses :: P.Declaration -> [SuperMap]
86−superClasses (P.TypeClassDeclaration sub _ supers@(_:_) _) =
89+superClasses (P.TypeClassDeclaration sub _ supers@(_:_) _ _) =
87 fmap (\(P.Constraint (P.Qualified _ super) _ _) -> SuperMap (Right (super, sub))) supers
90 fmap (\(P.Constraint (P.Qualified _ super) _ _) -> SuperMap (Right (super, sub))) supers
88−superClasses (P.TypeClassDeclaration sub _ _ _) = [SuperMap (Left sub)]
91+superClasses (P.TypeClassDeclaration sub _ _ _ _) = [SuperMap (Left sub)]
89superClasses (P.PositionedDeclaration _ _ decl) = superClasses decl
92superClasses (P.PositionedDeclaration _ _ decl) = superClasses decl
90superClasses _ = []
93superClasses _ = []
91
94
92inputFile :: Parser FilePath
95inputFile :: Parser FilePath
93−inputFile = strArgument $
96+inputFile = Opts.strArgument $
94− metavar "FILE"
97+ Opts.metavar "FILE"
95− <> value "main.purs"
98+ <> Opts.value "main.purs"
96− <> showDefault
99+ <> Opts.showDefault
97− <> help "The input file to generate a hierarchy from"
100+ <> Opts.help "The input file to generate a hierarchy from"
98
101
99outputFile :: Parser (Maybe FilePath)
102outputFile :: Parser (Maybe FilePath)
100−outputFile = optional . strOption $
103+outputFile = optional . Opts.strOption $
101− short 'o'
104+ Opts.short 'o'
102− <> long "output"
105+ <> Opts.long "output"
103− <> help "The output directory"
106+ <> Opts.help "The output directory"
104
107
105pscOptions :: Parser HierarchyOptions
108pscOptions :: Parser HierarchyOptions
106pscOptions = HierarchyOptions <$> inputFile
109pscOptions = HierarchyOptions <$> inputFile
107 <*> outputFile
110 <*> outputFile
108
111
109main :: IO ()
112main :: IO ()
110−main = execParser opts >>= compile
113+main = Opts.execParser opts >>= compile
111 where
114 where
112− opts = info (helper <*> pscOptions) infoModList
115+ opts = Opts.info (Opts.helper <*> pscOptions) infoModList
113− infoModList = fullDesc <> headerInfo <> footerInfo
116+ infoModList = Opts.fullDesc <> headerInfo <> footerInfo
114− headerInfo = header "hierarchy - Creates a GraphViz directed graph of PureScript TypeClasses"
117+ headerInfo = Opts.header "hierarchy - Creates a GraphViz directed graph of PureScript TypeClasses"
115− footerInfo = footer $ "hierarchy " ++ showVersion Paths.version
118+ footerInfo = Opts.footer $ "hierarchy " ++ showVersion Paths.version
psc-bundle/Main.hs+28−25
@@ -8,6 +8,7 @@ module Main (main) where
8
8
9import Data.Traversable (for)
9import Data.Traversable (for)
10import Data.Version (showVersion)
10import Data.Version (showVersion)
11+import Data.Monoid ((<>))
11
12
12import Control.Applicative
13import Control.Applicative
13import Control.Monad
14import Control.Monad
@@ -24,7 +25,8 @@ import System.Directory (createDirectoryIfMissing)
24
25
25import Language.PureScript.Bundle
26import Language.PureScript.Bundle
26
27
27−import Options.Applicative as Opts
28+import Options.Applicative (Parser, ParseError (..))
29+import qualified Options.Applicative as Opts
28
30
29import qualified Paths_purescript as Paths
31import qualified Paths_purescript as Paths
30
32
@@ -64,41 +66,41 @@ options = Options <$> some inputFile
64 <*> namespace
66 <*> namespace
65 where
67 where
66 inputFile :: Parser FilePath
68 inputFile :: Parser FilePath
67− inputFile = strArgument $
69+ inputFile = Opts.strArgument $
68− metavar "FILE"
70+ Opts.metavar "FILE"
69− <> help "The input .js file(s)"
71+ <> Opts.help "The input .js file(s)"
70
72
71 outputFile :: Parser FilePath
73 outputFile :: Parser FilePath
72− outputFile = strOption $
74+ outputFile = Opts.strOption $
73− short 'o'
75+ Opts.short 'o'
74− <> long "output"
76+ <> Opts.long "output"
75− <> help "The output .js file"
77+ <> Opts.help "The output .js file"
76
78
77 entryPoint :: Parser String
79 entryPoint :: Parser String
78− entryPoint = strOption $
80+ entryPoint = Opts.strOption $
79− short 'm'
81+ Opts.short 'm'
80− <> long "module"
82+ <> Opts.long "module"
81− <> help "Entry point module name(s). All code which is not a transitive dependency of an entry point module will be removed."
83+ <> Opts.help "Entry point module name(s). All code which is not a transitive dependency of an entry point module will be removed."
82
84
83 mainModule :: Parser String
85 mainModule :: Parser String
84− mainModule = strOption $
86+ mainModule = Opts.strOption $
85− long "main"
87+ Opts.long "main"
86− <> help "Generate code to run the main method in the specified module."
88+ <> Opts.help "Generate code to run the main method in the specified module."
87
89
88 namespace :: Parser String
90 namespace :: Parser String
89− namespace = strOption $
91+ namespace = Opts.strOption $
90− short 'n'
92+ Opts.short 'n'
91− <> long "namespace"
93+ <> Opts.long "namespace"
92 <> Opts.value "PS"
94 <> Opts.value "PS"
93− <> showDefault
95+ <> Opts.showDefault
94− <> help "Specify the namespace that PureScript modules will be exported to when running in the browser."
96+ <> Opts.help "Specify the namespace that PureScript modules will be exported to when running in the browser."
95
97
96-- | Make it go.
98-- | Make it go.
97main :: IO ()
99main :: IO ()
98main = do
100main = do
99 hSetEncoding stdout utf8
101 hSetEncoding stdout utf8
100 hSetEncoding stderr utf8
102 hSetEncoding stderr utf8
101− opts <- execParser (info (version <*> helper <*> options) infoModList)
103+ opts <- Opts.execParser (Opts.info (version <*> Opts.helper <*> options) infoModList)
102 output <- runExceptT (app opts)
104 output <- runExceptT (app opts)
103 case output of
105 case output of
104 Left err -> do
106 Left err -> do
@@ -111,9 +113,10 @@ main = do
111 writeFile outputFile js
113 writeFile outputFile js
112 Nothing -> putStrLn js
114 Nothing -> putStrLn js
113 where
115 where
114− infoModList = fullDesc <> headerInfo <> footerInfo
116+ infoModList = Opts.fullDesc <> headerInfo <> footerInfo
115− headerInfo = header "psc-bundle - Bundles compiled PureScript modules for the browser"
117+ headerInfo = Opts.header "psc-bundle - Bundles compiled PureScript modules for the browser"
116− footerInfo = footer $ "psc-bundle " ++ showVersion Paths.version
118+ footerInfo = Opts.footer $ "psc-bundle " ++ showVersion Paths.version
117
119
118 version :: Parser (a -> a)
120 version :: Parser (a -> a)
119− version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> help "Show the version number" <> hidden
121+ version = Opts.abortOption (InfoMsg (showVersion Paths.version)) $
122+ Opts.long "version" <> Opts.help "Show the version number" <> Opts.hidden
psc-docs/Tags.hs+1−1
@@ -13,6 +13,6 @@ tags = concatMap dtags . P.exportedDeclarations
13 names (P.TypeDeclaration ident _) = [P.showIdent ident]
13 names (P.TypeDeclaration ident _) = [P.showIdent ident]
14 names (P.ExternDeclaration ident _) = [P.showIdent ident]
14 names (P.ExternDeclaration ident _) = [P.showIdent ident]
15 names (P.TypeSynonymDeclaration name _ _) = [P.runProperName name]
15 names (P.TypeSynonymDeclaration name _ _) = [P.runProperName name]
16− names (P.TypeClassDeclaration name _ _ _) = [P.runProperName name]
16+ names (P.TypeClassDeclaration name _ _ _ _) = [P.runProperName name]
17 names (P.TypeInstanceDeclaration name _ _ _ _) = [P.showIdent name]
17 names (P.TypeInstanceDeclaration name _ _ _ _) = [P.showIdent name]
18 names _ = []
18 names _ = []
psc-ide-client/Main.hs+8−5
@@ -8,8 +8,10 @@ import Control.Exception
8import qualified Data.ByteString.Char8 as BS8
8import qualified Data.ByteString.Char8 as BS8
9import qualified Data.Text.IO as T
9import qualified Data.Text.IO as T
10import Data.Version (showVersion)
10import Data.Version (showVersion)
11+import Data.Monoid ((<>))
11import Network
12import Network
12−import Options.Applicative
13+import Options.Applicative (ParseError (..))
14+import qualified Options.Applicative as Opts
13import System.Exit
15import System.Exit
14import System.IO
16import System.IO
15
17
@@ -21,15 +23,16 @@ data Options = Options
21
23
22main :: IO ()
24main :: IO ()
23main = do
25main = do
24− Options port <- execParser opts
26+ Options port <- Opts.execParser opts
25 client port
27 client port
26 where
28 where
27 parser =
29 parser =
28 Options <$>
30 Options <$>
29 (PortNumber . fromIntegral <$>
31 (PortNumber . fromIntegral <$>
30− option auto (long "port" <> short 'p' <> value (4242 :: Integer)))
32+ Opts.option Opts.auto (Opts.long "port" <> Opts.short 'p' <> Opts.value (4242 :: Integer)))
31− opts = info (version <*> helper <*> parser) mempty
33+ opts = Opts.info (version <*> Opts.helper <*> parser) mempty
32− version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> help "Show the version number" <> hidden
34+ version = Opts.abortOption (InfoMsg (showVersion Paths.version)) $
35+ Opts.long "version" <> Opts.help "Show the version number" <> Opts.hidden
33
36
34client :: PortID -> IO ()
37client :: PortID -> IO ()
35client port = do
38client port = do
psc-ide-server/Main.hs+13−12
@@ -38,7 +38,8 @@ import Network hiding (socketPort, accept)
38import Network.BSD (getProtocolNumber)
38import Network.BSD (getProtocolNumber)
39import Network.Socket hiding (PortNumber, Type,
39import Network.Socket hiding (PortNumber, Type,
40 sClose)
40 sClose)
41−import Options.Applicative hiding ((<>))
41+import Options.Applicative (ParseError (..))
42+import qualified Options.Applicative as Opts
42import System.Directory
43import System.Directory
43import System.FilePath
44import System.FilePath
44import System.IO hiding (putStrLn, print)
45import System.IO hiding (putStrLn, print)
@@ -55,7 +56,7 @@ listenOnLocalhost port = do
55 sClose
56 sClose
56 (\sock -> do
57 (\sock -> do
57 setSocketOption sock ReuseAddr 1
58 setSocketOption sock ReuseAddr 1
58− bindSocket sock (SockAddrInet port localhost)
59+ bind sock (SockAddrInet port localhost)
59 listen sock maxListenQueue
60 listen sock maxListenQueue
60 pure sock)
61 pure sock)
61
62
@@ -70,7 +71,7 @@ data Options = Options
70
71
71main :: IO ()
72main :: IO ()
72main = do
73main = do
73− Options dir globs outputPath port noWatch debug <- execParser opts
74+ Options dir globs outputPath port noWatch debug <- Opts.execParser opts
74 maybe (pure ()) setCurrentDirectory dir
75 maybe (pure ()) setCurrentDirectory dir
75 ideState <- newTVarIO emptyIdeState
76 ideState <- newTVarIO emptyIdeState
76 cwd <- getCurrentDirectory
77 cwd <- getCurrentDirectory
@@ -91,17 +92,17 @@ main = do
91 where
92 where
92 parser =
93 parser =
93 Options
94 Options
94− <$> optional (strOption (long "directory" `mappend` short 'd'))
95+ <$> optional (Opts.strOption (Opts.long "directory" `mappend` Opts.short 'd'))
95− <*> many (argument str (metavar "Source GLOBS..."))
96+ <*> many (Opts.argument Opts.str (Opts.metavar "Source GLOBS..."))
96− <*> strOption (long "output-directory" `mappend` value "output/")
97+ <*> Opts.strOption (Opts.long "output-directory" `mappend` Opts.value "output/")
97 <*> (fromIntegral <$>
98 <*> (fromIntegral <$>
98− option auto (long "port" `mappend` short 'p' `mappend` value (4242 :: Integer)))
99+ Opts.option Opts.auto (Opts.long "port" `mappend` Opts.short 'p' `mappend` Opts.value (4242 :: Integer)))
99− <*> switch (long "no-watch")
100+ <*> Opts.switch (Opts.long "no-watch")
100− <*> switch (long "debug")
101+ <*> Opts.switch (Opts.long "debug")
101− opts = info (version <*> helper <*> parser) mempty
102+ opts = Opts.info (version <*> Opts.helper <*> parser) mempty
102− version = abortOption
103+ version = Opts.abortOption
103 (InfoMsg (showVersion Paths.version))
104 (InfoMsg (showVersion Paths.version))
104− (long "version" `mappend` help "Show the version number")
105+ (Opts.long "version" `mappend` Opts.help "Show the version number")
105
106
106startServer :: PortNumber -> IdeEnvironment -> IO ()
107startServer :: PortNumber -> IdeEnvironment -> IO ()
107startServer port env = withSocketsDo $ do
108startServer port env = withSocketsDo $ do
psc-ide-server/PROTOCOL.md+46−30
@@ -51,27 +51,7 @@ definition position, if it can be found in the passed source files.
51```
51```
52
52
53**Result:**
53**Result:**
54−The possible types are returned in the same format as completions + eventual position information
54+The possible types are returned in the same format as completions
55−```json
56−[
57− {
58− "module": "Data.Array",
59− "identifier": "filter",
60− "type": "forall a. (a -> Boolean) -> Array a -> Array a"
61− },
62− {
63− "module": "Data.Array",
64− "identifier": "filter",
65− "type": "forall a. (a -> Boolean) -> Array a -> Array a",
66− "definedAt":
67− {
68− "name": "/path/to/file",
69− "start": [1, 3],
70− "end": [3, 1]
71− }
72− }
73−]
74−```
75
55
76### Complete
56### Complete
77The `complete` command looks up possible completions/corrections.
57The `complete` command looks up possible completions/corrections.
@@ -88,7 +68,7 @@ The `complete` command looks up possible completions/corrections.
88
68
89 If no matcher is given every candidate, that passes the filters, is returned
69 If no matcher is given every candidate, that passes the filters, is returned
90 in no particular order.
70 in no particular order.
91−
71+
92```json
72```json
93{
73{
94 "command": "complete",
74 "command": "complete",
@@ -104,18 +84,29 @@ The `complete` command looks up possible completions/corrections.
104
84
105The following format is returned as the Result:
85The following format is returned as the Result:
106
86
87+Both the `definedAt` aswell as the `documentation` field might be `null` if they
88+couldn't be extracted from a source file.
89+
107```json
90```json
108[
91[
109 {
92 {
110 "module": "Data.Array",
93 "module": "Data.Array",
111 "identifier": "filter",
94 "identifier": "filter",
112− "type": "forall a. (a -> Boolean) -> Array a -> Array a"
95+ "type": "forall a. (a -> Boolean) -> Array a -> Array a",
96+ "expandedType": "forall a. (a -> Boolean) -> Array a -> Array a",
97+ "definedAt":
98+ {
99+ "name": "/path/to/file",
100+ "start": [1, 3],
101+ "end": [3, 1]
102+ },
103+ "documentation": "A filtering function"
113 }
104 }
114]
105]
115```
106```
116
107
117
108
118−### CaseSplit
109+### CaseSplit
119
110
120The CaseSplit command takes a line of source code, an area in that line of code
111The CaseSplit command takes a line of source code, an area in that line of code
121and replaces it with all patterns for a given type. The parameter `annotations`
112and replaces it with all patterns for a given type. The parameter `annotations`
@@ -259,9 +250,9 @@ Example:
259 "importCommand": {
250 "importCommand": {
260 "importCommand": "addImport",
251 "importCommand": "addImport",
261 "identifier": "bind"
252 "identifier": "bind"
262− }
253+ }
263 }
254 }
264−}
255+}
265```
256```
266
257
267### Rebuild
258### Rebuild
@@ -390,7 +381,7 @@ The list commmand can also list the imports for a given file.
390
381
391The list import command returns a list of imports where imports are of the following form:
382The list import command returns a list of imports where imports are of the following form:
392
383
393−Implicit Import(`import Data.Array`):
384+Implicit Import (`import Data.Array`):
394```json
385```json
395[
386[
396 {
387 {
@@ -400,7 +391,7 @@ Implicit Import(`import Data.Array`):
400]
391]
401```
392```
402
393
403−Implicit qualified Import(`import qualified Data.Array as A`):
394+Implicit qualified Import (`import Data.Array as A`):
404```json
395```json
405[
396[
406 {
397 {
@@ -411,7 +402,7 @@ Implicit qualified Import(`import qualified Data.Array as A`):
411]
402]
412```
403```
413
404
414−Explicit Import(`import Data.Array (filter, filterM, join)`):
405+Explicit Import (`import Data.Array (filter, filterM, join)`):
415```json
406```json
416[
407[
417 {
408 {
@@ -422,7 +413,19 @@ Explicit Import(`import Data.Array (filter, filterM, join)`):
422]
413]
423```
414```
424
415
416+Explicit qualified Import (`import Data.Array (filter, filterM, join) as A`):
417+```json
418+[
419+ {
420+ "module": "Data.Array",
421+ "importType": "explicit",
422+ "identifiers": ["filter", "filterM", "join"],
423+ "qualifier": "A"
424+ }
425+]
426+```
427+
425−Hiding Import(`import Data.Array hiding (filter, filterM, join)`):
428+Hiding Import (`import Data.Array hiding (filter, filterM, join)`):
426```json
429```json
427[
430[
428 {
431 {
@@ -432,6 +435,19 @@ Hiding Import(`import Data.Array hiding (filter, filterM, join)`):
432 }
435 }
433]
436]
434```
437```
438+
439+Qualified Hiding Import (`import Data.Array hiding (filter, filterM, join) as A`):
440+```json
441+[
442+ {
443+ "module": "Data.Array",
444+ "importType": "hiding",
445+ "identifiers": ["filter", "filterM", "join"],
446+ "qualifier": "A"
447+ }
448+]
449+```
450+
435### Cwd/Quit/Reset
451### Cwd/Quit/Reset
436`cwd` returns the working directory of the server(should be your project root).
452`cwd` returns the working directory of the server(should be your project root).
437
453
psc-publish/Main.hs+13−10
@@ -4,8 +4,10 @@ module Main where
4import Data.Version (Version(..), showVersion)
4import Data.Version (Version(..), showVersion)
5import qualified Data.Aeson as A
5import qualified Data.Aeson as A
6import qualified Data.ByteString.Lazy.Char8 as BL
6import qualified Data.ByteString.Lazy.Char8 as BL
7+import Data.Monoid ((<>))
7
8
8−import Options.Applicative hiding (str)
9+import Options.Applicative (Parser, ParseError (..))
10+import qualified Options.Applicative as Opts
9
11
10import System.IO (hSetEncoding, stderr, stdout, utf8)
12import System.IO (hSetEncoding, stderr, stdout, utf8)
11
13
@@ -14,9 +16,9 @@ import Language.PureScript.Publish
14import Language.PureScript.Publish.ErrorsWarnings
16import Language.PureScript.Publish.ErrorsWarnings
15
17
16dryRun :: Parser Bool
18dryRun :: Parser Bool
17−dryRun = switch $
19+dryRun = Opts.switch $
18− long "dry-run"
20+ Opts.long "dry-run"
19− <> help "Produce no output, and don't require a tagged version to be checked out."
21+ <> Opts.help "Produce no output, and don't require a tagged version to be checked out."
20
22
21dryRunOptions :: PublishOptions
23dryRunOptions :: PublishOptions
22dryRunOptions = defaultPublishOptions
24dryRunOptions = defaultPublishOptions
@@ -29,15 +31,16 @@ main :: IO ()
29main = do
31main = do
30 hSetEncoding stdout utf8
32 hSetEncoding stdout utf8
31 hSetEncoding stderr utf8
33 hSetEncoding stderr utf8
32− execParser opts >>= publish
34+ Opts.execParser opts >>= publish
33 where
35 where
34− opts = info (version <*> helper <*> dryRun) infoModList
36+ opts = Opts.info (version <*> Opts.helper <*> dryRun) infoModList
35− infoModList = fullDesc <> headerInfo <> footerInfo
37+ infoModList = Opts.fullDesc <> headerInfo <> footerInfo
36− headerInfo = header "psc-publish - Generates documentation packages for upload to http://pursuit.purescript.org"
38+ headerInfo = Opts.header "psc-publish - Generates documentation packages for upload to http://pursuit.purescript.org"
37− footerInfo = footer $ "psc-publish " ++ showVersion Paths.version
39+ footerInfo = Opts.footer $ "psc-publish " ++ showVersion Paths.version
38
40
39 version :: Parser (a -> a)
41 version :: Parser (a -> a)
40− version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> help "Show the version number" <> hidden
42+ version = Opts.abortOption (InfoMsg (showVersion Paths.version)) $
43+ Opts.long "version" <> Opts.help "Show the version number" <> Opts.hidden
41
44
42publish :: Bool -> IO ()
45publish :: Bool -> IO ()
43publish isDryRun =
46publish isDryRun =
psc/Main.hs+10−4
@@ -79,11 +79,11 @@ warnFileTypeNotFound = hPutStrLn stderr . ("psc: No files found using pattern: "
79globWarningOnMisses :: (String -> IO ()) -> [FilePath] -> IO [FilePath]
79globWarningOnMisses :: (String -> IO ()) -> [FilePath] -> IO [FilePath]
80globWarningOnMisses warn = concatMapM globWithWarning
80globWarningOnMisses warn = concatMapM globWithWarning
81 where
81 where
82− globWithWarning pattern = do
82+ globWithWarning pattern' = do
83− paths <- glob pattern
83+ paths <- glob pattern'
84− when (null paths) $ warn pattern
84+ when (null paths) $ warn pattern'
85 return paths
85 return paths
86− concatMapM f = liftM concat . mapM f
86+ concatMapM f = fmap concat . mapM f
87
87
88readInput :: [FilePath] -> IO [(FilePath, String)]
88readInput :: [FilePath] -> IO [(FilePath, String)]
89readInput inputFiles = forM inputFiles $ \inFile -> (inFile, ) <$> readUTF8File inFile
89readInput inputFiles = forM inputFiles $ \inFile -> (inFile, ) <$> readUTF8File inFile
@@ -143,6 +143,11 @@ sourceMaps = switch $
143 long "source-maps"
143 long "source-maps"
144 <> help "Generate source maps"
144 <> help "Generate source maps"
145
145
146+dumpCoreFn :: Parser Bool
147+dumpCoreFn = switch $
148+ long "dump-corefn"
149+ <> help "Dump the (functional) core representation of the compiled code at output/*/corefn.json"
150+
146
151
147options :: Parser P.Options
152options :: Parser P.Options
148options = P.Options <$> noTco
153options = P.Options <$> noTco
@@ -152,6 +157,7 @@ options = P.Options <$> noTco
152 <*> verboseErrors
157 <*> verboseErrors
153 <*> (not <$> comments)
158 <*> (not <$> comments)
154 <*> sourceMaps
159 <*> sourceMaps
160+ <*> dumpCoreFn
155
161
156pscMakeOptions :: Parser PSCMakeOptions
162pscMakeOptions :: Parser PSCMakeOptions
157pscMakeOptions = PSCMakeOptions <$> many inputFile
163pscMakeOptions = PSCMakeOptions <$> many inputFile
psci/Main.hs+3−3
@@ -207,7 +207,7 @@ browserBackend serverPort = Backend setup evaluate reload shutdown
207 -- With many connected clients, all but one of
207 -- With many connected clients, all but one of
208 -- these attempts will fail.
208 -- these attempts will fail.
209 tryPutMVar resultVar (unpack result)
209 tryPutMVar resultVar (unpack result)
210− Reload -> do
210+ Reload ->
211 WS.sendTextData conn ("reload" :: Text)
211 WS.sendTextData conn ("reload" :: Text)
212
212
213 shutdownHandler :: IO () -> IO ()
213 shutdownHandler :: IO () -> IO ()
@@ -278,7 +278,7 @@ browserBackend serverPort = Backend setup evaluate reload shutdown
278 Left err -> do
278 Left err -> do
279 putStrLn (unlines (Bundle.printErrorMessage err))
279 putStrLn (unlines (Bundle.printErrorMessage err))
280 exitFailure
280 exitFailure
281− Right js -> do
281+ Right js ->
282 atomically $ writeTVar (browserBundleJS state) (Just js)
282 atomically $ writeTVar (browserBundleJS state) (Just js)
283
283
284 reload :: BrowserState -> IO ()
284 reload :: BrowserState -> IO ()
@@ -335,7 +335,7 @@ main = getOpt >>= loop
335 (externs, env) <- ExceptT . runMake . make $ modules
335 (externs, env) <- ExceptT . runMake . make $ modules
336 return (modules, externs, env)
336 return (modules, externs, env)
337 case psciBackend of
337 case psciBackend of
338− Backend setup eval reload (shutdown :: state -> IO ()) -> do
338+ Backend setup eval reload (shutdown :: state -> IO ()) ->
339 case e of
339 case e of
340 Left errs -> putStrLn (P.prettyPrintMultipleErrors P.defaultPPEOptions errs) >> exitFailure
340 Left errs -> putStrLn (P.prettyPrintMultipleErrors P.defaultPPEOptions errs) >> exitFailure
341 Right (modules, externs, env) -> do
341 Right (modules, externs, env) -> do
purescript.cabal+7−2
@@ -1,5 +1,5 @@
1name: purescript
1name: purescript
2−version: 0.9.3
2+version: 0.10.0
3cabal-version: >=1.8
3cabal-version: >=1.8
4build-type: Simple
4build-type: Simple
5license: MIT
5license: MIT
@@ -60,6 +60,7 @@ extra-source-files: examples/passing/*.purs
60 , examples/failing/ConflictingImports2/*.purs
60 , examples/failing/ConflictingImports2/*.purs
61 , examples/failing/ConflictingQualifiedImports/*.purs
61 , examples/failing/ConflictingQualifiedImports/*.purs
62 , examples/failing/ConflictingQualifiedImports2/*.purs
62 , examples/failing/ConflictingQualifiedImports2/*.purs
63+ , examples/failing/DuplicateModule/*.purs
63 , examples/failing/ExportConflictClass/*.purs
64 , examples/failing/ExportConflictClass/*.purs
64 , examples/failing/ExportConflictCtor/*.purs
65 , examples/failing/ExportConflictCtor/*.purs
65 , examples/failing/ExportConflictType/*.purs
66 , examples/failing/ExportConflictType/*.purs
@@ -76,6 +77,7 @@ extra-source-files: examples/passing/*.purs
76 , examples/failing/OrphanInstance/*.purs
77 , examples/failing/OrphanInstance/*.purs
77 , examples/warning/*.purs
78 , examples/warning/*.purs
78 , examples/warning/*.js
79 , examples/warning/*.js
80+ , examples/warning/UnusedExplicitImportTypeOp/*.purs
79 , examples/docs/bower_components/purescript-prelude/src/*.purs
81 , examples/docs/bower_components/purescript-prelude/src/*.purs
80 , examples/docs/bower.json
82 , examples/docs/bower.json
81 , examples/docs/src/*.purs
83 , examples/docs/src/*.purs
@@ -110,6 +112,7 @@ library
110 bytestring -any,
112 bytestring -any,
111 containers -any,
113 containers -any,
112 clock -any,
114 clock -any,
115+ data-ordlist >= 0.4.7.0,
113 directory >= 1.2,
116 directory >= 1.2,
114 dlist -any,
117 dlist -any,
115 edit-distance -any,
118 edit-distance -any,
@@ -117,7 +120,7 @@ library
117 fsnotify >= 0.2.1,
120 fsnotify >= 0.2.1,
118 Glob >= 0.7 && < 0.8,
121 Glob >= 0.7 && < 0.8,
119 haskeline >= 0.7.0.0,
122 haskeline >= 0.7.0.0,
120− http-client >= 0.4.30 && <0.5,
123+ http-client >= 0.4.30 && <0.6,
121 http-types -any,
124 http-types -any,
122 language-javascript == 0.6.*,
125 language-javascript == 0.6.*,
123 lifted-base >= 0.2.3 && < 0.2.4,
126 lifted-base >= 0.2.3 && < 0.2.4,
@@ -196,6 +199,7 @@ library
196 Language.PureScript.CoreFn.Meta
199 Language.PureScript.CoreFn.Meta
197 Language.PureScript.CoreFn.Module
200 Language.PureScript.CoreFn.Module
198 Language.PureScript.CoreFn.Traversals
201 Language.PureScript.CoreFn.Traversals
202+ Language.PureScript.CoreFn.ToJSON
199 Language.PureScript.Comments
203 Language.PureScript.Comments
200 Language.PureScript.Environment
204 Language.PureScript.Environment
201 Language.PureScript.Errors
205 Language.PureScript.Errors
@@ -563,6 +567,7 @@ test-suite tests
563 Language.PureScript.Ide.ReexportsSpec
567 Language.PureScript.Ide.ReexportsSpec
564 Language.PureScript.Ide.SourceFile.IntegrationSpec
568 Language.PureScript.Ide.SourceFile.IntegrationSpec
565 Language.PureScript.Ide.SourceFileSpec
569 Language.PureScript.Ide.SourceFileSpec
570+ Language.PureScript.Ide.StateSpec
566 buildable: True
571 buildable: True
567 hs-source-dirs: tests
572 hs-source-dirs: tests
568
573
src/Control/Monad/Supply/Class.hs+4
@@ -7,6 +7,7 @@ import Prelude.Compat
7
7
8import Control.Monad.Supply
8import Control.Monad.Supply
9import Control.Monad.State
9import Control.Monad.State
10+import Control.Monad.Writer
10
11
11class Monad m => MonadSupply m where
12class Monad m => MonadSupply m where
12 fresh :: m Integer
13 fresh :: m Integer
@@ -20,5 +21,8 @@ instance Monad m => MonadSupply (SupplyT m) where
20instance MonadSupply m => MonadSupply (StateT s m) where
21instance MonadSupply m => MonadSupply (StateT s m) where
21 fresh = lift fresh
22 fresh = lift fresh
22
23
24+instance (Monoid w, MonadSupply m) => MonadSupply (WriterT w m) where
25+ fresh = lift fresh
26+
23freshName :: MonadSupply m => m String
27freshName :: MonadSupply m => m String
24freshName = fmap (('$' :) . show) fresh
28freshName = fmap (('$' :) . show) fresh
src/Language/PureScript/AST/Declarations.hs+21−11
@@ -47,7 +47,6 @@ data SimpleErrorMessage
47 | MultipleValueOpFixities (OpName 'ValueOpName)
47 | MultipleValueOpFixities (OpName 'ValueOpName)
48 | MultipleTypeOpFixities (OpName 'TypeOpName)
48 | MultipleTypeOpFixities (OpName 'TypeOpName)
49 | OrphanTypeDeclaration Ident
49 | OrphanTypeDeclaration Ident
50− | RedefinedModule ModuleName [SourceSpan]
51 | RedefinedIdent Ident
50 | RedefinedIdent Ident
52 | OverlappingNamesInLet
51 | OverlappingNamesInLet
53 | UnknownName (Qualified Name)
52 | UnknownName (Qualified Name)
@@ -59,7 +58,7 @@ data SimpleErrorMessage
59 | ScopeShadowing Name (Maybe ModuleName) [ModuleName]
58 | ScopeShadowing Name (Maybe ModuleName) [ModuleName]
60 | DeclConflict Name Name
59 | DeclConflict Name Name
61 | ExportConflict (Qualified Name) (Qualified Name)
60 | ExportConflict (Qualified Name) (Qualified Name)
62− | DuplicateModuleName ModuleName
61+ | DuplicateModule ModuleName [SourceSpan]
63 | DuplicateTypeArgument String
62 | DuplicateTypeArgument String
64 | InvalidDoBind
63 | InvalidDoBind
65 | InvalidDoLet
64 | InvalidDoLet
@@ -77,6 +76,7 @@ data SimpleErrorMessage
77 | NoInstanceFound Constraint
76 | NoInstanceFound Constraint
78 | PossiblyInfiniteInstance (Qualified (ProperName 'ClassName)) [Type]
77 | PossiblyInfiniteInstance (Qualified (ProperName 'ClassName)) [Type]
79 | CannotDerive (Qualified (ProperName 'ClassName)) [Type]
78 | CannotDerive (Qualified (ProperName 'ClassName)) [Type]
79+ | InvalidNewtypeInstance (Qualified (ProperName 'ClassName)) [Type]
80 | CannotFindDerivingType (ProperName 'TypeName)
80 | CannotFindDerivingType (ProperName 'TypeName)
81 | DuplicateLabel String (Maybe Expr)
81 | DuplicateLabel String (Maybe Expr)
82 | DuplicateValueDeclaration Ident
82 | DuplicateValueDeclaration Ident
@@ -89,7 +89,6 @@ data SimpleErrorMessage
89 | ExprDoesNotHaveType Expr Type
89 | ExprDoesNotHaveType Expr Type
90 | PropertyIsMissing String
90 | PropertyIsMissing String
91 | AdditionalProperty String
91 | AdditionalProperty String
92− | CannotApplyFunction Type Expr
93 | TypeSynonymInstance
92 | TypeSynonymInstance
94 | OrphanInstance Ident (Qualified (ProperName 'ClassName)) [Type]
93 | OrphanInstance Ident (Qualified (ProperName 'ClassName)) [Type]
95 | InvalidNewtype (ProperName 'TypeName)
94 | InvalidNewtype (ProperName 'TypeName)
@@ -107,9 +106,9 @@ data SimpleErrorMessage
107 | MisleadingEmptyTypeImport ModuleName (ProperName 'TypeName)
106 | MisleadingEmptyTypeImport ModuleName (ProperName 'TypeName)
108 | ImportHidingModule ModuleName
107 | ImportHidingModule ModuleName
109 | UnusedImport ModuleName
108 | UnusedImport ModuleName
110− | UnusedExplicitImport ModuleName [String] (Maybe ModuleName) [DeclarationRef]
109+ | UnusedExplicitImport ModuleName [Name] (Maybe ModuleName) [DeclarationRef]
111− | UnusedDctorImport (ProperName 'TypeName)
110+ | UnusedDctorImport ModuleName (ProperName 'TypeName) (Maybe ModuleName) [DeclarationRef]
112− | UnusedDctorExplicitImport (ProperName 'TypeName) [ProperName 'ConstructorName]
111+ | UnusedDctorExplicitImport ModuleName (ProperName 'TypeName) [ProperName 'ConstructorName] (Maybe ModuleName) [DeclarationRef]
113 | DuplicateSelectiveImport ModuleName
112 | DuplicateSelectiveImport ModuleName
114 | DuplicateImport ModuleName ImportDeclarationType (Maybe ModuleName)
113 | DuplicateImport ModuleName ImportDeclarationType (Maybe ModuleName)
115 | DuplicateImportRef Name
114 | DuplicateImportRef Name
@@ -123,6 +122,8 @@ data SimpleErrorMessage
123 | InvalidOperatorInBinder (Qualified (OpName 'ValueOpName)) (Qualified Ident)
122 | InvalidOperatorInBinder (Qualified (OpName 'ValueOpName)) (Qualified Ident)
124 | DeprecatedRequirePath
123 | DeprecatedRequirePath
125 | CannotGeneralizeRecursiveFunction Ident Type
124 | CannotGeneralizeRecursiveFunction Ident Type
125+ | CannotDeriveNewtypeForData (ProperName 'TypeName)
126+ | NonWildcardNewtypeInstance (ProperName 'TypeName)
126 deriving (Show)
127 deriving (Show)
127
128
128-- | Error message hints, providing more detailed information about failure.
129-- | Error message hints, providing more detailed information about failure.
@@ -177,6 +178,10 @@ data Module = Module SourceSpan [Comment] ModuleName [Declaration] (Maybe [Decla
177getModuleName :: Module -> ModuleName
178getModuleName :: Module -> ModuleName
178getModuleName (Module _ _ name _ _) = name
179getModuleName (Module _ _ name _ _) = name
179
180
181+-- | Return a module's source span.
182+getModuleSourceSpan :: Module -> SourceSpan
183+getModuleSourceSpan (Module ss _ _ _ _) = ss
184+
180-- |
185-- |
181-- Add an import declaration for a module if it does not already explicitly import it.
186-- Add an import declaration for a module if it does not already explicitly import it.
182--
187--
@@ -348,7 +353,7 @@ data Declaration
348 -- |
353 -- |
349 -- A type class declaration (name, argument, implies, member declarations)
354 -- A type class declaration (name, argument, implies, member declarations)
350 --
355 --
351− | TypeClassDeclaration (ProperName 'ClassName) [(String, Maybe Kind)] [Constraint] [Declaration]
356+ | TypeClassDeclaration (ProperName 'ClassName) [(String, Maybe Kind)] [Constraint] [FunctionalDependency] [Declaration]
352 -- |
357 -- |
353 -- A type instance declaration (name, dependencies, class name, instance types, member
358 -- A type instance declaration (name, dependencies, class name, instance types, member
354 -- declarations)
359 -- declarations)
@@ -374,10 +379,15 @@ pattern TypeFixityDeclaration fixity name op = FixityDeclaration (Right (TypeFix
374
379
375-- | The members of a type class instance declaration
380-- | The members of a type class instance declaration
376data TypeInstanceBody
381data TypeInstanceBody
377− -- | This is a derived instance
378 = DerivedInstance
382 = DerivedInstance
379− -- | This is a regular (explicit) instance
383+ -- ^ This is a derived instance
384+ | NewtypeInstance
385+ -- ^ This is an instance derived from a newtype
386+ | NewtypeInstanceWithDictionary Expr
387+ -- ^ This is an instance derived from a newtype, desugared to include a
388+ -- dictionary for the type under the newtype.
380 | ExplicitInstance [Declaration]
389 | ExplicitInstance [Declaration]
390+ -- ^ This is a regular (explicit) instance
381 deriving (Show)
391 deriving (Show)
382
392
383mapTypeInstanceBody :: ([Declaration] -> [Declaration]) -> TypeInstanceBody -> TypeInstanceBody
393mapTypeInstanceBody :: ([Declaration] -> [Declaration]) -> TypeInstanceBody -> TypeInstanceBody
@@ -385,8 +395,8 @@ mapTypeInstanceBody f = runIdentity . traverseTypeInstanceBody (Identity . f)
385
395
386-- | A traversal for TypeInstanceBody
396-- | A traversal for TypeInstanceBody
387traverseTypeInstanceBody :: (Applicative f) => ([Declaration] -> f [Declaration]) -> TypeInstanceBody -> f TypeInstanceBody
397traverseTypeInstanceBody :: (Applicative f) => ([Declaration] -> f [Declaration]) -> TypeInstanceBody -> f TypeInstanceBody
388−traverseTypeInstanceBody _ DerivedInstance = pure DerivedInstance
389traverseTypeInstanceBody f (ExplicitInstance ds) = ExplicitInstance <$> f ds
398traverseTypeInstanceBody f (ExplicitInstance ds) = ExplicitInstance <$> f ds
399+traverseTypeInstanceBody _ other = pure other
390
400
391-- |
401-- |
392-- Test if a declaration is a value declaration
402-- Test if a declaration is a value declaration
@@ -570,7 +580,7 @@ data Expr
570 -- |
580 -- |
571 -- A placeholder for a superclass dictionary to be turned into a TypeClassDictionary during typechecking
581 -- A placeholder for a superclass dictionary to be turned into a TypeClassDictionary during typechecking
572 --
582 --
573− | SuperClassDictionary (Qualified (ProperName 'ClassName)) [Type]
583+ | DeferredDictionary (Qualified (ProperName 'ClassName)) [Type]
574 -- |
584 -- |
575 -- A placeholder for an anonymous function argument
585 -- A placeholder for an anonymous function argument
576 --
586 --
src/Language/PureScript/AST/Exported.hs+1−1
@@ -133,7 +133,7 @@ isExported (Just exps) decl = any (matches decl) exps
133 matches (DataDeclaration _ ident _ _) (TypeRef ident' _) = ident == ident'
133 matches (DataDeclaration _ ident _ _) (TypeRef ident' _) = ident == ident'
134 matches (ExternDataDeclaration ident _) (TypeRef ident' _) = ident == ident'
134 matches (ExternDataDeclaration ident _) (TypeRef ident' _) = ident == ident'
135 matches (TypeSynonymDeclaration ident _ _) (TypeRef ident' _) = ident == ident'
135 matches (TypeSynonymDeclaration ident _ _) (TypeRef ident' _) = ident == ident'
136− matches (TypeClassDeclaration ident _ _ _) (TypeClassRef ident') = ident == ident'
136+ matches (TypeClassDeclaration ident _ _ _ _) (TypeClassRef ident') = ident == ident'
137 matches (ValueFixityDeclaration _ _ op) (ValueOpRef op') = op == op'
137 matches (ValueFixityDeclaration _ _ op) (ValueOpRef op') = op == op'
138 matches (TypeFixityDeclaration _ _ op) (TypeOpRef op') = op == op'
138 matches (TypeFixityDeclaration _ _ op) (TypeOpRef op') = op == op'
139 matches (PositionedDeclaration _ _ d) r = d `matches` r
139 matches (PositionedDeclaration _ _ d) r = d `matches` r
src/Language/PureScript/AST/Traversals.hs+9−9
@@ -34,7 +34,7 @@ everywhereOnValues f g h = (f', g', h')
34 f' (DataBindingGroupDeclaration ds) = f (DataBindingGroupDeclaration (map f' ds))
34 f' (DataBindingGroupDeclaration ds) = f (DataBindingGroupDeclaration (map f' ds))
35 f' (ValueDeclaration name nameKind bs val) = f (ValueDeclaration name nameKind (map h' bs) ((map (g' *** g') +++ g') val))
35 f' (ValueDeclaration name nameKind bs val) = f (ValueDeclaration name nameKind (map h' bs) ((map (g' *** g') +++ g') val))
36 f' (BindingGroupDeclaration ds) = f (BindingGroupDeclaration (map (\(name, nameKind, val) -> (name, nameKind, g' val)) ds))
36 f' (BindingGroupDeclaration ds) = f (BindingGroupDeclaration (map (\(name, nameKind, val) -> (name, nameKind, g' val)) ds))
37− f' (TypeClassDeclaration name args implies ds) = f (TypeClassDeclaration name args implies (map f' ds))
37+ f' (TypeClassDeclaration name args implies deps ds) = f (TypeClassDeclaration name args implies deps (map f' ds))
38 f' (TypeInstanceDeclaration name cs className args ds) = f (TypeInstanceDeclaration name cs className args (mapTypeInstanceBody (map f') ds))
38 f' (TypeInstanceDeclaration name cs className args ds) = f (TypeInstanceDeclaration name cs className args (mapTypeInstanceBody (map f') ds))
39 f' (PositionedDeclaration pos com d) = f (PositionedDeclaration pos com (f' d))
39 f' (PositionedDeclaration pos com d) = f (PositionedDeclaration pos com (f' d))
40 f' other = f other
40 f' other = f other
@@ -101,7 +101,7 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)
101 f' (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> traverse (f' <=< f) ds
101 f' (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> traverse (f' <=< f) ds
102 f' (ValueDeclaration name nameKind bs val) = ValueDeclaration name nameKind <$> traverse (h' <=< h) bs <*> eitherM (traverse (pairM (g' <=< g) (g' <=< g))) (g' <=< g) val
102 f' (ValueDeclaration name nameKind bs val) = ValueDeclaration name nameKind <$> traverse (h' <=< h) bs <*> eitherM (traverse (pairM (g' <=< g) (g' <=< g))) (g' <=< g) val
103 f' (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> traverse (\(name, nameKind, val) -> (,,) name nameKind <$> (g val >>= g')) ds
103 f' (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> traverse (\(name, nameKind, val) -> (,,) name nameKind <$> (g val >>= g')) ds
104− f' (TypeClassDeclaration name args implies ds) = TypeClassDeclaration name args implies <$> traverse (f' <=< f) ds
104+ f' (TypeClassDeclaration name args implies deps ds) = TypeClassDeclaration name args implies deps <$> traverse (f' <=< f) ds
105 f' (TypeInstanceDeclaration name cs className args ds) = TypeInstanceDeclaration name cs className args <$> traverseTypeInstanceBody (traverse (f' <=< f)) ds
105 f' (TypeInstanceDeclaration name cs className args ds) = TypeInstanceDeclaration name cs className args <$> traverseTypeInstanceBody (traverse (f' <=< f)) ds
106 f' (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> (f d >>= f')
106 f' (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> (f d >>= f')
107 f' other = f other
107 f' other = f other
@@ -168,7 +168,7 @@ everywhereOnValuesM f g h = (f', g', h')
168 f' (DataBindingGroupDeclaration ds) = (DataBindingGroupDeclaration <$> traverse f' ds) >>= f
168 f' (DataBindingGroupDeclaration ds) = (DataBindingGroupDeclaration <$> traverse f' ds) >>= f
169 f' (ValueDeclaration name nameKind bs val) = (ValueDeclaration name nameKind <$> traverse h' bs <*> eitherM (traverse (pairM g' g')) g' val) >>= f
169 f' (ValueDeclaration name nameKind bs val) = (ValueDeclaration name nameKind <$> traverse h' bs <*> eitherM (traverse (pairM g' g')) g' val) >>= f
170 f' (BindingGroupDeclaration ds) = (BindingGroupDeclaration <$> traverse (\(name, nameKind, val) -> (,,) name nameKind <$> g' val) ds) >>= f
170 f' (BindingGroupDeclaration ds) = (BindingGroupDeclaration <$> traverse (\(name, nameKind, val) -> (,,) name nameKind <$> g' val) ds) >>= f
171− f' (TypeClassDeclaration name args implies ds) = (TypeClassDeclaration name args implies <$> traverse f' ds) >>= f
171+ f' (TypeClassDeclaration name args implies deps ds) = (TypeClassDeclaration name args implies deps <$> traverse f' ds) >>= f
172 f' (TypeInstanceDeclaration name cs className args ds) = (TypeInstanceDeclaration name cs className args <$> traverseTypeInstanceBody (traverse f') ds) >>= f
172 f' (TypeInstanceDeclaration name cs className args ds) = (TypeInstanceDeclaration name cs className args <$> traverseTypeInstanceBody (traverse f') ds) >>= f
173 f' (PositionedDeclaration pos com d) = (PositionedDeclaration pos com <$> f' d) >>= f
173 f' (PositionedDeclaration pos com d) = (PositionedDeclaration pos com <$> f' d) >>= f
174 f' other = f other
174 f' other = f other
@@ -240,7 +240,7 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j')
240 f' d@(ValueDeclaration _ _ bs (Right val)) = foldl (<>) (f d) (map h' bs) <> g' val
240 f' d@(ValueDeclaration _ _ bs (Right val)) = foldl (<>) (f d) (map h' bs) <> g' val
241 f' d@(ValueDeclaration _ _ bs (Left gs)) = foldl (<>) (f d) (map h' bs ++ concatMap (\(grd, val) -> [g' grd, g' val]) gs)
241 f' d@(ValueDeclaration _ _ bs (Left gs)) = foldl (<>) (f d) (map h' bs ++ concatMap (\(grd, val) -> [g' grd, g' val]) gs)
242 f' d@(BindingGroupDeclaration ds) = foldl (<>) (f d) (map (\(_, _, val) -> g' val) ds)
242 f' d@(BindingGroupDeclaration ds) = foldl (<>) (f d) (map (\(_, _, val) -> g' val) ds)
243− f' d@(TypeClassDeclaration _ _ _ ds) = foldl (<>) (f d) (map f' ds)
243+ f' d@(TypeClassDeclaration _ _ _ _ ds) = foldl (<>) (f d) (map f' ds)
244 f' d@(TypeInstanceDeclaration _ _ _ _ (ExplicitInstance ds)) = foldl (<>) (f d) (map f' ds)
244 f' d@(TypeInstanceDeclaration _ _ _ _ (ExplicitInstance ds)) = foldl (<>) (f d) (map f' ds)
245 f' d@(PositionedDeclaration _ _ d1) = f d <> f' d1
245 f' d@(PositionedDeclaration _ _ d1) = f d <> f' d1
246 f' d = f d
246 f' d = f d
@@ -314,7 +314,7 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'
314 f' s (ValueDeclaration _ _ bs (Right val)) = foldl (<>) r0 (map (h'' s) bs) <> g'' s val
314 f' s (ValueDeclaration _ _ bs (Right val)) = foldl (<>) r0 (map (h'' s) bs) <> g'' s val
315 f' s (ValueDeclaration _ _ bs (Left gs)) = foldl (<>) r0 (map (h'' s) bs ++ concatMap (\(grd, val) -> [g'' s grd, g'' s val]) gs)
315 f' s (ValueDeclaration _ _ bs (Left gs)) = foldl (<>) r0 (map (h'' s) bs ++ concatMap (\(grd, val) -> [g'' s grd, g'' s val]) gs)
316 f' s (BindingGroupDeclaration ds) = foldl (<>) r0 (map (\(_, _, val) -> g'' s val) ds)
316 f' s (BindingGroupDeclaration ds) = foldl (<>) r0 (map (\(_, _, val) -> g'' s val) ds)
317− f' s (TypeClassDeclaration _ _ _ ds) = foldl (<>) r0 (map (f'' s) ds)
317+ f' s (TypeClassDeclaration _ _ _ _ ds) = foldl (<>) r0 (map (f'' s) ds)
318 f' s (TypeInstanceDeclaration _ _ _ _ (ExplicitInstance ds)) = foldl (<>) r0 (map (f'' s) ds)
318 f' s (TypeInstanceDeclaration _ _ _ _ (ExplicitInstance ds)) = foldl (<>) r0 (map (f'' s) ds)
319 f' s (PositionedDeclaration _ _ d1) = f'' s d1
319 f' s (PositionedDeclaration _ _ d1) = f'' s d1
320 f' _ _ = r0
320 f' _ _ = r0
@@ -395,7 +395,7 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j
395 f' s (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> traverse (f'' s) ds
395 f' s (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> traverse (f'' s) ds
396 f' s (ValueDeclaration name nameKind bs val) = ValueDeclaration name nameKind <$> traverse (h'' s) bs <*> eitherM (traverse (pairM (g'' s) (g'' s))) (g'' s) val
396 f' s (ValueDeclaration name nameKind bs val) = ValueDeclaration name nameKind <$> traverse (h'' s) bs <*> eitherM (traverse (pairM (g'' s) (g'' s))) (g'' s) val
397 f' s (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> traverse (thirdM (g'' s)) ds
397 f' s (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> traverse (thirdM (g'' s)) ds
398− f' s (TypeClassDeclaration name args implies ds) = TypeClassDeclaration name args implies <$> traverse (f'' s) ds
398+ f' s (TypeClassDeclaration name args implies deps ds) = TypeClassDeclaration name args implies deps <$> traverse (f'' s) ds
399 f' s (TypeInstanceDeclaration name cs className args ds) = TypeInstanceDeclaration name cs className args <$> traverseTypeInstanceBody (traverse (f'' s)) ds
399 f' s (TypeInstanceDeclaration name cs className args ds) = TypeInstanceDeclaration name cs className args <$> traverseTypeInstanceBody (traverse (f'' s)) ds
400 f' s (PositionedDeclaration pos com d1) = PositionedDeclaration pos com <$> f'' s d1
400 f' s (PositionedDeclaration pos com d1) = PositionedDeclaration pos com <$> f'' s d1
401 f' _ other = return other
401 f' _ other = return other
@@ -482,7 +482,7 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)
482 f' s (BindingGroupDeclaration ds) =
482 f' s (BindingGroupDeclaration ds) =
483 let s' = S.union s (S.fromList (map (\(name, _, _) -> name) ds))
483 let s' = S.union s (S.fromList (map (\(name, _, _) -> name) ds))
484 in foldMap (\(_, _, val) -> g'' s' val) ds
484 in foldMap (\(_, _, val) -> g'' s' val) ds
485− f' s (TypeClassDeclaration _ _ _ ds) = foldMap (f'' s) ds
485+ f' s (TypeClassDeclaration _ _ _ _ ds) = foldMap (f'' s) ds
486 f' s (TypeInstanceDeclaration _ _ _ _ (ExplicitInstance ds)) = foldMap (f'' s) ds
486 f' s (TypeInstanceDeclaration _ _ _ _ (ExplicitInstance ds)) = foldMap (f'' s) ds
487 f' s (PositionedDeclaration _ _ d) = f'' s d
487 f' s (PositionedDeclaration _ _ d) = f'' s d
488 f' _ _ = mempty
488 f' _ _ = mempty
@@ -576,13 +576,13 @@ accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (con
576 where
576 where
577 forDecls (DataDeclaration _ _ _ dctors) = mconcat (concatMap (map f . snd) dctors)
577 forDecls (DataDeclaration _ _ _ dctors) = mconcat (concatMap (map f . snd) dctors)
578 forDecls (ExternDeclaration _ ty) = f ty
578 forDecls (ExternDeclaration _ ty) = f ty
579− forDecls (TypeClassDeclaration _ _ implies _) = mconcat (concatMap (map f . constraintArgs) implies)
579+ forDecls (TypeClassDeclaration _ _ implies _ _) = mconcat (concatMap (map f . constraintArgs) implies)
580 forDecls (TypeInstanceDeclaration _ cs _ tys _) = mconcat (concatMap (map f . constraintArgs) cs) `mappend` mconcat (map f tys)
580 forDecls (TypeInstanceDeclaration _ cs _ tys _) = mconcat (concatMap (map f . constraintArgs) cs) `mappend` mconcat (map f tys)
581 forDecls (TypeSynonymDeclaration _ _ ty) = f ty
581 forDecls (TypeSynonymDeclaration _ _ ty) = f ty
582 forDecls (TypeDeclaration _ ty) = f ty
582 forDecls (TypeDeclaration _ ty) = f ty
583 forDecls _ = mempty
583 forDecls _ = mempty
584
584
585 forValues (TypeClassDictionary c _ _) = mconcat (map f (constraintArgs c))
585 forValues (TypeClassDictionary c _ _) = mconcat (map f (constraintArgs c))
586− forValues (SuperClassDictionary _ tys) = mconcat (map f tys)
586+ forValues (DeferredDictionary _ tys) = mconcat (map f tys)
587 forValues (TypedValue _ _ ty) = f ty
587 forValues (TypedValue _ _ ty) = f ty
588 forValues _ = mempty
588 forValues _ = mempty
src/Language/PureScript/Bundle.hs+19−7
@@ -43,6 +43,8 @@ data ErrorMessage
43 | UnableToParseModule String
43 | UnableToParseModule String
44 | UnsupportedExport
44 | UnsupportedExport
45 | ErrorInModule ModuleIdentifier ErrorMessage
45 | ErrorInModule ModuleIdentifier ErrorMessage
46+ | MissingEntryPoint String
47+ | MissingMainModule String
46 deriving (Show)
48 deriving (Show)
47
49
48-- | Modules are either "regular modules" (i.e. those generated by psc) or foreign modules.
50-- | Modules are either "regular modules" (i.e. those generated by psc) or foreign modules.
@@ -125,8 +127,14 @@ printErrorMessage (ErrorInModule mid e) =
125 : ""
127 : ""
126 : map (" " ++) (printErrorMessage e)
128 : map (" " ++) (printErrorMessage e)
127 where
129 where
128− displayIdentifier (ModuleIdentifier name ty) =
130+ displayIdentifier (ModuleIdentifier name ty) =
129− name ++ " (" ++ showModuleType ty ++ ")"
131+ name ++ " (" ++ showModuleType ty ++ ")"
132+printErrorMessage (MissingEntryPoint mName) =
133+ [ "Couldn't find a CommonJS module for the specified entry point: " ++ mName
134+ ]
135+printErrorMessage (MissingMainModule mName) =
136+ [ "Couldn't find a CommonJS module for the specified main module: " ++ mName
137+ ]
130
138
131-- | Calculate the ModuleIdentifier which a require(...) statement imports.
139-- | Calculate the ModuleIdentifier which a require(...) statement imports.
132checkImportPath :: String -> ModuleIdentifier -> S.Set String -> Either String ModuleIdentifier
140checkImportPath :: String -> ModuleIdentifier -> S.Set String -> Either String ModuleIdentifier
@@ -256,7 +264,7 @@ toModule mids mid top
256 = pure (Member stmt exported name decl [])
264 = pure (Member stmt exported name decl [])
257 toModuleElement stmt
265 toModuleElement stmt
258 | Just props <- matchExportsAssignment stmt
266 | Just props <- matchExportsAssignment stmt
259− = (ExportsList <$> traverse toExport (trailingCommaList props))
267+ = ExportsList <$> traverse toExport (trailingCommaList props)
260 where
268 where
261 toExport :: JSObjectProperty -> m (ExportType, String, JSExpression, [Key])
269 toExport :: JSObjectProperty -> m (ExportType, String, JSExpression, [Key])
262 toExport (JSPropertyNameandValue name _ [val]) =
270 toExport (JSPropertyNameandValue name _ [val]) =
@@ -524,7 +532,7 @@ codeGen optionsMainModule optionsNamespace ms = renderToString (JSAstProgram (p
524 indent :: [JSStatement] -> [JSStatement]
532 indent :: [JSStatement] -> [JSStatement]
525 indent = everywhere (mkT squash)
533 indent = everywhere (mkT squash)
526 where
534 where
527− squash JSNoAnnot = (JSAnnot (TokenPn 0 0 2) [])
535+ squash JSNoAnnot = JSAnnot (TokenPn 0 0 2) []
528 squash (JSAnnot pos ann) = JSAnnot (keepCol pos) (map splat ann)
536 squash (JSAnnot pos ann) = JSAnnot (keepCol pos) (map splat ann)
529
537
530 splat (CommentA pos s) = CommentA (keepCol pos) s
538 splat (CommentA pos s) = CommentA (keepCol pos) s
@@ -571,15 +579,15 @@ codeGen optionsMainModule optionsNamespace ms = renderToString (JSAstProgram (p
571 (JSSemi JSNoAnnot)
579 (JSSemi JSNoAnnot)
572 ]
580 ]
573 where
581 where
574− lfHead (h:t) = (addAnn (WhiteSpace tokenPosnEmpty "\n ") h) : t
582+ lfHead (h:t) = addAnn (WhiteSpace tokenPosnEmpty "\n ") h : t
575 lfHead x = x
583 lfHead x = x
576
584
577 addAnn :: CommentAnnotation -> JSStatement -> JSStatement
585 addAnn :: CommentAnnotation -> JSStatement -> JSStatement
578 addAnn a (JSExpressionStatement (JSStringLiteral ann s) _) =
586 addAnn a (JSExpressionStatement (JSStringLiteral ann s) _) =
579− (JSExpressionStatement (JSStringLiteral (appendAnn a ann) s) (JSSemi JSNoAnnot))
587+ JSExpressionStatement (JSStringLiteral (appendAnn a ann) s) (JSSemi JSNoAnnot)
580 addAnn _ x = x
588 addAnn _ x = x
581
589
582− appendAnn a JSNoAnnot = (JSAnnot tokenPosnEmpty [a])
590+ appendAnn a JSNoAnnot = JSAnnot tokenPosnEmpty [a]
583 appendAnn a (JSAnnot _ anns) = JSAnnot tokenPosnEmpty (a:anns ++ [WhiteSpace tokenPosnEmpty " "])
591 appendAnn a (JSAnnot _ anns) = JSAnnot tokenPosnEmpty (a:anns ++ [WhiteSpace tokenPosnEmpty " "])
584
592
585 runMain :: String -> [JSStatement]
593 runMain :: String -> [JSStatement]
@@ -609,6 +617,10 @@ bundle :: (MonadError ErrorMessage m)
609 -> String -- ^ The namespace (e.g. PS).
617 -> String -- ^ The namespace (e.g. PS).
610 -> m String
618 -> m String
611bundle inputStrs entryPoints mainModule namespace = do
619bundle inputStrs entryPoints mainModule namespace = do
620+ forM_ mainModule $ \mname ->
621+ when (mname `notElem` map (moduleName . fst) inputStrs) (throwError (MissingMainModule mname))
622+ forM_ entryPoints $ \mIdent ->
623+ when (mIdent `notElem` map fst inputStrs) (throwError (MissingEntryPoint (moduleName mIdent)))
612 input <- forM inputStrs $ \(ident, js) -> do
624 input <- forM inputStrs $ \(ident, js) -> do
613 ast <- either (throwError . ErrorInModule ident . UnableToParseModule) pure $ parse js (moduleName ident)
625 ast <- either (throwError . ErrorInModule ident . UnableToParseModule) pure $ parse js (moduleName ident)
614 return (ident, ast)
626 return (ident, ast)
src/Language/PureScript/CodeGen/JS.hs+4−4
@@ -15,7 +15,7 @@ import Control.Monad.Error.Class (MonadError(..))
15import Control.Monad.Reader (MonadReader, asks)
15import Control.Monad.Reader (MonadReader, asks)
16import Control.Monad.Supply.Class
16import Control.Monad.Supply.Class
17
17
18−import Data.List ((\\), delete, intersect)
18+import Data.List ((\\), delete, intersect, nub)
19import Data.Maybe (isNothing, fromMaybe)
19import Data.Maybe (isNothing, fromMaybe)
20import qualified Data.Foldable as F
20import qualified Data.Foldable as F
21import qualified Data.Map as M
21import qualified Data.Map as M
@@ -51,7 +51,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
51 rethrow (addHint (ErrorInModule mn)) $ do
51 rethrow (addHint (ErrorInModule mn)) $ do
52 let usedNames = concatMap getNames decls
52 let usedNames = concatMap getNames decls
53 let mnLookup = renameImports usedNames imps
53 let mnLookup = renameImports usedNames imps
54− jsImports <- T.traverse (importToJs mnLookup) . delete (ModuleName [ProperName C.prim]) . (\\ [mn]) $ map snd imps
54+ jsImports <- T.traverse (importToJs mnLookup) . delete (ModuleName [ProperName C.prim]) . (\\ [mn]) $ nub $ map snd imps
55 let decls' = renameModules mnLookup decls
55 let decls' = renameModules mnLookup decls
56 jsDecls <- mapM bindToJs decls'
56 jsDecls <- mapM bindToJs decls'
57 optimized <- T.traverse (T.traverse optimize) jsDecls
57 optimized <- T.traverse (T.traverse optimize) jsDecls
@@ -89,7 +89,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
89 in if mn' /= mn && mni `elem` used
89 in if mn' /= mn && mni `elem` used
90 then let newName = freshModuleName 1 mn' used
90 then let newName = freshModuleName 1 mn' used
91 in go (M.insert mn' (ann, newName) acc) (Ident (runModuleName newName) : used) mns'
91 in go (M.insert mn' (ann, newName) acc) (Ident (runModuleName newName) : used) mns'
92− else go (M.insert mn' (ann, mn') acc) (mni : used) mns'
92+ else go (M.insert mn' (ann, mn') acc) used mns'
93 go acc _ [] = acc
93 go acc _ [] = acc
94
94
95 freshModuleName :: Integer -> ModuleName -> [Ident] -> ModuleName
95 freshModuleName :: Integer -> ModuleName -> [Ident] -> ModuleName
@@ -367,7 +367,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
367 -- binder.
367 -- binder.
368 --
368 --
369 binderToJs' :: String -> [JS] -> Binder Ann -> m [JS]
369 binderToJs' :: String -> [JS] -> Binder Ann -> m [JS]
370− binderToJs' _ done (NullBinder{}) = return done
370+ binderToJs' _ done NullBinder{} = return done
371 binderToJs' varName done (LiteralBinder _ l) =
371 binderToJs' varName done (LiteralBinder _ l) =
372 literalToBinderJS varName done l
372 literalToBinderJS varName done l
373 binderToJs' varName done (VarBinder _ ident) =
373 binderToJs' varName done (VarBinder _ ident) =
src/Language/PureScript/CodeGen/JS/Optimizer.hs−6
@@ -34,7 +34,6 @@ import Language.PureScript.CodeGen.JS.Optimizer.MagicDo
34import Language.PureScript.CodeGen.JS.Optimizer.TCO
34import Language.PureScript.CodeGen.JS.Optimizer.TCO
35import Language.PureScript.CodeGen.JS.Optimizer.Unused
35import Language.PureScript.CodeGen.JS.Optimizer.Unused
36import Language.PureScript.Options
36import Language.PureScript.Options
37−import qualified Language.PureScript.Constants as C
38
37
39-- |
38-- |
40-- Apply a series of optimizer passes to simplified Javascript code
39-- Apply a series of optimizer passes to simplified Javascript code
@@ -49,11 +48,6 @@ optimize' js = do
49 opts <- ask
48 opts <- ask
50 js' <- untilFixedPoint (inlineFnComposition . tidyUp . applyAll
49 js' <- untilFixedPoint (inlineFnComposition . tidyUp . applyAll
51 [ inlineCommonValues
50 [ inlineCommonValues
52− , inlineOperator (C.prelude, (C.$)) $ \f x -> JSApp Nothing f [x]
53− , inlineOperator (C.dataFunction, C.apply) $ \f x -> JSApp Nothing f [x]
54− , inlineOperator (C.prelude, (C.#)) $ \x f -> JSApp Nothing f [x]
55− , inlineOperator (C.dataFunction, C.applyFlipped) $ \x f -> JSApp Nothing f [x]
56− , inlineOperator (C.dataArrayUnsafe, C.unsafeIndex) $ flip (JSIndexer Nothing)
57 , inlineCommonOperators
51 , inlineCommonOperators
58 ]) js
52 ]) js
59 untilFixedPoint (return . tidyUp) . tco opts . magicDo opts $ js'
53 untilFixedPoint (return . tidyUp) . tco opts . magicDo opts $ js'
src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs+7−4
@@ -4,7 +4,6 @@
4module Language.PureScript.CodeGen.JS.Optimizer.Inliner
4module Language.PureScript.CodeGen.JS.Optimizer.Inliner
5 ( inlineVariables
5 ( inlineVariables
6 , inlineCommonValues
6 , inlineCommonValues
7− , inlineOperator
8 , inlineCommonOperators
7 , inlineCommonOperators
9 , inlineFnComposition
8 , inlineFnComposition
10 , etaConvert
9 , etaConvert
@@ -100,13 +99,13 @@ inlineCommonValues = everywhereOnJS convert
100 fnSubtract = (C.dataRing, C.sub)
99 fnSubtract = (C.dataRing, C.sub)
101 intOp ss op x y = JSBinary ss BitwiseOr (JSBinary ss op x y) (JSNumericLiteral ss (Left 0))
100 intOp ss op x y = JSBinary ss BitwiseOr (JSBinary ss op x y) (JSNumericLiteral ss (Left 0))
102
101
103−inlineOperator :: (String, String) -> (JS -> JS -> JS) -> JS -> JS
102+inlineNonClassFunction :: (String, String) -> (JS -> JS -> JS) -> JS -> JS
104−inlineOperator (m, op) f = everywhereOnJS convert
103+inlineNonClassFunction (m, op) f = everywhereOnJS convert
105 where
104 where
106 convert :: JS -> JS
105 convert :: JS -> JS
107 convert (JSApp _ (JSApp _ op' [x]) [y]) | isOp op' = f x y
106 convert (JSApp _ (JSApp _ op' [x]) [y]) | isOp op' = f x y
108 convert other = other
107 convert other = other
109− isOp (JSIndexer _ (JSStringLiteral _ op') (JSVar _ m')) = m == m' && op == op'
108+ isOp (JSAccessor _ op' (JSVar _ m')) = m == m' && op == op'
110 isOp _ = False
109 isOp _ = False
111
110
112inlineCommonOperators :: JS -> JS
111inlineCommonOperators :: JS -> JS
@@ -167,6 +166,10 @@ inlineCommonOperators = applyAll $
167 , binary' C.dataIntBits C.shr ShiftRight
166 , binary' C.dataIntBits C.shr ShiftRight
168 , binary' C.dataIntBits C.zshr ZeroFillShiftRight
167 , binary' C.dataIntBits C.zshr ZeroFillShiftRight
169 , unary' C.dataIntBits C.complement BitwiseNot
168 , unary' C.dataIntBits C.complement BitwiseNot
169+
170+ , inlineNonClassFunction (C.dataFunction, C.apply) $ \f x -> JSApp Nothing f [x]
171+ , inlineNonClassFunction (C.dataFunction, C.applyFlipped) $ \x f -> JSApp Nothing f [x]
172+ , inlineNonClassFunction (C.dataArrayUnsafe, C.unsafeIndex) $ flip (JSIndexer Nothing)
170 ] ++
173 ] ++
171 [ fn | i <- [0..10], fn <- [ mkFn i, runFn i ] ]
174 [ fn | i <- [0..10], fn <- [ mkFn i, runFn i ] ]
172 where
175 where
src/Language/PureScript/CoreFn/Desugar.hs+1−1
@@ -72,7 +72,7 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =
72 [NonRec (ssA ss) name (exprToCoreFn ss com Nothing e)]
72 [NonRec (ssA ss) name (exprToCoreFn ss com Nothing e)]
73 declToCoreFn ss _ (A.BindingGroupDeclaration ds) =
73 declToCoreFn ss _ (A.BindingGroupDeclaration ds) =
74 [Rec $ map (\(name, _, e) -> ((ssA ss, name), exprToCoreFn ss [] Nothing e)) ds]
74 [Rec $ map (\(name, _, e) -> ((ssA ss, name), exprToCoreFn ss [] Nothing e)) ds]
75− declToCoreFn ss com (A.TypeClassDeclaration name _ supers members) =
75+ declToCoreFn ss com (A.TypeClassDeclaration name _ supers _ members) =
76 [NonRec (ssA ss) (properToIdent name) $ mkTypeClassConstructor ss com supers members]
76 [NonRec (ssA ss) (properToIdent name) $ mkTypeClassConstructor ss com supers members]
77 declToCoreFn _ com (A.PositionedDeclaration ss com1 d) =
77 declToCoreFn _ com (A.PositionedDeclaration ss com1 d) =
78 declToCoreFn (Just ss) (com ++ com1) d
78 declToCoreFn (Just ss) (com ++ com1) d
src/Language/PureScript/CoreFn/ToJSON.hsnew file+116
@@ -0,0 +1,116 @@
1+-- |
2+-- Dump the core functional representation in JSON format for consumption
3+-- by third-party code generators
4+--
5+module Language.PureScript.CoreFn.ToJSON
6+ ( moduleToJSON
7+ ) where
8+
9+import Prelude.Compat
10+
11+import Data.Aeson
12+import Data.Version (Version, showVersion)
13+import Data.Text (pack)
14+
15+import Language.PureScript.AST.Literals
16+import Language.PureScript.CoreFn
17+import Language.PureScript.Names
18+
19+literalToJSON :: (a -> Value) -> Literal a -> Value
20+literalToJSON _ (NumericLiteral (Left n)) = toJSON ("IntLiteral", n)
21+literalToJSON _ (NumericLiteral (Right n)) = toJSON ("NumberLiteral", n)
22+literalToJSON _ (StringLiteral s) = toJSON ("StringLiteral", s)
23+literalToJSON _ (CharLiteral c) = toJSON ("CharLiteral", c)
24+literalToJSON _ (BooleanLiteral b) = toJSON ("BooleanLiteral", b)
25+literalToJSON t (ArrayLiteral xs) = toJSON ("ArrayLiteral", map t xs)
26+literalToJSON t (ObjectLiteral xs) = toJSON ("ObjectLiteral", recordToJSON t xs)
27+
28+identToJSON :: Ident -> Value
29+identToJSON = toJSON . runIdent
30+
31+properNameToJSON :: ProperName a -> Value
32+properNameToJSON = toJSON . runProperName
33+
34+qualifiedToJSON :: (a -> String) -> Qualified a -> Value
35+qualifiedToJSON f = toJSON . showQualified f
36+
37+moduleNameToJSON :: ModuleName -> Value
38+moduleNameToJSON = toJSON . runModuleName
39+
40+moduleToJSON :: Version -> Module a -> Value
41+moduleToJSON v m = object [ pack "imports" .= map (moduleNameToJSON . snd) (moduleImports m)
42+ , pack "exports" .= map identToJSON (moduleExports m)
43+ , pack "foreign" .= map (identToJSON . fst) (moduleForeign m)
44+ , pack "decls" .= map bindToJSON (moduleDecls m)
45+ , pack "builtWith" .= toJSON (showVersion v)
46+ ]
47+
48+bindToJSON :: Bind a -> Value
49+bindToJSON (NonRec _ n e) = object [ pack (runIdent n) .= exprToJSON e ]
50+bindToJSON (Rec bs) = object $ map (\((_, n), e) -> pack (runIdent n) .= exprToJSON e) bs
51+
52+recordToJSON :: (a -> Value) -> [(String, a)] -> Value
53+recordToJSON f = object . map (\(label, a) -> pack label .= f a)
54+
55+exprToJSON :: Expr a -> Value
56+exprToJSON (Var _ i) = toJSON ( "Var"
57+ , qualifiedToJSON runIdent i
58+ )
59+exprToJSON (Literal _ l) = toJSON ( "Literal"
60+ , literalToJSON (exprToJSON) l
61+ )
62+exprToJSON (Constructor _ d c is) = toJSON ( "Constructor"
63+ , properNameToJSON d
64+ , properNameToJSON c
65+ , map identToJSON is
66+ )
67+exprToJSON (Accessor _ f r) = toJSON ( "Accessor"
68+ , f
69+ , exprToJSON r
70+ )
71+exprToJSON (ObjectUpdate _ r fs) = toJSON ( "ObjectUpdate"
72+ , exprToJSON r
73+ , recordToJSON exprToJSON fs
74+ )
75+exprToJSON (Abs _ p b) = toJSON ( "Abs"
76+ , identToJSON p
77+ , exprToJSON b
78+ )
79+exprToJSON (App _ f x) = toJSON ( "App"
80+ , exprToJSON f
81+ , exprToJSON x
82+ )
83+exprToJSON (Case _ ss cs) = toJSON ( "Case"
84+ , map exprToJSON ss
85+ , map caseAlternativeToJSON cs
86+ )
87+exprToJSON (Let _ bs e) = toJSON ( "Let"
88+ , map bindToJSON bs
89+ , exprToJSON e
90+ )
91+
92+caseAlternativeToJSON :: CaseAlternative a -> Value
93+caseAlternativeToJSON (CaseAlternative bs r') =
94+ toJSON [ toJSON (map binderToJSON bs)
95+ , case r' of
96+ Left rs -> toJSON $ map (\(g, e) -> (exprToJSON g, exprToJSON e)) rs
97+ Right r -> exprToJSON r
98+ ]
99+
100+binderToJSON :: Binder a -> Value
101+binderToJSON (VarBinder _ v) = toJSON ( "VarBinder"
102+ , identToJSON v
103+ )
104+binderToJSON (NullBinder _) = toJSON "NullBinder"
105+binderToJSON (LiteralBinder _ l) = toJSON ( "LiteralBinder"
106+ , literalToJSON binderToJSON l
107+ )
108+binderToJSON (ConstructorBinder _ d c bs) = toJSON ( "ConstructorBinder"
109+ , qualifiedToJSON runProperName d
110+ , qualifiedToJSON runProperName c
111+ , map binderToJSON bs
112+ )
113+binderToJSON (NamedBinder _ n b) = toJSON ( "NamedBinder"
114+ , identToJSON n
115+ , binderToJSON b
116+ )
src/Language/PureScript/Docs/Convert/Single.hs+2−2
@@ -81,7 +81,7 @@ getDeclarationTitle (P.ExternDeclaration name _) = Just (P.showIdent name)
81getDeclarationTitle (P.DataDeclaration _ name _ _) = Just (P.runProperName name)
81getDeclarationTitle (P.DataDeclaration _ name _ _) = Just (P.runProperName name)
82getDeclarationTitle (P.ExternDataDeclaration name _) = Just (P.runProperName name)
82getDeclarationTitle (P.ExternDataDeclaration name _) = Just (P.runProperName name)
83getDeclarationTitle (P.TypeSynonymDeclaration name _ _) = Just (P.runProperName name)
83getDeclarationTitle (P.TypeSynonymDeclaration name _ _) = Just (P.runProperName name)
84−getDeclarationTitle (P.TypeClassDeclaration name _ _ _) = Just (P.runProperName name)
84+getDeclarationTitle (P.TypeClassDeclaration name _ _ _ _) = Just (P.runProperName name)
85getDeclarationTitle (P.TypeInstanceDeclaration name _ _ _ _) = Just (P.showIdent name)
85getDeclarationTitle (P.TypeInstanceDeclaration name _ _ _ _) = Just (P.showIdent name)
86getDeclarationTitle (P.TypeFixityDeclaration _ _ op) = Just ("type " ++ P.showOp op)
86getDeclarationTitle (P.TypeFixityDeclaration _ _ op) = Just ("type " ++ P.showOp op)
87getDeclarationTitle (P.ValueFixityDeclaration _ _ op) = Just (P.showOp op)
87getDeclarationTitle (P.ValueFixityDeclaration _ _ op) = Just (P.showOp op)
@@ -121,7 +121,7 @@ convertDeclaration (P.ExternDataDeclaration _ kind') title =
121 basicDeclaration title (ExternDataDeclaration kind')
121 basicDeclaration title (ExternDataDeclaration kind')
122convertDeclaration (P.TypeSynonymDeclaration _ args ty) title =
122convertDeclaration (P.TypeSynonymDeclaration _ args ty) title =
123 basicDeclaration title (TypeSynonymDeclaration args ty)
123 basicDeclaration title (TypeSynonymDeclaration args ty)
124−convertDeclaration (P.TypeClassDeclaration _ args implies ds) title =
124+convertDeclaration (P.TypeClassDeclaration _ args implies _ ds) title = -- TODO: include fundep info
125 Just (Right (mkDeclaration title info) { declChildren = children })
125 Just (Right (mkDeclaration title info) { declChildren = children })
126 where
126 where
127 info = TypeClassDeclaration args implies
127 info = TypeClassDeclaration args implies
src/Language/PureScript/Environment.hs+42−28
@@ -18,35 +18,46 @@ import Language.PureScript.TypeClassDictionaries
18import Language.PureScript.Types
18import Language.PureScript.Types
19import qualified Language.PureScript.Constants as C
19import qualified Language.PureScript.Constants as C
20
20
21−-- |
22−-- The @Environment@ defines all values and types which are currently in scope:
21+-- | The @Environment@ defines all values and types which are currently in scope:
23−--
24−data Environment = Environment {
22+data Environment = Environment
25− -- |
26− -- Value names currently in scope
27− --
28− names :: M.Map (Qualified Ident) (Type, NameKind, NameVisibility)
23+ { names :: M.Map (Qualified Ident) (Type, NameKind, NameVisibility)
29− -- |
30− -- Type names currently in scope
24+ -- ^ Values currently in scope
31− --
32 , types :: M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind)
25 , types :: M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind)
33− -- |
26+ -- ^ Type names currently in scope
34− -- Data constructors currently in scope, along with their associated type
35− -- constructor name, argument types and return type.
36 , dataConstructors :: M.Map (Qualified (ProperName 'ConstructorName)) (DataDeclType, ProperName 'TypeName, Type, [Ident])
27 , dataConstructors :: M.Map (Qualified (ProperName 'ConstructorName)) (DataDeclType, ProperName 'TypeName, Type, [Ident])
37− -- |
28+ -- ^ Data constructors currently in scope, along with their associated type
38− -- Type synonyms currently in scope
29+ -- constructor name, argument types and return type.
39− --
40 , typeSynonyms :: M.Map (Qualified (ProperName 'TypeName)) ([(String, Maybe Kind)], Type)
30 , typeSynonyms :: M.Map (Qualified (ProperName 'TypeName)) ([(String, Maybe Kind)], Type)
41− -- |
31+ -- ^ Type synonyms currently in scope
42− -- Available type class dictionaries
43− --
44 , typeClassDictionaries :: M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope))
32 , typeClassDictionaries :: M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope))
45− -- |
33+ -- ^ Available type class dictionaries
46− -- Type classes
47− --
48− , typeClasses :: M.Map (Qualified (ProperName 'ClassName)) ([(String, Maybe Kind)], [(Ident, Type)], [Constraint])
34+ , typeClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData
35+ -- ^ Type classes
36+ } deriving Show
37+
38+-- | Information about a type class
39+data TypeClassData = TypeClassData
40+ { typeClassArguments :: [(String, Maybe Kind)]
41+ -- ^ A list of type argument names, and their kinds, where kind annotations
42+ -- were provided.
43+ , typeClassMembers :: [(Ident, Type)]
44+ -- ^ A list of type class members and their types. Type arguments listed above
45+ -- are considered bound in these types.
46+ , typeClassSuperclasses :: [Constraint]
47+ -- ^ A list of superclasses of this type class. Type arguments listed above
48+ -- are considered bound in the types appearing in these constraints.
49+ , typeClassDependencies :: [FunctionalDependency]
50+ -- ^ A list of functional dependencies for the type arguments of this class.
49− } deriving (Show)
51+ } deriving Show
52+
53+-- | A functional dependency indicates a relationship between two sets of
54+-- type arguments in a class declaration.
55+data FunctionalDependency = FunctionalDependency
56+ { fdDeterminers :: [Int]
57+ -- ^ the type arguments which determine the determined type arguments
58+ , fdDetermined :: [Int]
59+ -- ^ the determined type arguments
60+ } deriving Show
50
61
51-- |
62-- |
52-- The initial environment with no values and only the default javascript types defined
63-- The initial environment with no values and only the default javascript types defined
@@ -241,17 +252,19 @@ primTypes =
241 , (primName "Boolean", (Star, ExternData))
252 , (primName "Boolean", (Star, ExternData))
242 , (primName "Partial", (Star, ExternData))
253 , (primName "Partial", (Star, ExternData))
243 , (primName "Fail", (FunKind Symbol Star, ExternData))
254 , (primName "Fail", (FunKind Symbol Star, ExternData))
255+ , (primName "TypeString", (FunKind Star Symbol, ExternData))
256+ , (primName "TypeConcat", (FunKind Symbol (FunKind Symbol Symbol), ExternData))
244 ]
257 ]
245
258
246-- |
259-- |
247-- The primitive class map. This just contains to `Partial` class, used as a
260-- The primitive class map. This just contains to `Partial` class, used as a
248-- kind of magic constraint for partial functions.
261-- kind of magic constraint for partial functions.
249--
262--
250−primClasses :: M.Map (Qualified (ProperName 'ClassName)) ([(String, Maybe Kind)], [(Ident, Type)], [Constraint])
263+primClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData
251primClasses =
264primClasses =
252 M.fromList
265 M.fromList
253− [ (primName "Partial", ([], [], []))
266+ [ (primName "Partial", (TypeClassData [] [] [] []))
254− , (primName "Fail", ([("message", Just Symbol)], [], []))
267+ , (primName "Fail", (TypeClassData [("message", Just Symbol)] [] [] []))
255 ]
268 ]
256
269
257-- |
270-- |
@@ -276,3 +289,4 @@ lookupValue :: Environment -> Qualified Ident -> Maybe (Type, NameKind, NameVisi
276lookupValue env ident = ident `M.lookup` names env
289lookupValue env ident = ident `M.lookup` names env
277
290
278$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''TypeKind)
291$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''TypeKind)
292+$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''FunctionalDependency)
src/Language/PureScript/Errors.hs+62−39
@@ -25,6 +25,7 @@ import qualified Data.Map as M
25
25
26import Language.PureScript.AST
26import Language.PureScript.AST
27import Language.PureScript.Crash
27import Language.PureScript.Crash
28+import Language.PureScript.Environment
28import Language.PureScript.Names
29import Language.PureScript.Names
29import Language.PureScript.Pretty
30import Language.PureScript.Pretty
30import Language.PureScript.Traversals
31import Language.PureScript.Traversals
@@ -32,6 +33,7 @@ import Language.PureScript.Types
32import Language.PureScript.Pretty.Common (endWith)
33import Language.PureScript.Pretty.Common (endWith)
33import qualified Language.PureScript.Bundle as Bundle
34import qualified Language.PureScript.Bundle as Bundle
34import qualified Language.PureScript.Constants as C
35import qualified Language.PureScript.Constants as C
36+import Language.PureScript.Pretty.Common (before)
35
37
36import qualified System.Console.ANSI as ANSI
38import qualified System.Console.ANSI as ANSI
37
39
@@ -88,7 +90,6 @@ errorCode em = case unwrapErrorMessage em of
88 MultipleValueOpFixities{} -> "MultipleValueOpFixities"
90 MultipleValueOpFixities{} -> "MultipleValueOpFixities"
89 MultipleTypeOpFixities{} -> "MultipleTypeOpFixities"
91 MultipleTypeOpFixities{} -> "MultipleTypeOpFixities"
90 OrphanTypeDeclaration{} -> "OrphanTypeDeclaration"
92 OrphanTypeDeclaration{} -> "OrphanTypeDeclaration"
91− RedefinedModule{} -> "RedefinedModule"
92 RedefinedIdent{} -> "RedefinedIdent"
93 RedefinedIdent{} -> "RedefinedIdent"
93 OverlappingNamesInLet -> "OverlappingNamesInLet"
94 OverlappingNamesInLet -> "OverlappingNamesInLet"
94 UnknownName{} -> "UnknownName"
95 UnknownName{} -> "UnknownName"
@@ -100,7 +101,7 @@ errorCode em = case unwrapErrorMessage em of
100 ScopeShadowing{} -> "ScopeShadowing"
101 ScopeShadowing{} -> "ScopeShadowing"
101 DeclConflict{} -> "DeclConflict"
102 DeclConflict{} -> "DeclConflict"
102 ExportConflict{} -> "ExportConflict"
103 ExportConflict{} -> "ExportConflict"
103− DuplicateModuleName{} -> "DuplicateModuleName"
104+ DuplicateModule{} -> "DuplicateModule"
104 DuplicateTypeArgument{} -> "DuplicateTypeArgument"
105 DuplicateTypeArgument{} -> "DuplicateTypeArgument"
105 InvalidDoBind -> "InvalidDoBind"
106 InvalidDoBind -> "InvalidDoBind"
106 InvalidDoLet -> "InvalidDoLet"
107 InvalidDoLet -> "InvalidDoLet"
@@ -118,6 +119,7 @@ errorCode em = case unwrapErrorMessage em of
118 NoInstanceFound{} -> "NoInstanceFound"
119 NoInstanceFound{} -> "NoInstanceFound"
119 PossiblyInfiniteInstance{} -> "PossiblyInfiniteInstance"
120 PossiblyInfiniteInstance{} -> "PossiblyInfiniteInstance"
120 CannotDerive{} -> "CannotDerive"
121 CannotDerive{} -> "CannotDerive"
122+ InvalidNewtypeInstance{} -> "InvalidNewtypeInstance"
121 CannotFindDerivingType{} -> "CannotFindDerivingType"
123 CannotFindDerivingType{} -> "CannotFindDerivingType"
122 DuplicateLabel{} -> "DuplicateLabel"
124 DuplicateLabel{} -> "DuplicateLabel"
123 DuplicateValueDeclaration{} -> "DuplicateValueDeclaration"
125 DuplicateValueDeclaration{} -> "DuplicateValueDeclaration"
@@ -130,7 +132,6 @@ errorCode em = case unwrapErrorMessage em of
130 ExprDoesNotHaveType{} -> "ExprDoesNotHaveType"
132 ExprDoesNotHaveType{} -> "ExprDoesNotHaveType"
131 PropertyIsMissing{} -> "PropertyIsMissing"
133 PropertyIsMissing{} -> "PropertyIsMissing"
132 AdditionalProperty{} -> "AdditionalProperty"
134 AdditionalProperty{} -> "AdditionalProperty"
133− CannotApplyFunction{} -> "CannotApplyFunction"
134 TypeSynonymInstance -> "TypeSynonymInstance"
135 TypeSynonymInstance -> "TypeSynonymInstance"
135 OrphanInstance{} -> "OrphanInstance"
136 OrphanInstance{} -> "OrphanInstance"
136 InvalidNewtype{} -> "InvalidNewtype"
137 InvalidNewtype{} -> "InvalidNewtype"
@@ -164,6 +165,8 @@ errorCode em = case unwrapErrorMessage em of
164 InvalidOperatorInBinder{} -> "InvalidOperatorInBinder"
165 InvalidOperatorInBinder{} -> "InvalidOperatorInBinder"
165 DeprecatedRequirePath{} -> "DeprecatedRequirePath"
166 DeprecatedRequirePath{} -> "DeprecatedRequirePath"
166 CannotGeneralizeRecursiveFunction{} -> "CannotGeneralizeRecursiveFunction"
167 CannotGeneralizeRecursiveFunction{} -> "CannotGeneralizeRecursiveFunction"
168+ CannotDeriveNewtypeForData{} -> "CannotDeriveNewtypeForData"
169+ NonWildcardNewtypeInstance{} -> "NonWildcardNewtypeInstance"
167
170
168-- |
171-- |
169-- A stack trace for an error
172-- A stack trace for an error
@@ -254,12 +257,12 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse
254 gSimple (TypesDoNotUnify t1 t2) = TypesDoNotUnify <$> f t1 <*> f t2
257 gSimple (TypesDoNotUnify t1 t2) = TypesDoNotUnify <$> f t1 <*> f t2
255 gSimple (ConstrainedTypeUnified t1 t2) = ConstrainedTypeUnified <$> f t1 <*> f t2
258 gSimple (ConstrainedTypeUnified t1 t2) = ConstrainedTypeUnified <$> f t1 <*> f t2
256 gSimple (ExprDoesNotHaveType e t) = ExprDoesNotHaveType e <$> f t
259 gSimple (ExprDoesNotHaveType e t) = ExprDoesNotHaveType e <$> f t
257− gSimple (CannotApplyFunction t e) = CannotApplyFunction <$> f t <*> pure e
258 gSimple (InvalidInstanceHead t) = InvalidInstanceHead <$> f t
260 gSimple (InvalidInstanceHead t) = InvalidInstanceHead <$> f t
259 gSimple (NoInstanceFound con) = NoInstanceFound <$> overConstraintArgs (traverse f) con
261 gSimple (NoInstanceFound con) = NoInstanceFound <$> overConstraintArgs (traverse f) con
260 gSimple (OverlappingInstances cl ts insts) = OverlappingInstances cl <$> traverse f ts <*> pure insts
262 gSimple (OverlappingInstances cl ts insts) = OverlappingInstances cl <$> traverse f ts <*> pure insts
261 gSimple (PossiblyInfiniteInstance cl ts) = PossiblyInfiniteInstance cl <$> traverse f ts
263 gSimple (PossiblyInfiniteInstance cl ts) = PossiblyInfiniteInstance cl <$> traverse f ts
262 gSimple (CannotDerive cl ts) = CannotDerive cl <$> traverse f ts
264 gSimple (CannotDerive cl ts) = CannotDerive cl <$> traverse f ts
265+ gSimple (InvalidNewtypeInstance cl ts) = InvalidNewtypeInstance cl <$> traverse f ts
263 gSimple (ExpectedType ty k) = ExpectedType <$> f ty <*> pure k
266 gSimple (ExpectedType ty k) = ExpectedType <$> f ty <*> pure k
264 gSimple (OrphanInstance nm cl ts) = OrphanInstance nm cl <$> traverse f ts
267 gSimple (OrphanInstance nm cl ts) = OrphanInstance nm cl <$> traverse f ts
265 gSimple (WildcardInferredType ty ctx) = WildcardInferredType <$> f ty <*> traverse (sndM f) ctx
268 gSimple (WildcardInferredType ty ctx) = WildcardInferredType <$> f ty <*> traverse (sndM f) ctx
@@ -288,6 +291,8 @@ errorSuggestion err = case err of
288 UnusedImport{} -> emptySuggestion
291 UnusedImport{} -> emptySuggestion
289 DuplicateImport{} -> emptySuggestion
292 DuplicateImport{} -> emptySuggestion
290 UnusedExplicitImport mn _ qual refs -> suggest $ importSuggestion mn refs qual
293 UnusedExplicitImport mn _ qual refs -> suggest $ importSuggestion mn refs qual
294+ UnusedDctorImport mn _ qual refs -> suggest $ importSuggestion mn refs qual
295+ UnusedDctorExplicitImport mn _ _ qual refs -> suggest $ importSuggestion mn refs qual
291 ImplicitImport mn refs -> suggest $ importSuggestion mn refs Nothing
296 ImplicitImport mn refs -> suggest $ importSuggestion mn refs Nothing
292 ImplicitQualifiedImport mn asModule refs -> suggest $ importSuggestion mn refs (Just asModule)
297 ImplicitQualifiedImport mn asModule refs -> suggest $ importSuggestion mn refs (Just asModule)
293 HidingImport mn refs -> suggest $ importSuggestion mn refs Nothing
298 HidingImport mn refs -> suggest $ importSuggestion mn refs Nothing
@@ -482,10 +487,6 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS
482 line $ "There are multiple fixity/precedence declarations for type operator " ++ markCode (showOp op)
487 line $ "There are multiple fixity/precedence declarations for type operator " ++ markCode (showOp op)
483 renderSimpleErrorMessage (OrphanTypeDeclaration nm) =
488 renderSimpleErrorMessage (OrphanTypeDeclaration nm) =
484 line $ "The type declaration for " ++ markCode (showIdent nm) ++ " should be followed by its definition."
489 line $ "The type declaration for " ++ markCode (showIdent nm) ++ " should be followed by its definition."
485− renderSimpleErrorMessage (RedefinedModule name filenames) =
486− paras [ line ("The module " ++ markCode (runModuleName name) ++ " has been defined multiple times:")
487− , indent . paras $ map (line . displaySourceSpan) filenames
488− ]
489 renderSimpleErrorMessage (RedefinedIdent name) =
490 renderSimpleErrorMessage (RedefinedIdent name) =
490 line $ "The value " ++ markCode (showIdent name) ++ " has been defined multiple times"
491 line $ "The value " ++ markCode (showIdent name) ++ " has been defined multiple times"
491 renderSimpleErrorMessage (UnknownName name) =
492 renderSimpleErrorMessage (UnknownName name) =
@@ -515,8 +516,10 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS
515 line $ "Declaration for " ++ printName (Qualified Nothing new) ++ " conflicts with an existing " ++ nameType existing ++ " of the same name."
516 line $ "Declaration for " ++ printName (Qualified Nothing new) ++ " conflicts with an existing " ++ nameType existing ++ " of the same name."
516 renderSimpleErrorMessage (ExportConflict new existing) =
517 renderSimpleErrorMessage (ExportConflict new existing) =
517 line $ "Export for " ++ printName new ++ " conflicts with " ++ runName existing
518 line $ "Export for " ++ printName new ++ " conflicts with " ++ runName existing
518− renderSimpleErrorMessage (DuplicateModuleName mn) =
519+ renderSimpleErrorMessage (DuplicateModule mn ss) =
519− line $ "Module " ++ markCode (runModuleName mn) ++ " has been defined multiple times."
520+ paras [ line ("Module " ++ markCode (runModuleName mn) ++ " has been defined multiple times:")
521+ , indent . paras $ map (line . displaySourceSpan) ss
522+ ]
520 renderSimpleErrorMessage (CycleInDeclaration nm) =
523 renderSimpleErrorMessage (CycleInDeclaration nm) =
521 line $ "The value of " ++ markCode (showIdent nm) ++ " is undefined here, so this reference is not allowed."
524 line $ "The value of " ++ markCode (showIdent nm) ++ " is undefined here, so this reference is not allowed."
522 renderSimpleErrorMessage (CycleInModules mns) =
525 renderSimpleErrorMessage (CycleInModules mns) =
@@ -592,9 +595,9 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS
592 , line "They may be disallowed completely in a future version of the compiler."
595 , line "They may be disallowed completely in a future version of the compiler."
593 ]
596 ]
594 renderSimpleErrorMessage OverlappingInstances{} = internalError "OverlappingInstances: empty instance list"
597 renderSimpleErrorMessage OverlappingInstances{} = internalError "OverlappingInstances: empty instance list"
595− renderSimpleErrorMessage (NoInstanceFound (Constraint C.Fail [ TypeLevelString message ] _)) =
598+ renderSimpleErrorMessage (NoInstanceFound (Constraint C.Fail [ ty ] _)) | Just box <- toTypelevelString ty =
596 paras [ line "A custom type error occurred while solving type class constraints:"
599 paras [ line "A custom type error occurred while solving type class constraints:"
597− , indent . paras . map line . lines $ message
600+ , indent box
598 ]
601 ]
599 renderSimpleErrorMessage (NoInstanceFound (Constraint C.Partial
602 renderSimpleErrorMessage (NoInstanceFound (Constraint C.Partial
600 _
603 _
@@ -638,6 +641,14 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS
638 , Box.vcat Box.left (map typeAtomAsBox ts)
641 , Box.vcat Box.left (map typeAtomAsBox ts)
639 ]
642 ]
640 ]
643 ]
644+ renderSimpleErrorMessage (InvalidNewtypeInstance nm ts) =
645+ paras [ line "Cannot derive newtype instance for"
646+ , markCodeBox $ indent $ Box.hsep 1 Box.left
647+ [ line (showQualified runProperName nm)
648+ , Box.vcat Box.left (map typeAtomAsBox ts)
649+ ]
650+ , line "Make sure this is a newtype."
651+ ]
641 renderSimpleErrorMessage (CannotFindDerivingType nm) =
652 renderSimpleErrorMessage (CannotFindDerivingType nm) =
642 line $ "Cannot derive a type class instance, because the type declaration for " ++ markCode (runProperName nm) ++ " could not be found."
653 line $ "Cannot derive a type class instance, because the type declaration for " ++ markCode (runProperName nm) ++ " could not be found."
643 renderSimpleErrorMessage (DuplicateLabel l expr) =
654 renderSimpleErrorMessage (DuplicateLabel l expr) =
@@ -677,12 +688,6 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS
677 line $ "Type of expression lacks required label " ++ markCode prop ++ "."
688 line $ "Type of expression lacks required label " ++ markCode prop ++ "."
678 renderSimpleErrorMessage (AdditionalProperty prop) =
689 renderSimpleErrorMessage (AdditionalProperty prop) =
679 line $ "Type of expression contains additional label " ++ markCode prop ++ "."
690 line $ "Type of expression contains additional label " ++ markCode prop ++ "."
680− renderSimpleErrorMessage (CannotApplyFunction fn arg) =
681− paras [ line "A function of type"
682− , markCodeBox $ indent $ typeAsBox fn
683− , line "can not be applied to the argument"
684− , markCodeBox $ indent $ prettyPrintValue valueDepth arg
685− ]
686 renderSimpleErrorMessage TypeSynonymInstance =
691 renderSimpleErrorMessage TypeSynonymInstance =
687 line "Type class instances for type synonyms are disallowed."
692 line "Type class instances for type synonyms are disallowed."
688 renderSimpleErrorMessage (OrphanInstance nm cnm ts) =
693 renderSimpleErrorMessage (OrphanInstance nm cnm ts) =
@@ -752,16 +757,22 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS
752
757
753 renderSimpleErrorMessage msg@(UnusedExplicitImport mn names _ _) =
758 renderSimpleErrorMessage msg@(UnusedExplicitImport mn names _ _) =
754 paras [ line $ "The import of module " ++ markCode (runModuleName mn) ++ " contains the following unused references:"
759 paras [ line $ "The import of module " ++ markCode (runModuleName mn) ++ " contains the following unused references:"
755− , indent $ paras $ map line names
760+ , indent $ paras $ map (line . markCode . runName . Qualified Nothing) names
756 , line "It could be replaced with:"
761 , line "It could be replaced with:"
757 , indent $ line $ markCode $ showSuggestion msg ]
762 , indent $ line $ markCode $ showSuggestion msg ]
758
763
759− renderSimpleErrorMessage (UnusedDctorImport name) =
764+ renderSimpleErrorMessage msg@(UnusedDctorImport mn name _ _) =
760− line $ "The import of type " ++ markCode (runProperName name) ++ " includes data constructors but only the type is used"
765+ paras [line $ "The import of type " ++ markCode (runProperName name)
766+ ++ " from module " ++ markCode (runModuleName mn) ++ " includes data constructors but only the type is used"
767+ , line "It could be replaced with:"
768+ , indent $ line $ markCode $ showSuggestion msg ]
761
769
762− renderSimpleErrorMessage (UnusedDctorExplicitImport name names) =
770+ renderSimpleErrorMessage msg@(UnusedDctorExplicitImport mn name names _ _) =
763− paras [ line $ "The import of type " ++ markCode (runProperName name) ++ " includes the following unused data constructors:"
771+ paras [ line $ "The import of type " ++ markCode (runProperName name)
772+ ++ " from module " ++ markCode (runModuleName mn) ++ " includes the following unused data constructors:"
764− , indent $ paras $ map (line . markCode . runProperName) names ]
773+ , indent $ paras $ map (line . markCode . runProperName) names
774+ , line "It could be replaced with:"
775+ , indent $ line $ markCode $ showSuggestion msg ]
765
776
766 renderSimpleErrorMessage (DuplicateSelectiveImport name) =
777 renderSimpleErrorMessage (DuplicateSelectiveImport name) =
767 line $ "There is an existing import of " ++ markCode (runModuleName name) ++ ", consider merging the import lists"
778 line $ "There is an existing import of " ++ markCode (runModuleName name) ++ ", consider merging the import lists"
@@ -819,6 +830,14 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS
819 , line "Try adding a type signature."
830 , line "Try adding a type signature."
820 ]
831 ]
821
832
833+ renderSimpleErrorMessage (CannotDeriveNewtypeForData tyName) =
834+ paras [ line $ "Cannot derive an instance of the " ++ markCode "Newtype" ++ " class for non-newtype " ++ markCode (runProperName tyName) ++ "."
835+ ]
836+
837+ renderSimpleErrorMessage (NonWildcardNewtypeInstance tyName) =
838+ paras [ line $ "A type wildcard (_) should be used for the inner type when deriving the " ++ markCode "Newtype" ++ " instance for " ++ markCode (runProperName tyName) ++ "."
839+ ]
840+
822 renderHint :: ErrorMessageHint -> Box.Box -> Box.Box
841 renderHint :: ErrorMessageHint -> Box.Box -> Box.Box
823 renderHint (ErrorUnifyingTypes t1 t2) detail =
842 renderHint (ErrorUnifyingTypes t1 t2) detail =
824 paras [ detail
843 paras [ detail
@@ -933,7 +952,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS
933 ]
952 ]
934 renderHint (ErrorSolvingConstraint (Constraint nm ts _)) detail =
953 renderHint (ErrorSolvingConstraint (Constraint nm ts _)) detail =
935 paras [ detail
954 paras [ detail
936− , line "while solving type class constriant"
955+ , line "while solving type class constraint"
937 , markCodeBox $ indent $ Box.hsep 1 Box.left
956 , markCodeBox $ indent $ Box.hsep 1 Box.left
938 [ line (showQualified runProperName nm)
957 [ line (showQualified runProperName nm)
939 , Box.vcat Box.left (map typeAtomAsBox ts)
958 , Box.vcat Box.left (map typeAtomAsBox ts)
@@ -1016,10 +1035,6 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS
1016
1035
1017 -- | See https://github.com/purescript/purescript/issues/1802
1036 -- | See https://github.com/purescript/purescript/issues/1802
1018 stripRedudantHints :: SimpleErrorMessage -> [ErrorMessageHint] -> [ErrorMessageHint]
1037 stripRedudantHints :: SimpleErrorMessage -> [ErrorMessageHint] -> [ErrorMessageHint]
1019− stripRedudantHints CannotApplyFunction{} = stripFirst isApplicationHint
1020− where
1021− isApplicationHint ErrorInApplication{} = True
1022− isApplicationHint _ = False
1023 stripRedudantHints ExprDoesNotHaveType{} = stripFirst isCheckHint
1038 stripRedudantHints ExprDoesNotHaveType{} = stripFirst isCheckHint
1024 where
1039 where
1025 isCheckHint ErrorCheckingType{} = True
1040 isCheckHint ErrorCheckingType{} = True
@@ -1043,16 +1058,16 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS
1043 stripFirst _ [] = []
1058 stripFirst _ [] = []
1044
1059
1045 hintCategory :: ErrorMessageHint -> HintCategory
1060 hintCategory :: ErrorMessageHint -> HintCategory
1046− hintCategory ErrorCheckingType{} = ExprHint
1061+ hintCategory ErrorCheckingType{} = ExprHint
1047− hintCategory ErrorInferringType{} = ExprHint
1062+ hintCategory ErrorInferringType{} = ExprHint
1048− hintCategory ErrorInExpression{} = ExprHint
1063+ hintCategory ErrorInExpression{} = ExprHint
1049− hintCategory ErrorUnifyingTypes{} = CheckHint
1064+ hintCategory ErrorUnifyingTypes{} = CheckHint
1050− hintCategory ErrorInSubsumption{} = CheckHint
1065+ hintCategory ErrorInSubsumption{} = CheckHint
1051− hintCategory ErrorInApplication{} = CheckHint
1066+ hintCategory ErrorInApplication{} = CheckHint
1052− hintCategory ErrorCheckingKind{} = CheckHint
1067+ hintCategory ErrorCheckingKind{} = CheckHint
1053− hintCategory ErrorSolvingConstraint{} = SolverHint
1068+ hintCategory ErrorSolvingConstraint{} = SolverHint
1054− hintCategory PositionedError{} = PositionHint
1069+ hintCategory PositionedError{} = PositionHint
1055− hintCategory _ = OtherHint
1070+ hintCategory _ = OtherHint
1056
1071
1057-- Pretty print and export declaration
1072-- Pretty print and export declaration
1058prettyPrintExport :: DeclarationRef -> String
1073prettyPrintExport :: DeclarationRef -> String
@@ -1195,6 +1210,14 @@ renderBox = unlines
1195 dropWhileEnd p = reverse . dropWhile p . reverse
1210 dropWhileEnd p = reverse . dropWhile p . reverse
1196 whiteSpace = all isSpace
1211 whiteSpace = all isSpace
1197
1212
1213+toTypelevelString :: Type -> Maybe Box.Box
1214+toTypelevelString (TypeLevelString s) = Just $ Box.text s
1215+toTypelevelString (TypeApp (TypeConstructor f) x)
1216+ | f == primName "TypeString" = Just $ typeAsBox x
1217+toTypelevelString (TypeApp (TypeApp (TypeConstructor f) x) ret)
1218+ | f == primName "TypeConcat" = before <$> (toTypelevelString x) <*> (toTypelevelString ret)
1219+toTypelevelString _ = Nothing
1220+
1198-- |
1221-- |
1199-- Rethrow an error with a more detailed error message in the case of failure
1222-- Rethrow an error with a more detailed error message in the case of failure
1200--
1223--
src/Language/PureScript/Externs.hs+27−26
@@ -93,44 +93,45 @@ data ExternsTypeFixity = ExternsTypeFixity
93data ExternsDeclaration =
93data ExternsDeclaration =
94 -- | A type declaration
94 -- | A type declaration
95 EDType
95 EDType
96− { edTypeName :: ProperName 'TypeName
96+ { edTypeName :: ProperName 'TypeName
97− , edTypeKind :: Kind
97+ , edTypeKind :: Kind
98− , edTypeDeclarationKind :: TypeKind
98+ , edTypeDeclarationKind :: TypeKind
99 }
99 }
100 -- | A type synonym
100 -- | A type synonym
101 | EDTypeSynonym
101 | EDTypeSynonym
102− { edTypeSynonymName :: ProperName 'TypeName
102+ { edTypeSynonymName :: ProperName 'TypeName
103− , edTypeSynonymArguments :: [(String, Maybe Kind)]
103+ , edTypeSynonymArguments :: [(String, Maybe Kind)]
104− , edTypeSynonymType :: Type
104+ , edTypeSynonymType :: Type
105 }
105 }
106 -- | A data construtor
106 -- | A data construtor
107 | EDDataConstructor
107 | EDDataConstructor
108− { edDataCtorName :: ProperName 'ConstructorName
108+ { edDataCtorName :: ProperName 'ConstructorName
109− , edDataCtorOrigin :: DataDeclType
109+ , edDataCtorOrigin :: DataDeclType
110− , edDataCtorTypeCtor :: ProperName 'TypeName
110+ , edDataCtorTypeCtor :: ProperName 'TypeName
111− , edDataCtorType :: Type
111+ , edDataCtorType :: Type
112− , edDataCtorFields :: [Ident]
112+ , edDataCtorFields :: [Ident]
113 }
113 }
114 -- | A value declaration
114 -- | A value declaration
115 | EDValue
115 | EDValue
116− { edValueName :: Ident
116+ { edValueName :: Ident
117− , edValueType :: Type
117+ , edValueType :: Type
118 }
118 }
119 -- | A type class declaration
119 -- | A type class declaration
120 | EDClass
120 | EDClass
121− { edClassName :: ProperName 'ClassName
121+ { edClassName :: ProperName 'ClassName
122− , edClassTypeArguments :: [(String, Maybe Kind)]
122+ , edClassTypeArguments :: [(String, Maybe Kind)]
123− , edClassMembers :: [(Ident, Type)]
123+ , edClassMembers :: [(Ident, Type)]
124− , edClassConstraints :: [Constraint]
124+ , edClassConstraints :: [Constraint]
125+ , edFunctionalDependencies :: [FunctionalDependency]
125 }
126 }
126 -- | An instance declaration
127 -- | An instance declaration
127 | EDInstance
128 | EDInstance
128− { edInstanceClassName :: Qualified (ProperName 'ClassName)
129+ { edInstanceClassName :: Qualified (ProperName 'ClassName)
129− , edInstanceName :: Ident
130+ , edInstanceName :: Ident
130− , edInstanceTypes :: [Type]
131+ , edInstanceTypes :: [Type]
131− , edInstanceConstraints :: Maybe [Constraint]
132+ , edInstanceConstraints :: Maybe [Constraint]
132 }
133 }
133− deriving (Show)
134+ deriving Show
134
135
135-- | Convert an externs file back into a module
136-- | Convert an externs file back into a module
136applyExternsFileToEnvironment :: ExternsFile -> Environment -> Environment
137applyExternsFileToEnvironment :: ExternsFile -> Environment -> Environment
@@ -141,7 +142,7 @@ applyExternsFileToEnvironment ExternsFile{..} = flip (foldl' applyDecl) efDeclar
141 applyDecl env (EDTypeSynonym pn args ty) = env { typeSynonyms = M.insert (qual pn) (args, ty) (typeSynonyms env) }
142 applyDecl env (EDTypeSynonym pn args ty) = env { typeSynonyms = M.insert (qual pn) (args, ty) (typeSynonyms env) }
142 applyDecl env (EDDataConstructor pn dTy tNm ty nms) = env { dataConstructors = M.insert (qual pn) (dTy, tNm, ty, nms) (dataConstructors env) }
143 applyDecl env (EDDataConstructor pn dTy tNm ty nms) = env { dataConstructors = M.insert (qual pn) (dTy, tNm, ty, nms) (dataConstructors env) }
143 applyDecl env (EDValue ident ty) = env { names = M.insert (Qualified (Just efModuleName) ident) (ty, External, Defined) (names env) }
144 applyDecl env (EDValue ident ty) = env { names = M.insert (Qualified (Just efModuleName) ident) (ty, External, Defined) (names env) }
144− applyDecl env (EDClass pn args members cs) = env { typeClasses = M.insert (qual pn) (args, members, cs) (typeClasses env) }
145+ applyDecl env (EDClass pn args members cs deps) = env { typeClasses = M.insert (qual pn) (TypeClassData args members cs deps) (typeClasses env) }
145 applyDecl env (EDInstance className ident tys cs) = env { typeClassDictionaries = updateMap (updateMap (M.insert (qual ident) dict) className) (Just efModuleName) (typeClassDictionaries env) }
146 applyDecl env (EDInstance className ident tys cs) = env { typeClassDictionaries = updateMap (updateMap (M.insert (qual ident) dict) className) (Just efModuleName) (typeClassDictionaries env) }
146 where
147 where
147 dict :: TypeClassDictionaryInScope
148 dict :: TypeClassDictionaryInScope
@@ -204,12 +205,12 @@ moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..}
204 | Just (ty, _, _) <- Qualified (Just mn) ident `M.lookup` names env
205 | Just (ty, _, _) <- Qualified (Just mn) ident `M.lookup` names env
205 = [ EDValue ident ty ]
206 = [ EDValue ident ty ]
206 toExternsDeclaration (TypeClassRef className)
207 toExternsDeclaration (TypeClassRef className)
207− | Just (args, members, implies) <- Qualified (Just mn) className `M.lookup` typeClasses env
208+ | Just TypeClassData{..} <- Qualified (Just mn) className `M.lookup` typeClasses env
208 , Just (kind, TypeSynonym) <- Qualified (Just mn) (coerceProperName className) `M.lookup` types env
209 , Just (kind, TypeSynonym) <- Qualified (Just mn) (coerceProperName className) `M.lookup` types env
209 , Just (_, synTy) <- Qualified (Just mn) (coerceProperName className) `M.lookup` typeSynonyms env
210 , Just (_, synTy) <- Qualified (Just mn) (coerceProperName className) `M.lookup` typeSynonyms env
210 = [ EDType (coerceProperName className) kind TypeSynonym
211 = [ EDType (coerceProperName className) kind TypeSynonym
211− , EDTypeSynonym (coerceProperName className) args synTy
212+ , EDTypeSynonym (coerceProperName className) typeClassArguments synTy
212− , EDClass className args members implies
213+ , EDClass className typeClassArguments typeClassMembers typeClassSuperclasses typeClassDependencies
213 ]
214 ]
214 toExternsDeclaration (TypeInstanceRef ident)
215 toExternsDeclaration (TypeInstanceRef ident)
215 = [ EDInstance tcdClassName ident tcdInstanceTypes tcdDependencies
216 = [ EDInstance tcdClassName ident tcdInstanceTypes tcdDependencies
src/Language/PureScript/Ide.hs+6−6
@@ -38,9 +38,9 @@ import Language.PureScript.Ide.SourceFile
38import Language.PureScript.Ide.State
38import Language.PureScript.Ide.State
39import Language.PureScript.Ide.Types
39import Language.PureScript.Ide.Types
40import Language.PureScript.Ide.Util
40import Language.PureScript.Ide.Util
41−import System.Directory
41+import System.Directory (getCurrentDirectory, getDirectoryContents, doesDirectoryExist, doesFileExist)
42−import System.FilePath
42+import System.FilePath ((</>))
43−import System.FilePath.Glob
43+import System.FilePath.Glob (glob)
44
44
45-- | Accepts a Commmand and runs it against psc-ide's State. This is the main
45-- | Accepts a Commmand and runs it against psc-ide's State. This is the main
46-- entry point for the server.
46-- entry point for the server.
@@ -77,7 +77,7 @@ handleCommand c = case c of
77 case rs of
77 case rs of
78 Right rs' -> answerRequest outfp rs'
78 Right rs' -> answerRequest outfp rs'
79 Left question ->
79 Left question ->
80− pure (CompletionResult (map completionFromMatch question))
80+ pure (CompletionResult (map (completionFromMatch . map withEmptyAnn) question))
81 Rebuild file ->
81 Rebuild file ->
82 rebuildFile file
82 rebuildFile file
83 Cwd ->
83 Cwd ->
@@ -88,7 +88,7 @@ handleCommand c = case c of
88 liftIO exitSuccess
88 liftIO exitSuccess
89
89
90findCompletions :: Ide m =>
90findCompletions :: Ide m =>
91− [Filter] -> Matcher IdeDeclaration -> Maybe P.ModuleName -> m Success
91+ [Filter] -> Matcher IdeDeclarationAnn -> Maybe P.ModuleName -> m Success
92findCompletions filters matcher currentModule = do
92findCompletions filters matcher currentModule = do
93 modules <- getAllModules currentModule
93 modules <- getAllModules currentModule
94 pure . CompletionResult . map completionFromMatch . getCompletions filters matcher $ modules
94 pure . CompletionResult . map completionFromMatch . getCompletions filters matcher $ modules
@@ -97,7 +97,7 @@ findType :: Ide m =>
97 Text -> [Filter] -> Maybe P.ModuleName -> m Success
97 Text -> [Filter] -> Maybe P.ModuleName -> m Success
98findType search filters currentModule = do
98findType search filters currentModule = do
99 modules <- getAllModules currentModule
99 modules <- getAllModules currentModule
100− pure . InfoResult . map infoFromMatch . getExactMatches search filters $ modules
100+ pure . CompletionResult . map completionFromMatch . getExactMatches search filters $ modules
101
101
102findPursuitCompletions :: MonadIO m =>
102findPursuitCompletions :: MonadIO m =>
103 PursuitQuery -> m Success
103 PursuitQuery -> m Success
src/Language/PureScript/Ide/Command.hs+1−1
@@ -34,7 +34,7 @@ data Command
34 }
34 }
35 | Complete
35 | Complete
36 { completeFilters :: [Filter]
36 { completeFilters :: [Filter]
37− , completeMatcher :: Matcher IdeDeclaration
37+ , completeMatcher :: Matcher IdeDeclarationAnn
38 , completeCurrentModule :: Maybe P.ModuleName
38 , completeCurrentModule :: Maybe P.ModuleName
39 }
39 }
40 | Pursuit
40 | Pursuit
src/Language/PureScript/Ide/Completion.hs+7−8
@@ -9,24 +9,23 @@ import Protolude
9import Language.PureScript.Ide.Filter
9import Language.PureScript.Ide.Filter
10import Language.PureScript.Ide.Matcher
10import Language.PureScript.Ide.Matcher
11import Language.PureScript.Ide.Types
11import Language.PureScript.Ide.Types
12−import Language.PureScript.Ide.Util
13
12
14-- | Applies the CompletionFilters and the Matcher to the given Modules
13-- | Applies the CompletionFilters and the Matcher to the given Modules
15-- and sorts the found Completions according to the Matching Score
14-- and sorts the found Completions according to the Matching Score
16getCompletions
15getCompletions
17 :: [Filter]
16 :: [Filter]
18− -> Matcher IdeDeclaration
17+ -> Matcher IdeDeclarationAnn
19 -> [Module]
18 -> [Module]
20− -> [Match IdeDeclaration]
19+ -> [Match IdeDeclarationAnn]
21getCompletions filters matcher modules =
20getCompletions filters matcher modules =
22− runMatcher matcher (completionsFromModules discardAnn (applyFilters filters modules))
21+ runMatcher matcher (completionsFromModules (applyFilters filters modules))
23
22
24getExactMatches :: Text -> [Filter] -> [Module] -> [Match IdeDeclarationAnn]
23getExactMatches :: Text -> [Filter] -> [Module] -> [Match IdeDeclarationAnn]
25getExactMatches search filters modules =
24getExactMatches search filters modules =
26− completionsFromModules identity (applyFilters (equalityFilter search : filters) modules)
25+ completionsFromModules (applyFilters (equalityFilter search : filters) modules)
27
26
28−completionsFromModules :: (IdeDeclarationAnn -> a) -> [Module] -> [Match a]
27+completionsFromModules :: [Module] -> [Match IdeDeclarationAnn]
29−completionsFromModules f = foldMap completionFromModule
28+completionsFromModules = foldMap completionFromModule
30 where
29 where
31 completionFromModule (moduleName, decls) =
30 completionFromModule (moduleName, decls) =
32− map (\x -> Match (moduleName, f x)) decls
31+ map (\x -> Match (moduleName, x)) decls
src/Language/PureScript/Ide/Externs.hs+22−14
@@ -17,9 +17,9 @@
17{-# LANGUAGE FlexibleContexts #-}
17{-# LANGUAGE FlexibleContexts #-}
18
18
19module Language.PureScript.Ide.Externs
19module Language.PureScript.Ide.Externs
20− ( readExternFile,
20+ ( readExternFile
21− convertExterns,
21+ , convertExterns
22− annotateLocations
22+ , annotateModule
23 ) where
23 ) where
24
24
25import Protolude
25import Protolude
@@ -87,26 +87,31 @@ convertOperator :: P.ExternsFixity -> IdeDeclaration
87convertOperator P.ExternsFixity{..} =
87convertOperator P.ExternsFixity{..} =
88 IdeValueOperator
88 IdeValueOperator
89 efOperator
89 efOperator
90− (toS (P.showQualified (either P.runIdent P.runProperName) efAlias))
90+ efAlias
91 efPrecedence
91 efPrecedence
92 efAssociativity
92 efAssociativity
93+ Nothing
93
94
94convertTypeOperator :: P.ExternsTypeFixity -> IdeDeclaration
95convertTypeOperator :: P.ExternsTypeFixity -> IdeDeclaration
95convertTypeOperator P.ExternsTypeFixity{..} =
96convertTypeOperator P.ExternsTypeFixity{..} =
96 IdeTypeOperator
97 IdeTypeOperator
97 efTypeOperator
98 efTypeOperator
98− (toS (P.showQualified P.runProperName efTypeAlias))
99+ efTypeAlias
99 efTypePrecedence
100 efTypePrecedence
100 efTypeAssociativity
101 efTypeAssociativity
102+ Nothing
101
103
102−annotateLocations :: Map (Either Text Text) P.SourceSpan -> Module -> Module
104+annotateModule
105+ :: (DefinitionSites P.SourceSpan, TypeAnnotations)
106+ -> Module
107+ -> Module
103−annotateLocations ast (moduleName, decls) =
108+annotateModule (defs, types) (moduleName, decls) =
104 (moduleName, map convertDeclaration decls)
109 (moduleName, map convertDeclaration decls)
105 where
110 where
106 convertDeclaration :: IdeDeclarationAnn -> IdeDeclarationAnn
111 convertDeclaration :: IdeDeclarationAnn -> IdeDeclarationAnn
107 convertDeclaration (IdeDeclarationAnn ann d) = case d of
112 convertDeclaration (IdeDeclarationAnn ann d) = case d of
108 IdeValue i t ->
113 IdeValue i t ->
109− annotateValue (runIdentT i) (IdeValue i t)
114+ annotateFunction i (IdeValue i t)
110 IdeType i k ->
115 IdeType i k ->
111 annotateType (runProperNameT i) (IdeType i k)
116 annotateType (runProperNameT i) (IdeType i k)
112 IdeTypeSynonym i t ->
117 IdeTypeSynonym i t ->
@@ -115,10 +120,13 @@ annotateLocations ast (moduleName, decls) =
115 annotateValue (runProperNameT i) (IdeDataConstructor i tn t)
120 annotateValue (runProperNameT i) (IdeDataConstructor i tn t)
116 IdeTypeClass i ->
121 IdeTypeClass i ->
117 annotateType (runProperNameT i) (IdeTypeClass i)
122 annotateType (runProperNameT i) (IdeTypeClass i)
118− IdeValueOperator n i p a ->
123+ IdeValueOperator n i p a t ->
119− annotateValue i (IdeValueOperator n i p a)
124+ annotateValue (valueOperatorAliasT i) (IdeValueOperator n i p a t)
120− IdeTypeOperator n i p a ->
125+ IdeTypeOperator n i p a k ->
121− annotateType i (IdeTypeOperator n i p a)
126+ annotateType (typeOperatorAliasT i) (IdeTypeOperator n i p a k)
122 where
127 where
128+ annotateFunction x = IdeDeclarationAnn (ann { annLocation = Map.lookup (Left (runIdentT x)) defs
129+ , annTypeAnnotation = Map.lookup x types
130+ })
123− annotateValue x = IdeDeclarationAnn (ann {annLocation = Map.lookup (Left x) ast})
131+ annotateValue x = IdeDeclarationAnn (ann {annLocation = Map.lookup (Left x) defs})
124− annotateType x = IdeDeclarationAnn (ann {annLocation = Map.lookup (Right x) ast})
132+ annotateType x = IdeDeclarationAnn (ann {annLocation = Map.lookup (Right x) defs})
src/Language/PureScript/Ide/Imports.hs+2−2
@@ -203,9 +203,9 @@ addExplicitImport' decl moduleName imports =
203 P.TypeRef tn (Just [n])
203 P.TypeRef tn (Just [n])
204 refFromDeclaration (IdeType n _) =
204 refFromDeclaration (IdeType n _) =
205 P.TypeRef n (Just [])
205 P.TypeRef n (Just [])
206− refFromDeclaration (IdeValueOperator op _ _ _) =
206+ refFromDeclaration (IdeValueOperator op _ _ _ _) =
207 P.ValueOpRef op
207 P.ValueOpRef op
208− refFromDeclaration (IdeTypeOperator op _ _ _) =
208+ refFromDeclaration (IdeTypeOperator op _ _ _ _) =
209 P.TypeOpRef op
209 P.TypeOpRef op
210 refFromDeclaration d =
210 refFromDeclaration d =
211 P.ValueRef $ P.Ident $ T.unpack (identifierFromIdeDeclaration d)
211 P.ValueRef $ P.Ident $ T.unpack (identifierFromIdeDeclaration d)
src/Language/PureScript/Ide/Matcher.hs+8−8
@@ -38,7 +38,7 @@ type ScoredMatch a = (Match a, Double)
38
38
39newtype Matcher a = Matcher (Endo [Match a]) deriving (Monoid)
39newtype Matcher a = Matcher (Endo [Match a]) deriving (Monoid)
40
40
41−instance FromJSON (Matcher IdeDeclaration) where
41+instance FromJSON (Matcher IdeDeclarationAnn) where
42 parseJSON = withObject "matcher" $ \o -> do
42 parseJSON = withObject "matcher" $ \o -> do
43 (matcher :: Maybe Text) <- o .:? "matcher"
43 (matcher :: Maybe Text) <- o .:? "matcher"
44 case matcher of
44 case matcher of
@@ -60,17 +60,17 @@ instance FromJSON (Matcher IdeDeclaration) where
60-- Examples:
60-- Examples:
61-- flMa matches flexMatcher. Score: 14.28
61-- flMa matches flexMatcher. Score: 14.28
62-- sons matches sortCompletions. Score: 6.25
62-- sons matches sortCompletions. Score: 6.25
63−flexMatcher :: Text -> Matcher IdeDeclaration
63+flexMatcher :: Text -> Matcher IdeDeclarationAnn
64flexMatcher p = mkMatcher (flexMatch p)
64flexMatcher p = mkMatcher (flexMatch p)
65
65
66−distanceMatcher :: Text -> Int -> Matcher IdeDeclaration
66+distanceMatcher :: Text -> Int -> Matcher IdeDeclarationAnn
67distanceMatcher q maxDist = mkMatcher (distanceMatcher' q maxDist)
67distanceMatcher q maxDist = mkMatcher (distanceMatcher' q maxDist)
68
68
69−distanceMatcher' :: Text -> Int -> [Match IdeDeclaration] -> [ScoredMatch IdeDeclaration]
69+distanceMatcher' :: Text -> Int -> [Match IdeDeclarationAnn] -> [ScoredMatch IdeDeclarationAnn]
70distanceMatcher' q maxDist = mapMaybe go
70distanceMatcher' q maxDist = mapMaybe go
71 where
71 where
72 go m = let d = dist (T.unpack y)
72 go m = let d = dist (T.unpack y)
73− y = identifierFromIdeDeclaration (unwrapMatch m)
73+ y = identifierFromIdeDeclaration (discardAnn (unwrapMatch m))
74 in if d <= maxDist
74 in if d <= maxDist
75 then Just (m, 1 / fromIntegral d)
75 then Just (m, 1 / fromIntegral d)
76 else Nothing
76 else Nothing
@@ -85,12 +85,12 @@ runMatcher (Matcher m)= appEndo m
85sortCompletions :: [ScoredMatch a] -> [ScoredMatch a]
85sortCompletions :: [ScoredMatch a] -> [ScoredMatch a]
86sortCompletions = sortBy (flip compare `on` snd)
86sortCompletions = sortBy (flip compare `on` snd)
87
87
88−flexMatch :: Text -> [Match IdeDeclaration] -> [ScoredMatch IdeDeclaration]
88+flexMatch :: Text -> [Match IdeDeclarationAnn] -> [ScoredMatch IdeDeclarationAnn]
89flexMatch = mapMaybe . flexRate
89flexMatch = mapMaybe . flexRate
90
90
91−flexRate :: Text -> Match IdeDeclaration -> Maybe (ScoredMatch IdeDeclaration)
91+flexRate :: Text -> Match IdeDeclarationAnn -> Maybe (ScoredMatch IdeDeclarationAnn)
92flexRate p c = do
92flexRate p c = do
93− score <- flexScore p (identifierFromIdeDeclaration (unwrapMatch c))
93+ score <- flexScore p (identifierFromIdeDeclaration (discardAnn (unwrapMatch c)))
94 return (c, score)
94 return (c, score)
95
95
96-- FlexMatching ala Sublime.
96-- FlexMatching ala Sublime.
src/Language/PureScript/Ide/Pursuit.hs+20−24
@@ -35,41 +35,37 @@ import qualified Pipes.Prelude as P
35-- TODO: remove this when the issue is fixed at Pursuit
35-- TODO: remove this when the issue is fixed at Pursuit
36queryPursuit :: Text -> IO ByteString
36queryPursuit :: Text -> IO ByteString
37queryPursuit q = do
37queryPursuit q = do
38− let qClean = T.dropWhileEnd (== '.') q
38+ let qClean = T.dropWhileEnd (== '.') q
39− req' <- parseRequest "http://pursuit.purescript.org/search"
39+ req' <- parseRequest "http://pursuit.purescript.org/search"
40− let req = req'
40+ let req = req'
41− { queryString= "q=" <> (fromString . T.unpack) qClean
41+ { queryString= "q=" <> (fromString . T.unpack) qClean
42− , requestHeaders=[(hAccept, "application/json")]
42+ , requestHeaders=[(hAccept, "application/json")]
43− }
43+ }
44− m <- newManager tlsManagerSettings
44+ m <- newManager tlsManagerSettings
45− withHTTP req m $ \resp ->
45+ withHTTP req m $ \resp ->
46− P.fold (<>) "" identity (responseBody resp)
46+ P.fold (<>) "" identity (responseBody resp)
47−
48
47
49handler :: HttpException -> IO [a]
48handler :: HttpException -> IO [a]
50−handler StatusCodeException{} = pure []
51handler _ = pure []
49handler _ = pure []
52
50
53searchPursuitForDeclarations :: Text -> IO [PursuitResponse]
51searchPursuitForDeclarations :: Text -> IO [PursuitResponse]
54−searchPursuitForDeclarations query =
52+searchPursuitForDeclarations query = E.handle handler $ do
55− (do r <- queryPursuit query
53+ r <- queryPursuit query
56− let results' = decode (fromStrict r) :: Maybe Array
54+ let results' = decode (fromStrict r) :: Maybe Array
57− case results' of
55+ case results' of
58− Nothing -> pure []
56+ Nothing -> pure []
59− Just results -> pure (mapMaybe (isDeclarationResponse . fromJSON) (toList results))) `E.catch`
57+ Just results -> pure (mapMaybe (isDeclarationResponse . fromJSON) (toList results))
60− handler
61 where
58 where
62 isDeclarationResponse (Success a@DeclarationResponse{}) = Just a
59 isDeclarationResponse (Success a@DeclarationResponse{}) = Just a
63 isDeclarationResponse _ = Nothing
60 isDeclarationResponse _ = Nothing
64
61
65findPackagesForModuleIdent :: Text -> IO [PursuitResponse]
62findPackagesForModuleIdent :: Text -> IO [PursuitResponse]
66−findPackagesForModuleIdent query =
63+findPackagesForModuleIdent query = E.handle handler $ do
67− (do r <- queryPursuit query
64+ r <- queryPursuit query
68− let results' = decode (fromStrict r) :: Maybe Array
65+ let results' = decode (fromStrict r) :: Maybe Array
69− case results' of
66+ case results' of
70 Nothing -> pure []
67 Nothing -> pure []
71− Just results -> pure (mapMaybe (isModuleResponse . fromJSON) (toList results))) `E.catch`
68+ Just results -> pure (mapMaybe (isModuleResponse . fromJSON) (toList results))
72− handler
73 where
69 where
74 isModuleResponse (Success a@ModuleResponse{}) = Just a
70 isModuleResponse (Success a@ModuleResponse{}) = Just a
75 isModuleResponse _ = Nothing
71 isModuleResponse _ = Nothing
src/Language/PureScript/Ide/Reexports.hs+2−4
@@ -14,8 +14,6 @@
14-----------------------------------------------------------------------------
14-----------------------------------------------------------------------------
15
15
16{-# LANGUAGE OverloadedStrings #-}
16{-# LANGUAGE OverloadedStrings #-}
17−{-# LANGUAGE PackageImports #-}
18−{-# LANGUAGE TemplateHaskell #-}
19{-# LANGUAGE RecordWildCards #-}
17{-# LANGUAGE RecordWildCards #-}
20
18
21module Language.PureScript.Ide.Reexports
19module Language.PureScript.Ide.Reexports
@@ -93,9 +91,9 @@ resolveRef decls ref = case ref of
93 P.ValueRef i ->
91 P.ValueRef i ->
94 findWrapped (\case IdeValue i' _ -> i' == i; _ -> False)
92 findWrapped (\case IdeValue i' _ -> i' == i; _ -> False)
95 P.TypeOpRef name ->
93 P.TypeOpRef name ->
96− findWrapped (\case IdeTypeOperator n _ _ _ -> n == name; _ -> False)
94+ findWrapped (\case IdeTypeOperator n _ _ _ _ -> n == name; _ -> False)
97 P.ValueOpRef name ->
95 P.ValueOpRef name ->
98− findWrapped (\case IdeValueOperator n _ _ _ -> n == name; _ -> False)
96+ findWrapped (\case IdeValueOperator n _ _ _ _ -> n == name; _ -> False)
99 P.TypeClassRef name ->
97 P.TypeClassRef name ->
100 findWrapped (\case IdeTypeClass n -> n == name; _ -> False)
98 findWrapped (\case IdeTypeClass n -> n == name; _ -> False)
101 _ ->
99 _ ->
src/Language/PureScript/Ide/SourceFile.hs+24−1
@@ -17,11 +17,15 @@
17module Language.PureScript.Ide.SourceFile
17module Language.PureScript.Ide.SourceFile
18 ( parseModule
18 ( parseModule
19 , getImportsForFile
19 , getImportsForFile
20+ , extractAstInformation
21+ -- for tests
20 , extractSpans
22 , extractSpans
23+ , extractTypeAnnotations
21 ) where
24 ) where
22
25
23import Protolude
26import Protolude
24
27
28+import qualified Data.Map as Map
25import qualified Language.PureScript as P
29import qualified Language.PureScript as P
26import Language.PureScript.Ide.Error
30import Language.PureScript.Ide.Error
27import Language.PureScript.Ide.Util
31import Language.PureScript.Ide.Util
@@ -64,6 +68,25 @@ getImportsForFile fp = do
64 unwrapImportType (P.Hiding decls) = P.Hiding (map unwrapPositionedRef decls)
68 unwrapImportType (P.Hiding decls) = P.Hiding (map unwrapPositionedRef decls)
65 unwrapImportType P.Implicit = P.Implicit
69 unwrapImportType P.Implicit = P.Implicit
66
70
71+-- | Extracts AST information from a parsed module
72+extractAstInformation
73+ :: P.Module
74+ -> (DefinitionSites P.SourceSpan, TypeAnnotations)
75+extractAstInformation (P.Module ss _ _ decls _) =
76+ let definitions = Map.fromList (concatMap (extractSpans ss) decls)
77+ typeAnnotations = Map.fromList (extractTypeAnnotations decls)
78+ in (definitions, typeAnnotations)
79+
80+-- | Extracts type annotations for functions from a given Module
81+extractTypeAnnotations
82+ :: [P.Declaration]
83+ -> [(P.Ident, P.Type)]
84+extractTypeAnnotations = mapMaybe extract
85+ where
86+ extract d = case unwrapPositioned d of
87+ P.TypeDeclaration ident ty -> Just (ident, ty)
88+ _ -> Nothing
89+
67-- | Given a surrounding Sourcespan and a Declaration from the PS AST, extracts
90-- | Given a surrounding Sourcespan and a Declaration from the PS AST, extracts
68-- definition sites inside that Declaration.
91-- definition sites inside that Declaration.
69extractSpans
92extractSpans
@@ -81,7 +104,7 @@ extractSpans ss d = case d of
81 [(Left (runIdentT i), ss)]
104 [(Left (runIdentT i), ss)]
82 P.TypeSynonymDeclaration name _ _ ->
105 P.TypeSynonymDeclaration name _ _ ->
83 [(Right (runProperNameT name), ss)]
106 [(Right (runProperNameT name), ss)]
84− P.TypeClassDeclaration name _ _ members ->
107+ P.TypeClassDeclaration name _ _ _ members ->
85 (Right (runProperNameT name), ss) : concatMap (extractSpans' ss) members
108 (Right (runProperNameT name), ss) : concatMap (extractSpans' ss) members
86 P.DataDeclaration _ name _ ctors ->
109 P.DataDeclaration _ name _ ctors ->
87 (Right (runProperNameT name), ss)
110 (Right (runProperNameT name), ss)
src/Language/PureScript/Ide/State.hs+86−18
@@ -28,6 +28,8 @@ module Language.PureScript.Ide.State
28 , populateStage2
28 , populateStage2
29 , populateStage3
29 , populateStage3
30 , populateStage3STM
30 , populateStage3STM
31+ -- for tests
32+ , resolveOperatorsForModule
31 ) where
33 ) where
32
34
33import Protolude
35import Protolude
@@ -35,7 +37,8 @@ import qualified Prelude
35
37
36import Control.Concurrent.STM
38import Control.Concurrent.STM
37import "monad-logger" Control.Monad.Logger
39import "monad-logger" Control.Monad.Logger
38−import qualified Data.Map.Lazy as M
40+import qualified Data.Map.Lazy as Map
41+import qualified Data.List as List
39import Language.PureScript.Externs
42import Language.PureScript.Externs
40import Language.PureScript.Ide.Externs
43import Language.PureScript.Ide.Externs
41import Language.PureScript.Ide.Reexports
44import Language.PureScript.Ide.Reexports
@@ -55,10 +58,10 @@ resetIdeState = do
55
58
56-- | Gets the loaded Modulenames
59-- | Gets the loaded Modulenames
57getLoadedModulenames :: Ide m => m [P.ModuleName]
60getLoadedModulenames :: Ide m => m [P.ModuleName]
58−getLoadedModulenames = M.keys <$> getExternFiles
61+getLoadedModulenames = Map.keys <$> getExternFiles
59
62
60-- | Gets all loaded ExternFiles
63-- | Gets all loaded ExternFiles
61−getExternFiles :: Ide m => m (M.Map P.ModuleName ExternsFile)
64+getExternFiles :: Ide m => m (Map P.ModuleName ExternsFile)
62getExternFiles = s1Externs <$> getStage1
65getExternFiles = s1Externs <$> getStage1
63
66
64-- | Insert a Module into Stage1 of the State
67-- | Insert a Module into Stage1 of the State
@@ -72,7 +75,7 @@ insertModuleSTM :: TVar IdeState -> (FilePath, P.Module) -> STM ()
72insertModuleSTM ref (fp, module') =
75insertModuleSTM ref (fp, module') =
73 modifyTVar ref $ \x ->
76 modifyTVar ref $ \x ->
74 x { ideStage1 = (ideStage1 x) {
77 x { ideStage1 = (ideStage1 x) {
75− s1Modules = M.insert
78+ s1Modules = Map.insert
76 (P.getModuleName module')
79 (P.getModuleName module')
77 (module', fp)
80 (module', fp)
78 (s1Modules (ideStage1 x))}}
81 (s1Modules (ideStage1 x))}}
@@ -126,17 +129,24 @@ getAllModules mmoduleName = do
126 declarations <- s3Declarations <$> getStage3
129 declarations <- s3Declarations <$> getStage3
127 rebuild <- cachedRebuild
130 rebuild <- cachedRebuild
128 case mmoduleName of
131 case mmoduleName of
129− Nothing -> pure (M.toList declarations)
132+ Nothing -> pure (Map.toList declarations)
130 Just moduleName ->
133 Just moduleName ->
131 case rebuild of
134 case rebuild of
132 Just (cachedModulename, ef)
135 Just (cachedModulename, ef)
133 | cachedModulename == moduleName -> do
136 | cachedModulename == moduleName -> do
134 (AstData asts) <- s2AstData <$> getStage2
137 (AstData asts) <- s2AstData <$> getStage2
138+ let
139+ ast =
135− let ast = fromMaybe M.empty (M.lookup moduleName asts)
140+ fromMaybe (Map.empty, Map.empty) (Map.lookup moduleName asts)
136− pure . M.toList $
141+ cachedModule =
137− M.insert moduleName
138− (snd . annotateLocations ast . fst . convertExterns $ ef) declarations
142+ snd . annotateModule ast . fst . convertExterns $ ef
143+ tmp =
144+ Map.insert moduleName cachedModule declarations
145+ resolved =
146+ Map.adjust (resolveOperatorsForModule tmp) moduleName tmp
147+
148+ pure (Map.toList resolved)
139− _ -> pure (M.toList declarations)
149+ _ -> pure (Map.toList declarations)
140
150
141-- | Adds an ExternsFile into psc-ide's State Stage1. This does not populate the
151-- | Adds an ExternsFile into psc-ide's State Stage1. This does not populate the
142-- following Stages, which needs to be done after all the necessary Exterms have
152-- following Stages, which needs to be done after all the necessary Exterms have
@@ -151,7 +161,7 @@ insertExternsSTM :: TVar IdeState -> ExternsFile -> STM ()
151insertExternsSTM ref ef =
161insertExternsSTM ref ef =
152 modifyTVar ref $ \x ->
162 modifyTVar ref $ \x ->
153 x { ideStage1 = (ideStage1 x) {
163 x { ideStage1 = (ideStage1 x) {
154− s1Externs = M.insert (efModuleName ef) ef (s1Externs (ideStage1 x))}}
164+ s1Externs = Map.insert (efModuleName ef) ef (s1Externs (ideStage1 x))}}
155
165
156-- | Sets rebuild cache to the given ExternsFile
166-- | Sets rebuild cache to the given ExternsFile
157cacheRebuild :: Ide m => ExternsFile -> m ()
167cacheRebuild :: Ide m => ExternsFile -> m ()
@@ -180,8 +190,8 @@ populateStage2 = do
180populateStage2STM :: TVar IdeState -> STM ()
190populateStage2STM :: TVar IdeState -> STM ()
181populateStage2STM ref = do
191populateStage2STM ref = do
182 modules <- s1Modules <$> getStage1STM ref
192 modules <- s1Modules <$> getStage1STM ref
183− let spans = map (\((P.Module ss _ _ decls _), _) -> M.fromList (concatMap (extractSpans ss) decls)) modules
193+ let astData = map (extractAstInformation . fst) modules
184− setStage2STM ref (Stage2 (AstData spans))
194+ setStage2STM ref (Stage2 (AstData astData))
185
195
186-- | Resolves reexports and populates Stage3 with data to be used in queries.
196-- | Resolves reexports and populates Stage3 with data to be used in queries.
187populateStage3 :: (Ide m, MonadLogger m) => m ()
197populateStage3 :: (Ide m, MonadLogger m) => m ()
@@ -202,12 +212,70 @@ populateStage3STM :: TVar IdeState -> STM [ReexportResult Module]
202populateStage3STM ref = do
212populateStage3STM ref = do
203 externs <- s1Externs <$> getStage1STM ref
213 externs <- s1Externs <$> getStage1STM ref
204 (AstData asts) <- s2AstData <$> getStage2STM ref
214 (AstData asts) <- s2AstData <$> getStage2STM ref
205− let modules = M.map convertExterns externs
215+ let modules = Map.map convertExterns externs
206 nModules :: Map P.ModuleName (Module, [(P.ModuleName, P.DeclarationRef)])
216 nModules :: Map P.ModuleName (Module, [(P.ModuleName, P.DeclarationRef)])
207− nModules = M.mapWithKey
217+ nModules = Map.mapWithKey
208 (\moduleName (m, refs) ->
218 (\moduleName (m, refs) ->
209− (fromMaybe m $ annotateLocations <$> M.lookup moduleName asts <*> pure m, refs)) modules
219+ (fromMaybe m $ annotateModule <$> Map.lookup moduleName asts <*> pure m, refs)) modules
210 -- resolves reexports and discards load failures for now
220 -- resolves reexports and discards load failures for now
211− result = resolveReexports (M.map (snd . fst) nModules) <$> M.elems nModules
221+ result = resolveReexports (map (snd . fst) nModules) <$> Map.elems nModules
222+ resultP = resolveOperators (Map.fromList (reResolved <$> result))
212− setStage3STM ref (Stage3 (M.fromList (map reResolved result)) Nothing)
223+ setStage3STM ref (Stage3 resultP Nothing)
213 pure result
224 pure result
225+
226+resolveOperators
227+ :: Map P.ModuleName [IdeDeclarationAnn]
228+ -> Map P.ModuleName [IdeDeclarationAnn]
229+resolveOperators modules =
230+ map (resolveOperatorsForModule modules) modules
231+
232+-- | Looks up the types and kinds for operators and assigns them to their
233+-- declarations
234+resolveOperatorsForModule
235+ :: Map P.ModuleName [IdeDeclarationAnn]
236+ -> [IdeDeclarationAnn]
237+ -> [IdeDeclarationAnn]
238+resolveOperatorsForModule modules = map (mapIdeDeclaration resolveOperator)
239+ where
240+ resolveOperator (IdeValueOperator
241+ opName
242+ i@(P.Qualified (Just moduleName)
243+ (Left ident)) precedence assoc _) =
244+ let t = do
245+ sourceModule <- Map.lookup moduleName modules
246+ IdeValue _ tP <-
247+ List.find (\case
248+ IdeValue iP _ -> iP == ident
249+ _ -> False) (discardAnn <$> sourceModule)
250+ pure tP
251+
252+ in IdeValueOperator opName i precedence assoc t
253+ resolveOperator (IdeValueOperator
254+ opName
255+ i@(P.Qualified (Just moduleName)
256+ (Right ctor)) precedence assoc _) =
257+ let t = do
258+ sourceModule <- Map.lookup moduleName modules
259+ IdeDataConstructor _ _ tP <-
260+ List.find (\case
261+ IdeDataConstructor cname _ _ -> ctor == cname
262+ _ -> False) (discardAnn <$> sourceModule)
263+ pure tP
264+
265+ in IdeValueOperator opName i precedence assoc t
266+ resolveOperator (IdeTypeOperator
267+ opName
268+ i@(P.Qualified (Just moduleName) properName) precedence assoc _) =
269+ let k = do
270+ sourceModule <- Map.lookup moduleName modules
271+ IdeType _ kP <-
272+ List.find (\case
273+ IdeType name _ -> name == properName
274+ _ -> False) (discardAnn <$> sourceModule)
275+ pure kP
276+
277+ in IdeTypeOperator opName i precedence assoc k
278+ resolveOperator x = x
279+
280+mapIdeDeclaration :: (IdeDeclaration -> IdeDeclaration) -> IdeDeclarationAnn -> IdeDeclarationAnn
281+mapIdeDeclaration f (IdeDeclarationAnn ann decl) = IdeDeclarationAnn ann (f decl)
src/Language/PureScript/Ide/Types.hs+48−65
@@ -21,12 +21,10 @@ import Protolude
21
21
22import Control.Concurrent.STM
22import Control.Concurrent.STM
23import Data.Aeson
23import Data.Aeson
24−import Data.Map.Lazy as M
24+import qualified Data.Map.Lazy as M
25import qualified Language.PureScript.Errors.JSON as P
25import qualified Language.PureScript.Errors.JSON as P
26import qualified Language.PureScript as P
26import qualified Language.PureScript as P
27import Language.PureScript.Ide.Conversions
27import Language.PureScript.Ide.Conversions
28−import Text.Parsec as Parsec
29−import Text.Parsec.Text
30
28
31type ModuleIdent = Text
29type ModuleIdent = Text
32
30
@@ -36,8 +34,8 @@ data IdeDeclaration
36 | IdeTypeSynonym (P.ProperName 'P.TypeName) P.Type
34 | IdeTypeSynonym (P.ProperName 'P.TypeName) P.Type
37 | IdeDataConstructor (P.ProperName 'P.ConstructorName) (P.ProperName 'P.TypeName) P.Type
35 | IdeDataConstructor (P.ProperName 'P.ConstructorName) (P.ProperName 'P.TypeName) P.Type
38 | IdeTypeClass (P.ProperName 'P.ClassName)
36 | IdeTypeClass (P.ProperName 'P.ClassName)
39− | IdeValueOperator (P.OpName 'P.ValueOpName) Text P.Precedence P.Associativity
37+ | IdeValueOperator (P.OpName 'P.ValueOpName) (P.Qualified (Either P.Ident (P.ProperName 'P.ConstructorName))) P.Precedence P.Associativity (Maybe P.Type)
40− | IdeTypeOperator (P.OpName 'P.TypeOpName) Text P.Precedence P.Associativity
38+ | IdeTypeOperator (P.OpName 'P.TypeOpName) (P.Qualified (P.ProperName 'P.TypeName)) P.Precedence P.Associativity (Maybe P.Kind)
41 deriving (Show, Eq, Ord)
39 deriving (Show, Eq, Ord)
42
40
43data IdeDeclarationAnn = IdeDeclarationAnn Annotation IdeDeclaration
41data IdeDeclarationAnn = IdeDeclarationAnn Annotation IdeDeclaration
@@ -47,15 +45,19 @@ data Annotation
47 = Annotation
45 = Annotation
48 { annLocation :: Maybe P.SourceSpan
46 { annLocation :: Maybe P.SourceSpan
49 , annExportedFrom :: Maybe P.ModuleName
47 , annExportedFrom :: Maybe P.ModuleName
48+ , annTypeAnnotation :: Maybe P.Type
50 } deriving (Show, Eq, Ord)
49 } deriving (Show, Eq, Ord)
51
50
52emptyAnn :: Annotation
51emptyAnn :: Annotation
53−emptyAnn = Annotation Nothing Nothing
52+emptyAnn = Annotation Nothing Nothing Nothing
54
53
55type Module = (P.ModuleName, [IdeDeclarationAnn])
54type Module = (P.ModuleName, [IdeDeclarationAnn])
56
55
57−newtype AstData a =
56+type DefinitionSites a = Map (Either Text Text) a
58− AstData (Map P.ModuleName (Map (Either Text Text) a))
57+type TypeAnnotations = Map P.Ident P.Type
58+newtype AstData a = AstData (Map P.ModuleName (DefinitionSites a, TypeAnnotations))
59+ -- ^ SourceSpans for the definition sites of Values and Types aswell as type
60+ -- annotations found in a module
59 deriving (Show, Eq, Ord, Functor, Foldable)
61 deriving (Show, Eq, Ord, Functor, Foldable)
60
62
61data Configuration =
63data Configuration =
@@ -108,21 +110,25 @@ data Stage3 = Stage3
108newtype Match a = Match (P.ModuleName, a)
110newtype Match a = Match (P.ModuleName, a)
109 deriving (Show, Eq, Functor)
111 deriving (Show, Eq, Functor)
110
112
113+-- | A completion as it gets sent to the editors
111−newtype Completion =
114+data Completion = Completion
112− Completion (Text, Text, Text)
115+ { complModule :: Text
113− deriving (Show,Eq)
116+ , complIdentifier :: Text
114−
117+ , complType :: Text
115−newtype Info =
118+ , complExpandedType :: Text
116− Info (Text, Text, Text, Maybe P.SourceSpan)
119+ , complLocation :: Maybe P.SourceSpan
117− deriving (Show,Eq)
120+ , complDocumentation :: Maybe Text
118−
121+ } deriving (Show, Eq)
119−instance ToJSON Info where
120− toJSON (Info (m, d, t, sourceSpan)) =
121− object ["module" .= m, "identifier" .= d, "type" .= t, "definedAt" .= sourceSpan]
122
122
123instance ToJSON Completion where
123instance ToJSON Completion where
124− toJSON (Completion (m, d, t)) =
124+ toJSON (Completion {..}) =
125− object ["module" .= m, "identifier" .= d, "type" .= t]
125+ object [ "module" .= complModule
126+ , "identifier" .= complIdentifier
127+ , "type" .= complType
128+ , "expandedType" .= complExpandedType
129+ , "definedAt" .= complLocation
130+ , "documentation" .= complDocumentation
131+ ]
126
132
127data ModuleImport =
133data ModuleImport =
128 ModuleImport
134 ModuleImport
@@ -140,17 +146,17 @@ instance ToJSON ModuleImport where
140 toJSON (ModuleImport mn P.Implicit qualifier) =
146 toJSON (ModuleImport mn P.Implicit qualifier) =
141 object $ [ "module" .= mn
147 object $ [ "module" .= mn
142 , "importType" .= ("implicit" :: Text)
148 , "importType" .= ("implicit" :: Text)
143− ] ++ fmap (\x -> "qualifier" .= x) (maybeToList qualifier)
149+ ] ++ map (\x -> "qualifier" .= x) (maybeToList qualifier)
144− toJSON (ModuleImport mn (P.Explicit refs) _) =
150+ toJSON (ModuleImport mn (P.Explicit refs) qualifier) =
145− object [ "module" .= mn
151+ object $ [ "module" .= mn
146− , "importType" .= ("explicit" :: Text)
152+ , "importType" .= ("explicit" :: Text)
147− , "identifiers" .= (identifierFromDeclarationRef <$> refs)
153+ , "identifiers" .= (identifierFromDeclarationRef <$> refs)
148− ]
154+ ] ++ map (\x -> "qualifier" .= x) (maybeToList qualifier)
149− toJSON (ModuleImport mn (P.Hiding refs) _) =
155+ toJSON (ModuleImport mn (P.Hiding refs) qualifier) =
150− object [ "module" .= mn
156+ object $ [ "module" .= mn
151− , "importType" .= ("hiding" :: Text)
157+ , "importType" .= ("hiding" :: Text)
152− , "identifiers" .= (identifierFromDeclarationRef <$> refs)
158+ , "identifiers" .= (identifierFromDeclarationRef <$> refs)
153− ]
159+ ] ++ map (\x -> "qualifier" .= x) (maybeToList qualifier)
154
160
155identifierFromDeclarationRef :: P.DeclarationRef -> Text
161identifierFromDeclarationRef :: P.DeclarationRef -> Text
156identifierFromDeclarationRef (P.TypeRef name _) = runProperNameT name
162identifierFromDeclarationRef (P.TypeRef name _) = runProperNameT name
@@ -160,14 +166,13 @@ identifierFromDeclarationRef _ = ""
160
166
161data Success =
167data Success =
162 CompletionResult [Completion]
168 CompletionResult [Completion]
163− | InfoResult [Info]
164 | TextResult Text
169 | TextResult Text
165 | MultilineTextResult [Text]
170 | MultilineTextResult [Text]
166 | PursuitResult [PursuitResponse]
171 | PursuitResult [PursuitResponse]
167 | ImportList [ModuleImport]
172 | ImportList [ModuleImport]
168 | ModuleList [ModuleIdent]
173 | ModuleList [ModuleIdent]
169 | RebuildSuccess [P.JSONError]
174 | RebuildSuccess [P.JSONError]
170− deriving(Show, Eq)
175+ deriving (Show, Eq)
171
176
172encodeSuccess :: (ToJSON a) => a -> Value
177encodeSuccess :: (ToJSON a) => a -> Value
173encodeSuccess res =
178encodeSuccess res =
@@ -175,7 +180,6 @@ encodeSuccess res =
175
180
176instance ToJSON Success where
181instance ToJSON Success where
177 toJSON (CompletionResult cs) = encodeSuccess cs
182 toJSON (CompletionResult cs) = encodeSuccess cs
178− toJSON (InfoResult i) = encodeSuccess i
179 toJSON (TextResult t) = encodeSuccess t
183 toJSON (TextResult t) = encodeSuccess t
180 toJSON (MultilineTextResult ts) = encodeSuccess ts
184 toJSON (MultilineTextResult ts) = encodeSuccess ts
181 toJSON (PursuitResult resp) = encodeSuccess resp
185 toJSON (PursuitResult resp) = encodeSuccess resp
@@ -203,9 +207,9 @@ data PursuitResponse =
203 -- | A Pursuit Response for a module. Consists of the modules name and the
207 -- | A Pursuit Response for a module. Consists of the modules name and the
204 -- package it belongs to
208 -- package it belongs to
205 ModuleResponse ModuleIdent Text
209 ModuleResponse ModuleIdent Text
206− -- | A Pursuit Response for a declaration. Consist of the declarations type,
210+ -- | A Pursuit Response for a declaration. Consist of the declaration's
207− -- module, name and package
211+ -- module, name, package, type summary text
208− | DeclarationResponse Text ModuleIdent Text Text
212+ | DeclarationResponse Text ModuleIdent Text (Maybe Text) Text
209 deriving (Show,Eq)
213 deriving (Show,Eq)
210
214
211instance FromJSON PursuitResponse where
215instance FromJSON PursuitResponse where
@@ -219,42 +223,21 @@ instance FromJSON PursuitResponse where
219 pure (ModuleResponse name package)
223 pure (ModuleResponse name package)
220 "declaration" -> do
224 "declaration" -> do
221 moduleName <- info .: "module"
225 moduleName <- info .: "module"
222− Right (ident, declType) <- typeParse <$> o .: "text"
226+ ident <- info .: "title"
227+ (text :: Text) <- o .: "text"
228+ typ <- info .:? "typeText"
223− pure (DeclarationResponse declType moduleName ident package)
229+ pure (DeclarationResponse moduleName ident package typ text)
224 _ -> mzero
230 _ -> mzero
225 parseJSON _ = mzero
231 parseJSON _ = mzero
226
232
227−
228−typeParse :: Text -> Either Text (Text, Text)
229−typeParse t = case parse parseType "" t of
230− Right (x,y) -> Right (x, y)
231− Left err -> Left (show err)
232− where
233− parseType :: Parser (Text, Text)
234− parseType = do
235− name <- identifier
236− _ <- string "::"
237− spaces
238− type' <- many1 anyChar
239− pure (name, toS type')
240−
241− identifier :: Parser Text
242− identifier = do
243− spaces
244− ident <-
245− -- necessary for being able to parse the following ((++), concat)
246− between (char '(') (char ')') (many1 (noneOf ", )")) Parsec.<|>
247− many1 (noneOf ", )")
248− spaces
249− pure (toS ident)
250−
251instance ToJSON PursuitResponse where
233instance ToJSON PursuitResponse where
252 toJSON (ModuleResponse name package) =
234 toJSON (ModuleResponse name package) =
253 object ["module" .= name, "package" .= package]
235 object ["module" .= name, "package" .= package]
254− toJSON (DeclarationResponse module' ident type' package) =
236+ toJSON (DeclarationResponse module' ident package type' text) =
255 object
237 object
256 [ "module" .= module'
238 [ "module" .= module'
257 , "ident" .= ident
239 , "ident" .= ident
258 , "type" .= type'
240 , "type" .= type'
259 , "package" .= package
241 , "package" .= package
242+ , "text" .= text
260 ]
243 ]
src/Language/PureScript/Ide/Util.hs+41−25
@@ -20,10 +20,12 @@ module Language.PureScript.Ide.Util
20 , unwrapPositioned
20 , unwrapPositioned
21 , unwrapPositionedRef
21 , unwrapPositionedRef
22 , completionFromMatch
22 , completionFromMatch
23− , infoFromMatch
24 , encodeT
23 , encodeT
25 , decodeT
24 , decodeT
26 , discardAnn
25 , discardAnn
26+ , withEmptyAnn
27+ , valueOperatorAliasT
28+ , typeOperatorAliasT
27 , module Language.PureScript.Ide.Conversions
29 , module Language.PureScript.Ide.Conversions
28 ) where
30 ) where
29
31
@@ -42,31 +44,41 @@ identifierFromIdeDeclaration d = case d of
42 IdeTypeSynonym name _ -> runProperNameT name
44 IdeTypeSynonym name _ -> runProperNameT name
43 IdeDataConstructor name _ _ -> runProperNameT name
45 IdeDataConstructor name _ _ -> runProperNameT name
44 IdeTypeClass name -> runProperNameT name
46 IdeTypeClass name -> runProperNameT name
45− IdeValueOperator op _ _ _ -> runOpNameT op
47+ IdeValueOperator op _ _ _ _ -> runOpNameT op
46− IdeTypeOperator op _ _ _ -> runOpNameT op
48+ IdeTypeOperator op _ _ _ _ -> runOpNameT op
47
49
48discardAnn :: IdeDeclarationAnn -> IdeDeclaration
50discardAnn :: IdeDeclarationAnn -> IdeDeclaration
49discardAnn (IdeDeclarationAnn _ d) = d
51discardAnn (IdeDeclarationAnn _ d) = d
50
52
53+withEmptyAnn :: IdeDeclaration -> IdeDeclarationAnn
54+withEmptyAnn = IdeDeclarationAnn emptyAnn
55+
51unwrapMatch :: Match a -> a
56unwrapMatch :: Match a -> a
52unwrapMatch (Match (_, ed)) = ed
57unwrapMatch (Match (_, ed)) = ed
53
58
54−completionFromMatch :: Match IdeDeclaration -> Completion
59+completionFromMatch :: Match IdeDeclarationAnn -> Completion
55−completionFromMatch = Completion . completionFromMatch'
60+completionFromMatch (Match (m, IdeDeclarationAnn ann decl)) =
56−
61+ Completion {..}
57−completionFromMatch' :: Match IdeDeclaration -> (Text, Text, Text)
58−completionFromMatch' (Match (m', d)) = case d of
59− IdeValue name type' -> (m, runIdentT name, prettyTypeT type')
60− IdeType name kind -> (m, runProperNameT name, toS (P.prettyPrintKind kind))
61− IdeTypeSynonym name kind -> (m, runProperNameT name, prettyTypeT kind)
62− IdeDataConstructor name _ type' -> (m, runProperNameT name, prettyTypeT type')
63− IdeTypeClass name -> (m, runProperNameT name, "class")
64− IdeValueOperator op ref precedence associativity ->
65− (m, runOpNameT op, showFixity precedence associativity ref op)
66− IdeTypeOperator op ref precedence associativity ->
67− (m, runOpNameT op, showFixity precedence associativity ref op)
68 where
62 where
63+ (complIdentifier, complExpandedType) = case decl of
64+ IdeValue name type' -> (runIdentT name, prettyTypeT type')
65+ IdeType name kind -> (runProperNameT name, toS (P.prettyPrintKind kind))
66+ IdeTypeSynonym name kind -> (runProperNameT name, prettyTypeT kind)
67+ IdeDataConstructor name _ type' -> (runProperNameT name, prettyTypeT type')
68+ IdeTypeClass name -> (runProperNameT name, "class")
69+ IdeValueOperator op ref precedence associativity typeP ->
70+ (runOpNameT op, maybe (showFixity precedence associativity (valueOperatorAliasT ref) op) prettyTypeT typeP)
71+ IdeTypeOperator op ref precedence associativity kind ->
72+ (runOpNameT op, maybe (showFixity precedence associativity (typeOperatorAliasT ref) op) (toS . P.prettyPrintKind) kind)
73+
69− m = runModuleNameT m'
74+ complModule = runModuleNameT m
75+
76+ complType = maybe complExpandedType prettyTypeT (annTypeAnnotation ann)
77+
78+ complLocation = annLocation ann
79+
80+ complDocumentation = Nothing
81+
70 showFixity p a r o =
82 showFixity p a r o =
71 let asso = case a of
83 let asso = case a of
72 P.Infix -> "infix"
84 P.Infix -> "infix"
@@ -74,12 +86,16 @@ completionFromMatch' (Match (m', d)) = case d of
74 P.Infixr -> "infixr"
86 P.Infixr -> "infixr"
75 in T.unwords [asso, show p, r, "as", runOpNameT o]
87 in T.unwords [asso, show p, r, "as", runOpNameT o]
76
88
77−infoFromMatch :: Match IdeDeclarationAnn -> Info
89+valueOperatorAliasT
78−infoFromMatch (Match (m, (IdeDeclarationAnn ann d))) =
90+ :: P.Qualified (Either P.Ident (P.ProperName 'P.ConstructorName)) -> Text
79− Info (a, b, c, annLocation ann)
91+valueOperatorAliasT i =
80− where
92+ toS (P.showQualified (either P.runIdent P.runProperName) i)
81− (a, b, c) = completionFromMatch' (Match (m, d))
82
93
94+typeOperatorAliasT
95+ :: P.Qualified (P.ProperName 'P.TypeName) -> Text
96+typeOperatorAliasT i =
97+ toS (P.showQualified P.runProperName i)
98+
83encodeT :: (ToJSON a) => a -> Text
99encodeT :: (ToJSON a) => a -> Text
84encodeT = toS . decodeUtf8 . encode
100encodeT = toS . decodeUtf8 . encode
85
101
@@ -87,9 +103,9 @@ decodeT :: (FromJSON a) => Text -> Maybe a
87decodeT = decode . encodeUtf8 . toS
103decodeT = decode . encodeUtf8 . toS
88
104
89unwrapPositioned :: P.Declaration -> P.Declaration
105unwrapPositioned :: P.Declaration -> P.Declaration
90−unwrapPositioned (P.PositionedDeclaration _ _ x) = x
106+unwrapPositioned (P.PositionedDeclaration _ _ x) = unwrapPositioned x
91unwrapPositioned x = x
107unwrapPositioned x = x
92
108
93unwrapPositionedRef :: P.DeclarationRef -> P.DeclarationRef
109unwrapPositionedRef :: P.DeclarationRef -> P.DeclarationRef
94−unwrapPositionedRef (P.PositionedDeclarationRef _ _ x) = x
110+unwrapPositionedRef (P.PositionedDeclarationRef _ _ x) = unwrapPositionedRef x
95unwrapPositionedRef x = x
111unwrapPositionedRef x = x
src/Language/PureScript/Interactive/Completion.hs+2−2
@@ -206,7 +206,7 @@ identNames = nubOnFst . concatMap getDeclNames . P.exportedDeclarations
206 getDeclNames d@(P.ValueDeclaration ident _ _ _) = [(ident, d)]
206 getDeclNames d@(P.ValueDeclaration ident _ _ _) = [(ident, d)]
207 getDeclNames d@(P.TypeDeclaration ident _ ) = [(ident, d)]
207 getDeclNames d@(P.TypeDeclaration ident _ ) = [(ident, d)]
208 getDeclNames d@(P.ExternDeclaration ident _) = [(ident, d)]
208 getDeclNames d@(P.ExternDeclaration ident _) = [(ident, d)]
209− getDeclNames d@(P.TypeClassDeclaration _ _ _ ds) = map (second (const d)) $ concatMap getDeclNames ds
209+ getDeclNames d@(P.TypeClassDeclaration _ _ _ _ ds) = map (second (const d)) $ concatMap getDeclNames ds
210 getDeclNames (P.PositionedDeclaration _ _ d) = getDeclNames d
210 getDeclNames (P.PositionedDeclaration _ _ d) = getDeclNames d
211 getDeclNames _ = []
211 getDeclNames _ = []
212
212
@@ -214,7 +214,7 @@ dctorNames :: P.Module -> [(N.ProperName 'N.ConstructorName, P.Declaration)]
214dctorNames = nubOnFst . concatMap go . P.exportedDeclarations
214dctorNames = nubOnFst . concatMap go . P.exportedDeclarations
215 where
215 where
216 go :: P.Declaration -> [(N.ProperName 'N.ConstructorName, P.Declaration)]
216 go :: P.Declaration -> [(N.ProperName 'N.ConstructorName, P.Declaration)]
217− go decl@(P.DataDeclaration _ _ _ ctors) = map (\n -> (n, decl)) (map fst ctors)
217+ go decl@(P.DataDeclaration _ _ _ ctors) = map ((\n -> (n, decl)) . fst) ctors
218 go (P.PositionedDeclaration _ _ d) = go d
218 go (P.PositionedDeclaration _ _ d) = go d
219 go _ = []
219 go _ = []
220
220
src/Language/PureScript/Interactive/Printer.hs+11−11
@@ -17,7 +17,7 @@ import qualified Text.PrettyPrint.Boxes as Box
17-- Pretty print a module's signatures
17-- Pretty print a module's signatures
18--
18--
19printModuleSignatures :: P.ModuleName -> P.Environment -> String
19printModuleSignatures :: P.ModuleName -> P.Environment -> String
20−printModuleSignatures moduleName (P.Environment {..}) =
20+printModuleSignatures moduleName P.Environment{..} =
21 -- get relevant components of a module from environment
21 -- get relevant components of a module from environment
22 let moduleNamesIdent = byModuleName names
22 let moduleNamesIdent = byModuleName names
23 moduleTypeClasses = byModuleName typeClasses
23 moduleTypeClasses = byModuleName typeClasses
@@ -44,34 +44,34 @@ printModuleSignatures moduleName (P.Environment {..}) =
44 showNameType _ = P.internalError "The impossible happened in printModuleSignatures."
44 showNameType _ = P.internalError "The impossible happened in printModuleSignatures."
45
45
46 findTypeClass
46 findTypeClass
47− :: M.Map (P.Qualified (P.ProperName 'P.ClassName)) ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint])
47+ :: M.Map (P.Qualified (P.ProperName 'P.ClassName)) P.TypeClassData
48 -> P.Qualified (P.ProperName 'P.ClassName)
48 -> P.Qualified (P.ProperName 'P.ClassName)
49− -> (P.Qualified (P.ProperName 'P.ClassName), Maybe ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint]))
49+ -> (P.Qualified (P.ProperName 'P.ClassName), Maybe P.TypeClassData)
50 findTypeClass envTypeClasses name = (name, M.lookup name envTypeClasses)
50 findTypeClass envTypeClasses name = (name, M.lookup name envTypeClasses)
51
51
52 showTypeClass
52 showTypeClass
53− :: (P.Qualified (P.ProperName 'P.ClassName), Maybe ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint]))
53+ :: (P.Qualified (P.ProperName 'P.ClassName), Maybe P.TypeClassData)
54 -> Maybe Box.Box
54 -> Maybe Box.Box
55 showTypeClass (_, Nothing) = Nothing
55 showTypeClass (_, Nothing) = Nothing
56− showTypeClass (P.Qualified _ name, Just (vars, body, constrs)) =
56+ showTypeClass (P.Qualified _ name, Just P.TypeClassData{..}) =
57 let constraints =
57 let constraints =
58− if null constrs
58+ if null typeClassSuperclasses
59 then Box.text ""
59 then Box.text ""
60 else Box.text "("
60 else Box.text "("
61− 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)
61+ 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)
62 Box.<> Box.text ") <= "
62 Box.<> Box.text ") <= "
63 className =
63 className =
64 Box.text (P.runProperName name)
64 Box.text (P.runProperName name)
65− Box.<> Box.text (concatMap ((' ':) . fst) vars)
65+ Box.<> Box.text (concatMap ((' ':) . fst) typeClassArguments)
66 classBody =
66 classBody =
67− Box.vcat Box.top (map (\(i, t) -> Box.text (P.showIdent i ++ " ::") Box.<+> P.typeAsBox t) body)
67+ Box.vcat Box.top (map (\(i, t) -> Box.text (P.showIdent i ++ " ::") Box.<+> P.typeAsBox t) typeClassMembers)
68
68
69 in
69 in
70 Just $
70 Just $
71 (Box.text "class "
71 (Box.text "class "
72 Box.<> constraints
72 Box.<> constraints
73 Box.<> className
73 Box.<> className
74− Box.<+> if null body then Box.text "" else Box.text "where")
74+ Box.<+> if null typeClassMembers then Box.text "" else Box.text "where")
75 Box.// Box.moveRight 2 classBody
75 Box.// Box.moveRight 2 classBody
76
76
77
77
@@ -82,7 +82,7 @@ printModuleSignatures moduleName (P.Environment {..}) =
82 findType envTypes name = (name, M.lookup name envTypes)
82 findType envTypes name = (name, M.lookup name envTypes)
83
83
84 showType
84 showType
85− :: M.Map (P.Qualified (P.ProperName 'P.ClassName)) ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint])
85+ :: M.Map (P.Qualified (P.ProperName 'P.ClassName)) P.TypeClassData
86 -> M.Map (P.Qualified (P.ProperName 'P.ConstructorName)) (P.DataDeclType, P.ProperName 'P.TypeName, P.Type, [P.Ident])
86 -> M.Map (P.Qualified (P.ProperName 'P.ConstructorName)) (P.DataDeclType, P.ProperName 'P.TypeName, P.Type, [P.Ident])
87 -> M.Map (P.Qualified (P.ProperName 'P.TypeName)) ([(String, Maybe P.Kind)], P.Type)
87 -> M.Map (P.Qualified (P.ProperName 'P.TypeName)) ([(String, Maybe P.Kind)], P.Type)
88 -> (P.Qualified (P.ProperName 'P.TypeName), Maybe (P.Kind, P.TypeKind))
88 -> (P.Qualified (P.ProperName 'P.TypeName), Maybe (P.Kind, P.TypeKind))
src/Language/PureScript/Interactive/Types.hs+2−2
@@ -42,11 +42,11 @@ initialPSCiState = PSCiState [] [] []
42type ImportedModule = (P.ModuleName, P.ImportDeclarationType, Maybe P.ModuleName)
42type ImportedModule = (P.ModuleName, P.ImportDeclarationType, Maybe P.ModuleName)
43
43
44psciImportedModuleNames :: PSCiState -> [P.ModuleName]
44psciImportedModuleNames :: PSCiState -> [P.ModuleName]
45−psciImportedModuleNames (PSCiState{psciImportedModules = is}) =
45+psciImportedModuleNames PSCiState{psciImportedModules = is} =
46 map (\(mn, _, _) -> mn) is
46 map (\(mn, _, _) -> mn) is
47
47
48allImportsOf :: P.Module -> PSCiState -> [ImportedModule]
48allImportsOf :: P.Module -> PSCiState -> [ImportedModule]
49−allImportsOf m (PSCiState{psciImportedModules = is}) =
49+allImportsOf m PSCiState{psciImportedModules = is} =
50 filter isImportOfThis is
50 filter isImportOfThis is
51 where
51 where
52 name = P.getModuleName m
52 name = P.getModuleName m
src/Language/PureScript/Linter/Imports.hs+14−14
@@ -243,12 +243,12 @@ lintImportDecl env mni qualifierName names declType allowImplicit =
243 didWarn' <- forM (mapMaybe getTypeRef declrefs) $ \(tn, c) -> do
243 didWarn' <- forM (mapMaybe getTypeRef declrefs) $ \(tn, c) -> do
244 let allCtors = dctorsForType mni tn
244 let allCtors = dctorsForType mni tn
245 -- If we've not already warned a type is unused, check its data constructors
245 -- If we've not already warned a type is unused, check its data constructors
246− unless' (runProperName tn `notElem` usedNames) $
246+ unless' (TyName tn `notElem` usedNames) $
247 case (c, dctors `intersect` allCtors) of
247 case (c, dctors `intersect` allCtors) of
248− (_, []) | c /= Just [] -> warn (UnusedDctorImport tn)
248+ (_, []) | c /= Just [] -> warn (UnusedDctorImport mni tn qualifierName allRefs)
249 (Just ctors, dctors') ->
249 (Just ctors, dctors') ->
250 let ddiff = ctors \\ dctors'
250 let ddiff = ctors \\ dctors'
251− in unless' (null ddiff) $ warn $ UnusedDctorExplicitImport tn ddiff
251+ in unless' (null ddiff) $ warn $ UnusedDctorExplicitImport mni tn ddiff qualifierName allRefs
252 _ -> return False
252 _ -> return False
253
253
254 return (didWarn || or didWarn')
254 return (didWarn || or didWarn')
@@ -335,18 +335,18 @@ findUsedRefs env mni qn names =
335matchName
335matchName
336 :: (ProperName 'ConstructorName -> Maybe (ProperName 'TypeName))
336 :: (ProperName 'ConstructorName -> Maybe (ProperName 'TypeName))
337 -> Name
337 -> Name
338− -> Maybe String
338+ -> Maybe Name
339−matchName _ (IdentName x) = Just $ showIdent x
339+matchName lookupDc (DctorName x) = TyName <$> lookupDc x
340−matchName _ (TyName x) = Just $ runProperName x
341−matchName _ (TyClassName x) = Just $ runProperName x
342−matchName lookupDc (DctorName x) = runProperName <$> lookupDc x
343−matchName _ _ = Nothing
340+matchName _ ModName{} = Nothing
344−
341+matchName _ name = Just name
342+
345−runDeclRef :: DeclarationRef -> Maybe String
343+runDeclRef :: DeclarationRef -> Maybe Name
346runDeclRef (PositionedDeclarationRef _ _ ref) = runDeclRef ref
344runDeclRef (PositionedDeclarationRef _ _ ref) = runDeclRef ref
347−runDeclRef (ValueRef ident) = Just $ showIdent ident
345+runDeclRef (ValueRef ident) = Just $ IdentName ident
346+runDeclRef (ValueOpRef op) = Just $ ValOpName op
348−runDeclRef (TypeRef pn _) = Just $ runProperName pn
347+runDeclRef (TypeRef pn _) = Just $ TyName pn
348+runDeclRef (TypeOpRef op) = Just $ TyOpName op
349−runDeclRef (TypeClassRef pn) = Just $ runProperName pn
349+runDeclRef (TypeClassRef pn) = Just $ TyClassName pn
350runDeclRef _ = Nothing
350runDeclRef _ = Nothing
351
351
352checkDuplicateImports
352checkDuplicateImports
src/Language/PureScript/Make.hs+22−13
@@ -1,5 +1,6 @@
1{-# LANGUAGE GeneralizedNewtypeDeriving #-}
1{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2{-# LANGUAGE TypeFamilies #-}
2{-# LANGUAGE TypeFamilies #-}
3+{-# LANGUAGE OverloadedStrings #-}
3
4
4module Language.PureScript.Make
5module Language.PureScript.Make
5 (
6 (
@@ -36,10 +37,12 @@ import Control.Monad.Trans.Except
36import Control.Monad.Writer.Class (MonadWriter(..))
37import Control.Monad.Writer.Class (MonadWriter(..))
37
38
38import Data.Aeson (encode, decode)
39import Data.Aeson (encode, decode)
40+import qualified Data.Aeson as Aeson
39import Data.ByteString.Builder (toLazyByteString, stringUtf8)
41import Data.ByteString.Builder (toLazyByteString, stringUtf8)
40import Data.Either (partitionEithers)
42import Data.Either (partitionEithers)
43+import Data.Function (on)
41import Data.Foldable (for_)
44import Data.Foldable (for_)
42−import Data.List (foldl', sort)
45+import Data.List (foldl', sortBy, groupBy)
43import Data.Maybe (fromMaybe, catMaybes)
46import Data.Maybe (fromMaybe, catMaybes)
44import Data.String (fromString)
47import Data.String (fromString)
45import Data.Time.Clock
48import Data.Time.Clock
@@ -69,6 +72,7 @@ import qualified Language.PureScript.Bundle as Bundle
69import qualified Language.PureScript.CodeGen.JS as J
72import qualified Language.PureScript.CodeGen.JS as J
70import qualified Language.PureScript.Constants as C
73import qualified Language.PureScript.Constants as C
71import qualified Language.PureScript.CoreFn as CF
74import qualified Language.PureScript.CoreFn as CF
75+import qualified Language.PureScript.CoreFn.ToJSON as CFJ
72import qualified Language.PureScript.Parser as PSParser
76import qualified Language.PureScript.Parser as PSParser
73
77
74import qualified Paths_purescript as Paths
78import qualified Paths_purescript as Paths
@@ -188,18 +192,17 @@ make ma@MakeActions{..} ms = do
188 where
192 where
189 checkModuleNamesAreUnique :: m ()
193 checkModuleNamesAreUnique :: m ()
190 checkModuleNamesAreUnique =
194 checkModuleNamesAreUnique =
191− case findDuplicate (map getModuleName ms) of
195+ for_ (findDuplicates getModuleName ms) $ \mss ->
192− Nothing -> return ()
196+ throwError . flip foldMap mss $ \ms' ->
193− Just mn -> throwError . errorMessage $ DuplicateModuleName mn
197+ let mn = getModuleName (head ms')
194−
198+ in errorMessage $ DuplicateModule mn (map getModuleSourceSpan ms')
195− -- Verify that a list of values has unique keys
199+
196− findDuplicate :: (Ord a) => [a] -> Maybe a
200+ -- Find all groups of duplicate values in a list based on a projection.
197− findDuplicate = go . sort
201+ findDuplicates :: Ord b => (a -> b) -> [a] -> Maybe [[a]]
198− where
202+ findDuplicates f xs =
199− go (x : y : xs)
203+ case filter ((> 1) . length) . groupBy ((==) `on` f) . sortBy (compare `on` f) $ xs of
200− | x == y = Just x
201− | otherwise = go (y : xs)
202− go _ = Nothing
204+ [] -> Nothing
205+ xss -> Just xss
203
206
204 -- Sort a list so its elements appear in the same order as in another list.
207 -- Sort a list so its elements appear in the same order as in another list.
205 inOrderOf :: (Ord a) => [a] -> [a] -> [a]
208 inOrderOf :: (Ord a) => [a] -> [a] -> [a]
@@ -369,6 +372,12 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
369 for_ (mn `M.lookup` foreigns) (readTextFile >=> writeTextFile foreignFile)
372 for_ (mn `M.lookup` foreigns) (readTextFile >=> writeTextFile foreignFile)
370 writeTextFile externsFile exts
373 writeTextFile externsFile exts
371 lift $ when sourceMaps $ genSourceMap dir mapFile (length prefix) mappings
374 lift $ when sourceMaps $ genSourceMap dir mapFile (length prefix) mappings
375+ dumpCoreFn <- lift $ asks optionsDumpCoreFn
376+ when dumpCoreFn $ do
377+ let coreFnFile = outputDir </> filePath </> "corefn.json"
378+ let jsonPayload = CFJ.moduleToJSON Paths.version m
379+ let json = Aeson.object [ (fromString (runModuleName mn), jsonPayload) ]
380+ lift $ writeTextFile coreFnFile (BU8.toString . B.toStrict . encode $ json)
372
381
373 genSourceMap :: String -> String -> Int -> [SMap] -> Make ()
382 genSourceMap :: String -> String -> Int -> [SMap] -> Make ()
374 genSourceMap dir mapFile extraLines mappings = do
383 genSourceMap dir mapFile extraLines mappings = do
src/Language/PureScript/Options.hs+4−1
@@ -31,9 +31,12 @@ data Options = Options {
31 -- |
31 -- |
32 -- Generate soure maps
32 -- Generate soure maps
33 , optionsSourceMaps :: Bool
33 , optionsSourceMaps :: Bool
34+ -- |
35+ -- Dump CoreFn
36+ , optionsDumpCoreFn :: Bool
34 } deriving Show
37 } deriving Show
35
38
36-- |
39-- |
37-- Default make options
40-- Default make options
38defaultOptions :: Options
41defaultOptions :: Options
39−defaultOptions = Options False False Nothing False False False False
42+defaultOptions = Options False False Nothing False False False False False
src/Language/PureScript/Parser/Declarations.hs+10−3
@@ -17,6 +17,7 @@ module Language.PureScript.Parser.Declarations
17
17
18import Prelude hiding (lex)
18import Prelude hiding (lex)
19
19
20+import Data.Functor (($>))
20import Data.Maybe (fromMaybe)
21import Data.Maybe (fromMaybe)
21
22
22import Control.Applicative
23import Control.Applicative
@@ -183,10 +184,15 @@ parseTypeClassDeclaration = do
183 return implies
184 return implies
184 className <- indented *> properName
185 className <- indented *> properName
185 idents <- P.many (indented *> kindedIdent)
186 idents <- P.many (indented *> kindedIdent)
187+ let parseNamedIdent = foldl (<|>) empty (zipWith (\(name, _) index -> lname' name $> index) idents [0..])
188+ parseFunctionalDependency =
189+ FunctionalDependency <$> P.many parseNamedIdent <* rarrow
190+ <*> P.many parseNamedIdent
191+ dependencies <- P.option [] (indented *> pipe *> commaSep1 parseFunctionalDependency)
186 members <- P.option [] $ do
192 members <- P.option [] $ do
187 indented *> reserved "where"
193 indented *> reserved "where"
188 indented *> mark (P.many (same *> positioned parseTypeDeclaration))
194 indented *> mark (P.many (same *> positioned parseTypeDeclaration))
189− return $ TypeClassDeclaration className idents implies members
195+ return $ TypeClassDeclaration className idents implies dependencies members
190
196
191parseConstraint :: TokenParser Constraint
197parseConstraint :: TokenParser Constraint
192parseConstraint = Constraint <$> parseQualified properName
198parseConstraint = Constraint <$> parseQualified properName
@@ -203,7 +209,7 @@ parseInstanceDeclaration = do
203 rfatArrow
209 rfatArrow
204 return deps
210 return deps
205 className <- indented *> parseQualified properName
211 className <- indented *> parseQualified properName
206− ty <- P.many (indented *> noWildcards parseTypeAtom)
212+ ty <- P.many (indented *> parseTypeAtom)
207 return $ TypeInstanceDeclaration name (fromMaybe [] deps) className ty
213 return $ TypeInstanceDeclaration name (fromMaybe [] deps) className ty
208
214
209parseTypeInstanceDeclaration :: TokenParser Declaration
215parseTypeInstanceDeclaration :: TokenParser Declaration
@@ -217,8 +223,9 @@ parseTypeInstanceDeclaration = do
217parseDerivingInstanceDeclaration :: TokenParser Declaration
223parseDerivingInstanceDeclaration :: TokenParser Declaration
218parseDerivingInstanceDeclaration = do
224parseDerivingInstanceDeclaration = do
219 reserved "derive"
225 reserved "derive"
226+ ty <- P.option DerivedInstance (reserved "newtype" $> NewtypeInstance)
220 instanceDecl <- parseInstanceDeclaration
227 instanceDecl <- parseInstanceDeclaration
221− return $ instanceDecl DerivedInstance
228+ return $ instanceDecl ty
222
229
223positioned :: TokenParser Declaration -> TokenParser Declaration
230positioned :: TokenParser Declaration -> TokenParser Declaration
224positioned = withSourceSpan PositionedDeclaration
231positioned = withSourceSpan PositionedDeclaration
src/Language/PureScript/Parser/Lexer.hs+7
@@ -40,6 +40,7 @@ module Language.PureScript.Parser.Lexer
40 , commaSep
40 , commaSep
41 , commaSep1
41 , commaSep1
42 , lname
42 , lname
43+ , lname'
43 , qualifier
44 , qualifier
44 , tyname
45 , tyname
45 , uname
46 , uname
@@ -414,6 +415,12 @@ lname = token go P.<?> "identifier"
414 go (LName s) = Just s
415 go (LName s) = Just s
415 go _ = Nothing
416 go _ = Nothing
416
417
418+lname' :: String -> TokenParser ()
419+lname' s = token go P.<?> show s
420+ where
421+ go (LName s') | s == s' = Just ()
422+ go _ = Nothing
423+
417qualifier :: TokenParser String
424qualifier :: TokenParser String
418qualifier = token go P.<?> "qualifier"
425qualifier = token go P.<?> "qualifier"
419 where
426 where
src/Language/PureScript/Parser/Types.hs+2−4
@@ -54,8 +54,7 @@ parseForAll = mkForAll <$> ((reserved "forall" <|> reserved "∀") *> P.many1 (i
54--
54--
55parseTypeAtom :: TokenParser Type
55parseTypeAtom :: TokenParser Type
56parseTypeAtom = indented *> P.choice
56parseTypeAtom = indented *> P.choice
57− [ P.try parseConstrainedType
58− , P.try parseFunction
57+ [ P.try parseFunction
59 , parseTypeLevelString
58 , parseTypeLevelString
60 , parseObject
59 , parseObject
61 , parseTypeWildcard
60 , parseTypeWildcard
@@ -81,9 +80,8 @@ parseConstrainedType = do
81 ty <- P.many parseTypeAtom
80 ty <- P.many parseTypeAtom
82 return (Constraint className ty Nothing)
81 return (Constraint className ty Nothing)
83
82
84−
85parseAnyType :: TokenParser Type
83parseAnyType :: TokenParser Type
86−parseAnyType = P.buildExpressionParser operators (buildPostfixParser postfixTable parseTypeAtom) P.<?> "type"
84+parseAnyType = P.buildExpressionParser operators (buildPostfixParser postfixTable (P.try parseConstrainedType <|> parseTypeAtom)) P.<?> "type"
87 where
85 where
88 operators = [ [ P.Infix (return TypeApp) P.AssocLeft ]
86 operators = [ [ P.Infix (return TypeApp) P.AssocLeft ]
89 , [ P.Infix (P.try (parseQualified parseOperator) >>= \ident ->
87 , [ P.Infix (P.try (parseQualified parseOperator) >>= \ident ->
src/Language/PureScript/Pretty/Common.hs+1−1
@@ -74,7 +74,7 @@ instance Emit StrPos where
74 -- |
74 -- |
75 -- Add a new mapping entry for given source position with initially zero generated position
75 -- Add a new mapping entry for given source position with initially zero generated position
76 --
76 --
77− addMapping (SourceSpan { spanName = file, spanStart = startPos }) = StrPos (zeroPos, mempty, [mapping])
77+ addMapping SourceSpan { spanName = file, spanStart = startPos } = StrPos (zeroPos, mempty, [mapping])
78 where
78 where
79 mapping = SMap file startPos zeroPos
79 mapping = SMap file startPos zeroPos
80 zeroPos = SourcePos 0 0
80 zeroPos = SourcePos 0 0
src/Language/PureScript/Pretty/Types.hs+4−4
@@ -45,11 +45,11 @@ typeLiterals = mkPattern match
45 match _ = Nothing
45 match _ = Nothing
46
46
47constraintsAsBox :: [Constraint] -> Box -> Box
47constraintsAsBox :: [Constraint] -> Box -> Box
48−constraintsAsBox [(Constraint pn tys _)] ty = text "(" <> constraintAsBox pn tys <> text ") => " <> ty
48+constraintsAsBox [con] ty = text "(" <> constraintAsBox con `before` (text ") => " <> ty)
49−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)
49+constraintsAsBox xs ty = vcat left (zipWith (\i con -> text (if i == 0 then "( " else ", ") <> constraintAsBox con) [0 :: Int ..] xs) `before` (text ") => " <> ty)
50
50
51−constraintAsBox :: Qualified (ProperName a) -> [Type] -> Box
51+constraintAsBox :: Constraint -> Box
52−constraintAsBox pn tys = hsep 1 left (text (runProperName (disqualify pn)) : map typeAtomAsBox tys)
52+constraintAsBox (Constraint pn tys _) = typeAsBox (foldl TypeApp (TypeConstructor (fmap coerceProperName pn)) tys)
53
53
54-- |
54-- |
55-- Generate a pretty-printed string representing a Row
55-- Generate a pretty-printed string representing a Row
src/Language/PureScript/Pretty/Values.hs+1−1
@@ -61,7 +61,7 @@ prettyPrintValue d (Let ds val) =
61prettyPrintValue d (Do els) =
61prettyPrintValue d (Do els) =
62 text "do " <> vcat left (map (prettyPrintDoNotationElement (d - 1)) els)
62 text "do " <> vcat left (map (prettyPrintDoNotationElement (d - 1)) els)
63prettyPrintValue _ (TypeClassDictionary (Constraint name tys _) _ _) = foldl1 beforeWithSpace $ text ("#dict " ++ runProperName (disqualify name)) : map typeAtomAsBox tys
63prettyPrintValue _ (TypeClassDictionary (Constraint name tys _) _ _) = foldl1 beforeWithSpace $ text ("#dict " ++ runProperName (disqualify name)) : map typeAtomAsBox tys
64−prettyPrintValue _ (SuperClassDictionary name _) = text $ "#dict " ++ runProperName (disqualify name)
64+prettyPrintValue _ (DeferredDictionary name _) = text $ "#dict " ++ runProperName (disqualify name)
65prettyPrintValue _ (TypeClassDictionaryAccessor className ident) =
65prettyPrintValue _ (TypeClassDictionaryAccessor className ident) =
66 text "#dict-accessor " <> text (runProperName (disqualify className)) <> text "." <> text (showIdent ident) <> text ">"
66 text "#dict-accessor " <> text (runProperName (disqualify className)) <> text "." <> text (showIdent ident) <> text ">"
67prettyPrintValue d (TypedValue _ val _) = prettyPrintValue d val
67prettyPrintValue d (TypedValue _ val _) = prettyPrintValue d val
src/Language/PureScript/Publish/ErrorsWarnings.hs+8−8
@@ -182,10 +182,10 @@ displayUserError e = case e of
182 , spacer
182 , spacer
183 ] ++ spdxExamples ++
183 ] ++ spdxExamples ++
184 [ spacer
184 [ spacer
185− , para (concat
185+ , para (
186− [ "Note that distributing code without a license means that nobody "
186+ "Note that distributing code without a license means that nobody "
187− , "will (legally) be able to use it."
187+ ++ "will (legally) be able to use it."
188− ])
188+ )
189 , spacer
189 , spacer
190 , para (concat
190 , para (concat
191 [ "It is also recommended to add a LICENSE file to the repository, "
191 [ "It is also recommended to add a LICENSE file to the repository, "
@@ -420,10 +420,10 @@ warnUnacceptableVersions pkgs =
420
420
421warnDirtyWorkingTree :: Box
421warnDirtyWorkingTree :: Box
422warnDirtyWorkingTree =
422warnDirtyWorkingTree =
423− para (concat
423+ para (
424− [ "Your working tree is dirty. (Note: this would be an error if it "
424+ "Your working tree is dirty. (Note: this would be an error if it "
425− , "were not a dry run)"
425+ ++ "were not a dry run)"
426− ])
426+ )
427
427
428printWarnings :: [PackageWarning] -> IO ()
428printWarnings :: [PackageWarning] -> IO ()
429printWarnings = printToStderr . renderWarnings
429printWarnings = printToStderr . renderWarnings
src/Language/PureScript/Renamer.hs+3−3
@@ -142,7 +142,7 @@ renameInDecl isTopLevel (Rec ds) = do
142renameInValue :: Expr Ann -> Rename (Expr Ann)
142renameInValue :: Expr Ann -> Rename (Expr Ann)
143renameInValue (Literal ann l) =
143renameInValue (Literal ann l) =
144 Literal ann <$> renameInLiteral renameInValue l
144 Literal ann <$> renameInLiteral renameInValue l
145−renameInValue c@(Constructor{}) = return c
145+renameInValue c@Constructor{} = return c
146renameInValue (Accessor ann prop v) =
146renameInValue (Accessor ann prop v) =
147 Accessor ann prop <$> renameInValue v
147 Accessor ann prop <$> renameInValue v
148renameInValue (ObjectUpdate ann obj vs) =
148renameInValue (ObjectUpdate ann obj vs) =
@@ -154,7 +154,7 @@ renameInValue (App ann v1 v2) =
154 App ann <$> renameInValue v1 <*> renameInValue v2
154 App ann <$> renameInValue v1 <*> renameInValue v2
155renameInValue (Var ann (Qualified Nothing name)) =
155renameInValue (Var ann (Qualified Nothing name)) =
156 Var ann . Qualified Nothing <$> lookupIdent name
156 Var ann . Qualified Nothing <$> lookupIdent name
157−renameInValue v@(Var{}) = return v
157+renameInValue v@Var{} = return v
158renameInValue (Case ann vs alts) =
158renameInValue (Case ann vs alts) =
159 newScope $ Case ann <$> traverse renameInValue vs <*> traverse renameInCaseAlternative alts
159 newScope $ Case ann <$> traverse renameInValue vs <*> traverse renameInCaseAlternative alts
160renameInValue (Let ann ds v) =
160renameInValue (Let ann ds v) =
@@ -180,7 +180,7 @@ renameInCaseAlternative (CaseAlternative bs v) = newScope $
180-- Renames within binders.
180-- Renames within binders.
181--
181--
182renameInBinder :: Binder a -> Rename (Binder a)
182renameInBinder :: Binder a -> Rename (Binder a)
183−renameInBinder n@(NullBinder{}) = return n
183+renameInBinder n@NullBinder{} = return n
184renameInBinder (LiteralBinder ann b) =
184renameInBinder (LiteralBinder ann b) =
185 LiteralBinder ann <$> renameInLiteral renameInBinder b
185 LiteralBinder ann <$> renameInLiteral renameInBinder b
186renameInBinder (VarBinder ann name) =
186renameInBinder (VarBinder ann name) =
src/Language/PureScript/Sugar/Names.hs+8−11
@@ -99,15 +99,12 @@ desugarImportsWithEnv externs modules = do
99 exportedRefs f = M.fromList $ (, efModuleName) <$> mapMaybe f efExports
99 exportedRefs f = M.fromList $ (, efModuleName) <$> mapMaybe f efExports
100
100
101 updateEnv :: ([Module], Env) -> Module -> m ([Module], Env)
101 updateEnv :: ([Module], Env) -> Module -> m ([Module], Env)
102− updateEnv (ms, env) m@(Module ss _ mn _ refs) =
102+ updateEnv (ms, env) m@(Module ss _ mn _ refs) = do
103− case mn `M.lookup` env of
104− Just m' -> throwError . errorMessage $ RedefinedModule mn [envModuleSourceSpan m', ss]
105− Nothing -> do
106− members <- findExportable m
103+ members <- findExportable m
107− let env' = M.insert mn (ss, primImports, members) env
104+ let env' = M.insert mn (ss, primImports, members) env
108− (m', imps) <- resolveImports env' m
105+ (m', imps) <- resolveImports env' m
109− exps <- maybe (return members) (resolveExports env' ss mn imps members) refs
106+ exps <- maybe (return members) (resolveExports env' ss mn imps members) refs
110− return (m' : ms, M.insert mn (ss, imps, exps) env)
107+ return (m' : ms, M.insert mn (ss, imps, exps) env)
111
108
112 renameInModule' :: Env -> Module -> m Module
109 renameInModule' :: Env -> Module -> m Module
113 renameInModule' env m@(Module _ _ mn _ _) =
110 renameInModule' env m@(Module _ _ mn _ _) =
@@ -171,8 +168,8 @@ renameInModule imports (Module ss coms mn decls exps) =
171 (,) (pos, bound) <$> (DataDeclaration dtype name args <$> traverse (sndM (traverse (updateTypesEverywhere pos))) dctors)
168 (,) (pos, bound) <$> (DataDeclaration dtype name args <$> traverse (sndM (traverse (updateTypesEverywhere pos))) dctors)
172 updateDecl (pos, bound) (TypeSynonymDeclaration name ps ty) =
169 updateDecl (pos, bound) (TypeSynonymDeclaration name ps ty) =
173 (,) (pos, bound) <$> (TypeSynonymDeclaration name ps <$> updateTypesEverywhere pos ty)
170 (,) (pos, bound) <$> (TypeSynonymDeclaration name ps <$> updateTypesEverywhere pos ty)
174− updateDecl (pos, bound) (TypeClassDeclaration className args implies ds) =
171+ updateDecl (pos, bound) (TypeClassDeclaration className args implies deps ds) =
175− (,) (pos, bound) <$> (TypeClassDeclaration className args <$> updateConstraints pos implies <*> pure ds)
172+ (,) (pos, bound) <$> (TypeClassDeclaration className args <$> updateConstraints pos implies <*> pure deps <*> pure ds)
176 updateDecl (pos, bound) (TypeInstanceDeclaration name cs cn ts ds) =
173 updateDecl (pos, bound) (TypeInstanceDeclaration name cs cn ts ds) =
177 (,) (pos, bound) <$> (TypeInstanceDeclaration name <$> updateConstraints pos cs <*> updateClassName cn pos <*> traverse (updateTypesEverywhere pos) ts <*> pure ds)
174 (,) (pos, bound) <$> (TypeInstanceDeclaration name <$> updateConstraints pos cs <*> updateClassName cn pos <*> traverse (updateTypesEverywhere pos) ts <*> pure ds)
178 updateDecl (pos, bound) (TypeDeclaration name ty) =
175 updateDecl (pos, bound) (TypeDeclaration name ty) =
src/Language/PureScript/Sugar/Names/Exports.hs+1−1
@@ -30,7 +30,7 @@ findExportable (Module _ _ mn ds _) =
30 rethrow (addHint (ErrorInModule mn)) $ foldM updateExports nullExports ds
30 rethrow (addHint (ErrorInModule mn)) $ foldM updateExports nullExports ds
31 where
31 where
32 updateExports :: Exports -> Declaration -> m Exports
32 updateExports :: Exports -> Declaration -> m Exports
33− updateExports exps (TypeClassDeclaration tcn _ _ ds') = do
33+ updateExports exps (TypeClassDeclaration tcn _ _ _ ds') = do
34 exps' <- exportTypeClass Internal exps tcn mn
34 exps' <- exportTypeClass Internal exps tcn mn
35 foldM go exps' ds'
35 foldM go exps' ds'
36 where
36 where
src/Language/PureScript/Sugar/ObjectWildcards.hs+17−10
@@ -1,5 +1,6 @@
1module Language.PureScript.Sugar.ObjectWildcards
1module Language.PureScript.Sugar.ObjectWildcards
2 ( desugarObjectConstructors
2 ( desugarObjectConstructors
3+ , desugarDecl
3 ) where
4 ) where
4
5
5import Prelude.Compat
6import Prelude.Compat
@@ -21,13 +22,12 @@ desugarObjectConstructors
21 => Module
22 => Module
22 -> m Module
23 -> m Module
23desugarObjectConstructors (Module ss coms mn ds exts) = Module ss coms mn <$> mapM desugarDecl ds <*> pure exts
24desugarObjectConstructors (Module ss coms mn ds exts) = Module ss coms mn <$> mapM desugarDecl ds <*> pure exts
24− where
25
25
26− desugarDecl :: Declaration -> m Declaration
26+desugarDecl :: forall m. (MonadSupply m, MonadError MultipleErrors m) => Declaration -> m Declaration
27− desugarDecl (PositionedDeclaration pos com d) = rethrowWithPosition pos $ PositionedDeclaration pos com <$> desugarDecl d
27+desugarDecl (PositionedDeclaration pos com d) = rethrowWithPosition pos $ PositionedDeclaration pos com <$> desugarDecl d
28− desugarDecl other = f other
28+desugarDecl other = fn other
29− where
29+ where
30− (f, _, _) = everywhereOnValuesTopDownM return desugarExpr return
30+ (fn, _, _) = everywhereOnValuesTopDownM return desugarExpr return
31
31
32 desugarExpr :: Expr -> m Expr
32 desugarExpr :: Expr -> m Expr
33 desugarExpr AnonymousArgument = throwError . errorMessage $ IncorrectAnonymousArgument
33 desugarExpr AnonymousArgument = throwError . errorMessage $ IncorrectAnonymousArgument
@@ -45,12 +45,13 @@ desugarObjectConstructors (Module ss coms mn ds exts) = Module ss coms mn <$> ma
45 obj <- freshIdent'
45 obj <- freshIdent'
46 Abs (Left obj) <$> wrapLambda (ObjectUpdate (argToExpr obj)) ps
46 Abs (Left obj) <$> wrapLambda (ObjectUpdate (argToExpr obj)) ps
47 desugarExpr (ObjectUpdate obj ps) = wrapLambda (ObjectUpdate obj) ps
47 desugarExpr (ObjectUpdate obj ps) = wrapLambda (ObjectUpdate obj) ps
48− desugarExpr (Accessor prop u) | isAnonymousArgument u = do
48+ desugarExpr (Accessor prop u)
49+ | Just props <- peelAnonAccessorChain u = do
49− arg <- freshIdent'
50+ arg <- freshIdent'
50− return $ Abs (Left arg) (Accessor prop (argToExpr arg))
51+ return $ Abs (Left arg) $ foldr Accessor (argToExpr arg) (prop:props)
51 desugarExpr (Case args cas) | any isAnonymousArgument args = do
52 desugarExpr (Case args cas) | any isAnonymousArgument args = do
52 argIdents <- forM args freshIfAnon
53 argIdents <- forM args freshIfAnon
53− let args' = zipWith (\p -> maybe p argToExpr) args argIdents
54+ let args' = zipWith (`maybe` argToExpr) args argIdents
54 return $ foldr (Abs . Left) (Case args' cas) (catMaybes argIdents)
55 return $ foldr (Abs . Left) (Case args' cas) (catMaybes argIdents)
55 desugarExpr (IfThenElse u t f) | any isAnonymousArgument [u, t, f] = do
56 desugarExpr (IfThenElse u t f) | any isAnonymousArgument [u, t, f] = do
56 u' <- freshIfAnon u
57 u' <- freshIfAnon u
@@ -73,6 +74,12 @@ desugarObjectConstructors (Module ss coms mn ds exts) = Module ss coms mn <$> ma
73 stripPositionInfo (PositionedValue _ _ e) = stripPositionInfo e
74 stripPositionInfo (PositionedValue _ _ e) = stripPositionInfo e
74 stripPositionInfo e = e
75 stripPositionInfo e = e
75
76
77+ peelAnonAccessorChain :: Expr -> Maybe [String]
78+ peelAnonAccessorChain (Accessor p e) = (p :) <$> peelAnonAccessorChain e
79+ peelAnonAccessorChain (PositionedValue _ _ e) = peelAnonAccessorChain e
80+ peelAnonAccessorChain AnonymousArgument = Just []
81+ peelAnonAccessorChain _ = Nothing
82+
76 isAnonymousArgument :: Expr -> Bool
83 isAnonymousArgument :: Expr -> Bool
77 isAnonymousArgument AnonymousArgument = True
84 isAnonymousArgument AnonymousArgument = True
78 isAnonymousArgument (PositionedValue _ _ e) = isAnonymousArgument e
85 isAnonymousArgument (PositionedValue _ _ e) = isAnonymousArgument e
src/Language/PureScript/Sugar/Operators.hs+4−4
@@ -312,9 +312,9 @@ updateTypes goType = (goDecl, goExpr, goBinder)
312 goDecl pos (ExternDeclaration name ty) = do
312 goDecl pos (ExternDeclaration name ty) = do
313 ty' <- goType' pos ty
313 ty' <- goType' pos ty
314 return (pos, ExternDeclaration name ty')
314 return (pos, ExternDeclaration name ty')
315− goDecl pos (TypeClassDeclaration name args implies decls) = do
315+ goDecl pos (TypeClassDeclaration name args implies deps decls) = do
316 implies' <- traverse (overConstraintArgs (traverse (goType' pos))) implies
316 implies' <- traverse (overConstraintArgs (traverse (goType' pos))) implies
317− return (pos, TypeClassDeclaration name args implies' decls)
317+ return (pos, TypeClassDeclaration name args implies' deps decls)
318 goDecl pos (TypeInstanceDeclaration name cs className tys impls) = do
318 goDecl pos (TypeInstanceDeclaration name cs className tys impls) = do
319 cs' <- traverse (overConstraintArgs (traverse (goType' pos))) cs
319 cs' <- traverse (overConstraintArgs (traverse (goType' pos))) cs
320 tys' <- traverse (goType' pos) tys
320 tys' <- traverse (goType' pos) tys
@@ -332,9 +332,9 @@ updateTypes goType = (goDecl, goExpr, goBinder)
332 goExpr pos (TypeClassDictionary (Constraint name tys info) dicts hints) = do
332 goExpr pos (TypeClassDictionary (Constraint name tys info) dicts hints) = do
333 tys' <- traverse (goType' pos) tys
333 tys' <- traverse (goType' pos) tys
334 return (pos, TypeClassDictionary (Constraint name tys' info) dicts hints)
334 return (pos, TypeClassDictionary (Constraint name tys' info) dicts hints)
335− goExpr pos (SuperClassDictionary cls tys) = do
335+ goExpr pos (DeferredDictionary cls tys) = do
336 tys' <- traverse (goType' pos) tys
336 tys' <- traverse (goType' pos) tys
337− return (pos, SuperClassDictionary cls tys')
337+ return (pos, DeferredDictionary cls tys')
338 goExpr pos (TypedValue check v ty) = do
338 goExpr pos (TypedValue check v ty) = do
339 ty' <- goType' pos ty
339 ty' <- goType' pos ty
340 return (pos, TypedValue check v ty')
340 return (pos, TypedValue check v ty')
src/Language/PureScript/Sugar/Operators/Common.hs+2−2
@@ -28,12 +28,12 @@ parseValue :: P.Parsec (Chain a) () a
28parseValue = token (either Just (const Nothing)) P.<?> "expression"
28parseValue = token (either Just (const Nothing)) P.<?> "expression"
29
29
30parseOp
30parseOp
31− :: (a -> (Maybe (Qualified (OpName nameType))))
31+ :: (a -> Maybe (Qualified (OpName nameType)))
32 -> P.Parsec (Chain a) () (Qualified (OpName nameType))
32 -> P.Parsec (Chain a) () (Qualified (OpName nameType))
33parseOp fromOp = token (either (const Nothing) fromOp) P.<?> "operator"
33parseOp fromOp = token (either (const Nothing) fromOp) P.<?> "operator"
34
34
35matchOp
35matchOp
36− :: (a -> (Maybe (Qualified (OpName nameType))))
36+ :: (a -> Maybe (Qualified (OpName nameType)))
37 -> Qualified (OpName nameType)
37 -> Qualified (OpName nameType)
38 -> P.Parsec (Chain a) () ()
38 -> P.Parsec (Chain a) () ()
39matchOp fromOp op = do
39matchOp fromOp op = do
src/Language/PureScript/Sugar/Operators/Expr.hs+1−1
@@ -28,7 +28,7 @@ matchExprOperators = matchOperators isBinOp extractOp fromOp reapply modOpTable
28 fromOp _ = Nothing
28 fromOp _ = Nothing
29
29
30 reapply :: Qualified (OpName 'ValueOpName) -> Expr -> Expr -> Expr
30 reapply :: Qualified (OpName 'ValueOpName) -> Expr -> Expr -> Expr
31− reapply op t1 t2 = App (App (Op op) t1) t2
31+ reapply op t1 = App (App (Op op) t1)
32
32
33 modOpTable
33 modOpTable
34 :: [[P.Operator (Chain Expr) () Identity Expr]]
34 :: [[P.Operator (Chain Expr) () Identity Expr]]
src/Language/PureScript/Sugar/TypeClasses.hs+25−18
@@ -30,7 +30,7 @@ import Data.Maybe (catMaybes, mapMaybe, isJust)
30
30
31import qualified Data.Map as M
31import qualified Data.Map as M
32
32
33−type MemberMap = M.Map (ModuleName, ProperName 'ClassName) ([(String, Maybe Kind)], [Constraint], [Declaration])
33+type MemberMap = M.Map (ModuleName, ProperName 'ClassName) TypeClassData
34
34
35type Desugar = StateT MemberMap
35type Desugar = StateT MemberMap
36
36
@@ -46,14 +46,20 @@ desugarTypeClasses
46desugarTypeClasses externs = flip evalStateT initialState . traverse desugarModule
46desugarTypeClasses externs = flip evalStateT initialState . traverse desugarModule
47 where
47 where
48 initialState :: MemberMap
48 initialState :: MemberMap
49+ initialState =
49− initialState = M.singleton (ModuleName [ProperName C.prim], ProperName C.partial) ([], [], [])
50+ M.mapKeys (qualify (ModuleName [ProperName C.prim])) primClasses
50− `M.union` M.fromList (externs >>= \ExternsFile{..} -> mapMaybe (fromExternsDecl efModuleName) efDeclarations)
51+ `M.union` M.fromList (externs >>= \ExternsFile{..} -> mapMaybe (fromExternsDecl efModuleName) efDeclarations)
51
52
52 fromExternsDecl
53 fromExternsDecl
53 :: ModuleName
54 :: ModuleName
54 -> ExternsDeclaration
55 -> ExternsDeclaration
55− -> Maybe ((ModuleName, ProperName 'ClassName), ([(String, Maybe Kind)], [Constraint], [Declaration]))
56+ -> Maybe ((ModuleName, ProperName 'ClassName), TypeClassData)
56− fromExternsDecl mn (EDClass name args members implies) = Just ((mn, name), (args, implies, map (uncurry TypeDeclaration) members))
57+ fromExternsDecl mn (EDClass name args members implies deps) = Just ((mn, name), typeClass) where
58+ typeClass = TypeClassData { typeClassArguments = args
59+ , typeClassMembers = members
60+ , typeClassSuperclasses = implies
61+ , typeClassDependencies = deps
62+ }
57 fromExternsDecl _ _ = Nothing
63 fromExternsDecl _ _ = Nothing
58
64
59desugarModule
65desugarModule
@@ -129,7 +135,7 @@ desugarModule _ = internalError "Exports should have been elaborated in name des
129--
135--
130-- subString :: {} -> Sub String
136-- subString :: {} -> Sub String
131-- subString _ = { sub: "",
137-- subString _ = { sub: "",
132−-- , "__superclass_Foo_0": \_ -> <SuperClassDictionary Foo String>
138+-- , "__superclass_Foo_0": \_ -> <DeferredDictionary Foo String>
133-- }
139-- }
134--
140--
135-- and finally as the generated javascript:
141-- and finally as the generated javascript:
@@ -173,14 +179,18 @@ desugarDecl
173 -> Desugar m (Maybe DeclarationRef, [Declaration])
179 -> Desugar m (Maybe DeclarationRef, [Declaration])
174desugarDecl mn exps = go
180desugarDecl mn exps = go
175 where
181 where
176− go d@(TypeClassDeclaration name args implies members) = do
182+ go d@(TypeClassDeclaration name args implies deps members) = do
177− modify (M.insert (mn, name) (args, implies, members))
183+ modify (M.insert (mn, name) (TypeClassData args (map memberToNameAndType members) implies deps))
178 return (Nothing, d : typeClassDictionaryDeclaration name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members)
184 return (Nothing, d : typeClassDictionaryDeclaration name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members)
179 go (TypeInstanceDeclaration _ _ _ _ DerivedInstance) = internalError "Derived instanced should have been desugared"
185 go (TypeInstanceDeclaration _ _ _ _ DerivedInstance) = internalError "Derived instanced should have been desugared"
180 go d@(TypeInstanceDeclaration name deps className tys (ExplicitInstance members)) = do
186 go d@(TypeInstanceDeclaration name deps className tys (ExplicitInstance members)) = do
181 desugared <- desugarCases members
187 desugared <- desugarCases members
182 dictDecl <- typeInstanceDictionaryDeclaration name mn deps className tys desugared
188 dictDecl <- typeInstanceDictionaryDeclaration name mn deps className tys desugared
183 return (expRef name className tys, [d, dictDecl])
189 return (expRef name className tys, [d, dictDecl])
190+ go d@(TypeInstanceDeclaration name deps className tys (NewtypeInstanceWithDictionary dict)) = do
191+ let dictTy = foldl TypeApp (TypeConstructor (fmap coerceProperName className)) tys
192+ constrainedTy = quantify (if null deps then dictTy else ConstrainedType deps dictTy)
193+ return (expRef name className tys, [d, ValueDeclaration name Private [] (Right (TypedValue True dict constrainedTy))])
184 go (PositionedDeclaration pos com d) = do
194 go (PositionedDeclaration pos com d) = do
185 (dr, ds) <- rethrowWithPosition pos $ desugarDecl mn exps d
195 (dr, ds) <- rethrowWithPosition pos $ desugarDecl mn exps d
186 return (dr, map (PositionedDeclaration pos com) ds)
196 return (dr, map (PositionedDeclaration pos com) ds)
@@ -267,18 +277,15 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =
267 m <- get
277 m <- get
268
278
269 -- Lookup the type arguments and member types for the type class
279 -- Lookup the type arguments and member types for the type class
270− (args, implies, tyDecls) <-
280+ TypeClassData{..} <-
271 maybe (throwError . errorMessage . UnknownName $ fmap TyClassName className) return $
281 maybe (throwError . errorMessage . UnknownName $ fmap TyClassName className) return $
272 M.lookup (qualify mn className) m
282 M.lookup (qualify mn className) m
273
283
274− case mapMaybe declName tyDecls \\ mapMaybe declName decls of
284+ case map fst typeClassMembers \\ mapMaybe declName decls of
275 member : _ -> throwError . errorMessage $ MissingClassMember member
285 member : _ -> throwError . errorMessage $ MissingClassMember member
276 [] -> do
286 [] -> do
277−
278− let instanceTys = map memberToNameAndType tyDecls
279−
280 -- Replace the type arguments with the appropriate types in the member types
287 -- Replace the type arguments with the appropriate types in the member types
281− let memberTypes = map (second (replaceAllTypeVars (zip (map fst args) tys))) instanceTys
288+ let memberTypes = map (second (replaceAllTypeVars (zip (map fst typeClassArguments) tys))) typeClassMembers
282
289
283 -- Create values for the type instance members
290 -- Create values for the type instance members
284 members <- zip (map typeClassMemberName decls) <$> traverse (memberToValue memberTypes) decls
291 members <- zip (map typeClassMemberName decls) <$> traverse (memberToValue memberTypes) decls
@@ -286,10 +293,10 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =
286 -- Create the type of the dictionary
293 -- Create the type of the dictionary
287 -- The type is a record type, but depending on type instance dependencies, may be constrained.
294 -- The type is a record type, but depending on type instance dependencies, may be constrained.
288 -- The dictionary itself is a record literal.
295 -- The dictionary itself is a record literal.
289− let superclasses = superClassDictionaryNames implies `zip`
296+ let superclasses = superClassDictionaryNames typeClassSuperclasses `zip`
290− [ Abs (Left (Ident C.__unused)) (SuperClassDictionary superclass tyArgs)
297+ [ Abs (Left (Ident C.__unused)) (DeferredDictionary superclass tyArgs)
291− | (Constraint superclass suTyArgs _) <- implies
298+ | (Constraint superclass suTyArgs _) <- typeClassSuperclasses
292− , let tyArgs = map (replaceAllTypeVars (zip (map fst args) tys)) suTyArgs
299+ , let tyArgs = map (replaceAllTypeVars (zip (map fst typeClassArguments) tys)) suTyArgs
293 ]
300 ]
294
301
295 let props = Literal $ ObjectLiteral (members ++ superclasses)
302 let props = Literal $ ObjectLiteral (members ++ superclasses)
src/Language/PureScript/Sugar/TypeClasses/Deriving.hs+109−5
@@ -1,4 +1,5 @@
1{-# LANGUAGE OverloadedStrings #-}
1{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE PatternGuards #-}
2
3
3-- |
4-- |
4-- This module implements the generic deriving elaboration that takes place during desugaring.
5-- This module implements the generic deriving elaboration that takes place during desugaring.
@@ -22,6 +23,7 @@ import Language.PureScript.Environment
22import Language.PureScript.Errors
23import Language.PureScript.Errors
23import Language.PureScript.Names
24import Language.PureScript.Names
24import Language.PureScript.Types
25import Language.PureScript.Types
26+import Language.PureScript.TypeChecker (checkNewtype)
25import qualified Language.PureScript.Constants as C
27import qualified Language.PureScript.Constants as C
26
28
27-- | Elaborates deriving instance declarations by code generation.
29-- | Elaborates deriving instance declarations by code generation.
@@ -44,16 +46,29 @@ deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@[ty] Derived
44 , Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor ty
46 , Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor ty
45 , mn == fromMaybe mn mn'
47 , mn == fromMaybe mn mn'
46 = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveGeneric mn ds tyCon args
48 = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveGeneric mn ds tyCon args
47− | className == Qualified (Just (ModuleName [ ProperName "Data", ProperName "Eq" ])) (ProperName "Eq")
49+ | className == Qualified (Just dataEq) (ProperName "Eq")
48 , Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty
50 , Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty
49 , mn == fromMaybe mn mn'
51 , mn == fromMaybe mn mn'
50 = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveEq mn ds tyCon
52 = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveEq mn ds tyCon
51− | className == Qualified (Just (ModuleName [ ProperName "Data", ProperName "Ord" ])) (ProperName "Ord")
53+ | className == Qualified (Just dataOrd) (ProperName "Ord")
52 , Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty
54 , Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty
53 , mn == fromMaybe mn mn'
55 , mn == fromMaybe mn mn'
54 = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveOrd mn ds tyCon
56 = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveOrd mn ds tyCon
57+deriveInstance mn ds (TypeInstanceDeclaration nm deps className [wrappedTy, unwrappedTy] DerivedInstance)
58+ | className == Qualified (Just dataNewtype) (ProperName "Newtype")
59+ , Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor wrappedTy
60+ , mn == fromMaybe mn mn'
61+ = do
62+ (inst, actualUnwrappedTy) <- deriveNewtype mn ds tyCon args unwrappedTy
63+ return $ TypeInstanceDeclaration nm deps className [wrappedTy, actualUnwrappedTy] (ExplicitInstance inst)
55deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance)
64deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance)
56 = throwError . errorMessage $ CannotDerive className tys
65 = throwError . errorMessage $ CannotDerive className tys
66+deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@(_ : _) NewtypeInstance)
67+ | Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor (last tys)
68+ , mn == fromMaybe mn mn'
69+ = TypeInstanceDeclaration nm deps className tys . NewtypeInstanceWithDictionary <$> deriveNewtypeInstance className ds tys tyCon args
70+deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys NewtypeInstance)
71+ = throwError . errorMessage $ InvalidNewtypeInstance className tys
57deriveInstance mn ds (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> deriveInstance mn ds d
72deriveInstance mn ds (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> deriveInstance mn ds d
58deriveInstance _ _ e = return e
73deriveInstance _ _ e = return e
59
74
@@ -66,6 +81,44 @@ unwrapTypeConstructor = fmap (second reverse) . go
66 return (tyCon, arg : args)
81 return (tyCon, arg : args)
67 go _ = Nothing
82 go _ = Nothing
68
83
84+deriveNewtypeInstance
85+ :: forall m
86+ . MonadError MultipleErrors m
87+ => Qualified (ProperName 'ClassName)
88+ -> [Declaration]
89+ -> [Type]
90+ -> ProperName 'TypeName
91+ -> [Type]
92+ -> m Expr
93+deriveNewtypeInstance className ds tys tyConNm dargs = do
94+ tyCon <- findTypeDecl tyConNm ds
95+ go tyCon
96+ where
97+ go (DataDeclaration Newtype _ tyArgNames [(_, [wrapped])])
98+ -- The newtype might not be applied to all type arguments.
99+ -- This is okay as long as the newtype wraps something which ends with
100+ -- sufficiently many type applications to variables.
101+ -- For example, we can derive Functor for
102+ --
103+ -- newtype MyArray a = MyArray (Array a)
104+ --
105+ -- since Array a is a type application which uses the last
106+ -- type argument
107+ | Just wrapped' <- stripRight (takeReverse (length tyArgNames - length dargs) tyArgNames) wrapped =
108+ do let subst = zipWith (\(name, _) t -> (name, t)) tyArgNames dargs
109+ return (DeferredDictionary className (init tys ++ [replaceAllTypeVars subst wrapped']))
110+ go (PositionedDeclaration _ _ d) = go d
111+ go _ = throwError . errorMessage $ InvalidNewtypeInstance className tys
112+
113+ takeReverse :: Int -> [a] -> [a]
114+ takeReverse n = take n . reverse
115+
116+ stripRight :: [(String, Maybe kind)] -> Type -> Maybe Type
117+ stripRight [] ty = Just ty
118+ stripRight ((arg, _) : args) (TypeApp t (TypeVar arg'))
119+ | arg == arg' = stripRight args t
120+ stripRight _ _ = Nothing
121+
69dataGeneric :: ModuleName
122dataGeneric :: ModuleName
70dataGeneric = ModuleName [ ProperName "Data", ProperName "Generic" ]
123dataGeneric = ModuleName [ ProperName "Data", ProperName "Generic" ]
71
124
@@ -75,6 +128,15 @@ dataMaybe = ModuleName [ ProperName "Data", ProperName "Maybe" ]
75typesProxy :: ModuleName
128typesProxy :: ModuleName
76typesProxy = ModuleName [ ProperName "Type", ProperName "Proxy" ]
129typesProxy = ModuleName [ ProperName "Type", ProperName "Proxy" ]
77
130
131+dataEq :: ModuleName
132+dataEq = ModuleName [ ProperName "Data", ProperName "Eq" ]
133+
134+dataOrd :: ModuleName
135+dataOrd = ModuleName [ ProperName "Data", ProperName "Ord" ]
136+
137+dataNewtype :: ModuleName
138+dataNewtype = ModuleName [ ProperName "Data", ProperName "Newtype" ]
139+
78deriveGeneric
140deriveGeneric
79 :: forall m. (MonadError MultipleErrors m, MonadSupply m)
141 :: forall m. (MonadError MultipleErrors m, MonadSupply m)
80 => ModuleName
142 => ModuleName
@@ -223,7 +285,7 @@ deriveGeneric mn ds tyConNm dargs = do
223 $ liftApplicative (mkRecFun rs) (map (\(x, y) -> fromSpineFun (Accessor "recValue" (mkVar (Ident x))) y) rs)
285 $ liftApplicative (mkRecFun rs) (map (\(x, y) -> fromSpineFun (Accessor "recValue" (mkVar (Ident x))) y) rs)
224
286
225 mkRecFun :: [(String, Type)] -> Expr
287 mkRecFun :: [(String, Type)] -> Expr
226− mkRecFun xs = mkJust $ foldr lam recLiteral (map (Ident . fst) xs)
288+ mkRecFun xs = mkJust $ foldr (lam . Ident . fst) recLiteral xs
227 where recLiteral = Literal . ObjectLiteral $ map (\(s,_) -> (s, mkVar (Ident s))) xs
289 where recLiteral = Literal . ObjectLiteral $ map (\(s,_) -> (s, mkVar (Ident s))) xs
228 mkFromSpineFunction (PositionedDeclaration _ _ d) = mkFromSpineFunction d
290 mkFromSpineFunction (PositionedDeclaration _ _ d) = mkFromSpineFunction d
229 mkFromSpineFunction _ = internalError "mkFromSpineFunction: expected DataDeclaration"
291 mkFromSpineFunction _ = internalError "mkFromSpineFunction: expected DataDeclaration"
@@ -265,7 +327,7 @@ deriveEq mn ds tyConNm = do
265 preludeConj = App . App (Var (Qualified (Just (ModuleName [ProperName "Data", ProperName "HeytingAlgebra"])) (Ident C.conj)))
327 preludeConj = App . App (Var (Qualified (Just (ModuleName [ProperName "Data", ProperName "HeytingAlgebra"])) (Ident C.conj)))
266
328
267 preludeEq :: Expr -> Expr -> Expr
329 preludeEq :: Expr -> Expr -> Expr
268− preludeEq = App . App (Var (Qualified (Just (ModuleName [ProperName "Data", ProperName "Eq"])) (Ident C.eq)))
330+ preludeEq = App . App (Var (Qualified (Just dataEq) (Ident C.eq)))
269
331
270 addCatch :: [CaseAlternative] -> [CaseAlternative]
332 addCatch :: [CaseAlternative] -> [CaseAlternative]
271 addCatch xs
333 addCatch xs
@@ -335,7 +397,7 @@ deriveOrd mn ds tyConNm = do
335 orderingBinder name = ConstructorBinder (orderingName name) []
397 orderingBinder name = ConstructorBinder (orderingName name) []
336
398
337 ordCompare :: Expr -> Expr -> Expr
399 ordCompare :: Expr -> Expr -> Expr
338− ordCompare = App . App (Var (Qualified (Just (ModuleName [ProperName "Data", ProperName "Ord"])) (Ident C.compare)))
400+ ordCompare = App . App (Var (Qualified (Just dataOrd) (Ident C.compare)))
339
401
340 mkCtorClauses :: ((ProperName 'ConstructorName, [Type]), Bool) -> m [CaseAlternative]
402 mkCtorClauses :: ((ProperName 'ConstructorName, [Type]), Bool) -> m [CaseAlternative]
341 mkCtorClauses ((ctorName, tys), isLast) = do
403 mkCtorClauses ((ctorName, tys), isLast) = do
@@ -379,6 +441,48 @@ deriveOrd mn ds tyConNm = do
379 $ decomposeRec rec
441 $ decomposeRec rec
380 toOrdering l r _ = ordCompare l r
442 toOrdering l r _ = ordCompare l r
381
443
444+deriveNewtype
445+ :: forall m
446+ . (MonadError MultipleErrors m, MonadSupply m)
447+ => ModuleName
448+ -> [Declaration]
449+ -> ProperName 'TypeName
450+ -> [Type]
451+ -> Type
452+ -> m ([Declaration], Type)
453+deriveNewtype mn ds tyConNm tyConArgs unwrappedTy = do
454+ checkIsWildcard unwrappedTy
455+ go =<< findTypeDecl tyConNm ds
456+ where
457+ go :: Declaration -> m ([Declaration], Type)
458+ go (DataDeclaration Data name _ _) =
459+ throwError . errorMessage $ CannotDeriveNewtypeForData name
460+ go (DataDeclaration Newtype name args dctors) = do
461+ checkNewtype name dctors
462+ wrappedIdent <- freshIdent "n"
463+ unwrappedIdent <- freshIdent "a"
464+ let (ctorName, [ty]) = head dctors
465+ inst =
466+ [ ValueDeclaration (Ident "wrap") Public [] $ Right $
467+ Constructor (Qualified (Just mn) ctorName)
468+ , ValueDeclaration (Ident "unwrap") Public [] $ Right $
469+ lamCase wrappedIdent
470+ [ CaseAlternative
471+ [ConstructorBinder (Qualified (Just mn) ctorName) [VarBinder unwrappedIdent]]
472+ (Right (Var (Qualified Nothing unwrappedIdent)))
473+ ]
474+ ]
475+ subst = zipWith ((,) . fst) args tyConArgs
476+ return (inst, replaceAllTypeVars subst ty)
477+ go (PositionedDeclaration _ _ d) = go d
478+ go _ = internalError "deriveNewtype go: expected DataDeclaration"
479+
480+ checkIsWildcard :: Type -> m ()
481+ checkIsWildcard (TypeWildcard _) =
482+ return ()
483+ checkIsWildcard _ =
484+ throwError . errorMessage $ NonWildcardNewtypeInstance tyConNm
485+
382findTypeDecl
486findTypeDecl
383 :: (MonadError MultipleErrors m)
487 :: (MonadError MultipleErrors m)
384 => ProperName 'TypeName
488 => ProperName 'TypeName
src/Language/PureScript/TypeChecker.hs+27−13
@@ -6,6 +6,7 @@
6module Language.PureScript.TypeChecker
6module Language.PureScript.TypeChecker
7 ( module T
7 ( module T
8 , typeCheckModule
8 , typeCheckModule
9+ , checkNewtype
9 ) where
10 ) where
10
11
11import Prelude.Compat
12import Prelude.Compat
@@ -112,15 +113,23 @@ addTypeClass
112 -> ProperName 'ClassName
113 -> ProperName 'ClassName
113 -> [(String, Maybe Kind)]
114 -> [(String, Maybe Kind)]
114 -> [Constraint]
115 -> [Constraint]
116+ -> [FunctionalDependency]
115 -> [Declaration]
117 -> [Declaration]
116 -> m ()
118 -> m ()
117−addTypeClass moduleName pn args implies ds =
119+addTypeClass moduleName pn args implies dependencies ds =
118− let members = map toPair ds in
119− modify $ \st -> st { checkEnv = (checkEnv st) { typeClasses = M.insert (Qualified (Just moduleName) pn) (args, members, implies) (typeClasses . checkEnv $ st) } }
120+ modify $ \st -> st { checkEnv = (checkEnv st) { typeClasses = M.insert (Qualified (Just moduleName) pn) newClass (typeClasses . checkEnv $ st) } }
120 where
121 where
122+ newClass :: TypeClassData
123+ newClass =
124+ TypeClassData { typeClassArguments = args
125+ , typeClassMembers = map toPair ds
126+ , typeClassSuperclasses = implies
127+ , typeClassDependencies = dependencies
128+ }
129+
121− toPair (TypeDeclaration ident ty) = (ident, ty)
130+ toPair (TypeDeclaration ident ty) = (ident, ty)
122− toPair (PositionedDeclaration _ _ d) = toPair d
131+ toPair (PositionedDeclaration _ _ d) = toPair d
123− toPair _ = internalError "Invalid declaration in TypeClassDeclaration"
132+ toPair _ = internalError "Invalid declaration in TypeClassDeclaration"
124
133
125addTypeClassDictionaries
134addTypeClassDictionaries
126 :: (MonadState CheckState m)
135 :: (MonadState CheckState m)
@@ -265,8 +274,8 @@ typeCheckAll moduleName _ = traverse go
265 return d
274 return d
266 go d@FixityDeclaration{} = return d
275 go d@FixityDeclaration{} = return d
267 go d@ImportDeclaration{} = return d
276 go d@ImportDeclaration{} = return d
268− go d@(TypeClassDeclaration pn args implies tys) = do
277+ go d@(TypeClassDeclaration pn args implies deps tys) = do
269− addTypeClass moduleName pn args implies tys
278+ addTypeClass moduleName pn args implies deps tys
270 return d
279 return d
271 go (d@(TypeInstanceDeclaration dictName deps className tys body)) = rethrow (addHint (ErrorInInstance className tys)) $ do
280 go (d@(TypeInstanceDeclaration dictName deps className tys body)) = rethrow (addHint (ErrorInInstance className tys)) $ do
272 traverse_ (checkTypeClassInstance moduleName) tys
281 traverse_ (checkTypeClassInstance moduleName) tys
@@ -310,10 +319,6 @@ typeCheckAll moduleName _ = traverse go
310 checkType _ = internalError "Invalid type in instance in checkOrphanInstance"
319 checkType _ = internalError "Invalid type in instance in checkOrphanInstance"
311 checkOrphanInstance _ _ _ = internalError "Unqualified class name in checkOrphanInstance"
320 checkOrphanInstance _ _ _ = internalError "Unqualified class name in checkOrphanInstance"
312
321
313− checkNewtype :: ProperName 'TypeName -> [(ProperName 'ConstructorName, [Type])] -> m ()
314− checkNewtype _ [(_, [_])] = return ()
315− checkNewtype name _ = throwError . errorMessage $ InvalidNewtype name
316−
317 -- |
322 -- |
318 -- This function adds the argument kinds for a type constructor so that they may appear in the externs file,
323 -- This function adds the argument kinds for a type constructor so that they may appear in the externs file,
319 -- extracted from the kind of the type constructor itself.
324 -- extracted from the kind of the type constructor itself.
@@ -324,6 +329,15 @@ typeCheckAll moduleName _ = traverse go
324 withKinds ( (s, Nothing):ss) (FunKind k1 k2) = (s, Just k1) : withKinds ss k2
329 withKinds ( (s, Nothing):ss) (FunKind k1 k2) = (s, Just k1) : withKinds ss k2
325 withKinds _ _ = internalError "Invalid arguments to peelKinds"
330 withKinds _ _ = internalError "Invalid arguments to peelKinds"
326
331
332+checkNewtype
333+ :: forall m
334+ . MonadError MultipleErrors m
335+ => ProperName 'TypeName
336+ -> [(ProperName 'ConstructorName, [Type])]
337+ -> m ()
338+checkNewtype _ [(_, [_])] = return ()
339+checkNewtype name _ = throwError . errorMessage $ InvalidNewtype name
340+
327-- |
341-- |
328-- Type check an entire module and ensure all types and classes defined within the module that are
342-- Type check an entire module and ensure all types and classes defined within the module that are
329-- required by exported members are also exported.
343-- required by exported members are also exported.
@@ -414,7 +428,7 @@ typeCheckModule (Module ss coms mn decls (Just exps)) =
414 unless (null missingMembers) $ throwError . errorMessage $ TransitiveExportError dr members
428 unless (null missingMembers) $ throwError . errorMessage $ TransitiveExportError dr members
415 where
429 where
416 findClassMembers :: Declaration -> Maybe [Ident]
430 findClassMembers :: Declaration -> Maybe [Ident]
417− findClassMembers (TypeClassDeclaration name' _ _ ds) | name == name' = Just $ map extractMemberName ds
431+ findClassMembers (TypeClassDeclaration name' _ _ _ ds) | name == name' = Just $ map extractMemberName ds
418 findClassMembers (PositionedDeclaration _ _ d) = findClassMembers d
432 findClassMembers (PositionedDeclaration _ _ d) = findClassMembers d
419 findClassMembers _ = Nothing
433 findClassMembers _ = Nothing
420 extractMemberName :: Declaration -> Ident
434 extractMemberName :: Declaration -> Ident
src/Language/PureScript/TypeChecker/Entailment.hs+355−148
@@ -1,28 +1,35 @@
1+{-# LANGUAGE NamedFieldPuns #-}
2+
1-- |
3-- |
2-- Type class entailment
4-- Type class entailment
3--
5--
4module Language.PureScript.TypeChecker.Entailment
6module Language.PureScript.TypeChecker.Entailment
5 ( InstanceContext
7 ( InstanceContext
6 , replaceTypeClassDictionaries
8 , replaceTypeClassDictionaries
9+ , newDictionaries
7 ) where
10 ) where
8
11
9import Prelude.Compat
12import Prelude.Compat
10
13
14+import Control.Arrow (second)
11import Control.Monad.Error.Class (MonadError(..))
15import Control.Monad.Error.Class (MonadError(..))
12import Control.Monad.State
16import Control.Monad.State
13import Control.Monad.Supply.Class (MonadSupply(..))
17import Control.Monad.Supply.Class (MonadSupply(..))
14import Control.Monad.Writer
18import Control.Monad.Writer
15
19
20+import Data.Foldable (for_)
16import Data.Function (on)
21import Data.Function (on)
17−import Data.List (minimumBy, sortBy, groupBy)
22+import Data.List (minimumBy, nub)
18−import Data.Maybe (maybeToList, mapMaybe)
23+import Data.Maybe (fromMaybe, maybeToList, mapMaybe)
19import qualified Data.Map as M
24import qualified Data.Map as M
25+import qualified Data.Set as S
20
26
21import Language.PureScript.AST
27import Language.PureScript.AST
22import Language.PureScript.Crash
28import Language.PureScript.Crash
29+import Language.PureScript.Environment
23import Language.PureScript.Errors
30import Language.PureScript.Errors
24import Language.PureScript.Names
31import Language.PureScript.Names
25−import Language.PureScript.TypeChecker.Monad (CheckState, withErrorMessageHint)
32+import Language.PureScript.TypeChecker.Monad
26import Language.PureScript.TypeChecker.Unify
33import Language.PureScript.TypeChecker.Unify
27import Language.PureScript.TypeClassDictionaries
34import Language.PureScript.TypeClassDictionaries
28import Language.PureScript.Types
35import Language.PureScript.Types
@@ -34,24 +41,57 @@ type InstanceContext = M.Map (Maybe ModuleName)
34 (M.Map (Qualified Ident)
41 (M.Map (Qualified Ident)
35 TypeClassDictionaryInScope))
42 TypeClassDictionaryInScope))
36
43
37−-- | Merge two type class contexts
44+-- | A type substitution which makes an instance head match a list of types.
45+--
46+-- Note: we store many types per type variable name. For any name, all types
47+-- should unify if we are going to commit to an instance.
48+type Matching a = M.Map String a
49+
38combineContexts :: InstanceContext -> InstanceContext -> InstanceContext
50combineContexts :: InstanceContext -> InstanceContext -> InstanceContext
39combineContexts = M.unionWith (M.unionWith M.union)
51combineContexts = M.unionWith (M.unionWith M.union)
40
52
41-- | Replace type class dictionary placeholders with inferred type class dictionaries
53-- | Replace type class dictionary placeholders with inferred type class dictionaries
42replaceTypeClassDictionaries
54replaceTypeClassDictionaries
55+ :: forall m
43− :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m)
56+ . (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m)
44 => Bool
57 => Bool
45− -> ModuleName
46 -> Expr
58 -> Expr
47 -> m (Expr, [(Ident, Constraint)])
59 -> m (Expr, [(Ident, Constraint)])
48−replaceTypeClassDictionaries shouldGeneralize mn =
60+replaceTypeClassDictionaries shouldGeneralize expr = flip evalStateT M.empty $ do
49− let (_, f, _) = everywhereOnValuesTopDownM return (WriterT . go) return
61+ -- Loop, deferring any unsolved constraints, until there are no more
50− in flip evalStateT M.empty . runWriterT . f
62+ -- constraints which can be solved, then make a generalization pass.
63+ let loop e = do
64+ (e', solved) <- deferPass e
65+ if getAny solved
66+ then loop e'
67+ else return e'
68+ loop expr >>= generalizePass
51 where
69 where
70+ -- This pass solves constraints where possible, deferring constraints if not.
71+ deferPass :: Expr -> StateT InstanceContext m (Expr, Any)
72+ deferPass = fmap (second fst) . runWriterT . f where
73+ f :: Expr -> WriterT (Any, [(Ident, Constraint)]) (StateT InstanceContext m) Expr
74+ (_, f, _) = everywhereOnValuesTopDownM return (go True) return
75+
76+ -- This pass generalizes any remaining constraints
77+ generalizePass :: Expr -> StateT InstanceContext m (Expr, [(Ident, Constraint)])
78+ generalizePass = fmap (second snd) . runWriterT . f where
79+ f :: Expr -> WriterT (Any, [(Ident, Constraint)]) (StateT InstanceContext m) Expr
80+ (_, f, _) = everywhereOnValuesTopDownM return (go False) return
81+
82+ go :: Bool -> Expr -> WriterT (Any, [(Ident, Constraint)]) (StateT InstanceContext m) Expr
52− go (TypeClassDictionary constraint dicts hints) =
83+ go deferErrors dict@(TypeClassDictionary _ _ hints) =
53− rethrow (addHints hints) $ entails shouldGeneralize mn dicts constraint
84+ rethrow (addHints hints) $ entails shouldGeneralize deferErrors dict
54− go other = return (other, [])
85+ go _ other = return other
86+
87+-- | Three options for how we can handle a constraint, depending on the mode we're in.
88+data EntailsResult a
89+ = Solved a TypeClassDictionaryInScope
90+ -- ^ We solved this constraint
91+ | Unsolved Constraint
92+ -- ^ We couldn't solve this constraint right now, it will be generalized
93+ | Deferred
94+ -- ^ We couldn't solve this constraint right now, so it has been deferred
55
95
56-- |
96-- |
57-- Check that the current set of type class dictionaries entail the specified type class goal, and, if so,
97-- Check that the current set of type class dictionaries entail the specified type class goal, and, if so,
@@ -61,14 +101,14 @@ entails
61 :: forall m
101 :: forall m
62 . (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m)
102 . (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m)
63 => Bool
103 => Bool
64− -> ModuleName
104+ -> Bool
65− -> InstanceContext
105+ -> Expr
66− -> Constraint
106+ -> WriterT (Any, [(Ident, Constraint)]) (StateT InstanceContext m) Expr
67− -> StateT InstanceContext m (Expr, [(Ident, Constraint)])
68−entails shouldGeneralize moduleName context = solve
107+entails shouldGeneralize deferErrors (TypeClassDictionary constraint context hints) =
108+ solve constraint
69 where
109 where
70 forClassName :: InstanceContext -> Qualified (ProperName 'ClassName) -> [Type] -> [TypeClassDictionaryInScope]
110 forClassName :: InstanceContext -> Qualified (ProperName 'ClassName) -> [Type] -> [TypeClassDictionaryInScope]
71− forClassName ctx cn@(Qualified (Just mn) _) tys = concatMap (findDicts ctx cn) (Nothing : Just mn : map Just (mapMaybe ctorModules tys))
111+ forClassName ctx cn@(Qualified (Just mn) _) tys = concatMap (findDicts ctx cn) (nub (Nothing : Just mn : map Just (mapMaybe ctorModules tys)))
72 forClassName _ _ _ = internalError "forClassName: expected qualified class name"
112 forClassName _ _ _ = internalError "forClassName: expected qualified class name"
73
113
74 ctorModules :: Type -> Maybe ModuleName
114 ctorModules :: Type -> Maybe ModuleName
@@ -80,139 +120,306 @@ entails shouldGeneralize moduleName context = solve
80 findDicts :: InstanceContext -> Qualified (ProperName 'ClassName) -> Maybe ModuleName -> [TypeClassDictionaryInScope]
120 findDicts :: InstanceContext -> Qualified (ProperName 'ClassName) -> Maybe ModuleName -> [TypeClassDictionaryInScope]
81 findDicts ctx cn = maybe [] M.elems . (>>= M.lookup cn) . flip M.lookup ctx
121 findDicts ctx cn = maybe [] M.elems . (>>= M.lookup cn) . flip M.lookup ctx
82
122
123+ valUndefined :: Expr
124+ valUndefined = Var (Qualified (Just (ModuleName [ProperName C.prim])) (Ident C.undefined))
125+
83− solve :: Constraint -> StateT InstanceContext m (Expr, [(Ident, Constraint)])
126+ solve :: Constraint -> WriterT (Any, [(Ident, Constraint)]) (StateT InstanceContext m) Expr
84− solve con = StateT . (withErrorMessageHint (ErrorSolvingConstraint con) .) . runStateT $ do
127+ solve con = go 0 con
85− (dict, unsolved) <- go 0 con
86− return (dictionaryValueToValue dict, unsolved)
87 where
128 where
88− go :: Int -> Constraint -> StateT InstanceContext m (DictionaryValue, [(Ident, Constraint)])
129+ go :: Int -> Constraint -> WriterT (Any, [(Ident, Constraint)]) (StateT InstanceContext m) Expr
89− go work (Constraint className' tys' _) | work > 1000 = throwError . errorMessage $ PossiblyInfiniteInstance className' tys'
130+ go work (Constraint className' tys' _) | work > 1000 = throwError . errorMessage $ PossiblyInfiniteInstance className' tys'
90− go work con'@(Constraint className' tys' _) = do
131+ go work con'@(Constraint className' tys' conInfo) = WriterT . StateT . (withErrorMessageHint (ErrorSolvingConstraint con') .) . runStateT . runWriterT $ do
132+ -- We might have unified types by solving other constraints, so we need to
133+ -- apply the latest substitution.
134+ latestSubst <- lift . lift $ gets checkSubstitution
135+ let tys'' = map (substituteType latestSubst) tys'
91− -- Get the inferred constraint context so far, and merge it with the global context
136+ -- Get the inferred constraint context so far, and merge it with the global context
92− inferred <- get
137+ inferred <- lift get
138+ -- We need information about functional dependencies, so we have to look up the class
139+ -- name in the environment:
140+ let findClass = fromMaybe (internalError "entails: type class not found in environment") . M.lookup className'
141+ TypeClassData{ typeClassDependencies } <- lift . lift $ gets (findClass . typeClasses . checkEnv)
93− let instances = do
142+ let instances =
143+ [ (substs, tcd)
94− tcd <- forClassName (combineContexts context inferred) className' tys'
144+ | tcd <- forClassName (combineContexts context inferred) className' tys''
95− -- Make sure the type unifies with the type in the type instance definition
145+ -- Make sure the type unifies with the type in the type instance definition
96− subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName) tys' (tcdInstanceTypes tcd)
146+ , substs <- maybeToList (matches typeClassDependencies tcd tys'')
97− return (subst, tcd)
147+ ]
98− solution <- lift $ unique instances
148+ solution <- lift . lift $ unique tys'' instances
99− case solution of
149+ case solution of
100− Left (subst, tcd) -> do
150+ Solved substs tcd -> do
151+ -- Note that we solved something.
152+ tell (Any True, mempty)
153+ -- Make sure the substitution is valid:
154+ lift . lift . for_ substs $ pairwiseM unifyTypes
155+ -- Now enforce any functional dependencies, using unification
156+ -- Note: we need to generate fresh types for any unconstrained
157+ -- type variables before unifying.
158+ let subst = fmap head substs
159+ currentSubst <- lift . lift $ gets checkSubstitution
160+ subst' <- lift . lift $ withFreshTypes tcd (fmap (substituteType currentSubst) subst)
161+ lift . lift $ zipWithM_ (\t1 t2 -> do
162+ let inferredType = replaceAllTypeVars (M.toList subst') t1
163+ unifyTypes inferredType t2) (tcdInstanceTypes tcd) tys''
164+ currentSubst' <- lift . lift $ gets checkSubstitution
165+ let subst'' = fmap (substituteType currentSubst') subst'
101− -- Solve any necessary subgoals
166+ -- Solve any necessary subgoals
102− (args, unsolved) <- solveSubgoals subst (tcdDependencies tcd)
167+ args <- solveSubgoals subst'' (tcdDependencies tcd)
103− let match = foldr (\(superclassName, index) dict -> SubclassDictionaryValue dict superclassName index)
168+ let match = foldr (\(superclassName, index) dict -> subclassDictionaryValue dict superclassName index)
104− (mkDictionary (tcdName tcd) args)
169+ (mkDictionary (tcdName tcd) args)
105− (tcdPath tcd)
170+ (tcdPath tcd)
106− return (match, unsolved)
171+ return match
107− Right unsolved@(Constraint unsolvedClassName@(Qualified _ pn) unsolvedTys _) -> do
172+ Unsolved unsolved -> do
108− -- Generate a fresh name for the unsolved constraint's new dictionary
173+ -- Generate a fresh name for the unsolved constraint's new dictionary
109− ident <- freshIdent ("dict" ++ runProperName pn)
174+ ident <- freshIdent ("dict" ++ runProperName (disqualify (constraintClass unsolved)))
110− let qident = Qualified Nothing ident
175+ let qident = Qualified Nothing ident
111− -- Store the new dictionary in the InstanceContext so that we can solve this goal in
176+ -- Store the new dictionary in the InstanceContext so that we can solve this goal in
112− -- future.
177+ -- future.
113− let newDict = TypeClassDictionaryInScope qident [] unsolvedClassName unsolvedTys Nothing
178+ newDicts <- lift . lift $ newDictionaries [] qident unsolved
114− newContext = M.singleton Nothing (M.singleton unsolvedClassName (M.singleton qident newDict))
179+ let newContext = mkContext newDicts
115− modify (combineContexts newContext)
180+ modify (combineContexts newContext)
116− return (LocalDictionaryValue qident, [(ident, unsolved)])
181+ -- Mark this constraint for generalization
182+ tell (mempty, [(ident, unsolved)])
183+ return (Var qident)
184+ Deferred ->
185+ -- Constraint was deferred, just return the dictionary unchanged,
186+ -- with no unsolved constraints. Hopefully, we can solve this later.
187+ return (TypeClassDictionary (Constraint className' tys'' conInfo) context hints)
117− where
188+ where
189+ -- | When checking functional dependencies, we need to use unification to make
190+ -- sure it is safe to use the selected instance. We will unify the solved type with
191+ -- the type in the instance head under the substition inferred from its instantiation.
192+ -- As an example, when solving MonadState t0 (State Int), we choose the
193+ -- MonadState s (State s) instance, and we unify t0 with Int, since the functional
194+ -- dependency from MonadState dictates that t0 should unify with s\[s -> Int], which is
195+ -- Int. This is fine, but in some cases, the substitution does not remove all TypeVars
196+ -- from the type, so we end up with a unification error. So, any type arguments which
197+ -- appear in the instance head, but not in the substitution need to be replaced with
198+ -- fresh type variables. This function extends a substitution with fresh type variables
199+ -- as necessary, based on the types in the instance head.
200+ withFreshTypes
201+ :: TypeClassDictionaryInScope
202+ -> Matching Type
203+ -> m (Matching Type)
204+ withFreshTypes TypeClassDictionaryInScope{..} subst = do
205+ let onType = everythingOnTypes S.union fromTypeVar
206+ typeVarsInHead = foldMap onType tcdInstanceTypes
207+ <> foldMap (foldMap (foldMap onType . constraintArgs)) tcdDependencies
208+ typeVarsInSubst = S.fromList (M.keys subst)
209+ uninstantiatedTypeVars = typeVarsInHead S.\\ typeVarsInSubst
210+ newSubst <- traverse withFreshType (S.toList uninstantiatedTypeVars)
211+ return (subst <> M.fromList newSubst)
212+ where
213+ fromTypeVar (TypeVar v) = S.singleton v
214+ fromTypeVar _ = S.empty
118
215
119− unique :: [(a, TypeClassDictionaryInScope)] -> m (Either (a, TypeClassDictionaryInScope) Constraint)
216+ withFreshType s = do
120− unique [] | shouldGeneralize && all canBeGeneralized tys' = return (Right con')
217+ t <- freshType
121− | otherwise = throwError . errorMessage $ NoInstanceFound con'
218+ return (s, t)
122− unique [a] = return $ Left a
123− unique tcds | pairwise overlapping (map snd tcds) = do
124− tell . errorMessage $ OverlappingInstances className' tys' (map (tcdName . snd) tcds)
125− return $ Left (head tcds)
126− | otherwise = return $ Left (minimumBy (compare `on` length . tcdPath . snd) tcds)
127−
128− canBeGeneralized :: Type -> Bool
129− canBeGeneralized TUnknown{} = True
130− canBeGeneralized Skolem{} = True
131− canBeGeneralized _ = False
132−
133− -- |
134− -- Check if two dictionaries are overlapping
135− --
136− -- Dictionaries which are subclass dictionaries cannot overlap, since otherwise the overlap would have
137− -- been caught when constructing superclass dictionaries.
138− overlapping :: TypeClassDictionaryInScope -> TypeClassDictionaryInScope -> Bool
139− overlapping TypeClassDictionaryInScope{ tcdPath = _ : _ } _ = False
140− overlapping _ TypeClassDictionaryInScope{ tcdPath = _ : _ } = False
141− overlapping TypeClassDictionaryInScope{ tcdDependencies = Nothing } _ = False
142− overlapping _ TypeClassDictionaryInScope{ tcdDependencies = Nothing } = False
143− overlapping tcd1 tcd2 = tcdName tcd1 /= tcdName tcd2
144−
145− -- Create dictionaries for subgoals which still need to be solved by calling go recursively
146− -- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type
147− -- unifies with Either a b, and we can satisfy the subgoals Show a and Show b recursively.
148− solveSubgoals :: [(String, Type)] -> Maybe [Constraint] -> StateT InstanceContext m (Maybe [DictionaryValue], [(Ident, Constraint)])
149− solveSubgoals _ Nothing = return (Nothing, [])
150− solveSubgoals subst (Just subgoals) = do
151− zipped <- traverse (go (work + 1) . mapConstraintArgs (map (replaceAllTypeVars subst))) subgoals
152− let (dicts, unsolved) = unzip zipped
153− return (Just dicts, concat unsolved)
154−
155− -- Make a dictionary from subgoal dictionaries by applying the correct function
156− mkDictionary :: Qualified Ident -> Maybe [DictionaryValue] -> DictionaryValue
157− mkDictionary fnName Nothing = LocalDictionaryValue fnName
158− mkDictionary fnName (Just []) = GlobalDictionaryValue fnName
159− mkDictionary fnName (Just dicts) = DependentDictionaryValue fnName dicts
160−
161− -- Turn a DictionaryValue into a Expr
162− dictionaryValueToValue :: DictionaryValue -> Expr
163− dictionaryValueToValue (LocalDictionaryValue fnName) = Var fnName
164− dictionaryValueToValue (GlobalDictionaryValue fnName) = Var fnName
165− dictionaryValueToValue (DependentDictionaryValue fnName dicts) = foldl App (Var fnName) (map dictionaryValueToValue dicts)
166− dictionaryValueToValue (SubclassDictionaryValue dict superclassName index) =
167− App (Accessor (C.__superclass_ ++ showQualified runProperName superclassName ++ "_" ++ show index)
168− (dictionaryValueToValue dict))
169− valUndefined
170− -- Ensure that a substitution is valid
171− verifySubstitution :: [(String, Type)] -> Maybe [(String, Type)]
172− verifySubstitution subst = do
173− let grps = groupBy ((==) `on` fst) . sortBy (compare `on` fst) $ subst
174− guard (all (pairwise unifiesWith . map snd) grps)
175− return $ map head grps
176
219
177− valUndefined :: Expr
220+ unique :: [Type] -> [(a, TypeClassDictionaryInScope)] -> m (EntailsResult a)
178− valUndefined = Var (Qualified (Just (ModuleName [ProperName C.prim])) (Ident C.undefined))
221+ unique tyArgs []
222+ | deferErrors = return Deferred
223+ -- We need a special case for nullary type classes, since we want
224+ -- to generalize over Partial constraints.
225+ | shouldGeneralize && (null tyArgs || any canBeGeneralized tyArgs) = return (Unsolved (Constraint className' tyArgs conInfo))
226+ | otherwise = throwError . errorMessage $ NoInstanceFound (Constraint className' tyArgs conInfo)
227+ unique _ [(a, dict)] = return $ Solved a dict
228+ unique tyArgs tcds
229+ | pairwiseAny overlapping (map snd tcds) = do
230+ tell . errorMessage $ OverlappingInstances className' tyArgs (map (tcdName . snd) tcds)
231+ return $ uncurry Solved (head tcds)
232+ | otherwise = return $ uncurry Solved (minimumBy (compare `on` length . tcdPath . snd) tcds)
179
233
180−-- |
234+ canBeGeneralized :: Type -> Bool
181−-- Check whether the type heads of two types are equal (for the purposes of type class dictionary lookup),
235+ canBeGeneralized TUnknown{} = True
182−-- and return a substitution from type variables to types which makes the type heads unify.
236+ canBeGeneralized Skolem{} = True
183−--
237+ canBeGeneralized _ = False
184−typeHeadsAreEqual :: ModuleName -> Type -> Type -> Maybe [(String, Type)]
238+
185−typeHeadsAreEqual _ (TUnknown u1) (TUnknown u2) | u1 == u2 = Just []
239+ -- |
186−typeHeadsAreEqual _ (Skolem _ s1 _ _) (Skolem _ s2 _ _) | s1 == s2 = Just []
240+ -- Check if two dictionaries are overlapping
187−typeHeadsAreEqual _ t (TypeVar v) = Just [(v, t)]
241+ --
188−typeHeadsAreEqual _ (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = Just []
242+ -- Dictionaries which are subclass dictionaries cannot overlap, since otherwise the overlap would have
189−typeHeadsAreEqual _ (TypeLevelString s1) (TypeLevelString s2) | s1 == s2 = Just []
243+ -- been caught when constructing superclass dictionaries.
190−typeHeadsAreEqual m (TypeApp h1 t1) (TypeApp h2 t2) = (++) <$> typeHeadsAreEqual m h1 h2
244+ overlapping :: TypeClassDictionaryInScope -> TypeClassDictionaryInScope -> Bool
191− <*> typeHeadsAreEqual m t1 t2
245+ overlapping TypeClassDictionaryInScope{ tcdPath = _ : _ } _ = False
192−typeHeadsAreEqual _ REmpty REmpty = Just []
246+ overlapping _ TypeClassDictionaryInScope{ tcdPath = _ : _ } = False
193−typeHeadsAreEqual m r1@RCons{} r2@RCons{} =
247+ overlapping TypeClassDictionaryInScope{ tcdDependencies = Nothing } _ = False
194− let (s1, r1') = rowToList r1
248+ overlapping _ TypeClassDictionaryInScope{ tcdDependencies = Nothing } = False
195− (s2, r2') = rowToList r2
249+ overlapping tcd1 tcd2 = tcdName tcd1 /= tcdName tcd2
196−
250+
197− int = [ (t1, t2) | (name, t1) <- s1, (name', t2) <- s2, name == name' ]
251+ -- Create dictionaries for subgoals which still need to be solved by calling go recursively
198− sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ]
252+ -- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type
199− sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ]
253+ -- unifies with Either a b, and we can satisfy the subgoals Show a and Show b recursively.
200− in (++) <$> foldMap (uncurry (typeHeadsAreEqual m)) int
254+ solveSubgoals :: Matching Type -> Maybe [Constraint] -> WriterT (Any, [(Ident, Constraint)]) (StateT InstanceContext m) (Maybe [Expr])
201− <*> go sd1 r1' sd2 r2'
255+ solveSubgoals _ Nothing = return Nothing
256+ solveSubgoals subst (Just subgoals) =
257+ Just <$> traverse (go (work + 1) . mapConstraintArgs (map (replaceAllTypeVars (M.toList subst)))) subgoals
258+
259+ -- Make a dictionary from subgoal dictionaries by applying the correct function
260+ mkDictionary :: Qualified Ident -> Maybe [Expr] -> Expr
261+ mkDictionary fnName Nothing = Var fnName
262+ mkDictionary fnName (Just []) = Var fnName
263+ mkDictionary fnName (Just dicts) = foldl App (Var fnName) dicts
264+
265+ -- Turn a DictionaryValue into a Expr
266+ subclassDictionaryValue :: Expr -> Qualified (ProperName a) -> Integer -> Expr
267+ subclassDictionaryValue dict superclassName index =
268+ App (Accessor (C.__superclass_ ++ showQualified runProperName superclassName ++ "_" ++ show index)
269+ dict)
270+ valUndefined
271+entails _ _ _ = internalError "entails: expected TypeClassDictionary"
272+
273+-- Check if an instance matches our list of types, allowing for types
274+-- to be solved via functional dependencies. If the types match, we return a
275+-- substitution which makes them match. If not, we return 'Nothing'.
276+matches :: [FunctionalDependency] -> TypeClassDictionaryInScope -> [Type] -> Maybe (Matching [Type])
277+matches deps TypeClassDictionaryInScope{..} tys = do
278+ -- First, find those types which match exactly
279+ let matched = zipWith typeHeadsAreEqual tys tcdInstanceTypes
280+ -- Now, use any functional dependencies to infer any remaining types
281+ guard $ covers matched
282+ -- Verify that any repeated type variables are unifiable
283+ let determinedSet = foldMap (S.fromList . fdDetermined) deps
284+ solved = map snd . filter ((`S.notMember` determinedSet) . fst) $ zipWith (\(_, ts) i -> (i, ts)) matched [0..]
285+ verifySubstitution (M.unionsWith (++) solved)
202 where
286 where
203− go :: [(String, Type)] -> Type -> [(String, Type)] -> Type -> Maybe [(String, Type)]
287+ -- | Find the closure of a set of functional dependencies.
204− go [] REmpty [] REmpty = Just []
288+ covers :: [(Bool, subst)] -> Bool
205− go [] (TUnknown _) _ _ = Just []
289+ covers ms = finalSet == S.fromList [0..length ms - 1]
206− go [] (TypeVar v1) [] (TypeVar v2) | v1 == v2 = Just []
290+ where
207− go [] (Skolem _ s1 _ _) [] (Skolem _ s2 _ _) | s1 == s2 = Just []
291+ initialSet :: S.Set Int
208− go sd r [] (TypeVar v) = Just [(v, rowFromList (sd, r))]
292+ initialSet = S.fromList . map snd . filter (fst . fst) $ zip ms [0..]
209− go _ _ _ _ = Nothing
210−typeHeadsAreEqual _ _ _ = Nothing
211
293
212−-- |
294+ finalSet :: S.Set Int
213−-- Check all values in a list pairwise match a predicate
295+ finalSet = untilFixedPoint applyAll initialSet
214−--
296+
215−pairwise :: (a -> a -> Bool) -> [a] -> Bool
297+ untilFixedPoint :: Eq a => (a -> a) -> a -> a
216−pairwise _ [] = True
298+ untilFixedPoint f = go
217−pairwise _ [_] = True
299+ where
218−pairwise p (x : xs) = all (p x) xs && pairwise p xs
300+ go a | a' == a = a'
301+ | otherwise = go a'
302+ where a' = f a
303+
304+ applyAll :: S.Set Int -> S.Set Int
305+ applyAll s = foldr applyDependency s deps
306+
307+ applyDependency :: FunctionalDependency -> S.Set Int -> S.Set Int
308+ applyDependency FunctionalDependency{..} xs
309+ | S.fromList fdDeterminers `S.isSubsetOf` xs = xs <> S.fromList fdDetermined
310+ | otherwise = xs
311+
312+ --
313+ -- Check whether the type heads of two types are equal (for the purposes of type class dictionary lookup),
314+ -- and return a substitution from type variables to types which makes the type heads unify.
315+ --
316+ typeHeadsAreEqual :: Type -> Type -> (Bool, Matching [Type])
317+ typeHeadsAreEqual (TUnknown u1) (TUnknown u2) | u1 == u2 = (True, M.empty)
318+ typeHeadsAreEqual (Skolem _ s1 _ _) (Skolem _ s2 _ _) | s1 == s2 = (True, M.empty)
319+ typeHeadsAreEqual t (TypeVar v) = (True, M.singleton v [t])
320+ typeHeadsAreEqual (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = (True, M.empty)
321+ typeHeadsAreEqual (TypeLevelString s1) (TypeLevelString s2) | s1 == s2 = (True, M.empty)
322+ typeHeadsAreEqual (TypeApp h1 t1) (TypeApp h2 t2) =
323+ both (typeHeadsAreEqual h1 h2) (typeHeadsAreEqual t1 t2)
324+ typeHeadsAreEqual REmpty REmpty = (True, M.empty)
325+ typeHeadsAreEqual r1@RCons{} r2@RCons{} =
326+ foldr both (go sd1 r1' sd2 r2') (map (uncurry typeHeadsAreEqual) int)
327+ where
328+ (s1, r1') = rowToList r1
329+ (s2, r2') = rowToList r2
330+
331+ int = [ (t1, t2) | (name, t1) <- s1, (name', t2) <- s2, name == name' ]
332+ sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ]
333+ sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ]
334+
335+ go :: [(String, Type)] -> Type -> [(String, Type)] -> Type -> (Bool, Matching [Type])
336+ go [] REmpty [] REmpty = (True, M.empty)
337+ go [] (TUnknown u1) [] (TUnknown u2) | u1 == u2 = (True, M.empty)
338+ go [] (TypeVar v1) [] (TypeVar v2) | v1 == v2 = (True, M.empty)
339+ go [] (Skolem _ sk1 _ _) [] (Skolem _ sk2 _ _) | sk1 == sk2 = (True, M.empty)
340+ go sd r [] (TypeVar v) = (True, M.singleton v [rowFromList (sd, r)])
341+ go _ _ _ _ = (False, M.empty)
342+ typeHeadsAreEqual _ _ = (False, M.empty)
343+
344+ both :: (Bool, Matching [Type]) -> (Bool, Matching [Type]) -> (Bool, Matching [Type])
345+ both (b1, m1) (b2, m2) = (b1 && b2, M.unionWith (++) m1 m2)
346+
347+ -- Ensure that a substitution is valid
348+ verifySubstitution :: Matching [Type] -> Maybe (Matching [Type])
349+ verifySubstitution = traverse meet where
350+ meet ts | pairwiseAll typesAreEqual ts = Just ts
351+ | otherwise = Nothing
352+
353+ -- Note that unknowns are only allowed to unify if they came from a type
354+ -- which was _not_ solved, i.e. one which was inferred by a functional
355+ -- dependency.
356+ typesAreEqual :: Type -> Type -> Bool
357+ typesAreEqual (TUnknown u1) (TUnknown u2) | u1 == u2 = True
358+ typesAreEqual (Skolem _ s1 _ _) (Skolem _ s2 _ _) = s1 == s2
359+ typesAreEqual (TypeVar v1) (TypeVar v2) = v1 == v2
360+ typesAreEqual (TypeLevelString s1) (TypeLevelString s2) = s1 == s2
361+ typesAreEqual (TypeConstructor c1) (TypeConstructor c2) = c1 == c2
362+ typesAreEqual (TypeApp h1 t1) (TypeApp h2 t2) = typesAreEqual h1 h2 && typesAreEqual t1 t2
363+ typesAreEqual REmpty REmpty = True
364+ typesAreEqual r1 r2 | isRCons r1 || isRCons r2 =
365+ let (s1, r1') = rowToList r1
366+ (s2, r2') = rowToList r2
367+
368+ int = [ (t1, t2) | (name, t1) <- s1, (name', t2) <- s2, name == name' ]
369+ sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ]
370+ sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ]
371+ in all (uncurry typesAreEqual) int && go sd1 r1' sd2 r2'
372+ where
373+ go :: [(String, Type)] -> Type -> [(String, Type)] -> Type -> Bool
374+ go [] (TUnknown u1) [] (TUnknown u2) | u1 == u2 = True
375+ go [] (Skolem _ s1 _ _) [] (Skolem _ s2 _ _) = s1 == s2
376+ go [] REmpty [] REmpty = True
377+ go [] (TypeVar v1) [] (TypeVar v2) = v1 == v2
378+ go _ _ _ _ = False
379+ typesAreEqual _ _ = False
380+
381+ isRCons :: Type -> Bool
382+ isRCons RCons{} = True
383+ isRCons _ = False
384+
385+-- | Add a dictionary for the constraint to the scope, and dictionaries
386+-- for all implied superclass instances.
387+newDictionaries
388+ :: MonadState CheckState m
389+ => [(Qualified (ProperName 'ClassName), Integer)]
390+ -> Qualified Ident
391+ -> Constraint
392+ -> m [TypeClassDictionaryInScope]
393+newDictionaries path name (Constraint className instanceTy _) = do
394+ tcs <- gets (typeClasses . checkEnv)
395+ let TypeClassData{..} = fromMaybe (internalError "newDictionaries: type class lookup failed") $ M.lookup className tcs
396+ supDicts <- join <$> zipWithM (\(Constraint supName supArgs _) index ->
397+ newDictionaries ((supName, index) : path)
398+ name
399+ (Constraint supName (instantiateSuperclass (map fst typeClassArguments) supArgs instanceTy) Nothing)
400+ ) typeClassSuperclasses [0..]
401+ return (TypeClassDictionaryInScope name path className instanceTy Nothing : supDicts)
402+ where
403+ instantiateSuperclass :: [String] -> [Type] -> [Type] -> [Type]
404+ instantiateSuperclass args supArgs tys = map (replaceAllTypeVars (zip args tys)) supArgs
405+
406+mkContext :: [TypeClassDictionaryInScope] -> InstanceContext
407+mkContext = foldr combineContexts M.empty . map fromDict where
408+ fromDict d = M.singleton Nothing (M.singleton (tcdClassName d) (M.singleton (tcdName d) d))
409+
410+-- | Check all pairs of values in a list match a predicate
411+pairwiseAll :: (a -> a -> Bool) -> [a] -> Bool
412+pairwiseAll _ [] = True
413+pairwiseAll _ [_] = True
414+pairwiseAll p (x : xs) = all (p x) xs && pairwiseAll p xs
415+
416+-- | Check any pair of values in a list match a predicate
417+pairwiseAny :: (a -> a -> Bool) -> [a] -> Bool
418+pairwiseAny _ [] = False
419+pairwiseAny _ [_] = False
420+pairwiseAny p (x : xs) = any (p x) xs || pairwiseAny p xs
421+
422+pairwiseM :: Applicative m => (a -> a -> m ()) -> [a] -> m ()
423+pairwiseM _ [] = pure ()
424+pairwiseM _ [_] = pure ()
425+pairwiseM p (x : xs) = traverse (p x) xs *> pairwiseM p xs
src/Language/PureScript/TypeChecker/Kinds.hs+7−8
@@ -16,7 +16,6 @@ import Control.Arrow (second)
16import Control.Monad
16import Control.Monad
17import Control.Monad.Error.Class (MonadError(..))
17import Control.Monad.Error.Class (MonadError(..))
18import Control.Monad.State
18import Control.Monad.State
19−import Control.Monad.Writer.Class (MonadWriter(..))
20
19
21import qualified Data.Map as M
20import qualified Data.Map as M
22
21
@@ -96,19 +95,19 @@ unifyKinds k1 k2 = do
96
95
97-- | Infer the kind of a single type
96-- | Infer the kind of a single type
98kindOf
97kindOf
99− :: (MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m)
98+ :: (MonadError MultipleErrors m, MonadState CheckState m)
100 => Type
99 => Type
101 -> m Kind
100 -> m Kind
102kindOf ty = fst <$> kindOfWithScopedVars ty
101kindOf ty = fst <$> kindOfWithScopedVars ty
103
102
104-- | Infer the kind of a single type, returning the kinds of any scoped type variables
103-- | Infer the kind of a single type, returning the kinds of any scoped type variables
105kindOfWithScopedVars ::
104kindOfWithScopedVars ::
106− (MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m) =>
105+ (MonadError MultipleErrors m, MonadState CheckState m) =>
107 Type ->
106 Type ->
108 m (Kind, [(String, Kind)])
107 m (Kind, [(String, Kind)])
109kindOfWithScopedVars ty =
108kindOfWithScopedVars ty =
110 withErrorMessageHint (ErrorCheckingKind ty) $
109 withErrorMessageHint (ErrorCheckingKind ty) $
111− fmap tidyUp . liftUnify $ infer ty
110+ fmap tidyUp . withFreshSubstitution . captureSubstitution $ infer ty
112 where
111 where
113 tidyUp ((k, args), sub) = ( starIfUnknown (substituteKind sub k)
112 tidyUp ((k, args), sub) = ( starIfUnknown (substituteKind sub k)
114 , map (second (starIfUnknown . substituteKind sub)) args
113 , map (second (starIfUnknown . substituteKind sub)) args
@@ -116,14 +115,14 @@ kindOfWithScopedVars ty =
116
115
117-- | Infer the kind of a type constructor with a collection of arguments and a collection of associated data constructors
116-- | Infer the kind of a type constructor with a collection of arguments and a collection of associated data constructors
118kindsOf
117kindsOf
119− :: (MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m)
118+ :: (MonadError MultipleErrors m, MonadState CheckState m)
120 => Bool
119 => Bool
121 -> ModuleName
120 -> ModuleName
122 -> ProperName 'TypeName
121 -> ProperName 'TypeName
123 -> [(String, Maybe Kind)]
122 -> [(String, Maybe Kind)]
124 -> [Type]
123 -> [Type]
125 -> m Kind
124 -> m Kind
126−kindsOf isData moduleName name args ts = fmap tidyUp . liftUnify $ do
125+kindsOf isData moduleName name args ts = fmap tidyUp . withFreshSubstitution . captureSubstitution $ do
127 tyCon <- freshKind
126 tyCon <- freshKind
128 kargs <- replicateM (length args) freshKind
127 kargs <- replicateM (length args) freshKind
129 rest <- zipWithM freshKindVar args kargs
128 rest <- zipWithM freshKindVar args kargs
@@ -145,12 +144,12 @@ freshKindVar (arg, Just kind') kind = do
145
144
146-- | Simultaneously infer the kinds of several mutually recursive type constructors
145-- | Simultaneously infer the kinds of several mutually recursive type constructors
147kindsOfAll
146kindsOfAll
148− :: (MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m)
147+ :: (MonadError MultipleErrors m, MonadState CheckState m)
149 => ModuleName
148 => ModuleName
150 -> [(ProperName 'TypeName, [(String, Maybe Kind)], Type)]
149 -> [(ProperName 'TypeName, [(String, Maybe Kind)], Type)]
151 -> [(ProperName 'TypeName, [(String, Maybe Kind)], [Type])]
150 -> [(ProperName 'TypeName, [(String, Maybe Kind)], [Type])]
152 -> m ([Kind], [Kind])
151 -> m ([Kind], [Kind])
153−kindsOfAll moduleName syns tys = fmap tidyUp . liftUnify $ do
152+kindsOfAll moduleName syns tys = fmap tidyUp . withFreshSubstitution . captureSubstitution $ do
154 synVars <- replicateM (length syns) freshKind
153 synVars <- replicateM (length syns) freshKind
155 let dict = zipWith (\(name, _, _) var -> (name, var)) syns synVars
154 let dict = zipWith (\(name, _, _) var -> (name, var)) syns synVars
156 bindLocalTypeVariables moduleName dict $ do
155 bindLocalTypeVariables moduleName dict $ do
src/Language/PureScript/TypeChecker/Monad.hs+31−19
@@ -11,7 +11,7 @@ import Prelude.Compat
11import Control.Arrow (second)
11import Control.Arrow (second)
12import Control.Monad.Error.Class (MonadError(..))
12import Control.Monad.Error.Class (MonadError(..))
13import Control.Monad.State
13import Control.Monad.State
14−import Control.Monad.Writer.Class (MonadWriter(..), listen, censor)
14+import Control.Monad.Writer.Class (MonadWriter(..), censor)
15
15
16import Data.Maybe
16import Data.Maybe
17import qualified Data.Map as M
17import qualified Data.Map as M
@@ -245,7 +245,7 @@ getEnv = checkEnv <$> get
245getLocalContext :: MonadState CheckState m => m Context
245getLocalContext :: MonadState CheckState m => m Context
246getLocalContext = do
246getLocalContext = do
247 env <- getEnv
247 env <- getEnv
248− return [ (ident, ty') | ((Qualified Nothing ident@Ident{}), (ty', _, Defined)) <- M.toList (names env) ]
248+ return [ (ident, ty') | (Qualified Nothing ident@Ident{}, (ty', _, Defined)) <- M.toList (names env) ]
249
249
250-- | Update the @Environment@
250-- | Update the @Environment@
251putEnv :: (MonadState CheckState m) => Environment -> m ()
251putEnv :: (MonadState CheckState m) => Environment -> m ()
@@ -269,23 +269,35 @@ guardWith _ True = return ()
269guardWith e False = throwError e
269guardWith e False = throwError e
270
270
271-- | Run a computation in the substitution monad, generating a return value and the final substitution.
271-- | Run a computation in the substitution monad, generating a return value and the final substitution.
272−liftUnify ::
272+captureSubstitution
273− (MonadState CheckState m, MonadWriter MultipleErrors m, MonadError MultipleErrors m) =>
273+ :: MonadState CheckState m
274− m a ->
274+ => m a
275− m (a, Substitution)
275+ -> m (a, Substitution)
276−liftUnify = liftUnifyWarnings (const id)
276+captureSubstitution = capturingSubstitution (,)
277−
277+
278−-- | Run a computation in the substitution monad, generating a return value, the final substitution and updating warnings values.
278+capturingSubstitution
279−liftUnifyWarnings ::
279+ :: MonadState CheckState m
280− (MonadState CheckState m, MonadWriter MultipleErrors m, MonadError MultipleErrors m) =>
280+ => (a -> Substitution -> b)
281− (Substitution -> ErrorMessage -> ErrorMessage) ->
281+ -> m a
282− m a ->
282+ -> m b
283− m (a, Substitution)
283+capturingSubstitution f ma = do
284−liftUnifyWarnings replace ma = do
284+ a <- ma
285+ subst <- gets checkSubstitution
286+ return (f a subst)
287+
288+withFreshSubstitution
289+ :: MonadState CheckState m
290+ => m a
291+ -> m a
292+withFreshSubstitution ma = do
285 orig <- get
293 orig <- get
286 modify $ \st -> st { checkSubstitution = emptySubstitution }
294 modify $ \st -> st { checkSubstitution = emptySubstitution }
287− (a, w) <- reflectErrors . censor (const mempty) . reifyErrors . listen $ ma
295+ a <- ma
288− subst <- gets checkSubstitution
289− tell . onErrorMessages (replace subst) $ w
290 modify $ \st -> st { checkSubstitution = checkSubstitution orig }
296 modify $ \st -> st { checkSubstitution = checkSubstitution orig }
291− return (a, subst)
297+ return a
298+
299+withoutWarnings
300+ :: MonadWriter w m
301+ => m a
302+ -> m (a, w)
303+withoutWarnings = censor (const mempty) . listen
src/Language/PureScript/TypeChecker/Skolems.hs+3−3
@@ -61,7 +61,7 @@ skolemize ident sko scope ss = replaceTypeVars ident (Skolem ident sko scope ss)
61
61
62-- |
62-- |
63-- This function has one purpose - to skolemize type variables appearing in a
63-- This function has one purpose - to skolemize type variables appearing in a
64−-- SuperClassDictionary placeholder. These type variables are somewhat unique since they are the
64+-- DeferredDictionary placeholder. These type variables are somewhat unique since they are the
65-- only example of scoped type variables.
65-- only example of scoped type variables.
66--
66--
67skolemizeTypesInValue :: String -> Int -> SkolemScope -> Maybe SourceSpan -> Expr -> Expr
67skolemizeTypesInValue :: String -> Int -> SkolemScope -> Maybe SourceSpan -> Expr -> Expr
@@ -71,8 +71,8 @@ skolemizeTypesInValue ident sko scope ss =
71 in runIdentity . f
71 in runIdentity . f
72 where
72 where
73 onExpr :: [String] -> Expr -> Identity ([String], Expr)
73 onExpr :: [String] -> Expr -> Identity ([String], Expr)
74− onExpr sco (SuperClassDictionary c ts)
74+ onExpr sco (DeferredDictionary c ts)
75− | ident `notElem` sco = return (sco, SuperClassDictionary c (map (skolemize ident sko scope ss) ts))
75+ | ident `notElem` sco = return (sco, DeferredDictionary c (map (skolemize ident sko scope ss) ts))
76 onExpr sco (TypedValue check val ty)
76 onExpr sco (TypedValue check val ty)
77 | ident `notElem` sco = return (sco ++ peelTypeVars ty, TypedValue check val (skolemize ident sko scope ss ty))
77 | ident `notElem` sco = return (sco ++ peelTypeVars ty, TypedValue check val (skolemize ident sko scope ss ty))
78 onExpr sco other = return (sco, other)
78 onExpr sco other = return (sco, other)
src/Language/PureScript/TypeChecker/Subsumption.hs+17−8
@@ -7,10 +7,13 @@ module Language.PureScript.TypeChecker.Subsumption
7
7
8import Prelude.Compat
8import Prelude.Compat
9
9
10+import Control.Monad (when)
10import Control.Monad.Error.Class (MonadError(..))
11import Control.Monad.Error.Class (MonadError(..))
11import Control.Monad.State.Class (MonadState(..), gets)
12import Control.Monad.State.Class (MonadState(..), gets)
12
13
13−import Data.List (sortBy)
14+import Data.Foldable (for_)
15+import Data.List (sortBy, uncons)
16+import Data.List.Ordered (minusBy')
14import Data.Ord (comparing)
17import Data.Ord (comparing)
15
18
16import Language.PureScript.AST
19import Language.PureScript.AST
@@ -26,7 +29,7 @@ import Language.PureScript.Types
26subsumes :: (MonadError MultipleErrors m, MonadState CheckState m) => Maybe Expr -> Type -> Type -> m (Maybe Expr)
29subsumes :: (MonadError MultipleErrors m, MonadState CheckState m) => Maybe Expr -> Type -> Type -> m (Maybe Expr)
27subsumes val ty1 ty2 = withErrorMessageHint (ErrorInSubsumption ty1 ty2) $ subsumes' val ty1 ty2
30subsumes val ty1 ty2 = withErrorMessageHint (ErrorInSubsumption ty1 ty2) $ subsumes' val ty1 ty2
28
31
29−-- | Check tahat one type subsumes another
32+-- | Check that one type subsumes another
30subsumes' :: (MonadError MultipleErrors m, MonadState CheckState m) =>
33subsumes' :: (MonadError MultipleErrors m, MonadState CheckState m) =>
31 Maybe Expr ->
34 Maybe Expr ->
32 Type ->
35 Type ->
@@ -60,6 +63,14 @@ subsumes' val (TypeApp f1 r1) (TypeApp f2 r2) | f1 == tyRecord && f2 == tyRecord
60 (ts2, r2') = rowToList r2
63 (ts2, r2') = rowToList r2
61 ts1' = sortBy (comparing fst) ts1
64 ts1' = sortBy (comparing fst) ts1
62 ts2' = sortBy (comparing fst) ts2
65 ts2' = sortBy (comparing fst) ts2
66+ -- For { ts1 | r1 } to subsume { ts2 | r2 } when r1 is empty (= we're working with a closed row),
67+ -- every property in ts2 must appear in ts1. If not, then the candidate expression is missing a required property.
68+ -- Conversely, when r2 is empty, every property in ts1 must appear in ts2, or else the expression has
69+ -- an additional property which is not allowed.
70+ when (r1' == REmpty)
71+ (for_ (firstMissingProp ts2' ts1') (throwError . errorMessage . PropertyIsMissing . fst))
72+ when (r2' == REmpty)
73+ (for_ (firstMissingProp ts1' ts2') (throwError . errorMessage . AdditionalProperty . fst))
63 go ts1' ts2' r1' r2'
74 go ts1' ts2' r1' r2'
64 return val
75 return val
65 where
76 where
@@ -72,15 +83,13 @@ subsumes' val (TypeApp f1 r1) (TypeApp f2 r2) | f1 == tyRecord && f2 == tyRecord
72 -- What happens next is a bit of a hack.
83 -- What happens next is a bit of a hack.
73 -- TODO: in the new type checker, object properties will probably be restricted to being monotypes
84 -- TODO: in the new type checker, object properties will probably be restricted to being monotypes
74 -- in which case, this branch of the subsumes function should not even be necessary.
85 -- in which case, this branch of the subsumes function should not even be necessary.
75− case r2' of
86+ unifyTypes r2' (RCons p1 ty1 rest)
76− REmpty -> throwError . errorMessage $ AdditionalProperty p1
77− _ -> unifyTypes r2' (RCons p1 ty1 rest)
78 go ts1 ((p2, ty2) : ts2) r1' rest
87 go ts1 ((p2, ty2) : ts2) r1' rest
79 | otherwise = do rest <- freshType
88 | otherwise = do rest <- freshType
80− case r1' of
89+ unifyTypes r1' (RCons p2 ty2 rest)
81− REmpty -> throwError . errorMessage $ PropertyIsMissing p2
82− _ -> unifyTypes r1' (RCons p2 ty2 rest)
83 go ((p1, ty1) : ts1) ts2 rest r2'
90 go ((p1, ty1) : ts1) ts2 rest r2'
91+ -- Find the first property that's in the first list (of tuples) but not in the second
92+ firstMissingProp t1 t2 = fst <$> uncons (minusBy' (comparing fst) t1 t2)
84subsumes' val ty1 ty2@(TypeApp obj _) | obj == tyRecord = subsumes val ty2 ty1
93subsumes' val ty1 ty2@(TypeApp obj _) | obj == tyRecord = subsumes val ty2 ty1
85subsumes' val ty1 ty2 = do
94subsumes' val ty1 ty2 = do
86 unifyTypes ty1 ty2
95 unifyTypes ty1 ty2
src/Language/PureScript/TypeChecker/Types.hs+125−119
@@ -1,4 +1,5 @@
1{-# LANGUAGE OverloadedStrings #-}
1{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE NamedFieldPuns #-}
2
3
3-- |
4-- |
4-- This module implements the type checker
5-- This module implements the type checker
@@ -36,6 +37,7 @@ import Data.Either (lefts, rights)
36import Data.List (transpose, nub, (\\), partition, delete)
37import Data.List (transpose, nub, (\\), partition, delete)
37import Data.Maybe (fromMaybe)
38import Data.Maybe (fromMaybe)
38import qualified Data.Map as M
39import qualified Data.Map as M
40+import qualified Data.Set as S
39
41
40import Language.PureScript.AST
42import Language.PureScript.AST
41import Language.PureScript.Crash
43import Language.PureScript.Crash
@@ -52,7 +54,6 @@ import Language.PureScript.TypeChecker.Skolems
52import Language.PureScript.TypeChecker.Subsumption
54import Language.PureScript.TypeChecker.Subsumption
53import Language.PureScript.TypeChecker.Synonyms
55import Language.PureScript.TypeChecker.Synonyms
54import Language.PureScript.TypeChecker.Unify
56import Language.PureScript.TypeChecker.Unify
55−import Language.PureScript.TypeClassDictionaries
56import Language.PureScript.Types
57import Language.PureScript.Types
57
58
58data BindingGroupType
59data BindingGroupType
@@ -62,65 +63,78 @@ data BindingGroupType
62
63
63-- | Infer the types of multiple mutually-recursive values, and return elaborated values including
64-- | Infer the types of multiple mutually-recursive values, and return elaborated values including
64-- type class dictionaries and type annotations.
65-- type class dictionaries and type annotations.
65−typesOf ::
66+typesOf
66− (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
67+ :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
67− BindingGroupType ->
68+ => BindingGroupType
68− ModuleName ->
69+ -> ModuleName
69− [(Ident, Expr)] ->
70+ -> [(Ident, Expr)]
70− m [(Ident, (Expr, Type))]
71+ -> m [(Ident, (Expr, Type))]
71−typesOf bindingGroupType moduleName vals = do
72+typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do
72− tys <- fmap tidyUp . escalateWarningWhen isHoleError . liftUnifyWarnings replace $ do
73+ (tys, w) <- withoutWarnings . capturingSubstitution tidyUp $ do
73− (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup (Just moduleName) vals
74+ (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup (Just moduleName) vals
74− ds1 <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict
75+ ds1 <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict
75− ds2 <- forM untyped $ \e -> typeForBindingGroupElement e dict untypedDict
76+ ds2 <- forM untyped $ \e -> typeForBindingGroupElement e dict untypedDict
76− return (map (\x -> (False, x)) ds1 ++ map (\x -> (True, x)) ds2)
77+ return (map (\x -> (False, x)) ds1 ++ map (\x -> (True, x)) ds2)
77−
78+
78− forM tys $ \(shouldGeneralize, (ident, (val, ty))) -> do
79+ inferred <- forM tys $ \(shouldGeneralize, (ident, (val, ty))) -> do
79− -- Replace type class dictionary placeholders with actual dictionaries
80+ -- Replace type class dictionary placeholders with actual dictionaries
80− (val', unsolved) <- replaceTypeClassDictionaries shouldGeneralize moduleName val
81+ (val', unsolved) <- replaceTypeClassDictionaries shouldGeneralize val
81− let unsolvedTypeVars = nub $ unknownsInType ty
82+ -- Generalize and constrain the type
82− -- Generalize and constrain the type
83+ currentSubst <- gets checkSubstitution
83− let generalized = generalize unsolved ty
84+ let ty' = substituteType currentSubst ty
84−
85+ unsolvedTypeVars = nub $ unknownsInType ty'
85− when shouldGeneralize $ do
86+ generalized = generalize unsolved ty'
86− -- Show the inferred type in a warning
87+
87− tell . errorMessage $ MissingTypeDeclaration ident generalized
88+ when shouldGeneralize $ do
88− -- For non-recursive binding groups, can generalize over constraints.
89+ -- Show the inferred type in a warning
89− -- For recursive binding groups, we throw an error here for now.
90+ tell . errorMessage $ MissingTypeDeclaration ident generalized
90− when (bindingGroupType == RecursiveBindingGroup && not (null unsolved))
91+ -- For non-recursive binding groups, can generalize over constraints.
91− . throwError
92+ -- For recursive binding groups, we throw an error here for now.
92− . errorMessage
93+ when (bindingGroupType == RecursiveBindingGroup && not (null unsolved))
93− $ CannotGeneralizeRecursiveFunction ident generalized
94+ . throwError
94− -- Make sure any unsolved type constraints only use type variables which appear
95+ . errorMessage
95− -- unknown in the inferred type.
96+ $ CannotGeneralizeRecursiveFunction ident generalized
96− forM_ unsolved $ \(_, con) -> do
97+ -- Make sure any unsolved type constraints only use type variables which appear
97− let constraintTypeVars = nub $ foldMap unknownsInType (constraintArgs con)
98+ -- unknown in the inferred type.
98− when (any (`notElem` unsolvedTypeVars) constraintTypeVars) $
99+ forM_ unsolved $ \(_, con) -> do
99− throwError . errorMessage $ NoInstanceFound con
100+ -- We need information about functional dependencies, since we allow
100−
101+ -- ambiguous types to be inferred if they can be solved by some functional
101− -- Check skolem variables did not escape their scope
102+ -- dependency.
102− skolemEscapeCheck val'
103+ let findClass = fromMaybe (internalError "entails: type class not found in environment") . M.lookup (constraintClass con)
103− -- Check rows do not contain duplicate labels
104+ TypeClassData{ typeClassDependencies } <- gets (findClass . typeClasses . checkEnv)
104− checkDuplicateLabels val'
105+ let solved = foldMap (S.fromList . fdDetermined) typeClassDependencies
105− return (ident, (foldr (Abs . Left . fst) val' unsolved, generalized))
106+ let constraintTypeVars = nub . foldMap (unknownsInType . fst) . filter ((`notElem` solved) . snd) $ zip (constraintArgs con) [0..]
107+ when (any (`notElem` unsolvedTypeVars) constraintTypeVars) $
108+ throwError . onErrorMessages (replaceTypes currentSubst) . errorMessage $ NoInstanceFound con
109+
110+ -- Check skolem variables did not escape their scope
111+ skolemEscapeCheck val'
112+ -- Check rows do not contain duplicate labels
113+ checkDuplicateLabels val'
114+ return (ident, (foldr (Abs . Left . fst) val' unsolved, generalized))
115+
116+ -- Show warnings here, since types in wildcards might have been solved during
117+ -- instance resolution (by functional dependencies).
118+ finalSubst <- gets checkSubstitution
119+ escalateWarningWhen isHoleError . tell . onErrorMessages (replaceTypes finalSubst) $ w
120+
121+ return inferred
106 where
122 where
123+ replaceTypes subst = onTypesInErrorMessage (substituteType subst)
107
124
108− -- | Generalize type vars using forall and add inferred constraints
125+ -- | Generalize type vars using forall and add inferred constraints
109− generalize unsolved = varIfUnknown . constrain unsolved
126+ generalize unsolved = varIfUnknown . constrain unsolved
110
127
111− -- | Add any unsolved constraints
128+ -- | Add any unsolved constraints
112− constrain [] = id
129+ constrain [] = id
113− constrain cs = ConstrainedType (map snd cs)
130+ constrain cs = ConstrainedType (map snd cs)
114
131
115− -- Apply the substitution that was returned from runUnify to both types and (type-annotated) values
132+ -- Apply the substitution that was returned from runUnify to both types and (type-annotated) values
116− tidyUp (ts, sub) = map (\(b, (i, (val, ty))) -> (b, (i, (overTypes (substituteType sub) val, substituteType sub ty)))) ts
133+ tidyUp ts sub = map (\(b, (i, (val, ty))) -> (b, (i, (overTypes (substituteType sub) val, substituteType sub ty)))) ts
117
134
118− -- Replace all the wildcards types with their inferred types
135+ isHoleError :: ErrorMessage -> Bool
119− replace sub = onTypesInErrorMessage (substituteType sub)
136+ isHoleError (ErrorMessage _ HoleInferredType{}) = True
120−
137+ isHoleError _ = False
121− isHoleError :: ErrorMessage -> Bool
122− isHoleError (ErrorMessage _ HoleInferredType{}) = True
123− isHoleError _ = False
124
138
125type TypeData = M.Map (Qualified Ident) (Type, NameKind, NameVisibility)
139type TypeData = M.Map (Qualified Ident) (Type, NameKind, NameVisibility)
126
140
@@ -148,7 +162,7 @@ typeDictionaryForBindingGroup moduleName vals = do
148 -- Make a map of names to the unification variables of untyped declarations
162 -- Make a map of names to the unification variables of untyped declarations
149 untypedDict = zip (map fst untyped) untypedNames
163 untypedDict = zip (map fst untyped) untypedNames
150 -- Create the dictionary of all name/type pairs, which will be added to the environment during type checking
164 -- Create the dictionary of all name/type pairs, which will be added to the environment during type checking
151− dict = M.fromList (map (\(ident, ty) -> ((Qualified moduleName ident), (ty, Private, Undefined))) $ typedDict ++ untypedDict)
165+ dict = M.fromList (map (\(ident, ty) -> (Qualified moduleName ident, (ty, Private, Undefined))) $ typedDict ++ untypedDict)
152 return (untyped, typed, dict, untypedDict)
166 return (untyped, typed, dict, untypedDict)
153
167
154checkTypedBindingGroupElement
168checkTypedBindingGroupElement
@@ -278,7 +292,7 @@ infer' (Abs (Left arg) ret) = do
278infer' (Abs (Right _) _) = internalError "Binder was not desugared"
292infer' (Abs (Right _) _) = internalError "Binder was not desugared"
279infer' (App f arg) = do
293infer' (App f arg) = do
280 f'@(TypedValue _ _ ft) <- infer f
294 f'@(TypedValue _ _ ft) <- infer f
281− (ret, app) <- checkFunctionApplication f' ft arg Nothing
295+ (ret, app) <- checkFunctionApplication f' ft arg
282 return $ TypedValue True app ret
296 return $ TypedValue True app ret
283infer' (Var var) = do
297infer' (Var var) = do
284 checkVisibility var
298 checkVisibility var
@@ -311,7 +325,7 @@ infer' (IfThenElse cond th el) = do
311infer' (Let ds val) = do
325infer' (Let ds val) = do
312 (ds', val'@(TypedValue _ _ valTy)) <- inferLetBinding [] ds val infer
326 (ds', val'@(TypedValue _ _ valTy)) <- inferLetBinding [] ds val infer
313 return $ TypedValue True (Let ds' val') valTy
327 return $ TypedValue True (Let ds' val') valTy
314−infer' (SuperClassDictionary className tys) = do
328+infer' (DeferredDictionary className tys) = do
315 dicts <- getTypeClassDictionaries
329 dicts <- getTypeClassDictionaries
316 hints <- gets checkHints
330 hints <- gets checkHints
317 return $ TypeClassDictionary (Constraint className tys Nothing) dicts hints
331 return $ TypeClassDictionary (Constraint className tys Nothing) dicts hints
@@ -526,26 +540,6 @@ check' val t@(ConstrainedType constraints ty) = do
526 dicts <- join <$> zipWithM (newDictionaries []) (map (Qualified Nothing) dictNames) constraints
540 dicts <- join <$> zipWithM (newDictionaries []) (map (Qualified Nothing) dictNames) constraints
527 val' <- withBindingGroupVisible $ withTypeClassDictionaries dicts $ check val ty
541 val' <- withBindingGroupVisible $ withTypeClassDictionaries dicts $ check val ty
528 return $ TypedValue True (foldr (Abs . Left) val' dictNames) t
542 return $ TypedValue True (foldr (Abs . Left) val' dictNames) t
529− where
530− -- | Add a dictionary for the constraint to the scope, and dictionaries
531− -- for all implied superclass instances.
532− newDictionaries
533− :: [(Qualified (ProperName 'ClassName), Integer)]
534− -> Qualified Ident
535− -> Constraint
536− -> m [TypeClassDictionaryInScope]
537− newDictionaries path name (Constraint className instanceTy _) = do
538− tcs <- gets (typeClasses . checkEnv)
539− let (args, _, superclasses) = fromMaybe (internalError "newDictionaries: type class lookup failed") $ M.lookup className tcs
540− supDicts <- join <$> zipWithM (\(Constraint supName supArgs _) index ->
541− newDictionaries ((supName, index) : path)
542− name
543− (Constraint supName (instantiateSuperclass (map fst args) supArgs instanceTy) Nothing)
544− ) superclasses [0..]
545− return (TypeClassDictionaryInScope name path className instanceTy Nothing : supDicts)
546−
547− instantiateSuperclass :: [String] -> [Type] -> [Type] -> [Type]
548− instantiateSuperclass args supArgs tys = map (replaceAllTypeVars (zip args tys)) supArgs
549check' val u@(TUnknown _) = do
543check' val u@(TUnknown _) = do
550 val'@(TypedValue _ _ ty) <- infer val
544 val'@(TypedValue _ _ ty) <- infer val
551 -- Don't unify an unknown with an inferred polytype
545 -- 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
573check' (Abs (Right _) _) _ = internalError "Binder was not desugared"
567check' (Abs (Right _) _) _ = internalError "Binder was not desugared"
574check' (App f arg) ret = do
568check' (App f arg) ret = do
575 f'@(TypedValue _ _ ft) <- infer f
569 f'@(TypedValue _ _ ft) <- infer f
576− (_, app) <- checkFunctionApplication f' ft arg (Just ret)
570+ (retTy, app) <- checkFunctionApplication f' ft arg
577− return $ TypedValue True app ret
571+ v' <- subsumes (Just app) retTy ret
572+ case v' of
573+ Nothing -> internalError "check: unable to check the subsumes relation."
574+ Just app' -> return $ TypedValue True app' ret
578check' v@(Var var) ty = do
575check' v@(Var var) ty = do
579 checkVisibility var
576 checkVisibility var
580 repl <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< lookupVariable $ var
577 repl <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< lookupVariable $ var
@@ -583,7 +580,7 @@ check' v@(Var var) ty = do
583 case v' of
580 case v' of
584 Nothing -> internalError "check: unable to check the subsumes relation."
581 Nothing -> internalError "check: unable to check the subsumes relation."
585 Just v'' -> return $ TypedValue True v'' ty'
582 Just v'' -> return $ TypedValue True v'' ty'
586−check' (SuperClassDictionary className tys) _ = do
583+check' (DeferredDictionary className tys) _ = do
587 {-
584 {-
588 -- Here, we replace a placeholder for a superclass dictionary with a regular
585 -- Here, we replace a placeholder for a superclass dictionary with a regular
589 -- TypeClassDictionary placeholder. The reason we do this is that it is necessary to have the
586 -- 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
698 return $ (p, v') : ps''
695 return $ (p, v') : ps''
699 go _ _ _ = throwError . errorMessage $ ExprDoesNotHaveType expr (TypeApp tyRecord row)
696 go _ _ _ = throwError . errorMessage $ ExprDoesNotHaveType expr (TypeApp tyRecord row)
700
697
701−-- | Check the type of a function application, rethrowing errors to provide a better error message
698+-- | Check the type of a function application, rethrowing errors to provide a better error message.
702−checkFunctionApplication ::
699+--
703− (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
700+-- This judgment takes three inputs:
704− Expr ->
701+--
705− Type ->
702+-- * The expression of the function we are applying
706− Expr ->
703+-- * The type of that function
707− Maybe Type ->
704+-- * The expression we are applying it to
708− m (Type, Expr)
705+--
709−checkFunctionApplication fn fnTy arg ret = withErrorMessageHint (ErrorInApplication fn fnTy arg) $ do
706+-- and synthesizes two outputs:
707+--
708+-- * The return type
709+-- * The elaborated expression for the function application (since we might need to
710+-- insert type class dictionaries, etc.)
711+checkFunctionApplication
712+ :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
713+ => Expr
714+ -- ^ The function expression
715+ -> Type
716+ -- ^ The type of the function
717+ -> Expr
718+ -- ^ The argument expression
719+ -> m (Type, Expr)
720+ -- ^ The result type, and the elaborated term
721+checkFunctionApplication fn fnTy arg = withErrorMessageHint (ErrorInApplication fn fnTy arg) $ do
710 subst <- gets checkSubstitution
722 subst <- gets checkSubstitution
711− checkFunctionApplication' fn (substituteType subst fnTy) arg (substituteType subst <$> ret)
723+ checkFunctionApplication' fn (substituteType subst fnTy) arg
712
724
713-- | Check the type of a function application
725-- | Check the type of a function application
714−checkFunctionApplication' ::
726+checkFunctionApplication'
715− (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
727+ :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
716− Expr ->
728+ => Expr
717− Type ->
729+ -> Type
718− Expr ->
730+ -> Expr
719− Maybe Type ->
731+ -> m (Type, Expr)
720− m (Type, Expr)
732+checkFunctionApplication' fn (TypeApp (TypeApp tyFunction' argTy) retTy) arg = do
721−checkFunctionApplication' fn (TypeApp (TypeApp tyFunction' argTy) retTy) arg ret = do
722 unifyTypes tyFunction' tyFunction
733 unifyTypes tyFunction' tyFunction
723 arg' <- check arg argTy
734 arg' <- check arg argTy
724− case ret of
735+ return (retTy, App fn arg')
725− Nothing -> return (retTy, App fn arg')
736+checkFunctionApplication' fn (ForAll ident ty _) arg = do
726− Just ret' -> do
727− Just app' <- subsumes (Just (App fn arg')) retTy ret'
728− return (retTy, app')
729−checkFunctionApplication' fn (ForAll ident ty _) arg ret = do
730 replaced <- replaceVarWithUnknown ident ty
737 replaced <- replaceVarWithUnknown ident ty
731− checkFunctionApplication fn replaced arg ret
738+ checkFunctionApplication fn replaced arg
732−checkFunctionApplication' fn u@(TUnknown _) arg ret = do
739+checkFunctionApplication' fn (KindedType ty _) arg =
740+ checkFunctionApplication fn ty arg
741+checkFunctionApplication' fn (ConstrainedType constraints fnTy) arg = do
742+ dicts <- getTypeClassDictionaries
743+ hints <- gets checkHints
744+ checkFunctionApplication' (foldl App fn (map (\cs -> TypeClassDictionary cs dicts hints) constraints)) fnTy arg
745+checkFunctionApplication' fn fnTy dict@TypeClassDictionary{} =
746+ return (fnTy, App fn dict)
747+checkFunctionApplication' fn u arg = do
733 arg' <- do
748 arg' <- do
734 TypedValue _ arg' t <- infer arg
749 TypedValue _ arg' t <- infer arg
735 (arg'', t') <- instantiatePolyTypeWithUnknowns arg' t
750 (arg'', t') <- instantiatePolyTypeWithUnknowns arg' t
736 return $ TypedValue True arg'' t'
751 return $ TypedValue True arg'' t'
737 let ty = (\(TypedValue _ _ t) -> t) arg'
752 let ty = (\(TypedValue _ _ t) -> t) arg'
738− ret' <- maybe freshType return ret
753+ ret <- freshType
739− unifyTypes u (function ty ret')
754+ unifyTypes u (function ty ret)
740− return (ret', App fn arg')
755+ return (ret, App fn arg')
741−checkFunctionApplication' fn (KindedType ty _) arg ret =
742− checkFunctionApplication fn ty arg ret
743−checkFunctionApplication' fn (ConstrainedType constraints fnTy) arg ret = do
744− dicts <- getTypeClassDictionaries
745− hints <- gets checkHints
746− checkFunctionApplication' (foldl App fn (map (\cs -> TypeClassDictionary cs dicts hints) constraints)) fnTy arg ret
747−checkFunctionApplication' fn fnTy dict@TypeClassDictionary{} _ =
748− return (fnTy, App fn dict)
749−checkFunctionApplication' _ fnTy arg _ = throwError . errorMessage $ CannotApplyFunction fnTy arg
750
756
751-- |
757-- |
752-- Ensure a set of property names and value does not contain duplicate labels
758-- Ensure a set of property names and value does not contain duplicate labels
src/Language/PureScript/TypeChecker/Unify.hs+1−31
@@ -10,7 +10,6 @@ module Language.PureScript.TypeChecker.Unify
10 , unknownsInType
10 , unknownsInType
11 , unifyTypes
11 , unifyTypes
12 , unifyRows
12 , unifyRows
13− , unifiesWith
14 , replaceVarWithUnknown
13 , replaceVarWithUnknown
15 , replaceTypeWildcards
14 , replaceTypeWildcards
16 , varIfUnknown
15 , varIfUnknown
@@ -102,6 +101,7 @@ unifyTypes t1 t2 = do
102 unifyTypes' (TypeVar v1) (TypeVar v2) | v1 == v2 = return ()
101 unifyTypes' (TypeVar v1) (TypeVar v2) | v1 == v2 = return ()
103 unifyTypes' ty1@(TypeConstructor c1) ty2@(TypeConstructor c2) =
102 unifyTypes' ty1@(TypeConstructor c1) ty2@(TypeConstructor c2) =
104 guardWith (errorMessage (TypesDoNotUnify ty1 ty2)) (c1 == c2)
103 guardWith (errorMessage (TypesDoNotUnify ty1 ty2)) (c1 == c2)
104+ unifyTypes' (TypeLevelString s1) (TypeLevelString s2) | s1 == s2 = return ()
105 unifyTypes' (TypeApp t3 t4) (TypeApp t5 t6) = do
105 unifyTypes' (TypeApp t3 t4) (TypeApp t5 t6) = do
106 t3 `unifyTypes` t5
106 t3 `unifyTypes` t5
107 t4 `unifyTypes` t6
107 t4 `unifyTypes` t6
@@ -152,36 +152,6 @@ unifyRows r1 r2 =
152 unifyRows' _ _ _ _ =
152 unifyRows' _ _ _ _ =
153 throwError . errorMessage $ TypesDoNotUnify r1 r2
153 throwError . errorMessage $ TypesDoNotUnify r1 r2
154
154
155−-- |
156−-- Check that two types unify
157−--
158−unifiesWith :: Type -> Type -> Bool
159−unifiesWith (TUnknown u1) (TUnknown u2) = u1 == u2
160−unifiesWith (Skolem _ s1 _ _) (Skolem _ s2 _ _) = s1 == s2
161−unifiesWith (TypeVar v1) (TypeVar v2) = v1 == v2
162−unifiesWith (TypeLevelString s1) (TypeLevelString s2) = s1 == s2
163−unifiesWith (TypeConstructor c1) (TypeConstructor c2) = c1 == c2
164−unifiesWith (TypeApp h1 t1) (TypeApp h2 t2) = h1 `unifiesWith` h2 && t1 `unifiesWith` t2
165−unifiesWith REmpty REmpty = True
166−unifiesWith r1@RCons{} r2@RCons{} =
167− let (s1, r1') = rowToList r1
168− (s2, r2') = rowToList r2
169−
170− int = [ (t1, t2) | (name, t1) <- s1, (name', t2) <- s2, name == name' ]
171− sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ]
172− sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ]
173− in all (uncurry unifiesWith) int && go sd1 r1' sd2 r2'
174− where
175− go :: [(String, Type)] -> Type -> [(String, Type)] -> Type -> Bool
176− go [] REmpty [] REmpty = True
177− go [] (TypeVar v1) [] (TypeVar v2) = v1 == v2
178− go [] (Skolem _ s1 _ _) [] (Skolem _ s2 _ _) = s1 == s2
179− go [] (TUnknown _) _ _ = True
180− go _ _ [] (TUnknown _) = True
181− go _ (TUnknown _) _ (TUnknown _) = True
182− go _ _ _ _ = False
183−unifiesWith _ _ = False
184−
185-- |
155-- |
186-- Replace a single type variable with a new unification variable
156-- Replace a single type variable with a new unification variable
187--
157--
src/Language/PureScript/TypeClassDictionaries.hs−23
@@ -22,26 +22,3 @@ data TypeClassDictionaryInScope
22 , tcdDependencies :: Maybe [Constraint]
22 , tcdDependencies :: Maybe [Constraint]
23 }
23 }
24 deriving (Show)
24 deriving (Show)
25−
26−-- |
27−-- A simplified representation of expressions which are used to represent type
28−-- class dictionaries at runtime, which can be compared for equality
29−--
30−data DictionaryValue
31− -- |
32− -- A dictionary which is brought into scope by a local constraint
33− --
34− = LocalDictionaryValue (Qualified Ident)
35− -- |
36− -- A dictionary which is brought into scope by an instance declaration
37− --
38− | GlobalDictionaryValue (Qualified Ident)
39− -- |
40− -- A dictionary which depends on other dictionaries
41− --
42− | DependentDictionaryValue (Qualified Ident) [DictionaryValue]
43− -- |
44− -- A subclass dictionary
45− --
46− | SubclassDictionaryValue DictionaryValue (Qualified (ProperName 'ClassName)) Integer
47− deriving (Show, Ord, Eq)
src/Language/PureScript/Types.hs+2−2
@@ -257,8 +257,8 @@ everywhereOnTypesTopDown f = go . f
257 go (PrettyPrintFunction t1 t2) = PrettyPrintFunction (go (f t1)) (go (f t2))
257 go (PrettyPrintFunction t1 t2) = PrettyPrintFunction (go (f t1)) (go (f t2))
258 go (PrettyPrintObject t) = PrettyPrintObject (go (f t))
258 go (PrettyPrintObject t) = PrettyPrintObject (go (f t))
259 go (PrettyPrintForAll args t) = PrettyPrintForAll args (go (f t))
259 go (PrettyPrintForAll args t) = PrettyPrintForAll args (go (f t))
260− go (BinaryNoParensType t1 t2 t3) = BinaryNoParensType (f (go t1)) (f (go t2)) (f (go t3))
260+ go (BinaryNoParensType t1 t2 t3) = BinaryNoParensType (go (f t1)) (go (f t2)) (go (f t3))
261− go (ParensInType t) = ParensInType (f (go t))
261+ go (ParensInType t) = ParensInType (go (f t))
262 go other = f other
262 go other = f other
263
263
264everywhereOnTypesM :: Monad m => (Type -> m Type) -> Type -> m Type
264everywhereOnTypesM :: Monad m => (Type -> m Type) -> Type -> m Type
src/System/IO/UTF8.hs+4−15
@@ -2,24 +2,13 @@ module System.IO.UTF8 where
2
2
3import Prelude.Compat
3import Prelude.Compat
4
4
5−import System.IO ( IOMode(..)
5+import qualified Data.ByteString as BS
6− , hGetContents
6+import qualified Data.ByteString.UTF8 as UTF8
7− , hSetEncoding
8− , hClose
9− , hPutStr
10− , openFile
11− , utf8
12− )
13
7
14readUTF8File :: FilePath -> IO String
8readUTF8File :: FilePath -> IO String
15readUTF8File inFile = do
9readUTF8File inFile = do
16− h <- openFile inFile ReadMode
10+ fmap UTF8.toString (BS.readFile inFile)
17− hSetEncoding h utf8
18− hGetContents h
19
11
20writeUTF8File :: FilePath -> String -> IO ()
12writeUTF8File :: FilePath -> String -> IO ()
21writeUTF8File inFile text = do
13writeUTF8File inFile text = do
22− h <- openFile inFile WriteMode
14+ BS.writeFile inFile (UTF8.fromString text)
23− hSetEncoding h utf8
24− hPutStr h text
25− hClose h
stack.yaml+4−1
@@ -1,8 +1,11 @@
1−resolver: lts-6.10
1+resolver: lts-6.13
2packages:
2packages:
3- '.'
3- '.'
4extra-deps:
4extra-deps:
5- aeson-1.0.0.0
5- aeson-1.0.0.0
6+- http-client-0.5.1
7+- http-client-tls-0.3.0
8+- pipes-http-1.0.4
6- semigroups-0.18.2
9- semigroups-0.18.2
7flags:
10flags:
8 semigroups:
11 semigroups:
tests/Language/PureScript/Ide/ImportsSpec.hs+1−1
@@ -70,7 +70,7 @@ spec = do
70 addValueImport i mn is =
70 addValueImport i mn is =
71 prettyPrintImportSection (addExplicitImport' (IdeValue (P.Ident i) wildcard) mn is)
71 prettyPrintImportSection (addExplicitImport' (IdeValue (P.Ident i) wildcard) mn is)
72 addOpImport op mn is =
72 addOpImport op mn is =
73− prettyPrintImportSection (addExplicitImport' (IdeValueOperator op "" 2 P.Infix) mn is)
73+ prettyPrintImportSection (addExplicitImport' (IdeValueOperator op (P.Qualified Nothing (Left (P.Ident ""))) 2 P.Infix Nothing) mn is)
74 addDtorImport i t mn is =
74 addDtorImport i t mn is =
75 prettyPrintImportSection (addExplicitImport' (IdeDataConstructor (P.ProperName i) t wildcard) mn is)
75 prettyPrintImportSection (addExplicitImport' (IdeDataConstructor (P.ProperName i) t wildcard) mn is)
76 it "adds an implicit unqualified import" $
76 it "adds an implicit unqualified import" $
tests/Language/PureScript/Ide/Integration.hs+8−20
@@ -37,13 +37,11 @@ module Language.PureScript.Ide.Integration
37 , getFlexCompletions
37 , getFlexCompletions
38 , getFlexCompletionsInModule
38 , getFlexCompletionsInModule
39 , getType
39 , getType
40− , getInfo
41 , rebuildModule
40 , rebuildModule
42 , reset
41 , reset
43 -- checking results
42 -- checking results
44 , resultIsSuccess
43 , resultIsSuccess
45 , parseCompletions
44 , parseCompletions
46− , parseInfo
47 , parseTextResult
45 , parseTextResult
48 ) where
46 ) where
49
47
@@ -95,7 +93,7 @@ compileTestProject = do
95 pdir <- projectDirectory
93 pdir <- projectDirectory
96 (_, _, _, procHandle) <- createProcess $
94 (_, _, _, procHandle) <- createProcess $
97 (shell . toS $ "psc " <> fileGlob) { cwd = Just pdir }
95 (shell . toS $ "psc " <> fileGlob) { cwd = Just pdir }
98− r <- tryNTimes 5 (getProcessExitCode procHandle)
96+ r <- tryNTimes 10 (getProcessExitCode procHandle)
99 pure (fromMaybe False (isSuccess <$> r))
97 pure (fromMaybe False (isSuccess <$> r))
100
98
101tryNTimes :: Int -> IO (Maybe a) -> IO (Maybe a)
99tryNTimes :: Int -> IO (Maybe a) -> IO (Maybe a)
@@ -158,18 +156,15 @@ loadModules = sendCommand . load
158loadAll :: IO Text
156loadAll :: IO Text
159loadAll = sendCommand (load [])
157loadAll = sendCommand (load [])
160
158
161−getFlexCompletions :: Text -> IO [(Text, Text, Text)]
159+getFlexCompletions :: Text -> IO [(Text, Text, Text, Maybe P.SourceSpan)]
162getFlexCompletions q = parseCompletions <$> sendCommand (completion [] (Just (flexMatcher q)) Nothing)
160getFlexCompletions q = parseCompletions <$> sendCommand (completion [] (Just (flexMatcher q)) Nothing)
163
161
164−getFlexCompletionsInModule :: Text -> Text -> IO [(Text, Text, Text)]
162+getFlexCompletionsInModule :: Text -> Text -> IO [(Text, Text, Text, Maybe P.SourceSpan)]
165getFlexCompletionsInModule q m = parseCompletions <$> sendCommand (completion [] (Just (flexMatcher q)) (Just m))
163getFlexCompletionsInModule q m = parseCompletions <$> sendCommand (completion [] (Just (flexMatcher q)) (Just m))
166
164
167−getType :: Text -> IO [(Text, Text, Text)]
165+getType :: Text -> IO [(Text, Text, Text, Maybe P.SourceSpan)]
168getType q = parseCompletions <$> sendCommand (typeC q [])
166getType q = parseCompletions <$> sendCommand (typeC q [])
169
167
170−getInfo :: Text -> IO [P.SourceSpan]
171−getInfo q = parseInfo <$> sendCommand (typeC q [])
172−
173addImport :: Text -> FilePath -> FilePath -> IO Text
168addImport :: Text -> FilePath -> FilePath -> IO Text
174addImport identifier fp outfp = sendCommand (addImportC identifier fp outfp)
169addImport identifier fp outfp = sendCommand (addImportC identifier fp outfp)
175
170
@@ -254,17 +249,14 @@ withResult p v = do
254 Left err -> pure (Left err)
249 Left err -> pure (Left err)
255 Right res -> Right <$> p res
250 Right res -> Right <$> p res
256
251
257−completionParser :: Value -> Parser [(Text, Text, Text)]
252+completionParser :: Value -> Parser [(Text, Text, Text, Maybe P.SourceSpan)]
258completionParser = withArray "res" $ \cs ->
253completionParser = withArray "res" $ \cs ->
259 mapM (withObject "completion" $ \o -> do
254 mapM (withObject "completion" $ \o -> do
260 ident <- o .: "identifier"
255 ident <- o .: "identifier"
261 module' <- o .: "module"
256 module' <- o .: "module"
262 ty <- o .: "type"
257 ty <- o .: "type"
263− pure (module', ident, ty)) (V.toList cs)
258+ ss <- o .: "definedAt"
264−
259+ pure (module', ident, ty, ss)) (V.toList cs)
265−infoParser :: Value -> Parser [P.SourceSpan]
266−infoParser = withArray "res" $ \cs ->
267− mapM (withObject "info" $ \o -> o .: "definedAt") (V.toList cs)
268
260
269valueFromText :: Text -> Value
261valueFromText :: Text -> Value
270valueFromText = fromJust . decode . toS
262valueFromText = fromJust . decode . toS
@@ -272,14 +264,10 @@ valueFromText = fromJust . decode . toS
272resultIsSuccess :: Text -> Bool
264resultIsSuccess :: Text -> Bool
273resultIsSuccess = isRight . join . first toS . parseEither unwrapResult . valueFromText
265resultIsSuccess = isRight . join . first toS . parseEither unwrapResult . valueFromText
274
266
275−parseCompletions :: Text -> [(Text, Text, Text)]
267+parseCompletions :: Text -> [(Text, Text, Text, Maybe P.SourceSpan)]
276parseCompletions s =
268parseCompletions s =
277 fromJust $ join (rightToMaybe <$> parseMaybe (withResult completionParser) (valueFromText s))
269 fromJust $ join (rightToMaybe <$> parseMaybe (withResult completionParser) (valueFromText s))
278
270
279−parseInfo :: Text -> [P.SourceSpan]
280−parseInfo s =
281− fromJust $ join (rightToMaybe <$> parseMaybe (withResult infoParser) (valueFromText s))
282−
283parseTextResult :: Text -> Text
271parseTextResult :: Text -> Text
284parseTextResult s =
272parseTextResult s =
285 fromJust $ join (rightToMaybe <$> parseMaybe (withResult (withText "tr" pure)) (valueFromText s))
273 fromJust $ join (rightToMaybe <$> parseMaybe (withResult (withText "tr" pure)) (valueFromText s))
tests/Language/PureScript/Ide/MatcherSpec.hs+9−7
@@ -9,20 +9,21 @@ import qualified Language.PureScript as P
9import Language.PureScript.Ide.Integration
9import Language.PureScript.Ide.Integration
10import Language.PureScript.Ide.Matcher
10import Language.PureScript.Ide.Matcher
11import Language.PureScript.Ide.Types
11import Language.PureScript.Ide.Types
12+import Language.PureScript.Ide.Util
12import Test.Hspec
13import Test.Hspec
13
14
14−value :: Text -> IdeDeclaration
15+value :: Text -> IdeDeclarationAnn
15−value s = IdeValue (P.Ident (toS s)) P.REmpty
16+value s = withEmptyAnn (IdeValue (P.Ident (toS s)) P.REmpty)
16
17
17−firstResult, secondResult, fiult :: Match IdeDeclaration
18+firstResult, secondResult, fiult :: Match IdeDeclarationAnn
18firstResult = Match (P.moduleNameFromString "Match", value "firstResult")
19firstResult = Match (P.moduleNameFromString "Match", value "firstResult")
19secondResult = Match (P.moduleNameFromString "Match", value "secondResult")
20secondResult = Match (P.moduleNameFromString "Match", value "secondResult")
20fiult = Match (P.moduleNameFromString "Match", value "fiult")
21fiult = Match (P.moduleNameFromString "Match", value "fiult")
21
22
22−completions :: [Match IdeDeclaration]
23+completions :: [Match IdeDeclarationAnn]
23completions = [firstResult, secondResult, fiult]
24completions = [firstResult, secondResult, fiult]
24
25
25−runFlex :: Text -> [Match IdeDeclaration]
26+runFlex :: Text -> [Match IdeDeclarationAnn]
26runFlex s = runMatcher (flexMatcher s) completions
27runFlex s = runMatcher (flexMatcher s) completions
27
28
28setup :: IO ()
29setup :: IO ()
@@ -43,5 +44,6 @@ spec = do
43 cs <- getFlexCompletions ""
44 cs <- getFlexCompletions ""
44 cs `shouldBe` []
45 cs `shouldBe` []
45 it "matches on equality" $ do
46 it "matches on equality" $ do
46− cs <- getFlexCompletions "const"
47+ -- ignore any position information
47− cs `shouldBe` [("MatcherSpec", "const", "forall a b. a -> b -> a")]
48+ (m, i, t, _) : _ <- getFlexCompletions "const"
49+ (m, i, t) `shouldBe` ("MatcherSpec", "const", "forall a b. a -> b -> a")
tests/Language/PureScript/Ide/ReexportsSpec.hs+1−1
@@ -2,7 +2,7 @@
2{-# LANGUAGE NoImplicitPrelude #-}
2{-# LANGUAGE NoImplicitPrelude #-}
3module Language.PureScript.Ide.ReexportsSpec where
3module Language.PureScript.Ide.ReexportsSpec where
4
4
5−import qualified Prelude as Prelude
5+import qualified Prelude
6import Protolude
6import Protolude
7
7
8import qualified Data.Map as Map
8import qualified Data.Map as Map
tests/Language/PureScript/Ide/SourceFile/IntegrationSpec.hs+13−8
@@ -14,23 +14,28 @@ setup :: IO ()
14setup = void (Integration.reset *> Integration.loadAll)
14setup = void (Integration.reset *> Integration.loadAll)
15
15
16spec :: Spec
16spec :: Spec
17−spec = beforeAll_ setup $ do
17+spec = beforeAll_ setup $
18 describe "Sourcefile Integration" $ do
18 describe "Sourcefile Integration" $ do
19− it "finds a value declaration" $ do
19+ it "finds a value declaration" $
20 testCase "sfValue" (3, 1)
20 testCase "sfValue" (3, 1)
21− it "finds a type declaration" $ do
21+ it "finds a type declaration" $
22 testCase "SFType" (5, 1)
22 testCase "SFType" (5, 1)
23− it "finds a data declaration" $ do
23+ it "finds a data declaration" $
24 testCase "SFData" (7, 1)
24 testCase "SFData" (7, 1)
25− it "finds a data constructor" $ do
25+ it "finds a data constructor" $
26 testCase "SFOne" (7, 1)
26 testCase "SFOne" (7, 1)
27− it "finds a typeclass" $ do
27+ it "finds a typeclass" $
28 testCase "SFClass" (9, 1)
28 testCase "SFClass" (9, 1)
29− it "finds a typeclass member" $ do
29+ it "finds a typeclass member" $
30 testCase "sfShow" (10, 3)
30 testCase "sfShow" (10, 3)
31
31
32testCase :: Text -> (Int, Int) -> IO ()
32testCase :: Text -> (Int, Int) -> IO ()
33testCase s (x, y) = do
33testCase s (x, y) = do
34− (P.SourceSpan f (P.SourcePos l c) _):_ <- Integration.getInfo s
34+ P.SourceSpan f (P.SourcePos l c) _ <- getLocation s
35 toS f `shouldSatisfy` T.isSuffixOf "SourceFileSpec.purs"
35 toS f `shouldSatisfy` T.isSuffixOf "SourceFileSpec.purs"
36 (l, c) `shouldBe` (x, y)
36 (l, c) `shouldBe` (x, y)
37+
38+getLocation :: Text -> IO P.SourceSpan
39+getLocation s = do
40+ (_, _, _, Just location) : _ <- Integration.getType s
41+ pure location
tests/Language/PureScript/Ide/SourceFileSpec.hs+7−3
@@ -13,11 +13,12 @@ span0 = P.SourceSpan "ModuleLevel" (P.SourcePos 0 0) (P.SourcePos 1 1)
13span1 = P.SourceSpan "" (P.SourcePos 1 1) (P.SourcePos 2 2)
13span1 = P.SourceSpan "" (P.SourcePos 1 1) (P.SourcePos 2 2)
14span2 = P.SourceSpan "" (P.SourcePos 2 2) (P.SourcePos 3 3)
14span2 = P.SourceSpan "" (P.SourcePos 2 2) (P.SourcePos 3 3)
15
15
16−value1, synonym1, class1, class2, data1, data2, foreign1, foreign2, member1 :: P.Declaration
16+typeAnnotation1, value1, synonym1, class1, class2, data1, data2, foreign1, foreign2, member1 :: P.Declaration
17+typeAnnotation1 = P.TypeDeclaration (P.Ident "value1") P.REmpty
17value1 = P.ValueDeclaration (P.Ident "value1") P.Public [] (Left [])
18value1 = P.ValueDeclaration (P.Ident "value1") P.Public [] (Left [])
18synonym1 = P.TypeSynonymDeclaration (P.ProperName "Synonym1") [] P.REmpty
19synonym1 = P.TypeSynonymDeclaration (P.ProperName "Synonym1") [] P.REmpty
19−class1 = P.TypeClassDeclaration (P.ProperName "Class1") [] [] []
20+class1 = P.TypeClassDeclaration (P.ProperName "Class1") [] [] [] []
20−class2 = P.TypeClassDeclaration (P.ProperName "Class2") [] []
21+class2 = P.TypeClassDeclaration (P.ProperName "Class2") [] [] []
21 [P.PositionedDeclaration span2 [] member1]
22 [P.PositionedDeclaration span2 [] member1]
22data1 = P.DataDeclaration P.Newtype (P.ProperName "Data1") [] []
23data1 = P.DataDeclaration P.Newtype (P.ProperName "Data1") [] []
23data2 = P.DataDeclaration P.Data (P.ProperName "Data2") [] [(P.ProperName "Cons1", [])]
24data2 = P.DataDeclaration P.Data (P.ProperName "Data2") [] [(P.ProperName "Cons1", [])]
@@ -44,3 +45,6 @@ spec = do
44 extractSpans span0 (P.PositionedDeclaration span1 [] foreign1) `shouldBe` [(Left "foreign1", span1)]
45 extractSpans span0 (P.PositionedDeclaration span1 [] foreign1) `shouldBe` [(Left "foreign1", span1)]
45 it "extracts a span for a data foreign declaration" $
46 it "extracts a span for a data foreign declaration" $
46 extractSpans span0 (P.PositionedDeclaration span1 [] foreign2) `shouldBe` [(Right "Foreign2", span1)]
47 extractSpans span0 (P.PositionedDeclaration span1 [] foreign2) `shouldBe` [(Right "Foreign2", span1)]
48+ describe "Type annotations" $ do
49+ it "extracts a type annotation" $
50+ extractTypeAnnotations [typeAnnotation1] `shouldBe` [(P.Ident "value1", P.REmpty)]
tests/Language/PureScript/Ide/StateSpec.hsnew file+51
@@ -0,0 +1,51 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE NoImplicitPrelude #-}
3+module Language.PureScript.Ide.StateSpec where
4+
5+import Protolude
6+import Language.PureScript.Ide.Types
7+import Language.PureScript.Ide.State
8+import qualified Language.PureScript as P
9+import Test.Hspec
10+import qualified Data.Map as Map
11+
12+valueOperator :: Maybe P.Type -> IdeDeclarationAnn
13+valueOperator =
14+ d . IdeValueOperator (P.OpName "<$>") (P.Qualified (Just (mn "Test")) (Left (P.Ident "function"))) 2 P.Infix
15+
16+ctorOperator :: Maybe P.Type -> IdeDeclarationAnn
17+ctorOperator =
18+ d . IdeValueOperator (P.OpName ":") (P.Qualified (Just (mn "Test")) (Right (P.ProperName "Cons"))) 2 P.Infix
19+
20+typeOperator :: Maybe P.Kind -> IdeDeclarationAnn
21+typeOperator =
22+ d . IdeTypeOperator (P.OpName ":") (P.Qualified (Just (mn "Test")) (P.ProperName "List")) 2 P.Infix
23+
24+testModule :: Module
25+testModule = (mn "Test", [ d (IdeValue (P.Ident "function") P.REmpty)
26+ , d (IdeDataConstructor (P.ProperName "Cons") (P.ProperName "List") (P.REmpty))
27+ , d (IdeType (P.ProperName "List") P.Star)
28+ , valueOperator Nothing
29+ , ctorOperator Nothing
30+ , typeOperator Nothing
31+ ])
32+
33+d :: IdeDeclaration -> IdeDeclarationAnn
34+d = IdeDeclarationAnn emptyAnn
35+
36+mn :: Text -> P.ModuleName
37+mn = P.moduleNameFromString . toS
38+
39+testState :: Map P.ModuleName [IdeDeclarationAnn]
40+testState = Map.fromList
41+ [ testModule
42+ ]
43+
44+spec :: Spec
45+spec = describe "resolving operators" $ do
46+ it "resolves the type for a value operator" $
47+ resolveOperatorsForModule testState (snd testModule) `shouldSatisfy` elem (valueOperator (Just P.REmpty))
48+ it "resolves the type for a constructor operator" $
49+ resolveOperatorsForModule testState (snd testModule) `shouldSatisfy` elem (ctorOperator (Just P.REmpty))
50+ it "resolves the kind for a type operator" $
51+ resolveOperatorsForModule testState (snd testModule) `shouldSatisfy` elem (typeOperator (Just P.Star))
tests/TestDocs.hs+1
@@ -278,6 +278,7 @@ testCases =
278 [ ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "explicit" (ShowFn (hasTypeVar "something"))
278 [ ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "explicit" (ShowFn (hasTypeVar "something"))
279 , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "anInt" (ShowFn (P.tyInt ==))
279 , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "anInt" (ShowFn (P.tyInt ==))
280 , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "aNumber" (ShowFn (P.tyNumber ==))
280 , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "aNumber" (ShowFn (P.tyNumber ==))
281+ , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "nestedForAll" (renderedType "forall c. (forall a b. c)")
281 ])
282 ])
282
283
283 , ("ConstrainedArgument",
284 , ("ConstrainedArgument",
tests/TestPscIde.hs+1
@@ -11,4 +11,5 @@ main = do
11 s <- compileTestProject
11 s <- compileTestProject
12 unless s $ fail "Failed to compile .purs sources"
12 unless s $ fail "Failed to compile .purs sources"
13
13
14+ quitServer -- shuts down any left over server (primarily happens during development)
14 withServer (hspec PscIdeSpec.spec)
15 withServer (hspec PscIdeSpec.spec)
tests/TestPsci.hs−1
@@ -102,7 +102,6 @@ completionTestData =
102 , ("ST.new", ["ST.newSTRef"])
102 , ("ST.new", ["ST.newSTRef"])
103 , ("Control.Monad.ST.new", ["Control.Monad.ST.newSTRef"])
103 , ("Control.Monad.ST.new", ["Control.Monad.ST.newSTRef"])
104 ]
104 ]
105− where
106
105
107assertCompletedOk :: (String, [String]) -> Assertion
106assertCompletedOk :: (String, [String]) -> Assertion
108assertCompletedOk (line, expecteds) = do
107assertCompletedOk (line, expecteds) = do
tests/TestUtils.hs+2
@@ -75,6 +75,8 @@ supportModules =
75 , "Data.Function"
75 , "Data.Function"
76 , "Data.Functor"
76 , "Data.Functor"
77 , "Data.HeytingAlgebra"
77 , "Data.HeytingAlgebra"
78+ , "Data.NaturalTransformation"
79+ , "Data.Newtype"
78 , "Data.Ord.Unsafe"
80 , "Data.Ord.Unsafe"
79 , "Data.Ord"
81 , "Data.Ord"
80 , "Data.Ordering"
82 , "Data.Ordering"
tests/support/bower.json+3−2
@@ -5,8 +5,9 @@
5 "purescript-console": "1.0.0-rc.1",
5 "purescript-console": "1.0.0-rc.1",
6 "purescript-eff": "1.0.0-rc.1",
6 "purescript-eff": "1.0.0-rc.1",
7 "purescript-functions": "1.0.0-rc.1",
7 "purescript-functions": "1.0.0-rc.1",
8− "purescript-prelude": "1.0.0-rc.3",
8+ "purescript-prelude": "1.1.0",
9 "purescript-st": "1.0.0-rc.1",
9 "purescript-st": "1.0.0-rc.1",
10− "purescript-partial": "1.1.2"
10+ "purescript-partial": "1.1.2",
11+ "purescript-newtype": "0.1.0"
11 }
12 }
12}
13}