summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2017-01-02 06:19:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2017-01-02 06:19:00 (GMT)
commitdfc92b2cabaa9529df644929982e90166ffdea4d (patch)
tree1c11edbd2d2d5c27b40182bf17d44959b53b83b5
parent79948f219fa19b886408053ae2e9ec97d28ccf45 (diff)
version 0.10.40.10.4
-rw-r--r--CONTRIBUTORS.md1
-rw-r--r--LICENSE899
-rw-r--r--README.md4
-rw-r--r--examples/docs/src/DocComments.purs11
-rw-r--r--examples/failing/DiffKindsSameName.purs15
-rw-r--r--examples/failing/DiffKindsSameName/LibA.purs4
-rw-r--r--examples/failing/DiffKindsSameName/LibB.purs6
-rw-r--r--examples/failing/OrphanInstanceFunDepCycle.purs5
-rw-r--r--examples/failing/OrphanInstanceFunDepCycle/Lib.purs4
-rw-r--r--examples/failing/OrphanInstanceNullary.purs4
-rw-r--r--examples/failing/OrphanInstanceNullary/Lib.purs2
-rw-r--r--examples/failing/OrphanInstanceWithDetermined.purs5
-rw-r--r--examples/failing/OrphanInstanceWithDetermined/Lib.purs5
-rw-r--r--examples/passing/DeriveNewtype.purs4
-rw-r--r--examples/passing/DeriveWithNestedSynonyms.purs29
-rw-r--r--examples/passing/Deriving.purs4
-rw-r--r--examples/passing/DerivingFunctor.purs28
-rw-r--r--examples/passing/EntailsKindedType.purs11
-rw-r--r--examples/passing/ForeignKind.purs10
-rw-r--r--examples/passing/ForeignKind/Lib.purs60
-rw-r--r--examples/passing/GenericsRep.purs4
-rw-r--r--examples/passing/HasOwnProperty.purs5
-rw-r--r--examples/passing/NewtypeInstance.purs4
-rw-r--r--examples/passing/NonOrphanInstanceFunDepExtra.purs8
-rw-r--r--examples/passing/NonOrphanInstanceFunDepExtra/Lib.purs4
-rw-r--r--examples/passing/NonOrphanInstanceMulti.purs7
-rw-r--r--examples/passing/NonOrphanInstanceMulti/Lib.purs4
-rw-r--r--examples/passing/SolvingAppendSymbol.purs32
-rw-r--r--examples/passing/SolvingCompareSymbol.purs30
-rw-r--r--psc-bundle/Main.hs39
-rw-r--r--psc-docs/Main.hs9
-rw-r--r--psc-docs/Tags.hs1
-rw-r--r--psc-package/Main.hs160
-rw-r--r--psc-publish/Main.hs1
-rw-r--r--psci/Main.hs26
-rw-r--r--psci/static/index.js2
-rw-r--r--purescript.cabal23
-rw-r--r--src/Language/PureScript/AST/Declarations.hs26
-rw-r--r--src/Language/PureScript/AST/Exported.hs1
-rw-r--r--src/Language/PureScript/AST/Traversals.hs43
-rw-r--r--src/Language/PureScript/Bundle.hs135
-rw-r--r--src/Language/PureScript/CodeGen/JS.hs2
-rw-r--r--src/Language/PureScript/Constants.hs51
-rw-r--r--src/Language/PureScript/Docs.hs1
-rw-r--r--src/Language/PureScript/Docs/AsMarkdown.hs39
-rw-r--r--src/Language/PureScript/Docs/Convert.hs28
-rw-r--r--src/Language/PureScript/Docs/Convert/ReExports.hs62
-rw-r--r--src/Language/PureScript/Docs/Convert/Single.hs77
-rw-r--r--src/Language/PureScript/Docs/Prim.hs244
-rw-r--r--src/Language/PureScript/Docs/Render.hs34
-rw-r--r--src/Language/PureScript/Docs/RenderedCode/Render.hs23
-rw-r--r--src/Language/PureScript/Docs/RenderedCode/Types.hs46
-rw-r--r--src/Language/PureScript/Docs/Types.hs132
-rw-r--r--src/Language/PureScript/Environment.hs106
-rw-r--r--src/Language/PureScript/Errors.hs21
-rw-r--r--src/Language/PureScript/Errors/JSON.hs2
-rw-r--r--src/Language/PureScript/Externs.hs9
-rw-r--r--src/Language/PureScript/Ide/Externs.hs10
-rw-r--r--src/Language/PureScript/Ide/SourceFile.hs23
-rw-r--r--src/Language/PureScript/Ide/Types.hs13
-rw-r--r--src/Language/PureScript/Ide/Util.hs2
-rw-r--r--src/Language/PureScript/Interactive.hs2
-rw-r--r--src/Language/PureScript/Interactive/Message.hs6
-rw-r--r--src/Language/PureScript/Interactive/Parser.hs1
-rw-r--r--src/Language/PureScript/Kinds.hs10
-rw-r--r--src/Language/PureScript/Names.hs8
-rw-r--r--src/Language/PureScript/Parser/Common.hs6
-rw-r--r--src/Language/PureScript/Parser/Declarations.hs19
-rw-r--r--src/Language/PureScript/Parser/Kinds.hs18
-rw-r--r--src/Language/PureScript/Parser/Lexer.hs7
-rw-r--r--src/Language/PureScript/Pretty/Kinds.hs5
-rw-r--r--src/Language/PureScript/Pretty/Values.hs8
-rw-r--r--src/Language/PureScript/Publish.hs53
-rw-r--r--src/Language/PureScript/Publish/ErrorsWarnings.hs14
-rw-r--r--src/Language/PureScript/Sugar.hs2
-rw-r--r--src/Language/PureScript/Sugar/BindingGroups.hs1
-rw-r--r--src/Language/PureScript/Sugar/Names.hs46
-rw-r--r--src/Language/PureScript/Sugar/Names/Env.hs41
-rw-r--r--src/Language/PureScript/Sugar/Names/Exports.hs39
-rw-r--r--src/Language/PureScript/Sugar/Names/Imports.hs6
-rwxr-xr-xsrc/Language/PureScript/Sugar/TypeClasses/Deriving.hs216
-rw-r--r--src/Language/PureScript/TypeChecker.hs48
-rw-r--r--src/Language/PureScript/TypeChecker/Entailment.hs37
-rw-r--r--src/Language/PureScript/TypeChecker/Kinds.hs28
-rw-r--r--src/Language/PureScript/TypeChecker/Synonyms.hs55
-rw-r--r--src/Language/PureScript/TypeChecker/Types.hs2
-rw-r--r--tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs2
-rw-r--r--tests/Language/PureScript/Ide/ImportsSpec.hs4
-rw-r--r--tests/Language/PureScript/Ide/ReexportsSpec.hs2
-rw-r--r--tests/Language/PureScript/Ide/SourceFileSpec.hs24
-rw-r--r--tests/Language/PureScript/Ide/StateSpec.hs4
-rw-r--r--tests/Main.hs2
-rw-r--r--tests/TestCompiler.hs39
-rw-r--r--tests/TestDocs.hs180
-rw-r--r--tests/TestPrimDocs.hs30
-rw-r--r--tests/TestPscPublish.hs12
-rw-r--r--tests/TestUtils.hs27
-rw-r--r--tests/support/bower.json21
98 files changed, 2900 insertions, 725 deletions
diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md
index d4e6edf..192f952 100644
--- a/CONTRIBUTORS.md
+++ b/CONTRIBUTORS.md
@@ -86,6 +86,7 @@ This file lists the contributors to the PureScript compiler project, and the ter
- [@brandonhamilton](https://github.com/brandonhamilton) (Brandon Hamilton) My existing contributions and all future contributions until further notice are Copyright Brandon Hamilton, 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).
- [@bbqbaron](https://github.com/bbqbaron) (Eric Loren) My existing contributions and all future contributions until further notice are Copyright Eric Loren, 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).
- [@RyanGlScott](https://github.com/RyanGlScott) (Ryan Scott) My existing contributions and all future contributions until further notice are Copyright Ryan Scott, 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).
+- [@seungha-kim](https://github.com/seungha-kim) (Seungha Kim) My existing contributions and all future contributions until further notice are Copyright Seungha Kim, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
### Companies
diff --git a/LICENSE b/LICENSE
index d392d3d..550b1b6 100644
--- a/LICENSE
+++ b/LICENSE
@@ -16,6 +16,8 @@ PureScript uses the following Haskell library packages. Their license files foll
Glob
SHA
+ StateVar
+ adjunctions
aeson
aeson-better-errors
aeson-pretty
@@ -31,7 +33,9 @@ PureScript uses the following Haskell library packages. Their license files foll
auto-update
base
base-compat
+ base-orphans
base64-bytestring
+ bifunctors
binary
blaze-builder
blaze-html
@@ -46,16 +50,19 @@ PureScript uses the following Haskell library packages. Their license files foll
cereal
clock
cmdargs
+ comonad
conduit
conduit-extra
connection
containers
+ contravariant
cookie
cryptonite
data-default-class
data-ordlist
deepseq
directory
+ distributive
dlist
easy-file
edit-distance
@@ -65,12 +72,15 @@ PureScript uses the following Haskell library packages. Their license files foll
fast-logger
file-embed
filepath
+ foldl
+ free
fsnotify
ghc-prim
hashable
haskeline
hex
- hfsevents
+ hinotify
+ hostname
hourglass
http-client
http-client-tls
@@ -79,8 +89,11 @@ PureScript uses the following Haskell library packages. Their license files foll
http2
integer-gmp
iproute
+ kan-extensions
language-javascript
+ lens
lifted-base
+ managed
memory
mime-types
mmorph
@@ -88,10 +101,12 @@ PureScript uses the following Haskell library packages. Their license files foll
monad-logger
monad-loops
mtl
+ mwc-random
network
network-uri
old-locale
old-time
+ optional-args
optparse-applicative
parallel
parsec
@@ -99,16 +114,20 @@ PureScript uses the following Haskell library packages. Their license files foll
pem
pipes
pipes-http
+ prelude-extras
primitive
process
+ profunctors
protolude
psqueues
random
+ reflection
regex-base
regex-tdfa
resourcet
safe
scientific
+ semigroupoids
semigroups
simple-sendfile
socks
@@ -120,16 +139,19 @@ PureScript uses the following Haskell library packages. Their license files foll
streaming-commons
stringsearch
syb
+ system-fileio
+ system-filepath
tagged
template-haskell
+ temporary
terminfo
text
time
- time-locale-compat
tls
transformers
transformers-base
transformers-compat
+ turtle
unix
unix-compat
unix-time
@@ -215,6 +237,67 @@ SHA LICENSE file:
ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.
+StateVar LICENSE file:
+
+ Copyright (c) 2014-2015, Edward Kmett
+ Copyright (c) 2009-2016, Sven Panne
+ All rights reserved.
+
+ Redistribution and use in source and binary forms, with or without
+ modification, are permitted provided that the following conditions are met:
+
+ 1. Redistributions of source code must retain the above copyright notice,
+ this list of conditions and the following disclaimer.
+
+ 2. Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer in the
+ documentation and/or other materials provided with the distribution.
+
+ 3. Neither the name of the author nor the names of its contributors may be
+ used to endorse or promote products derived from this software without
+ specific prior written permission.
+
+ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
+ LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ POSSIBILITY OF SUCH DAMAGE.
+
+adjunctions LICENSE file:
+
+ Copyright 2011-2014 Edward Kmett
+
+ All rights reserved.
+
+ Redistribution and use in source and binary forms, with or without
+ modification, are permitted provided that the following conditions
+ are met:
+
+ 1. Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ 2. Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer in the
+ documentation and/or other materials provided with the distribution.
+
+ THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
+ IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+ WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+ DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
+ ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+ STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
+ ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ POSSIBILITY OF SUCH DAMAGE.
+
aeson LICENSE file:
Copyright (c) 2011, MailRank, Inc.
@@ -762,6 +845,29 @@ base-compat LICENSE file:
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
THE SOFTWARE.
+base-orphans LICENSE file:
+
+ Copyright (c) 2015-2016 Simon Hengel <sol@typeful.net>, João Cristóvão <jmacristovao@gmail.com>, Ryan Scott <ryan.gl.scott@gmail.com>
+
+ Permission is hereby granted, free of charge, to any person obtaining
+ a copy of this software and associated documentation files (the
+ "Software"), to deal in the Software without restriction, including
+ without limitation the rights to use, copy, modify, merge, publish,
+ distribute, sublicense, and/or sell copies of the Software, and to
+ permit persons to whom the Software is furnished to do so, subject to
+ the following conditions:
+
+ The above copyright notice and this permission notice shall be included
+ in all copies or substantial portions of the Software.
+
+ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+ IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+ CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+ TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+ SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+
base64-bytestring LICENSE file:
Copyright (c) 2010 Bryan O'Sullivan <bos@serpentine.com>
@@ -795,6 +901,35 @@ base64-bytestring LICENSE file:
ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.
+bifunctors LICENSE file:
+
+ Copyright 2008-2016 Edward Kmett
+
+ All rights reserved.
+
+ Redistribution and use in source and binary forms, with or without
+ modification, are permitted provided that the following conditions
+ are met:
+
+ 1. Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ 2. Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer in the
+ documentation and/or other materials provided with the distribution.
+
+ THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
+ IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+ WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+ DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
+ ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+ STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
+ ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ POSSIBILITY OF SUCH DAMAGE.
+
binary LICENSE file:
Copyright (c) Lennart Kolmodin
@@ -1244,6 +1379,36 @@ cmdargs LICENSE file:
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+comonad LICENSE file:
+
+ Copyright 2008-2014 Edward Kmett
+ Copyright 2004-2008 Dave Menendez
+
+ All rights reserved.
+
+ Redistribution and use in source and binary forms, with or without
+ modification, are permitted provided that the following conditions
+ are met:
+
+ 1. Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ 2. Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer in the
+ documentation and/or other materials provided with the distribution.
+
+ THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
+ IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+ WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+ DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
+ ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+ STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
+ ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ POSSIBILITY OF SUCH DAMAGE.
+
conduit LICENSE file:
Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/
@@ -1354,6 +1519,39 @@ containers LICENSE file:
OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
DAMAGE.
+contravariant LICENSE file:
+
+ Copyright 2007-2015 Edward Kmett
+
+ All rights reserved.
+
+ Redistribution and use in source and binary forms, with or without
+ modification, are permitted provided that the following conditions
+ are met:
+
+ 1. Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ 2. Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer in the
+ documentation and/or other materials provided with the distribution.
+
+ 3. Neither the name of the author nor the names of his contributors
+ may be used to endorse or promote products derived from this software
+ without specific prior written permission.
+
+ THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
+ IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+ WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+ DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
+ ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+ STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
+ ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ POSSIBILITY OF SUCH DAMAGE.
+
cookie LICENSE file:
Copyright (c) 2010 Michael Snoyman, http://www.yesodweb.com/
@@ -1426,16 +1624,16 @@ data-default-class LICENSE file:
may be used to endorse or promote products derived from this software
without specific prior written permission.
- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+ THIS SOFTWARE IS PROVIDED BY LUKAS MAI 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 HOLDERS 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.
+ DISCLAIMED. IN NO EVENT SHALL THE REGENTS 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.
data-ordlist LICENSE file:
@@ -1558,9 +1756,38 @@ directory LICENSE file:
-----------------------------------------------------------------------------
+distributive LICENSE file:
+
+ Copyright 2011-2016 Edward Kmett
+
+ All rights reserved.
+
+ Redistribution and use in source and binary forms, with or without
+ modification, are permitted provided that the following conditions
+ are met:
+
+ 1. Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ 2. Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer in the
+ documentation and/or other materials provided with the distribution.
+
+ THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
+ IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+ WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+ DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
+ ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+ STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
+ ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ POSSIBILITY OF SUCH DAMAGE.
+
dlist LICENSE file:
- Copyright (c) 2006-2009 Don Stewart, 2013-2016 Sean Leather
+ Copyright (c) 2006-2009 Don Stewart, 2013-2014 Sean Leather
All rights reserved.
@@ -1842,6 +2069,66 @@ filepath LICENSE file:
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+foldl LICENSE file:
+
+ Copyright (c) 2013 Gabriel Gonzalez
+ All rights reserved.
+
+ Redistribution and use in source and binary forms, with or without modification,
+ are permitted provided that the following conditions are met:
+ * Redistributions of source code must retain the above copyright notice,
+ this list of conditions and the following disclaimer.
+ * Redistributions in binary form must reproduce the above copyright notice,
+ this list of conditions and the following disclaimer in the documentation
+ and/or other materials provided with the distribution.
+ * Neither the name of Gabriel Gonzalez nor the names of other contributors
+ may be used to endorse or promote products derived from this software
+ without specific prior written permission.
+
+ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
+ ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+ WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+ DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR
+ ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+ (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
+ LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
+ ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+ (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+ SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+free LICENSE file:
+
+ Copyright 2008-2013 Edward Kmett
+
+ All rights reserved.
+
+ Redistribution and use in source and binary forms, with or without
+ modification, are permitted provided that the following conditions
+ are met:
+
+ 1. Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ 2. Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer in the
+ documentation and/or other materials provided with the distribution.
+
+ 3. Neither the name of the author nor the names of his contributors
+ may be used to endorse or promote products derived from this software
+ without specific prior written permission.
+
+ THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
+ IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+ WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+ DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
+ ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+ STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
+ ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ POSSIBILITY OF SUCH DAMAGE.
+
fsnotify LICENSE file:
Copyright (c) 2012, Mark Dittmer
@@ -2001,40 +2288,93 @@ haskeline LICENSE file:
hex LICENSE file:
- Page not found: Sorry, it's just not here.
-
-hfsevents LICENSE file:
-
- Copyright (c) 2012, Luite Stegeman
-
+ Copyright (c) 2008, Taru Karttunen
All rights reserved.
Redistribution and use in source and binary forms, with or without
- modification, are permitted provided that the following conditions are met:
+ modification, are permitted provided that the following conditions
+ are met:
- * Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
+ Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
- * Redistributions in binary form must reproduce the above
- copyright notice, this list of conditions and the following
- disclaimer in the documentation and/or other materials provided
- with the distribution.
+ Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer in the
+ documentation and/or other materials provided with the distribution.
- * Neither the name of Luite Stegeman nor the names of other
- contributors may be used to endorse or promote products derived
- from this software without specific prior written permission.
+ Neither the name of the Taru Karttunen; nor the names of its contributors
+ may be used to endorse or promote products derived from this software
+ without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
- A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
- OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
- LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
- DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
- THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
- (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ 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.
+
+hinotify LICENSE file:
+
+ Copyright (c) Lennart Kolmodin
+
+ All rights reserved.
+
+ Redistribution and use in source and binary forms, with or without
+ modification, are permitted provided that the following conditions
+ are met:
+
+ 1. Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ 2. Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer in the
+ documentation and/or other materials provided with the distribution.
+
+ 3. Neither the name of the author nor the names of his contributors
+ may be used to endorse or promote products derived from this software
+ without specific prior written permission.
+
+ THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS
+ OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+ WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+ DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
+ ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+ STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
+ ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ POSSIBILITY OF SUCH DAMAGE.
+
+hostname LICENSE file:
+
+ Copyright (c) 2008, Maximilian Bolingbroke
+ All rights reserved.
+
+ Redistribution and use in source and binary forms, with or without modification, are permitted
+ provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright notice, this list of
+ conditions and the following disclaimer.
+ * Redistributions in binary form must reproduce the above copyright notice, this list of
+ conditions and the following disclaimer in the documentation and/or other materials
+ provided with the distribution.
+ * Neither the name of Maximilian Bolingbroke nor the names of other contributors may be used to
+ endorse or promote products derived from this software without specific prior written permission.
+
+ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR
+ IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+ FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR
+ CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+ DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER
+ IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT
+ OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
hourglass LICENSE file:
@@ -2275,6 +2615,39 @@ iproute LICENSE file:
ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.
+kan-extensions LICENSE file:
+
+ Copyright 2008-2013 Edward Kmett
+
+ All rights reserved.
+
+ Redistribution and use in source and binary forms, with or without
+ modification, are permitted provided that the following conditions
+ are met:
+
+ 1. Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ 2. Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer in the
+ documentation and/or other materials provided with the distribution.
+
+ 3. Neither the name of the author nor the names of his contributors
+ may be used to endorse or promote products derived from this software
+ without specific prior written permission.
+
+ THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
+ IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+ WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+ DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
+ ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+ STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
+ ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ POSSIBILITY OF SUCH DAMAGE.
+
language-javascript LICENSE file:
Copyright (c)2010, Alan Zimmerman
@@ -2308,6 +2681,39 @@ language-javascript LICENSE file:
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+lens LICENSE file:
+
+ Copyright 2012-2015 Edward Kmett
+
+ All rights reserved.
+
+ Redistribution and use in source and binary forms, with or without
+ modification, are permitted provided that the following conditions
+ are met:
+
+ 1. Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ 2. Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer in the
+ documentation and/or other materials provided with the distribution.
+
+ 3. Neither the name of the author nor the names of his contributors
+ may be used to endorse or promote products derived from this software
+ without specific prior written permission.
+
+ THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
+ IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+ WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+ DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
+ ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+ STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
+ ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ POSSIBILITY OF SUCH DAMAGE.
+
lifted-base LICENSE file:
Copyright © 2010-2012, Bas van Dijk, Anders Kaseorg
@@ -2340,6 +2746,33 @@ lifted-base LICENSE file:
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+managed LICENSE file:
+
+ Copyright (c) 2014 Gabriel Gonzalez
+ All rights reserved.
+
+ Redistribution and use in source and binary forms, with or without modification,
+ are permitted provided that the following conditions are met:
+ * Redistributions of source code must retain the above copyright notice,
+ this list of conditions and the following disclaimer.
+ * Redistributions in binary form must reproduce the above copyright notice,
+ this list of conditions and the following disclaimer in the documentation
+ and/or other materials provided with the distribution.
+ * Neither the name of Gabriel Gonzalez nor the names of other contributors
+ may be used to endorse or promote products derived from this software
+ without specific prior written permission.
+
+ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
+ ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+ WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+ DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR
+ ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+ (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
+ LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
+ ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+ (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+ SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
memory LICENSE file:
Copyright (c) 2015 Vincent Hanquez <vincent@snarc.org>
@@ -2477,10 +2910,6 @@ monad-logger LICENSE file:
OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
-monad-loops LICENSE file:
-
- Page not found: Sorry, it's just not here.
-
mtl LICENSE file:
The Glasgow Haskell Compiler License
@@ -2515,6 +2944,35 @@ mtl LICENSE file:
OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
DAMAGE.
+mwc-random LICENSE file:
+
+ Copyright (c) 2009, Bryan O'Sullivan
+ All rights reserved.
+
+ Redistribution and use in source and binary forms, with or without
+ modification, are permitted provided that the following conditions
+ are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS 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.
+
network LICENSE file:
Copyright (c) 2002-2010, The University Court of the University of Glasgow.
@@ -2711,6 +3169,33 @@ old-time LICENSE file:
-----------------------------------------------------------------------------
+optional-args LICENSE file:
+
+ Copyright (c) 2015 Gabriel Gonzalez
+ All rights reserved.
+
+ Redistribution and use in source and binary forms, with or without modification,
+ are permitted provided that the following conditions are met:
+ * Redistributions of source code must retain the above copyright notice,
+ this list of conditions and the following disclaimer.
+ * Redistributions in binary form must reproduce the above copyright notice,
+ this list of conditions and the following disclaimer in the documentation
+ and/or other materials provided with the distribution.
+ * Neither the name of Gabriel Gonzalez nor the names of other contributors
+ may be used to endorse or promote products derived from this software
+ without specific prior written permission.
+
+ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
+ ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+ WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+ DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR
+ ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+ (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
+ LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
+ ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+ (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+ SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
optparse-applicative LICENSE file:
Copyright (c) 2012, Paolo Capriotti
@@ -2865,7 +3350,7 @@ pem LICENSE file:
pipes LICENSE file:
- Copyright (c) 2012-2016 Gabriel Gonzalez
+ Copyright (c) 2012-2014 Gabriel Gonzalez
All rights reserved.
Redistribution and use in source and binary forms, with or without modification,
@@ -2917,6 +3402,39 @@ pipes-http LICENSE file:
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+prelude-extras LICENSE file:
+
+ Copyright 2011-2016 Edward Kmett
+
+ All rights reserved.
+
+ Redistribution and use in source and binary forms, with or without
+ modification, are permitted provided that the following conditions
+ are met:
+
+ 1. Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ 2. Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer in the
+ documentation and/or other materials provided with the distribution.
+
+ 3. Neither the name of the author nor the names of his contributors
+ may be used to endorse or promote products derived from this software
+ without specific prior written permission.
+
+ THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
+ IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+ WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+ DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
+ ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+ STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
+ ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ POSSIBILITY OF SUCH DAMAGE.
+
primitive LICENSE file:
Copyright (c) 2008-2009, Roman Leshchinskiy
@@ -3016,6 +3534,39 @@ process LICENSE file:
-----------------------------------------------------------------------------
+profunctors LICENSE file:
+
+ Copyright 2011-2015 Edward Kmett
+
+ All rights reserved.
+
+ Redistribution and use in source and binary forms, with or without
+ modification, are permitted provided that the following conditions
+ are met:
+
+ 1. Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ 2. Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer in the
+ documentation and/or other materials provided with the distribution.
+
+ 3. Neither the name of the author nor the names of his contributors
+ may be used to endorse or promote products derived from this software
+ without specific prior written permission.
+
+ THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
+ IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+ WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+ DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
+ ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+ STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
+ ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ POSSIBILITY OF SUCH DAMAGE.
+
protolude LICENSE file:
Copyright (c) 2016, Stephen Diehl
@@ -3138,6 +3689,40 @@ random LICENSE file:
-----------------------------------------------------------------------------
+reflection LICENSE file:
+
+ Copyright (c) 2009-2013 Edward Kmett
+ Copyright (c) 2004 Oleg Kiselyov and Chung-chieh Shan
+ All rights reserved.
+
+ Redistribution and use in source and binary forms, with or without
+ modification, are permitted provided that the following conditions are
+ met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Edward Kmett nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+ "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+ LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+ A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+ OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+ SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+ LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+ DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+ THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+ (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
regex-base LICENSE file:
This modile is under this "3 clause" BSD license:
@@ -3203,7 +3788,7 @@ resourcet LICENSE file:
safe LICENSE file:
- Copyright Neil Mitchell 2007-2015.
+ Copyright Neil Mitchell 2007-2016.
All rights reserved.
Redistribution and use in source and binary forms, with or without
@@ -3267,6 +3852,35 @@ scientific LICENSE file:
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+semigroupoids LICENSE file:
+
+ Copyright 2011-2015 Edward Kmett
+
+ All rights reserved.
+
+ Redistribution and use in source and binary forms, with or without
+ modification, are permitted provided that the following conditions
+ are met:
+
+ 1. Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ 2. Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer in the
+ documentation and/or other materials provided with the distribution.
+
+ THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
+ IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+ WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+ DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
+ ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+ STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
+ ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ POSSIBILITY OF SUCH DAMAGE.
+
semigroups LICENSE file:
Copyright 2011-2015 Edward Kmett
@@ -3552,7 +4166,36 @@ streaming-commons LICENSE file:
stringsearch LICENSE file:
- Page not found: Sorry, it's just not here.
+ Copyright (c)2010, Daniel Fischer
+
+ All rights reserved.
+
+ Redistribution and use in source and binary forms, with or without
+ modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Daniel Fischer nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+ "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+ LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+ A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+ OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+ SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+ LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+ DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+ THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+ (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
syb LICENSE file:
@@ -3640,6 +4283,56 @@ syb LICENSE file:
-----------------------------------------------------------------------------
+system-fileio LICENSE file:
+
+ Copyright (c) 2011 John Millikin
+
+ Permission is hereby granted, free of charge, to any person
+ obtaining a copy of this software and associated documentation
+ files (the "Software"), to deal in the Software without
+ restriction, including without limitation the rights to use,
+ copy, modify, merge, publish, distribute, sublicense, and/or sell
+ copies of the Software, and to permit persons to whom the
+ Software is furnished to do so, subject to the following
+ conditions:
+
+ The above copyright notice and this permission notice shall be
+ included in all copies or substantial portions of the Software.
+
+ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
+ OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+ HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+ WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+ FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
+ OTHER DEALINGS IN THE SOFTWARE.
+
+system-filepath LICENSE file:
+
+ Copyright (c) 2010 John Millikin
+
+ Permission is hereby granted, free of charge, to any person
+ obtaining a copy of this software and associated documentation
+ files (the "Software"), to deal in the Software without
+ restriction, including without limitation the rights to use,
+ copy, modify, merge, publish, distribute, sublicense, and/or sell
+ copies of the Software, and to permit persons to whom the
+ Software is furnished to do so, subject to the following
+ conditions:
+
+ The above copyright notice and this permission notice shall be
+ included in all copies or substantial portions of the Software.
+
+ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
+ OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+ HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+ WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+ FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
+ OTHER DEALINGS IN THE SOFTWARE.
+
tagged LICENSE file:
Copyright (c) 2009-2015 Edward Kmett
@@ -3709,6 +4402,31 @@ template-haskell LICENSE file:
DAMAGE.
+temporary LICENSE file:
+
+ Copyright (c) 2008, Maximilian Bolingbroke
+ All rights reserved.
+
+ Redistribution and use in source and binary forms, with or without modification, are permitted
+ provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright notice, this list of
+ conditions and the following disclaimer.
+ * Redistributions in binary form must reproduce the above copyright notice, this list of
+ conditions and the following disclaimer in the documentation and/or other materials
+ provided with the distribution.
+ * Neither the name of Maximilian Bolingbroke nor the names of other contributors may be used to
+ endorse or promote products derived from this software without specific prior written permission.
+
+ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR
+ IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+ FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR
+ CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+ DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER
+ IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT
+ OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
terminfo LICENSE file:
Copyright 2007, Judah Jacobson.
@@ -3777,39 +4495,6 @@ time LICENSE file:
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-time-locale-compat LICENSE file:
-
- Copyright (c) 2014, Kei Hibino
-
- All rights reserved.
-
- Redistribution and use in source and binary forms, with or without
- modification, are permitted provided that the following conditions are met:
-
- * Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
-
- * Redistributions in binary form must reproduce the above
- copyright notice, this list of conditions and the following
- disclaimer in the documentation and/or other materials provided
- with the distribution.
-
- * Neither the name of Kei Hibino nor the names of other
- contributors may be used to endorse or promote products derived
- from this software without specific prior written permission.
-
- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
- A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
- OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
- LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
- DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
- THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
- (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
tls LICENSE file:
Copyright (c) 2010-2015 Vincent Hanquez <vincent@snarc.org>
@@ -3906,7 +4591,7 @@ transformers-base LICENSE file:
transformers-compat LICENSE file:
- Copyright 2012-2015 Edward Kmett
+ Copyright 2012 Edward Kmett
All rights reserved.
@@ -3937,6 +4622,33 @@ transformers-compat LICENSE file:
ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.
+turtle LICENSE file:
+
+ Copyright (c) 2015 Gabriel Gonzalez
+ All rights reserved.
+
+ Redistribution and use in source and binary forms, with or without modification,
+ are permitted provided that the following conditions are met:
+ * Redistributions of source code must retain the above copyright notice,
+ this list of conditions and the following disclaimer.
+ * Redistributions in binary form must reproduce the above copyright notice,
+ this list of conditions and the following disclaimer in the documentation
+ and/or other materials provided with the distribution.
+ * Neither the name of Gabriel Gonzalez nor the names of other contributors
+ may be used to endorse or promote products derived from this software
+ without specific prior written permission.
+
+ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
+ ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+ WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+ DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR
+ ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+ (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
+ LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
+ ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+ (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+ SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
unix LICENSE file:
The Glasgow Haskell Compiler License
@@ -4343,7 +5055,36 @@ warp LICENSE file:
websockets LICENSE file:
- Page not found: Sorry, it's just not here.
+ Copyright Jasper Van der Jeugt, 2011
+
+ All rights reserved.
+
+ Redistribution and use in source and binary forms, with or without
+ modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Siniša Biđin nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+ "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+ LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+ A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+ OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+ SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+ LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+ DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+ THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+ (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
word8 LICENSE file:
@@ -4499,7 +5240,7 @@ x509-validation LICENSE file:
zlib LICENSE file:
- Copyright (c) 2006-2015, Duncan Coutts
+ Copyright (c) 2006-2016, Duncan Coutts
All rights reserved.
Redistribution and use in source and binary forms, with or without
diff --git a/README.md b/README.md
index f7e5a86..b6c4df2 100644
--- a/README.md
+++ b/README.md
@@ -4,10 +4,6 @@ A small strongly typed programming language with expressive types that compiles
[![Hackage](https://img.shields.io/hackage/v/purescript.svg)](http://hackage.haskell.org/package/purescript) [![Build Status](https://api.travis-ci.org/purescript/purescript.svg?branch=master)](http://travis-ci.org/purescript/purescript)
-[![Stackage LTS 2](http://stackage.org/package/purescript/badge/lts-2)](http://stackage.org/lts-2/package/purescript)
-[![Stackage LTS 3](http://stackage.org/package/purescript/badge/lts-3)](http://stackage.org/lts-3/package/purescript)
-[![Stackage Nightly](http://stackage.org/package/purescript/badge/nightly)](http://stackage.org/nightly/package/purescript)
-
## Language info
- [PureScript home](http://purescript.org)
diff --git a/examples/docs/src/DocComments.purs b/examples/docs/src/DocComments.purs
new file mode 100644
index 0000000..4bc2e93
--- /dev/null
+++ b/examples/docs/src/DocComments.purs
@@ -0,0 +1,11 @@
+module DocComments where
+
+-- | This declaration has a code block:
+-- |
+-- | example == 0
+-- |
+-- | Here we are really testing that the leading whitespace is not stripped, as
+-- | this ensures that we don't accidentally change code blocks into normal
+-- | paragraphs.
+example :: Int
+example = 0
diff --git a/examples/failing/DiffKindsSameName.purs b/examples/failing/DiffKindsSameName.purs
new file mode 100644
index 0000000..afcf48a
--- /dev/null
+++ b/examples/failing/DiffKindsSameName.purs
@@ -0,0 +1,15 @@
+-- @shouldFailWith KindsDoNotUnify
+module DiffKindsSameName where
+
+import DiffKindsSameName.LibA as LibA
+import DiffKindsSameName.LibB as LibB
+
+-- both `LibA` and `LibB` define a kind locally called `DemoKind`
+-- `LibB` defines `DemoData :: LibB.DemoKind`
+-- if we try to use `DemoData` in a place where `LibA.DemoKind` is expected, it should fail with `KindsDoNotUnify`
+
+data AProxy (m :: LibA.DemoKind) = AProxy
+
+bProxy :: AProxy LibB.DemoData
+bProxy = AProxy
+
diff --git a/examples/failing/DiffKindsSameName/LibA.purs b/examples/failing/DiffKindsSameName/LibA.purs
new file mode 100644
index 0000000..d36b2ec
--- /dev/null
+++ b/examples/failing/DiffKindsSameName/LibA.purs
@@ -0,0 +1,4 @@
+module DiffKindsSameName.LibA where
+
+foreign import kind DemoKind
+
diff --git a/examples/failing/DiffKindsSameName/LibB.purs b/examples/failing/DiffKindsSameName/LibB.purs
new file mode 100644
index 0000000..52bcb0f
--- /dev/null
+++ b/examples/failing/DiffKindsSameName/LibB.purs
@@ -0,0 +1,6 @@
+module DiffKindsSameName.LibB where
+
+foreign import kind DemoKind
+
+foreign import data DemoData :: DemoKind
+
diff --git a/examples/failing/OrphanInstanceFunDepCycle.purs b/examples/failing/OrphanInstanceFunDepCycle.purs
new file mode 100644
index 0000000..c11877c
--- /dev/null
+++ b/examples/failing/OrphanInstanceFunDepCycle.purs
@@ -0,0 +1,5 @@
+-- @shouldFailWith OrphanInstance
+module Main where
+import Lib
+data L
+instance clr :: C L R
diff --git a/examples/failing/OrphanInstanceFunDepCycle/Lib.purs b/examples/failing/OrphanInstanceFunDepCycle/Lib.purs
new file mode 100644
index 0000000..5c77a8d
--- /dev/null
+++ b/examples/failing/OrphanInstanceFunDepCycle/Lib.purs
@@ -0,0 +1,4 @@
+module Lib where
+-- covering sets: {{l}, {r}}
+class C l r | l -> r, r -> l
+data R
diff --git a/examples/failing/OrphanInstanceNullary.purs b/examples/failing/OrphanInstanceNullary.purs
new file mode 100644
index 0000000..cd2e6af
--- /dev/null
+++ b/examples/failing/OrphanInstanceNullary.purs
@@ -0,0 +1,4 @@
+-- @shouldFailWith OrphanInstance
+module Test where
+import Lib
+instance c :: C
diff --git a/examples/failing/OrphanInstanceNullary/Lib.purs b/examples/failing/OrphanInstanceNullary/Lib.purs
new file mode 100644
index 0000000..b96dc89
--- /dev/null
+++ b/examples/failing/OrphanInstanceNullary/Lib.purs
@@ -0,0 +1,2 @@
+module Lib where
+class C
diff --git a/examples/failing/OrphanInstanceWithDetermined.purs b/examples/failing/OrphanInstanceWithDetermined.purs
new file mode 100644
index 0000000..f905fd5
--- /dev/null
+++ b/examples/failing/OrphanInstanceWithDetermined.purs
@@ -0,0 +1,5 @@
+-- @shouldFailWith OrphanInstance
+module Main where
+import Lib
+data R
+instance cflr :: C F L R
diff --git a/examples/failing/OrphanInstanceWithDetermined/Lib.purs b/examples/failing/OrphanInstanceWithDetermined/Lib.purs
new file mode 100644
index 0000000..03b701f
--- /dev/null
+++ b/examples/failing/OrphanInstanceWithDetermined/Lib.purs
@@ -0,0 +1,5 @@
+module Lib where
+-- covering sets: {{f, l}}
+class C f l r | l -> r
+data F
+data L
diff --git a/examples/passing/DeriveNewtype.purs b/examples/passing/DeriveNewtype.purs
index bdcdce4..3f0648c 100644
--- a/examples/passing/DeriveNewtype.purs
+++ b/examples/passing/DeriveNewtype.purs
@@ -4,7 +4,9 @@ import Control.Monad.Eff.Console (log)
import Data.Newtype
-newtype Test = Test String
+type MyString = String
+
+newtype Test = Test MyString
derive instance newtypeTest :: Newtype Test _
diff --git a/examples/passing/DeriveWithNestedSynonyms.purs b/examples/passing/DeriveWithNestedSynonyms.purs
new file mode 100644
index 0000000..c23c8e3
--- /dev/null
+++ b/examples/passing/DeriveWithNestedSynonyms.purs
@@ -0,0 +1,29 @@
+module Main where
+
+import Prelude
+import Control.Monad.Eff.Console (log)
+
+type L = {}
+data X = X L
+derive instance eqX :: Eq X
+
+type M = {}
+data Y = Y {foo :: M}
+derive instance eqY :: Eq Y
+
+type N = {}
+data Z = Z N
+derive instance eqZ :: Eq Z
+
+type Foo = String
+
+type Bar = { foo :: Foo }
+
+type Baz = { baz :: Bar }
+
+newtype T = T Baz
+
+derive instance eqT :: Eq T
+derive instance ordT :: Ord T
+
+main = log "Done"
diff --git a/examples/passing/Deriving.purs b/examples/passing/Deriving.purs
index 2609cf3..9630699 100644
--- a/examples/passing/Deriving.purs
+++ b/examples/passing/Deriving.purs
@@ -10,7 +10,9 @@ derive instance eqV :: Eq V
derive instance ordV :: Ord V
-data X = X Int | Y String
+type MyString = String
+
+data X = X Int | Y MyString
derive instance eqX :: Eq X
diff --git a/examples/passing/DerivingFunctor.purs b/examples/passing/DerivingFunctor.purs
new file mode 100644
index 0000000..bd40cac
--- /dev/null
+++ b/examples/passing/DerivingFunctor.purs
@@ -0,0 +1,28 @@
+module Main where
+
+import Prelude
+import Control.Monad.Eff.Console (log)
+import Test.Assert
+
+type MyRecord a = { myField :: a }
+
+data M f a
+ = M0 a (Array a)
+ | M1 Int
+ | M2 (f a)
+ | M3 { foo :: Int, bar :: a, baz :: f a }
+ | M4 (MyRecord a)
+
+derive instance eqM :: (Eq (f a), Eq a) => Eq (M f a)
+
+derive instance functorM :: Functor f => Functor (M f)
+
+type MA = M Array
+
+main = do
+ assert $ map show (M0 0 [1, 2] :: MA Int) == M0 "0" ["1", "2"]
+ assert $ map show (M1 0 :: MA Int) == M1 0
+ assert $ map show (M2 [0, 1] :: MA Int) == M2 ["0", "1"]
+ assert $ map show (M3 {foo: 0, bar: 1, baz: [2, 3]} :: MA Int) == M3 {foo: 0, bar: "1", baz: ["2", "3"]}
+ assert $ map show (M4 { myField: 42 }) == M4 { myField: "42" } :: MA String
+ log "Done"
diff --git a/examples/passing/EntailsKindedType.purs b/examples/passing/EntailsKindedType.purs
new file mode 100644
index 0000000..cd2489a
--- /dev/null
+++ b/examples/passing/EntailsKindedType.purs
@@ -0,0 +1,11 @@
+module Main where
+
+import Prelude
+import Control.Monad.Eff
+import Control.Monad.Eff.Console
+
+test x = show (x :: _ :: *)
+
+main = do
+ when (show (unit :: Unit :: *) == "unit") (log "Done")
+ when (test unit == "unit") (log "Done")
diff --git a/examples/passing/ForeignKind.purs b/examples/passing/ForeignKind.purs
new file mode 100644
index 0000000..0b91f7d
--- /dev/null
+++ b/examples/passing/ForeignKind.purs
@@ -0,0 +1,10 @@
+module Main where
+
+import Prelude
+import ForeignKinds.Lib (kind Nat, Zero, Succ, N3, NatProxy, class AddNat, addNat, proxy1, proxy2)
+import Control.Monad.Eff.Console (log)
+
+proxy1Add2Is3 :: NatProxy N3
+proxy1Add2Is3 = addNat proxy1 proxy2
+
+main = log "Done"
diff --git a/examples/passing/ForeignKind/Lib.purs b/examples/passing/ForeignKind/Lib.purs
new file mode 100644
index 0000000..0ca2c13
--- /dev/null
+++ b/examples/passing/ForeignKind/Lib.purs
@@ -0,0 +1,60 @@
+module ForeignKinds.Lib (kind Nat, Kinded, Zero, Succ, N0, N1, N2, N3, NatProxy(..), class AddNat, addNat, proxy1, proxy2) where
+
+-- declaration
+
+foreign import kind Nat
+
+-- use in foreign data
+
+foreign import data Zero :: Nat
+foreign import data Succ :: Nat -> Nat
+
+-- use in data
+
+data NatProxy (t :: Nat) = NatProxy
+
+-- use in type sig
+
+succProxy :: forall n. NatProxy n -> NatProxy (Succ n)
+succProxy _ = NatProxy
+
+-- use in alias
+
+type Kinded f = f :: Nat
+
+type KindedZero = Kinded Zero
+
+type N0 = Zero
+type N1 = Succ N0
+type N2 = Succ N1
+type N3 = Succ N2
+
+-- use of alias
+
+proxy0 :: NatProxy N0
+proxy0 = NatProxy
+
+proxy1 :: NatProxy N1
+proxy1 = NatProxy
+
+proxy2 :: NatProxy N2
+proxy2 = NatProxy
+
+proxy3 :: NatProxy N3
+proxy3 = NatProxy
+
+-- use in class
+
+class AddNat (l :: Nat) (r :: Nat) (o :: Nat) | l -> r o
+
+instance addNatZero
+ :: AddNat Zero r r
+
+instance addNatSucc
+ :: AddNat l r o
+ => AddNat (Succ l) r (Succ o)
+
+-- use of class
+
+addNat :: forall l r o. AddNat l r o => NatProxy l -> NatProxy r -> NatProxy o
+addNat _ _ = NatProxy
diff --git a/examples/passing/GenericsRep.purs b/examples/passing/GenericsRep.purs
index 4f60106..be75d86 100644
--- a/examples/passing/GenericsRep.purs
+++ b/examples/passing/GenericsRep.purs
@@ -27,7 +27,9 @@ derive instance genericZ :: Generic Z _
instance eqZ :: Eq Z where
eq x y = genericEq x y
-newtype W = W { x :: Int, y :: String }
+type MyString = String
+
+newtype W = W { x :: Int, y :: MyString }
derive instance genericW :: Generic W _
diff --git a/examples/passing/HasOwnProperty.purs b/examples/passing/HasOwnProperty.purs
new file mode 100644
index 0000000..6a70fb7
--- /dev/null
+++ b/examples/passing/HasOwnProperty.purs
@@ -0,0 +1,5 @@
+module Main where
+
+import Control.Monad.Eff.Console (log)
+
+main = log ({hasOwnProperty: "Hi"} {hasOwnProperty = "Done"}).hasOwnProperty
diff --git a/examples/passing/NewtypeInstance.purs b/examples/passing/NewtypeInstance.purs
index 8a83399..f7b9ea8 100644
--- a/examples/passing/NewtypeInstance.purs
+++ b/examples/passing/NewtypeInstance.purs
@@ -4,7 +4,9 @@ import Prelude
import Control.Monad.Eff
import Control.Monad.Eff.Console
-newtype X = X String
+type MyString = String
+
+newtype X = X MyString
derive newtype instance showX :: Show X
diff --git a/examples/passing/NonOrphanInstanceFunDepExtra.purs b/examples/passing/NonOrphanInstanceFunDepExtra.purs
new file mode 100644
index 0000000..eb86ead
--- /dev/null
+++ b/examples/passing/NonOrphanInstanceFunDepExtra.purs
@@ -0,0 +1,8 @@
+-- Both f and l must be known, thus can be in separate modules
+module Main where
+import Control.Monad.Eff.Console (log)
+import Lib
+data F
+data R
+instance cflr :: C F L R
+main = log "Done"
diff --git a/examples/passing/NonOrphanInstanceFunDepExtra/Lib.purs b/examples/passing/NonOrphanInstanceFunDepExtra/Lib.purs
new file mode 100644
index 0000000..5909771
--- /dev/null
+++ b/examples/passing/NonOrphanInstanceFunDepExtra/Lib.purs
@@ -0,0 +1,4 @@
+module Lib where
+-- covering sets: {{f, l}}
+class C f l r | l -> r
+data L
diff --git a/examples/passing/NonOrphanInstanceMulti.purs b/examples/passing/NonOrphanInstanceMulti.purs
new file mode 100644
index 0000000..71d5634
--- /dev/null
+++ b/examples/passing/NonOrphanInstanceMulti.purs
@@ -0,0 +1,7 @@
+-- Both l and r must be known, thus can be in separate modules
+module Main where
+import Control.Monad.Eff.Console (log)
+import Lib
+data L
+instance clr :: C L R
+main = log "Done"
diff --git a/examples/passing/NonOrphanInstanceMulti/Lib.purs b/examples/passing/NonOrphanInstanceMulti/Lib.purs
new file mode 100644
index 0000000..49b5b73
--- /dev/null
+++ b/examples/passing/NonOrphanInstanceMulti/Lib.purs
@@ -0,0 +1,4 @@
+module Lib where
+-- covering sets: {{l, r}}
+class C l r
+data R
diff --git a/examples/passing/SolvingAppendSymbol.purs b/examples/passing/SolvingAppendSymbol.purs
new file mode 100644
index 0000000..41fa545
--- /dev/null
+++ b/examples/passing/SolvingAppendSymbol.purs
@@ -0,0 +1,32 @@
+module Main where
+
+import Prelude
+import Control.Monad.Eff.Console (log)
+import Type.Data.Symbol (SProxy(..), class AppendSymbol, appendSymbol, reflectSymbol)
+
+sym :: SProxy ""
+sym = SProxy
+
+symA :: SProxy "A"
+symA = SProxy
+
+symB :: SProxy "B"
+symB = SProxy
+
+egAB :: SProxy "AB"
+egAB = appendSymbol symA symB
+
+egBA :: SProxy "BA"
+egBA = appendSymbol symB symA
+
+egA' :: SProxy "A"
+egA' = appendSymbol sym (appendSymbol symA sym)
+
+main = do
+ let gotAB = reflectSymbol egAB == "AB"
+ gotBA = reflectSymbol egBA == "BA"
+ gotA' = reflectSymbol egA' == "A"
+ when (not gotAB) $ log "Did not get AB"
+ when (not gotBA) $ log "Did not get BA"
+ when (not gotA') $ log "Did not get A"
+ when (gotAB && gotBA && gotA') $ log "Done"
diff --git a/examples/passing/SolvingCompareSymbol.purs b/examples/passing/SolvingCompareSymbol.purs
new file mode 100644
index 0000000..24ffece
--- /dev/null
+++ b/examples/passing/SolvingCompareSymbol.purs
@@ -0,0 +1,30 @@
+module Main where
+
+import Prelude
+import Control.Monad.Eff.Console (log)
+import Type.Data.Symbol (SProxy(..), class CompareSymbol, compareSymbol)
+import Type.Data.Ordering (OProxy(..), kind Ordering, LT, EQ, GT, reflectOrdering)
+
+symA :: SProxy "A"
+symA = SProxy
+
+symB :: SProxy "B"
+symB = SProxy
+
+egLT :: OProxy LT
+egLT = compareSymbol symA symB
+
+egEQ :: OProxy EQ
+egEQ = compareSymbol symA symA
+
+egGT :: OProxy GT
+egGT = compareSymbol symB symA
+
+main = do
+ let gotLT = reflectOrdering egLT == LT
+ gotEQ = reflectOrdering egEQ == EQ
+ gotGT = reflectOrdering egGT == GT
+ when (not gotLT) $ log "Did not get LT"
+ when (not gotEQ) $ log "Did not get EQ"
+ when (not gotGT) $ log "Did not get GT"
+ when (gotLT && gotEQ && gotGT) $ log "Done"
diff --git a/psc-bundle/Main.hs b/psc-bundle/Main.hs
index ab4a09a..2bd9428 100644
--- a/psc-bundle/Main.hs
+++ b/psc-bundle/Main.hs
@@ -9,6 +9,8 @@ module Main (main) where
import Data.Traversable (for)
import Data.Version (showVersion)
import Data.Monoid ((<>))
+import Data.Aeson (encode)
+import Data.Maybe (isNothing)
import Control.Applicative
import Control.Monad
@@ -16,12 +18,15 @@ import Control.Monad.Error.Class
import Control.Monad.Trans.Except
import Control.Monad.IO.Class
-import System.FilePath (takeDirectory)
+import System.FilePath (takeDirectory, (</>), (<.>), takeFileName)
import System.FilePath.Glob (glob)
import System.Exit (exitFailure)
import System.IO (stderr, stdout, hPutStrLn, hSetEncoding, utf8)
import System.IO.UTF8 (readUTF8File, writeUTF8File)
-import System.Directory (createDirectoryIfMissing)
+import System.Directory (createDirectoryIfMissing, getCurrentDirectory)
+
+import qualified Data.ByteString.Lazy as B
+import qualified Data.ByteString.UTF8 as BU8
import Language.PureScript.Bundle
@@ -30,6 +35,9 @@ import qualified Options.Applicative as Opts
import qualified Paths_purescript as Paths
+import SourceMap
+import SourceMap.Types
+
-- | Command line options.
data Options = Options
{ optionsInputFiles :: [FilePath]
@@ -37,25 +45,32 @@ data Options = Options
, optionsEntryPoints :: [String]
, optionsMainModule :: Maybe String
, optionsNamespace :: String
+ , optionsSourceMaps :: Bool
} deriving Show
-- | The main application function.
-- This function parses the input files, performs dead code elimination, filters empty modules
-- and generates and prints the final Javascript bundle.
-app :: (MonadError ErrorMessage m, MonadIO m) => Options -> m String
+app :: (MonadError ErrorMessage m, MonadIO m) => Options -> m (Maybe SourceMapping, String)
app Options{..} = do
inputFiles <- concat <$> mapM (liftIO . glob) optionsInputFiles
when (null inputFiles) . liftIO $ do
hPutStrLn stderr "psc-bundle: No input files."
exitFailure
+ when (isNothing optionsOutputFile && optionsSourceMaps == True) . liftIO $ do
+ hPutStrLn stderr "psc-bundle: Source maps only supported when output file specified."
+ exitFailure
+
input <- for inputFiles $ \filename -> do
js <- liftIO (readUTF8File filename)
mid <- guessModuleIdentifier filename
- length js `seq` return (mid, js) -- evaluate readFile till EOF before returning, not to exhaust file handles
+ length js `seq` return (mid, Just filename, js) -- evaluate readFile till EOF before returning, not to exhaust file handles
let entryIds = map (`ModuleIdentifier` Regular) optionsEntryPoints
- bundle input entryIds optionsMainModule optionsNamespace
+ currentDir <- liftIO getCurrentDirectory
+ let outFile = if optionsSourceMaps then fmap (currentDir </>) optionsOutputFile else Nothing
+ bundleSM input entryIds optionsMainModule optionsNamespace outFile
-- | Command line options parser.
options :: Parser Options
@@ -64,6 +79,7 @@ options = Options <$> some inputFile
<*> many entryPoint
<*> optional mainModule
<*> namespace
+ <*> sourceMaps
where
inputFile :: Parser FilePath
inputFile = Opts.strArgument $
@@ -95,6 +111,11 @@ options = Options <$> some inputFile
<> Opts.showDefault
<> Opts.help "Specify the namespace that PureScript modules will be exported to when running in the browser."
+ sourceMaps :: Parser Bool
+ sourceMaps = Opts.switch $
+ Opts.long "source-maps"
+ <> Opts.help "Whether to generate source maps for the bundle (requires --output)."
+
-- | Make it go.
main :: IO ()
main = do
@@ -106,11 +127,15 @@ main = do
Left err -> do
hPutStrLn stderr (unlines (printErrorMessage err))
exitFailure
- Right js ->
+ Right (sourcemap, js) ->
case optionsOutputFile opts of
Just outputFile -> do
createDirectoryIfMissing True (takeDirectory outputFile)
- writeUTF8File outputFile js
+ case sourcemap of
+ Just sm -> do
+ writeUTF8File outputFile $ js ++ "\n//# sourceMappingURL=" ++ (takeFileName outputFile <.> "map") ++ "\n"
+ writeUTF8File (outputFile <.> "map") $ BU8.toString . B.toStrict . encode $ generate sm
+ Nothing -> writeUTF8File outputFile js
Nothing -> putStrLn js
where
infoModList = Opts.fullDesc <> headerInfo <> footerInfo
diff --git a/psc-docs/Main.hs b/psc-docs/Main.hs
index ff557bc..a1ca8ec 100644
--- a/psc-docs/Main.hs
+++ b/psc-docs/Main.hs
@@ -9,6 +9,7 @@ import Control.Category ((>>>))
import Control.Monad.Writer
import Data.Text (Text)
import qualified Data.Text as T
+import qualified Data.Text.IO as T
import Data.Function (on)
import Data.List
import Data.Maybe (fromMaybe)
@@ -22,7 +23,7 @@ import qualified Language.PureScript as P
import qualified Paths_purescript as Paths
import System.Exit (exitFailure)
import System.IO (hPutStrLn, hPrint, hSetEncoding, stderr, stdout, utf8)
-import System.IO.UTF8 (readUTF8FileT)
+import System.IO.UTF8 (readUTF8FileT, writeUTF8FileT)
import System.Directory (createDirectoryIfMissing)
import System.FilePath (takeDirectory)
import System.FilePath.Glob (glob)
@@ -65,11 +66,11 @@ docgen (PSCDocsOptions fmt inputGlob output) = do
case output of
EverythingToStdOut ->
- putStrLn (D.runDocs (D.modulesAsMarkdown ms))
+ T.putStrLn (D.runDocs (D.modulesAsMarkdown ms))
ToStdOut names -> do
let (ms', missing) = takeByName ms names
guardMissing missing
- putStrLn (D.runDocs (D.modulesAsMarkdown ms'))
+ T.putStrLn (D.runDocs (D.modulesAsMarkdown ms'))
ToFiles names -> do
let (ms', missing) = takeByName' ms names
guardMissing missing
@@ -78,7 +79,7 @@ docgen (PSCDocsOptions fmt inputGlob output) = do
forM_ ms'' $ \grp -> do
let fp = fst (head grp)
createDirectoryIfMissing True (takeDirectory fp)
- writeFile fp (D.runDocs (D.modulesAsMarkdown (map snd grp)))
+ writeUTF8FileT fp (D.runDocs (D.modulesAsMarkdown (map snd grp)))
where
guardMissing [] = return ()
diff --git a/psc-docs/Tags.hs b/psc-docs/Tags.hs
index df5d2be..5bee382 100644
--- a/psc-docs/Tags.hs
+++ b/psc-docs/Tags.hs
@@ -17,4 +17,5 @@ tags = map (first T.unpack) . concatMap dtags . P.exportedDeclarations
names (P.TypeSynonymDeclaration name _ _) = [P.runProperName name]
names (P.TypeClassDeclaration name _ _ _ _) = [P.runProperName name]
names (P.TypeInstanceDeclaration name _ _ _ _) = [P.showIdent name]
+ names (P.ExternKindDeclaration name) = [P.runProperName name]
names _ = []
diff --git a/psc-package/Main.hs b/psc-package/Main.hs
index b6b7943..71d9560 100644
--- a/psc-package/Main.hs
+++ b/psc-package/Main.hs
@@ -7,17 +7,20 @@
module Main where
+import qualified Control.Foldl as Foldl
import qualified Data.Aeson as Aeson
import Data.Aeson.Encode.Pretty
import Data.Foldable (fold, for_, traverse_)
import Data.List (nub)
import qualified Data.Map as Map
-import Data.Maybe (mapMaybe)
+import Data.Maybe (fromMaybe, mapMaybe)
import qualified Data.Set as Set
import Data.Text (pack)
+import qualified Data.Text as T
+import Data.Text.Encoding (encodeUtf8)
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TB
-import Data.Text.Encoding (encodeUtf8)
+import qualified Data.Text.Read as TR
import Data.Traversable (for)
import Data.Version (showVersion)
import qualified Filesystem.Path.CurrentOS as Path
@@ -25,7 +28,8 @@ import GHC.Generics (Generic)
import qualified Options.Applicative as Opts
import qualified Paths_purescript as Paths
import qualified System.IO as IO
-import Turtle hiding (fold)
+import Turtle hiding (fold, s, x)
+import qualified Turtle
packageFile :: Path.FilePath
packageFile = "psc-package.json"
@@ -61,8 +65,8 @@ readPackageFile = do
exit (ExitFailure 1)
Just pkg -> return pkg
-encodePrettyToText :: Aeson.ToJSON json => json -> Text
-encodePrettyToText =
+packageConfigToJSON :: PackageConfig -> Text
+packageConfigToJSON =
TL.toStrict
. TB.toLazyText
. encodePrettyToTextBuilder' config
@@ -76,10 +80,18 @@ encodePrettyToText =
]
}
+packageSetToJSON :: PackageSet -> Text
+packageSetToJSON =
+ TL.toStrict
+ . TB.toLazyText
+ . encodePrettyToTextBuilder' config
+ where
+ config = defConfig { confCompare = compare }
+
writePackageFile :: PackageConfig -> IO ()
writePackageFile =
writeTextFile packageFile
- . encodePrettyToText
+ . packageConfigToJSON
data PackageInfo = PackageInfo
{ repo :: Text
@@ -108,6 +120,18 @@ cloneShallow from ref into =
, pathToTextUnsafe into
] empty .||. exit (ExitFailure 1)
+listRemoteTags
+ :: Text
+ -- ^ repo
+ -> Turtle.Shell Text
+listRemoteTags from =
+ inproc "git"
+ [ "ls-remote"
+ , "-q"
+ , "-t"
+ , from
+ ] empty
+
getPackageSet :: PackageConfig -> IO ()
getPackageSet PackageConfig{ source, set } = do
let pkgDir = ".psc-package" </> fromText set </> ".set"
@@ -128,11 +152,18 @@ readPackageSet PackageConfig{ set } = do
exit (ExitFailure 1)
Just db -> return db
-installOrUpdate :: PackageConfig -> Text -> PackageInfo -> IO ()
-installOrUpdate PackageConfig{ set } pkgName PackageInfo{ repo, version } = do
+writePackageSet :: PackageConfig -> PackageSet -> IO ()
+writePackageSet PackageConfig{ set } =
+ let dbFile = ".psc-package" </> fromText set </> ".set" </> "packages.json"
+ in writeTextFile dbFile . packageSetToJSON
+
+installOrUpdate :: Text -> Text -> PackageInfo -> IO Turtle.FilePath
+installOrUpdate set pkgName PackageInfo{ repo, version } = do
+ echo ("Updating " <> pkgName)
let pkgDir = ".psc-package" </> fromText set </> fromText pkgName </> fromText version
exists <- testdir pkgDir
unless exists . void $ cloneShallow repo version pkgDir
+ pure pkgDir
getTransitiveDeps :: PackageSet -> [Text] -> IO [(Text, PackageInfo)]
getTransitiveDeps db depends = do
@@ -151,9 +182,7 @@ updateImpl config@PackageConfig{ depends } = do
db <- readPackageSet config
trans <- getTransitiveDeps db depends
echo ("Updating " <> pack (show (length trans)) <> " packages...")
- for_ trans $ \(pkgName, pkg) -> do
- echo ("Updating " <> pkgName)
- installOrUpdate config pkgName pkg
+ for_ trans $ \(pkgName, pkg) -> installOrUpdate (set config) pkgName pkg
initialize :: IO ()
initialize = do
@@ -233,6 +262,101 @@ exec exeName = do
(map pathToTextUnsafe ("src" </> "**" </> "*.purs" : paths))
empty
+checkForUpdates :: Bool -> Bool -> IO ()
+checkForUpdates applyMinorUpdates applyMajorUpdates = do
+ pkg <- readPackageFile
+ db <- readPackageSet pkg
+
+ echo ("Checking " <> pack (show (Map.size db)) <> " packages for updates.")
+ echo "Warning: this could take some time!"
+
+ newDb <- Map.fromList <$> (for (Map.toList db) $ \(name, p@PackageInfo{ repo, version }) -> do
+ echo ("Checking package " <> name)
+ tagLines <- Turtle.fold (listRemoteTags repo) Foldl.list
+ let tags = mapMaybe parseTag tagLines
+ newVersion <- case parseVersion version of
+ Just parts ->
+ let applyMinor =
+ case filter (isMinorReleaseFrom parts) tags of
+ [] -> pure version
+ minorReleases -> do
+ echo ("New minor release available")
+ case applyMinorUpdates of
+ True -> do
+ let latestMinorRelease = maximum minorReleases
+ pure ("v" <> T.intercalate "." (map (pack . show) latestMinorRelease))
+ False -> pure version
+ applyMajor =
+ case filter (isMajorReleaseFrom parts) tags of
+ [] -> applyMinor
+ newReleases -> do
+ echo ("New major release available")
+ case applyMajorUpdates of
+ True -> do
+ let latestRelease = maximum newReleases
+ pure ("v" <> T.intercalate "." (map (pack . show) latestRelease))
+ False -> applyMinor
+ in applyMajor
+ _ -> do
+ echo "Unable to parse version string"
+ pure version
+ pure (name, p { version = newVersion }))
+
+ when (applyMinorUpdates || applyMajorUpdates)
+ (writePackageSet pkg newDb)
+ where
+ parseTag :: Text -> Maybe [Int]
+ parseTag line =
+ case T.splitOn "\t" line of
+ [_sha, ref] ->
+ case T.stripPrefix "refs/tags/" ref of
+ Just tag ->
+ case parseVersion tag of
+ Just parts -> pure parts
+ _ -> Nothing
+ _ -> Nothing
+ _ -> Nothing
+
+ parseVersion :: Text -> Maybe [Int]
+ parseVersion ref =
+ case T.stripPrefix "v" ref of
+ Just tag ->
+ traverse parseDecimal (T.splitOn "." tag)
+ _ -> Nothing
+
+ parseDecimal :: Text -> Maybe Int
+ parseDecimal s =
+ case TR.decimal s of
+ Right (n, "") -> Just n
+ _ -> Nothing
+
+ isMajorReleaseFrom :: [Int] -> [Int] -> Bool
+ isMajorReleaseFrom (0 : xs) (0 : ys) = isMajorReleaseFrom xs ys
+ isMajorReleaseFrom (x : _) (y : _) = y > x
+ isMajorReleaseFrom _ _ = False
+
+ isMinorReleaseFrom :: [Int] -> [Int] -> Bool
+ isMinorReleaseFrom (0 : xs) (0 : ys) = isMinorReleaseFrom xs ys
+ isMinorReleaseFrom (x : xs) (y : ys) = y == x && ys > xs
+ isMinorReleaseFrom _ _ = False
+
+verifyPackageSet :: IO ()
+verifyPackageSet = do
+ pkg <- readPackageFile
+ db <- readPackageSet pkg
+
+ echo ("Verifying " <> pack (show (Map.size db)) <> " packages.")
+ echo "Warning: this could take some time!"
+
+ let installOrUpdate' (name, pkgInfo) = (name, ) <$> installOrUpdate (set pkg) name pkgInfo
+ paths <- Map.fromList <$> traverse installOrUpdate' (Map.toList db)
+
+ for_ (Map.toList db) $ \(name, PackageInfo{..}) -> do
+ let dirFor = fromMaybe (error "verifyPackageSet: no directory") . (`Map.lookup` paths)
+ echo ("Verifying package " <> name)
+ let srcGlobs = map (pathToTextUnsafe . (</> ("src" </> "**" </> "*.purs")) . dirFor) (name : dependencies)
+ procs "psc" srcGlobs empty
+
main :: IO ()
main = do
IO.hSetEncoding IO.stdout IO.utf8
@@ -275,8 +399,22 @@ main = do
, Opts.command "available"
(Opts.info (pure listPackages)
(Opts.progDesc "List all packages available in the package set"))
+ , Opts.command "updates"
+ (Opts.info (checkForUpdates <$> apply <*> applyMajor)
+ (Opts.progDesc "Check all packages in the package set for new releases"))
+ , Opts.command "verify-set"
+ (Opts.info (pure verifyPackageSet)
+ (Opts.progDesc "Verify that the packages in the package set build correctly"))
]
where
pkg = Opts.strArgument $
Opts.metavar "PACKAGE"
<> Opts.help "The name of the package to install"
+
+ apply = Opts.switch $
+ Opts.long "apply"
+ <> Opts.help "Apply all minor package updates"
+
+ applyMajor = Opts.switch $
+ Opts.long "apply-breaking"
+ <> Opts.help "Apply all major package updates"
diff --git a/psc-publish/Main.hs b/psc-publish/Main.hs
index dd8f663..5d2e902 100644
--- a/psc-publish/Main.hs
+++ b/psc-publish/Main.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE OverloadedStrings #-}
module Main where
diff --git a/psci/Main.hs b/psci/Main.hs
index e86f758..1a8bec8 100644
--- a/psci/Main.hs
+++ b/psci/Main.hs
@@ -72,10 +72,16 @@ inputFile = Opts.strArgument $
Opts.metavar "FILE"
<> Opts.help "Optional .purs files to load on start"
-nodeFlagsFlag :: Opts.Parser [String]
-nodeFlagsFlag = Opts.option parser $
+nodePathOption :: Opts.Parser (Maybe FilePath)
+nodePathOption = Opts.optional . Opts.strOption $
+ Opts.metavar "FILE"
+ <> Opts.long "node-path"
+ <> Opts.help "Path to the Node executable"
+
+nodeFlagsOption :: Opts.Parser [String]
+nodeFlagsOption = Opts.option parser $
Opts.long "node-opts"
- <> Opts.metavar "NODE_OPTS"
+ <> Opts.metavar "OPTS"
<> Opts.value []
<> Opts.help "Flags to pass to node, separated by spaces"
where
@@ -90,7 +96,7 @@ port = Opts.option Opts.auto $
backend :: Opts.Parser Backend
backend =
(browserBackend <$> port)
- <|> (nodeBackend <$> nodeFlagsFlag)
+ <|> (nodeBackend <$> nodePathOption <*> nodeFlagsOption)
psciOptions :: Opts.Parser PSCiOptions
psciOptions = PSCiOptions <$> many inputFile
@@ -293,8 +299,8 @@ browserBackend serverPort = Backend setup evaluate reload shutdown
result <- takeMVar resultVar
putStrLn result
-nodeBackend :: [String] -> Backend
-nodeBackend nodeArgs = Backend setup eval reload shutdown
+nodeBackend :: Maybe FilePath -> [String] -> Backend
+nodeBackend nodePath nodeArgs = Backend setup eval reload shutdown
where
setup :: IO ()
setup = return ()
@@ -302,12 +308,12 @@ nodeBackend nodeArgs = Backend setup eval reload shutdown
eval :: () -> String -> IO ()
eval _ _ = do
writeFile indexFile "require('$PSCI')['$main']();"
- process <- findNodeProcess
+ process <- maybe findNodeProcess (pure . pure) nodePath
result <- traverse (\node -> readProcessWithExitCode node (nodeArgs ++ [indexFile]) "") process
case result of
- Just (ExitSuccess, out, _) -> putStrLn out
- Just (ExitFailure _, _, err) -> putStrLn err
- Nothing -> putStrLn "Couldn't find node.js"
+ Just (ExitSuccess, out, _) -> putStrLn out
+ Just (ExitFailure _, _, err) -> putStrLn err
+ Nothing -> putStrLn "Couldn't find node.js"
reload :: () -> IO ()
reload _ = return ()
diff --git a/psci/static/index.js b/psci/static/index.js
index 08b5f1e..e6ea3ea 100644
--- a/psci/static/index.js
+++ b/psci/static/index.js
@@ -34,7 +34,7 @@ var evaluate = function evaluate(js) {
return buffer.join('\n');
};
window.onload = function() {
- var socket = new WebSocket('ws://0.0.0.0:' + location.port);
+ var socket = new WebSocket('ws://localhost:' + location.port);
var evalNext = function reload() {
get('js/latest.js', function(response) {
try {
diff --git a/purescript.cabal b/purescript.cabal
index d39f3fe..bf50897 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,5 +1,5 @@
name: purescript
-version: 0.10.3
+version: 0.10.4
cabal-version: >=1.8
build-type: Simple
license: BSD3
@@ -28,6 +28,7 @@ extra-source-files: examples/passing/*.purs
, examples/passing/ExplicitImportReExport/*.purs
, examples/passing/ExportExplicit/*.purs
, examples/passing/ExportExplicit2/*.purs
+ , examples/passing/ForeignKind/*.purs
, examples/passing/Import/*.purs
, examples/passing/ImportExplicit/*.purs
, examples/passing/ImportQualified/*.purs
@@ -39,6 +40,8 @@ extra-source-files: examples/passing/*.purs
, examples/passing/ModuleExportQualified/*.purs
, examples/passing/ModuleExportSelf/*.purs
, examples/passing/NonConflictingExports/*.purs
+ , examples/passing/NonOrphanInstanceMulti/*.purs
+ , examples/passing/NonOrphanInstanceFunDepExtra/*.purs
, examples/passing/OperatorAliasElsewhere/*.purs
, examples/passing/Operators/*.purs
, examples/passing/PendingConflictingImports/*.purs
@@ -63,6 +66,7 @@ extra-source-files: examples/passing/*.purs
, examples/failing/ConflictingImports2/*.purs
, examples/failing/ConflictingQualifiedImports/*.purs
, examples/failing/ConflictingQualifiedImports2/*.purs
+ , examples/failing/DiffKindsSameName/*.purs
, examples/failing/DuplicateModule/*.purs
, examples/failing/ExportConflictClass/*.purs
, examples/failing/ExportConflictCtor/*.purs
@@ -78,6 +82,9 @@ extra-source-files: examples/passing/*.purs
, examples/failing/ImportModule/*.purs
, examples/failing/InstanceExport/*.purs
, examples/failing/OrphanInstance/*.purs
+ , examples/failing/OrphanInstanceFunDepCycle/*.purs
+ , examples/failing/OrphanInstanceWithDetermined/*.purs
+ , examples/failing/OrphanInstanceNullary/*.purs
, examples/warning/*.purs
, examples/warning/*.js
, examples/warning/UnusedExplicitImportTypeOp/*.purs
@@ -124,7 +131,7 @@ library
haskeline >= 0.7.0.0,
http-client >= 0.4.30 && <0.5,
http-types -any,
- language-javascript == 0.6.*,
+ language-javascript >= 0.6.0.9 && < 0.7,
lens == 4.*,
lifted-base >= 0.2.3 && < 0.2.4,
monad-control >= 1.0.0.0 && < 1.1,
@@ -250,6 +257,7 @@ library
Language.PureScript.Docs.Convert
Language.PureScript.Docs.Convert.Single
Language.PureScript.Docs.Convert.ReExports
+ Language.PureScript.Docs.Prim
Language.PureScript.Docs.Render
Language.PureScript.Docs.Types
Language.PureScript.Docs.RenderedCode
@@ -426,7 +434,7 @@ executable psc-package
optparse-applicative -any,
system-filepath -any,
text -any,
- turtle -any
+ turtle <1.3
main-is: Main.hs
other-modules: Paths_purescript
buildable: True
@@ -456,14 +464,19 @@ executable psc-bundle
other-modules: Paths_purescript
other-extensions:
build-depends: base >=4 && <5,
+ bytestring -any,
purescript -any,
directory -any,
+ aeson >= 0.8 && < 1.0,
filepath -any,
Glob -any,
mtl -any,
optparse-applicative >= 0.12.1,
+ sourcemap >= 0.1.6,
transformers -any,
- transformers-compat -any
+ transformers-compat -any,
+ utf8-string >= 1 && < 2
+
ghc-options: -Wall -O2
hs-source-dirs: psc-bundle
@@ -510,6 +523,7 @@ test-suite tests
aeson -any,
aeson-better-errors -any,
base-compat -any,
+ bower-json -any,
boxes -any,
bytestring -any,
containers -any,
@@ -539,6 +553,7 @@ test-suite tests
other-modules: TestUtils
TestCompiler
TestDocs
+ TestPrimDocs
TestPscPublish
TestPsci
TestPscIde
diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs
index 9029b1a..781ec09 100644
--- a/src/Language/PureScript/AST/Declarations.hs
+++ b/src/Language/PureScript/AST/Declarations.hs
@@ -240,6 +240,10 @@ data DeclarationRef
--
| ModuleRef ModuleName
-- |
+ -- A named kind
+ --
+ | KindRef (ProperName 'KindName)
+ -- |
-- A value re-exported from another module. These will be inserted during
-- elaboration in name desugaring.
--
@@ -258,6 +262,7 @@ instance Eq DeclarationRef where
(TypeClassRef name) == (TypeClassRef name') = name == name'
(TypeInstanceRef name) == (TypeInstanceRef name') = name == name'
(ModuleRef name) == (ModuleRef name') = name == name'
+ (KindRef name) == (KindRef name') = name == name'
(ReExportRef mn ref) == (ReExportRef mn' ref') = mn == mn' && ref == ref'
(PositionedDeclarationRef _ _ r) == r' = r == r'
r == (PositionedDeclarationRef _ _ r') = r == r'
@@ -274,6 +279,7 @@ compDecRef (ValueOpRef name) (ValueOpRef name') = compare name name'
compDecRef (TypeClassRef name) (TypeClassRef name') = compare name name'
compDecRef (TypeInstanceRef ident) (TypeInstanceRef ident') = compare ident ident'
compDecRef (ModuleRef name) (ModuleRef name') = compare name name'
+compDecRef (KindRef name) (KindRef name') = compare name name'
compDecRef (ReExportRef name _) (ReExportRef name' _) = compare name name'
compDecRef (PositionedDeclarationRef _ _ ref) ref' = compDecRef ref ref'
compDecRef ref (PositionedDeclarationRef _ _ ref') = compDecRef ref ref'
@@ -286,7 +292,8 @@ compDecRef ref ref' = compare
orderOf (TypeRef _ _) = 2
orderOf (ValueRef _) = 3
orderOf (ValueOpRef _) = 4
- orderOf _ = 5
+ orderOf (KindRef _) = 5
+ orderOf _ = 6
getTypeRef :: DeclarationRef -> Maybe (ProperName 'TypeName, Maybe [ProperName 'ConstructorName])
getTypeRef (TypeRef name dctors) = Just (name, dctors)
@@ -313,6 +320,11 @@ getTypeClassRef (TypeClassRef name) = Just name
getTypeClassRef (PositionedDeclarationRef _ _ r) = getTypeClassRef r
getTypeClassRef _ = Nothing
+getKindRef :: DeclarationRef -> Maybe (ProperName 'KindName)
+getKindRef (KindRef name) = Just name
+getKindRef (PositionedDeclarationRef _ _ r) = getKindRef r
+getKindRef _ = Nothing
+
isModuleRef :: DeclarationRef -> Bool
isModuleRef (PositionedDeclarationRef _ _ r) = isModuleRef r
isModuleRef (ModuleRef _) = True
@@ -381,6 +393,10 @@ data Declaration
--
| ExternDataDeclaration (ProperName 'TypeName) Kind
-- |
+ -- A foreign kind import (name)
+ --
+ | ExternKindDeclaration (ProperName 'KindName)
+ -- |
-- A fixity declaration
--
| FixityDeclaration (Either ValueFixity TypeFixity)
@@ -470,6 +486,14 @@ isExternDataDecl (PositionedDeclaration _ _ d) = isExternDataDecl d
isExternDataDecl _ = False
-- |
+-- Test if a declaration is a foreign kind import
+--
+isExternKindDecl :: Declaration -> Bool
+isExternKindDecl ExternKindDeclaration{} = True
+isExternKindDecl (PositionedDeclaration _ _ d) = isExternKindDecl d
+isExternKindDecl _ = False
+
+-- |
-- Test if a declaration is a fixity declaration
--
isFixityDecl :: Declaration -> Bool
diff --git a/src/Language/PureScript/AST/Exported.hs b/src/Language/PureScript/AST/Exported.hs
index ab9a2f3..8c7c720 100644
--- a/src/Language/PureScript/AST/Exported.hs
+++ b/src/Language/PureScript/AST/Exported.hs
@@ -132,6 +132,7 @@ isExported (Just exps) decl = any (matches decl) exps
matches (ExternDeclaration ident _) (ValueRef ident') = ident == ident'
matches (DataDeclaration _ ident _ _) (TypeRef ident' _) = ident == ident'
matches (ExternDataDeclaration ident _) (TypeRef ident' _) = ident == ident'
+ matches (ExternKindDeclaration ident) (KindRef ident') = ident == ident'
matches (TypeSynonymDeclaration ident _ _) (TypeRef ident' _) = ident == ident'
matches (TypeClassDeclaration ident _ _ _ _) (TypeClassRef ident') = ident == ident'
matches (ValueFixityDeclaration _ _ op) (ValueOpRef op') = op == op'
diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs
index 610cd7e..e15b30d 100644
--- a/src/Language/PureScript/AST/Traversals.hs
+++ b/src/Language/PureScript/AST/Traversals.hs
@@ -14,11 +14,12 @@ import Data.Maybe (mapMaybe)
import qualified Data.Set as S
import Language.PureScript.AST.Binders
-import Language.PureScript.AST.Literals
import Language.PureScript.AST.Declarations
-import Language.PureScript.Types
-import Language.PureScript.Traversals
+import Language.PureScript.AST.Literals
+import Language.PureScript.Kinds
import Language.PureScript.Names
+import Language.PureScript.Traversals
+import Language.PureScript.Types
everywhereOnValues
:: (Declaration -> Declaration)
@@ -588,6 +589,42 @@ accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (con
forValues (TypedValue _ _ ty) = f ty
forValues _ = mempty
+accumKinds
+ :: (Monoid r)
+ => (Kind -> r)
+ -> ( Declaration -> r
+ , Expr -> r
+ , Binder -> r
+ , CaseAlternative -> r
+ , DoNotationElement -> r
+ )
+accumKinds f = everythingOnValues mappend forDecls forValues (const mempty) (const mempty) (const mempty)
+ where
+ forDecls (DataDeclaration _ _ args dctors) =
+ foldMap (foldMap f . snd) args `mappend`
+ foldMap (foldMap forTypes . snd) dctors
+ forDecls (TypeClassDeclaration _ args implies _ _) =
+ foldMap (foldMap f . snd) args `mappend`
+ foldMap (foldMap forTypes . constraintArgs) implies
+ forDecls (TypeInstanceDeclaration _ cs _ tys _) =
+ foldMap (foldMap forTypes . constraintArgs) cs `mappend`
+ foldMap forTypes tys
+ forDecls (TypeSynonymDeclaration _ args ty) =
+ foldMap (foldMap f . snd) args `mappend`
+ forTypes ty
+ forDecls (TypeDeclaration _ ty) = forTypes ty
+ forDecls (ExternDeclaration _ ty) = forTypes ty
+ forDecls (ExternDataDeclaration _ kn) = f kn
+ forDecls _ = mempty
+
+ forValues (TypeClassDictionary c _ _) = foldMap forTypes (constraintArgs c)
+ forValues (DeferredDictionary _ tys) = foldMap forTypes tys
+ forValues (TypedValue _ _ ty) = forTypes ty
+ forValues _ = mempty
+
+ forTypes (KindedType _ k) = f k
+ forTypes _ = mempty
+
-- |
-- Map a function over type annotations appearing inside a value
--
diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs
index 2a36afe..6b63d19 100644
--- a/src/Language/PureScript/Bundle.hs
+++ b/src/Language/PureScript/Bundle.hs
@@ -6,6 +6,7 @@
-- and generates the final Javascript bundle.
module Language.PureScript.Bundle
( bundle
+ , bundleSM
, guessModuleIdentifier
, ModuleIdentifier(..)
, moduleName
@@ -19,6 +20,7 @@ import Prelude.Compat
import Control.Monad
import Control.Monad.Error.Class
+import Control.Arrow ((&&&))
import Data.Char (chr, digitToInt)
import Data.Generics (everything, everywhere, mkQ, mkT)
@@ -33,7 +35,9 @@ import Language.JavaScript.Parser.AST
import qualified Paths_purescript as Paths
-import System.FilePath (takeFileName, takeDirectory)
+import System.FilePath (takeFileName, takeDirectory, takeDirectory, makeRelative)
+
+import SourceMap.Types
-- | The type of error messages. We separate generation and rendering of errors using a data
-- type, in case we need to match on error types later.
@@ -98,10 +102,11 @@ data ModuleElement
| Member JSStatement Bool String JSExpression [Key]
| ExportsList [(ExportType, String, JSExpression, [Key])]
| Other JSStatement
+ | Skip JSStatement
deriving (Show)
-- | A module is just a list of elements of the types listed above.
-data Module = Module ModuleIdentifier [ModuleElement] deriving (Show)
+data Module = Module ModuleIdentifier (Maybe FilePath) [ModuleElement] deriving (Show)
-- | Prepare an error message for consumption by humans.
printErrorMessage :: ErrorMessage -> [String]
@@ -159,7 +164,7 @@ checkImportPath name _ _ = Left name
--
-- where name is the name of a member defined in the current module.
withDeps :: Module -> Module
-withDeps (Module modulePath es) = Module modulePath (map expandDeps es)
+withDeps (Module modulePath fn es) = Module modulePath fn (map expandDeps es)
where
-- | Collects all modules which are imported, so that we can identify dependencies of the first type.
imports :: [(String, ModuleIdentifier)]
@@ -248,9 +253,9 @@ trailingCommaList (JSCTLNone l) = commaList l
--
-- Each type of module element is matched using pattern guards, and everything else is bundled into the
-- Other constructor.
-toModule :: forall m. (MonadError ErrorMessage m) => S.Set String -> ModuleIdentifier -> JSAST -> m Module
-toModule mids mid top
- | JSAstProgram smts _ <- top = Module mid <$> traverse toModuleElement smts
+toModule :: forall m. (MonadError ErrorMessage m) => S.Set String -> ModuleIdentifier -> Maybe FilePath -> JSAST -> m Module
+toModule mids mid filename top
+ | JSAstProgram smts _ <- top = Module mid filename <$> traverse toModuleElement smts
| otherwise = err InvalidTopLevel
where
err = throwError . ErrorInModule mid
@@ -389,7 +394,7 @@ compile modules entryPoints = filteredModules
-- | The vertex set
verts :: [(ModuleElement, Key, [Key])]
verts = do
- Module mid els <- modules
+ Module mid _ els <- modules
concatMap (toVertices mid) els
where
-- | Create a set of vertices for a module element.
@@ -425,14 +430,21 @@ compile modules entryPoints = filteredModules
filteredModules = map filterUsed modules
where
filterUsed :: Module -> Module
- filterUsed (Module mid ds) = Module mid (map filterExports (go ds))
+ filterUsed (Module mid fn ds) = Module mid fn (map filterExports (go ds))
where
go :: [ModuleElement] -> [ModuleElement]
go [] = []
go (d : rest)
- | not (isDeclUsed d) = go rest
+ | not (isDeclUsed d) = skipDecl d : go rest
| otherwise = d : go rest
+ skipDecl :: ModuleElement -> ModuleElement
+ skipDecl (Require s _ _) = Skip s
+ skipDecl (Member s _ _ _ _) = Skip s
+ skipDecl (ExportsList _) = Skip (JSEmptyStatement JSNoAnnot)
+ skipDecl (Other s) = Skip s
+ skipDecl (Skip s) = Skip s
+
-- | Filter out the exports for members which aren't used.
filterExports :: ModuleElement -> ModuleElement
filterExports (ExportsList exps) = ExportsList (filter (\(_, nm, _, _) -> isKeyUsed (mid, nm)) exps)
@@ -453,7 +465,7 @@ sortModules :: [Module] -> [Module]
sortModules modules = map (\v -> case nodeFor v of (n, _, _) -> n) (reverse (topSort graph))
where
(graph, nodeFor, _) = graphFromEdges $ do
- m@(Module mid els) <- modules
+ m@(Module mid _ els) <- modules
return (m, mid, mapMaybe getKey els)
getKey :: ModuleElement -> Maybe ModuleIdentifier
@@ -466,12 +478,13 @@ sortModules modules = map (\v -> case nodeFor v of (n, _, _) -> n) (reverse (top
--
-- If a module is empty, we don't want to generate code for it.
isModuleEmpty :: Module -> Bool
-isModuleEmpty (Module _ els) = all isElementEmpty els
+isModuleEmpty (Module _ _ els) = all isElementEmpty els
where
isElementEmpty :: ModuleElement -> Bool
isElementEmpty (ExportsList exps) = null exps
isElementEmpty Require{} = True
isElementEmpty (Other _) = True
+ isElementEmpty (Skip _) = True
isElementEmpty _ = False
-- | Generate code for a set of modules, including a call to main().
@@ -490,16 +503,62 @@ isModuleEmpty (Module _ els) = all isElementEmpty els
codeGen :: Maybe String -- ^ main module
-> String -- ^ namespace
-> [Module] -- ^ input modules
- -> String
-codeGen optionsMainModule optionsNamespace ms = renderToString (JSAstProgram (prelude : concatMap moduleToJS ms ++ maybe [] runMain optionsMainModule) JSNoAnnot)
+ -> Maybe String -- ^ output filename
+ -> (Maybe SourceMapping, String)
+codeGen optionsMainModule optionsNamespace ms outFileOpt = (fmap sourceMapping outFileOpt, rendered)
where
- moduleToJS :: Module -> [JSStatement]
- moduleToJS (Module mn ds) = wrap (moduleName mn) (indent (concatMap declToJS ds))
+ rendered = renderToString (JSAstProgram (prelude : concatMap fst modulesJS ++ maybe [] runMain optionsMainModule) JSNoAnnot)
+
+ sourceMapping :: String -> SourceMapping
+ sourceMapping outFile = SourceMapping {
+ smFile = outFile,
+ smSourceRoot = Nothing,
+ smMappings = concat $
+ zipWith3 (\file (pos :: Int) positions ->
+ map (\(porig, pgen) -> Mapping {
+ mapOriginal = Just (Pos (fromIntegral $ porig + 1) 0)
+ , mapSourceFile = pathToFile <$> file
+ , mapGenerated = (Pos (fromIntegral $ pos + pgen) 0)
+ , mapName = Nothing
+ })
+ (offsets (0,0) (Right 1 : positions)))
+ moduleFns
+ (scanl (+) (3 + moduleLength [prelude]) (map (3+) moduleLengths)) -- 3 lines between each module & at top
+ (map snd modulesJS)
+ }
where
- declToJS :: ModuleElement -> [JSStatement]
- declToJS (Member n _ _ _ _) = [n]
- declToJS (Other n) = [n]
- declToJS (Require _ nm req) =
+ pathToFile = makeRelative (takeDirectory outFile)
+
+ offsets (m, n) (Left d:rest) = offsets (m+d, n) rest
+ offsets (m, n) (Right d:rest) = map ((m+) &&& (n+)) [0 .. d - 1] ++ offsets (m+d, n+d) rest
+ offsets _ _ = []
+
+ moduleLength :: [JSStatement] -> Int
+ moduleLength = everything (+) (mkQ 0 countw)
+ where
+ countw :: CommentAnnotation -> Int
+ countw (WhiteSpace _ s) = length (filter (== '\n') s)
+ countw _ = 0
+
+ moduleLengths :: [Int]
+ moduleLengths = map (sum . map (either (const 0) id) . snd) modulesJS
+ moduleFns = map (\(Module _ fn _) -> fn) ms
+
+ modulesJS = map moduleToJS ms
+
+ moduleToJS :: Module -> ([JSStatement], [Either Int Int])
+ moduleToJS (Module mn _ ds) = (wrap (moduleName mn) (indent (concat jsDecls)), lengths)
+ where
+ (jsDecls, lengths) = unzip $ map declToJS ds
+
+ withLength :: [JSStatement] -> ([JSStatement], Either Int Int)
+ withLength n = (n, Right $ moduleLength n)
+
+ declToJS :: ModuleElement -> ([JSStatement], Either Int Int)
+ declToJS (Member n _ _ _ _) = withLength [n]
+ declToJS (Other n) = withLength [n]
+ declToJS (Skip n) = ([], Left $ moduleLength [n])
+ declToJS (Require _ nm req) = withLength
[
JSVariable lfsp
(cList [
@@ -507,9 +566,10 @@ codeGen optionsMainModule optionsNamespace ms = renderToString (JSAstProgram (p
(JSVarInit sp $ either require (moduleReference sp . moduleName) req )
]) (JSSemi JSNoAnnot)
]
- declToJS (ExportsList exps) = map toExport exps
+ declToJS (ExportsList exps) = withLength $ map toExport exps
where
+
toExport :: (ExportType, String, JSExpression, [Key]) -> JSStatement
toExport (_, nm, val, _) =
JSAssignStatement
@@ -612,26 +672,39 @@ codeGen optionsMainModule optionsNamespace ms = renderToString (JSAstProgram (p
-- | The bundling function.
-- This function performs dead code elimination, filters empty modules
-- and generates and prints the final Javascript bundle.
-bundle :: (MonadError ErrorMessage m)
- => [(ModuleIdentifier, String)] -- ^ The input modules. Each module should be javascript rendered from 'Language.PureScript.Make' or @psc@.
+bundleSM :: (MonadError ErrorMessage m)
+ => [(ModuleIdentifier, Maybe FilePath, String)] -- ^ The input modules. Each module should be javascript rendered from 'Language.PureScript.Make' or @psc@.
-> [ModuleIdentifier] -- ^ Entry points. These module identifiers are used as the roots for dead-code elimination
-> Maybe String -- ^ An optional main module.
-> String -- ^ The namespace (e.g. PS).
- -> m String
-bundle inputStrs entryPoints mainModule namespace = do
+ -> Maybe FilePath -- ^ The output file name (if there is one - in which case generate source map)
+ -> m (Maybe SourceMapping, String)
+bundleSM inputStrs entryPoints mainModule namespace outFilename = do
+ let mid (a,_,_) = a
forM_ mainModule $ \mname ->
- when (mname `notElem` map (moduleName . fst) inputStrs) (throwError (MissingMainModule mname))
+ when (mname `notElem` map (moduleName . mid) inputStrs) (throwError (MissingMainModule mname))
forM_ entryPoints $ \mIdent ->
- when (mIdent `notElem` map fst inputStrs) (throwError (MissingEntryPoint (moduleName mIdent)))
- input <- forM inputStrs $ \(ident, js) -> do
+ when (mIdent `notElem` map mid inputStrs) (throwError (MissingEntryPoint (moduleName mIdent)))
+ input <- forM inputStrs $ \(ident, filename, js) -> do
ast <- either (throwError . ErrorInModule ident . UnableToParseModule) pure $ parse js (moduleName ident)
- return (ident, ast)
+ return (ident, filename, ast)
- let mids = S.fromList (map (moduleName . fst) input)
+ let mids = S.fromList (map (moduleName . mid) input)
- modules <- traverse (fmap withDeps . uncurry (toModule mids)) input
+ modules <- traverse (fmap withDeps . (\(a,fn,c) -> toModule mids a fn c)) input
let compiled = compile modules entryPoints
sorted = sortModules (filter (not . isModuleEmpty) compiled)
- return (codeGen mainModule namespace sorted)
+ return (codeGen mainModule namespace sorted outFilename)
+
+-- | The bundling function.
+-- This function performs dead code elimination, filters empty modules
+-- and generates and prints the final Javascript bundle.
+bundle :: (MonadError ErrorMessage m)
+ => [(ModuleIdentifier, String)] -- ^ The input modules. Each module should be javascript rendered from 'Language.PureScript.Make' or @psc@.
+ -> [ModuleIdentifier] -- ^ Entry points. These module identifiers are used as the roots for dead-code elimination
+ -> Maybe String -- ^ An optional main module.
+ -> String -- ^ The namespace (e.g. PS).
+ -> m String
+bundle inputStrs entryPoints mainModule namespace = snd <$> bundleSM (map (\(a,b) -> (a,Nothing,b)) inputStrs) entryPoints mainModule namespace Nothing
diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index 2625a6a..c92de6b 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -293,7 +293,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
evaluate = JSVariableIntroduction Nothing evaluatedObj (Just obj)
objAssign = JSVariableIntroduction Nothing newObj (Just $ JSObjectLiteral Nothing [])
copy = JSForIn Nothing key jsEvaluatedObj $ JSBlock Nothing [JSIfElse Nothing cond assign Nothing]
- cond = JSApp Nothing (JSAccessor Nothing "hasOwnProperty" jsEvaluatedObj) [jsKey]
+ cond = JSApp Nothing (JSAccessor Nothing "call" (JSAccessor Nothing "hasOwnProperty" (JSObjectLiteral Nothing []))) [jsEvaluatedObj, jsKey]
assign = JSBlock Nothing [JSAssignment Nothing (JSIndexer Nothing jsKey jsNewObj) (JSIndexer Nothing jsKey jsEvaluatedObj)]
stToAssign (s, js) = JSAssignment Nothing (accessorString s jsNewObj) js
extend = map stToAssign sts
diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs
index a472387..3d9351d 100644
--- a/src/Language/PureScript/Constants.hs
+++ b/src/Language/PureScript/Constants.hs
@@ -139,6 +139,9 @@ compose = "compose"
composeFlipped :: Text
composeFlipped = "composeFlipped"
+map :: Text
+map = "map"
+
-- Functions
negate :: Text
@@ -314,10 +317,38 @@ fromSpine = "fromSpine"
toSignature :: Text
toSignature = "toSignature"
--- IsSymbol class
+-- Data.Symbol
+
+pattern DataSymbol :: ModuleName
+pattern DataSymbol = ModuleName [ProperName "Data", ProperName "Symbol"]
pattern IsSymbol :: Qualified (ProperName 'ClassName)
-pattern IsSymbol = Qualified (Just (ModuleName [ProperName "Data", ProperName "Symbol"])) (ProperName "IsSymbol")
+pattern IsSymbol = Qualified (Just DataSymbol) (ProperName "IsSymbol")
+
+-- Type.Data.Symbol
+
+pattern TypeDataSymbol :: ModuleName
+pattern TypeDataSymbol = ModuleName [ProperName "Type", ProperName "Data", ProperName "Symbol"]
+
+pattern CompareSymbol :: Qualified (ProperName 'ClassName)
+pattern CompareSymbol = Qualified (Just TypeDataSymbol) (ProperName "CompareSymbol")
+
+pattern AppendSymbol :: Qualified (ProperName 'ClassName)
+pattern AppendSymbol = Qualified (Just TypeDataSymbol) (ProperName "AppendSymbol")
+
+-- Type.Data.Ordering
+
+typeDataOrdering :: ModuleName
+typeDataOrdering = ModuleName [ProperName "Type", ProperName "Data", ProperName "Ordering"]
+
+orderingLT :: Qualified (ProperName 'TypeName)
+orderingLT = Qualified (Just typeDataOrdering) (ProperName "LT")
+
+orderingEQ :: Qualified (ProperName 'TypeName)
+orderingEQ = Qualified (Just typeDataOrdering) (ProperName "EQ")
+
+orderingGT :: Qualified (ProperName 'TypeName)
+orderingGT = Qualified (Just typeDataOrdering) (ProperName "GT")
-- Main module
@@ -329,11 +360,23 @@ main = "main"
partial :: Text
partial = "Partial"
+pattern Prim :: ModuleName
+pattern Prim = ModuleName [ProperName "Prim"]
+
pattern Partial :: Qualified (ProperName 'ClassName)
-pattern Partial = Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName "Partial")
+pattern Partial = Qualified (Just Prim) (ProperName "Partial")
pattern Fail :: Qualified (ProperName 'ClassName)
-pattern Fail = Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName "Fail")
+pattern Fail = Qualified (Just Prim) (ProperName "Fail")
+
+typ :: Text
+typ = "Type"
+
+effect :: Text
+effect = "Effect"
+
+symbol :: Text
+symbol = "Symbol"
-- Code Generation
diff --git a/src/Language/PureScript/Docs.hs b/src/Language/PureScript/Docs.hs
index 9297000..9f36874 100644
--- a/src/Language/PureScript/Docs.hs
+++ b/src/Language/PureScript/Docs.hs
@@ -7,6 +7,7 @@ module Language.PureScript.Docs (
) where
import Language.PureScript.Docs.Convert as Docs
+import Language.PureScript.Docs.Prim as Docs
import Language.PureScript.Docs.ParseAndBookmark as Docs
import Language.PureScript.Docs.Render as Docs
import Language.PureScript.Docs.RenderedCode.Render as Docs
diff --git a/src/Language/PureScript/Docs/AsMarkdown.hs b/src/Language/PureScript/Docs/AsMarkdown.hs
index a336030..bcc258e 100644
--- a/src/Language/PureScript/Docs/AsMarkdown.hs
+++ b/src/Language/PureScript/Docs/AsMarkdown.hs
@@ -13,7 +13,9 @@ import Control.Monad.Error.Class (MonadError)
import Control.Monad.Writer (Writer, tell, execWriter)
import Data.Foldable (for_)
+import Data.Monoid ((<>))
import Data.List (partition)
+import Data.Text (Text)
import qualified Data.Text as T
import Language.PureScript.Docs.RenderedCode
@@ -24,27 +26,28 @@ import qualified Language.PureScript.Docs.Render as Render
-- |
-- Take a list of modules and render them all in order, returning a single
--- Markdown-formatted String.
+-- Markdown-formatted Text.
--
renderModulesAsMarkdown ::
(MonadError P.MultipleErrors m) =>
[P.Module] ->
- m String
+ m Text
renderModulesAsMarkdown =
- fmap (runDocs . modulesAsMarkdown) . Convert.convertModules
+ fmap (runDocs . modulesAsMarkdown) . Convert.convertModules Local
modulesAsMarkdown :: [Module] -> Docs
modulesAsMarkdown = mapM_ moduleAsMarkdown
moduleAsMarkdown :: Module -> Docs
moduleAsMarkdown Module{..} = do
- headerLevel 2 $ "Module " ++ T.unpack (P.runModuleName modName)
+ headerLevel 2 $ "Module " <> P.runModuleName modName
spacer
for_ modComments tell'
mapM_ (declAsMarkdown modName) modDeclarations
spacer
- for_ modReExports $ \(mn, decls) -> do
- headerLevel 3 $ "Re-exported from " ++ T.unpack (P.runModuleName mn) ++ ":"
+ for_ modReExports $ \(mn', decls) -> do
+ let mn = ignorePackage mn'
+ headerLevel 3 $ "Re-exported from " <> P.runModuleName mn <> ":"
spacer
mapM_ (declAsMarkdown mn) decls
@@ -71,7 +74,7 @@ declAsMarkdown mn decl@Declaration{..} = do
isChildInstance (ChildInstance _ _) = True
isChildInstance _ = False
-codeToString :: RenderedCode -> String
+codeToString :: RenderedCode -> Text
codeToString = outputWith elemAsMarkdown
where
elemAsMarkdown (Syntax x) = x
@@ -95,14 +98,14 @@ codeToString = outputWith elemAsMarkdown
-- P.Infixr -> "right-associative"
-- P.Infix -> "non-associative"
-childToString :: First -> ChildDeclaration -> String
+childToString :: First -> ChildDeclaration -> Text
childToString f decl@ChildDeclaration{..} =
case cdeclInfo of
ChildDataConstructor _ ->
let c = if f == First then "=" else "|"
- in " " ++ c ++ " " ++ str
+ in " " <> c <> " " <> str
ChildTypeClassMember _ ->
- " " ++ str
+ " " <> str
ChildInstance _ _ ->
str
where
@@ -113,19 +116,19 @@ data First
| NotFirst
deriving (Show, Eq, Ord)
-type Docs = Writer [String] ()
+type Docs = Writer [Text] ()
-runDocs :: Docs -> String
-runDocs = unlines . execWriter
+runDocs :: Docs -> Text
+runDocs = T.unlines . execWriter
-tell' :: String -> Docs
+tell' :: Text -> Docs
tell' = tell . (:[])
spacer :: Docs
spacer = tell' ""
-headerLevel :: Int -> String -> Docs
-headerLevel level hdr = tell' (replicate level '#' ++ ' ' : hdr)
+headerLevel :: Int -> Text -> Docs
+headerLevel level hdr = tell' (T.replicate level "#" <> " " <> hdr)
fencedBlock :: Docs -> Docs
fencedBlock inner = do
@@ -133,5 +136,5 @@ fencedBlock inner = do
inner
tell' "```"
-ticks :: String -> String
-ticks = ("`" ++) . (++ "`")
+ticks :: Text -> Text
+ticks = ("`" <>) . (<> "`")
diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs
index 5473cff..541d80b 100644
--- a/src/Language/PureScript/Docs/Convert.hs
+++ b/src/Language/PureScript/Docs/Convert.hs
@@ -15,8 +15,9 @@ import Control.Monad
import Control.Monad.Error.Class (MonadError)
import Control.Monad.State (runStateT)
import Control.Monad.Writer.Strict (runWriterT)
+import Data.List (find)
import qualified Data.Map as Map
-import qualified Data.Text as T
+import Data.Text (Text)
import Language.PureScript.Docs.Convert.ReExports (updateReExports)
import Language.PureScript.Docs.Convert.Single (convertSingleModule, collectBookmarks)
@@ -42,9 +43,18 @@ convertModulesInPackage modules =
map P.getModuleName (takeLocals modules)
go =
map ignorePackage
- >>> convertModules
+ >>> convertModules withPackage
>>> fmap (filter ((`elem` localNames) . modName))
+ withPackage :: P.ModuleName -> InPackage P.ModuleName
+ withPackage mn =
+ case find ((== mn) . P.getModuleName . ignorePackage) modules of
+ Just m ->
+ fmap P.getModuleName m
+ Nothing ->
+ P.internalError $ "withPackage: missing module:" ++
+ show (P.runModuleName mn)
+
-- |
-- Convert a group of modules to the intermediate format, designed for
-- producing documentation from. It is also necessary to pass an Env containing
@@ -61,12 +71,13 @@ convertModulesInPackage modules =
--
convertModules ::
(MonadError P.MultipleErrors m) =>
+ (P.ModuleName -> InPackage P.ModuleName) ->
[P.Module] ->
m [Module]
-convertModules =
+convertModules withPackage =
P.sortModules
>>> fmap (fst >>> map importPrim)
- >=> convertSorted
+ >=> convertSorted withPackage
importPrim :: P.Module -> P.Module
importPrim = P.addDefaultImport (P.ModuleName [P.ProperName C.prim])
@@ -76,16 +87,17 @@ importPrim = P.addDefaultImport (P.ModuleName [P.ProperName C.prim])
--
convertSorted ::
(MonadError P.MultipleErrors m) =>
+ (P.ModuleName -> InPackage P.ModuleName) ->
[P.Module] ->
m [Module]
-convertSorted modules = do
+convertSorted withPackage modules = do
(env, convertedModules) <- second (map convertSingleModule) <$> partiallyDesugar modules
modulesWithTypes <- typeCheckIfNecessary modules convertedModules
let moduleMap = Map.fromList (map (modName &&& id) modulesWithTypes)
let traversalOrder = map P.getModuleName modules
- pure (Map.elems (updateReExports env traversalOrder moduleMap))
+ pure (Map.elems (updateReExports env traversalOrder withPackage moduleMap))
-- |
-- If any exported value declarations have either wildcard type signatures, or
@@ -167,9 +179,9 @@ insertValueTypes env m =
err msg =
P.internalError ("Docs.Convert.insertValueTypes: " ++ msg)
-runParser :: P.TokenParser a -> String -> Either String a
+runParser :: P.TokenParser a -> Text -> Either String a
runParser p s = either (Left . show) Right $ do
- ts <- P.lex "" (T.pack s)
+ ts <- P.lex "" s
P.runTokenParser "" (p <* eof) ts
-- |
diff --git a/src/Language/PureScript/Docs/Convert/ReExports.hs b/src/Language/PureScript/Docs/Convert/ReExports.hs
index f4fcec2..044cf98 100644
--- a/src/Language/PureScript/Docs/Convert/ReExports.hs
+++ b/src/Language/PureScript/Docs/Convert/ReExports.hs
@@ -16,6 +16,7 @@ import Data.Map (Map)
import Data.Maybe (mapMaybe)
import Data.Monoid ((<>))
import qualified Data.Map as Map
+import Data.Text (Text)
import qualified Data.Text as T
import Language.PureScript.Docs.Types
@@ -34,9 +35,10 @@ import qualified Language.PureScript as P
updateReExports ::
P.Env ->
[P.ModuleName] ->
+ (P.ModuleName -> InPackage P.ModuleName) ->
Map P.ModuleName Module ->
Map P.ModuleName Module
-updateReExports env order = execState action
+updateReExports env order withPackage = execState action
where
action =
void (traverse go order)
@@ -44,7 +46,7 @@ updateReExports env order = execState action
go mn = do
mdl <- lookup' mn
reExports <- getReExports env mn
- let mdl' = mdl { modReExports = reExports }
+ let mdl' = mdl { modReExports = map (first withPackage) reExports }
modify (Map.insert mn mdl')
lookup' mn = do
@@ -108,13 +110,14 @@ collectDeclarations imports exports = do
typeClasses <- collect lookupTypeClassDeclaration impTCs expTCs
types <- collect lookupTypeDeclaration impTypes expTypes
typeOps <- collect lookupTypeOpDeclaration impTypeOps expTypeOps
+ kinds <- collect lookupKindDeclaration impKinds expKinds
(vals, classes) <- handleTypeClassMembers valsAndMembers typeClasses
let filteredTypes = filterDataConstructors expCtors types
let filteredClasses = filterTypeClassMembers (Map.keys expVals) classes
- pure (Map.toList (Map.unionsWith (<>) [filteredTypes, filteredClasses, vals, valOps, typeOps]))
+ pure (Map.toList (Map.unionsWith (<>) [filteredTypes, filteredClasses, vals, valOps, typeOps, kinds]))
where
@@ -145,6 +148,9 @@ collectDeclarations imports exports = do
expTCs = P.exportedTypeClasses exports
impTCs = concat (Map.elems (P.importedTypeClasses imports))
+ expKinds = P.exportedKinds exports
+ impKinds = concat (Map.elems (P.importedKinds imports))
+
-- |
-- Given a list of imported declarations (of a particular kind, ie. type, data,
-- class, value, etc), and the name of an exported declaration of the same
@@ -184,12 +190,12 @@ lookupValueDeclaration ::
MonadReader P.ModuleName m) =>
P.ModuleName ->
P.Ident ->
- m (P.ModuleName, [Either (String, P.Constraint, ChildDeclaration) Declaration])
+ m (P.ModuleName, [Either (Text, P.Constraint, ChildDeclaration) Declaration])
lookupValueDeclaration importedFrom ident = do
decls <- lookupModuleDeclarations "lookupValueDeclaration" importedFrom
let
rs =
- filter (\d -> declTitle d == T.unpack (P.showIdent ident)
+ filter (\d -> declTitle d == P.showIdent ident
&& (isValue d || isValueAlias d)) decls
errOther other =
internalErrorInModule
@@ -215,7 +221,7 @@ lookupValueDeclaration importedFrom ident = do
(declChildren d))
matchesIdent cdecl =
- cdeclTitle cdecl == T.unpack (P.showIdent ident)
+ cdeclTitle cdecl == P.showIdent ident
matchesAndIsTypeClassMember =
uncurry (&&) . (matchesIdent &&& isTypeClassMember)
@@ -239,7 +245,7 @@ lookupValueOpDeclaration
-> m (P.ModuleName, [Declaration])
lookupValueOpDeclaration importedFrom op = do
decls <- lookupModuleDeclarations "lookupValueOpDeclaration" importedFrom
- case filter (\d -> declTitle d == T.unpack (P.showOp op) && isValueAlias d) decls of
+ case filter (\d -> declTitle d == P.showOp op && isValueAlias d) decls of
[d] ->
pure (importedFrom, [d])
other ->
@@ -259,7 +265,7 @@ lookupTypeDeclaration ::
lookupTypeDeclaration importedFrom ty = do
decls <- lookupModuleDeclarations "lookupTypeDeclaration" importedFrom
let
- ds = filter (\d -> declTitle d == T.unpack (P.runProperName ty) && isType d) decls
+ ds = filter (\d -> declTitle d == P.runProperName ty && isType d) decls
case ds of
[d] ->
pure (importedFrom, [d])
@@ -275,7 +281,7 @@ lookupTypeOpDeclaration
lookupTypeOpDeclaration importedFrom tyOp = do
decls <- lookupModuleDeclarations "lookupTypeOpDeclaration" importedFrom
let
- ds = filter (\d -> declTitle d == ("type " ++ T.unpack (P.showOp tyOp)) && isTypeAlias d) decls
+ ds = filter (\d -> declTitle d == ("type " <> P.showOp tyOp) && isTypeAlias d) decls
case ds of
[d] ->
pure (importedFrom, [d])
@@ -291,7 +297,7 @@ lookupTypeClassDeclaration
lookupTypeClassDeclaration importedFrom tyClass = do
decls <- lookupModuleDeclarations "lookupTypeClassDeclaration" importedFrom
let
- ds = filter (\d -> declTitle d == T.unpack (P.runProperName tyClass)
+ ds = filter (\d -> declTitle d == P.runProperName tyClass
&& isTypeClass d)
decls
case ds of
@@ -302,6 +308,24 @@ lookupTypeClassDeclaration importedFrom tyClass = do
("lookupTypeClassDeclaration: unexpected result: "
++ (unlines . map show) other)
+lookupKindDeclaration
+ :: (MonadState (Map P.ModuleName Module) m, MonadReader P.ModuleName m)
+ => P.ModuleName
+ -> P.ProperName 'P.KindName
+ -> m (P.ModuleName, [Declaration])
+lookupKindDeclaration importedFrom kind = do
+ decls <- lookupModuleDeclarations "lookupKindDeclaration" importedFrom
+ let
+ ds = filter (\d -> declTitle d == P.runProperName kind
+ && isKind d)
+ decls
+ case ds of
+ [d] ->
+ pure (importedFrom, [d])
+ other ->
+ internalErrorInModule
+ ("lookupKindDeclaration: unexpected result: " ++ show other)
+
-- |
-- Get the full list of declarations for a particular module out of the
-- state, or raise an internal error if it is not there.
@@ -324,7 +348,7 @@ lookupModuleDeclarations definedIn moduleName = do
handleTypeClassMembers ::
(MonadReader P.ModuleName m) =>
- Map P.ModuleName [Either (String, P.Constraint, ChildDeclaration) Declaration] ->
+ Map P.ModuleName [Either (Text, P.Constraint, ChildDeclaration) Declaration] ->
Map P.ModuleName [Declaration] ->
m (Map P.ModuleName [Declaration], Map P.ModuleName [Declaration])
handleTypeClassMembers valsAndMembers typeClasses =
@@ -339,7 +363,7 @@ handleTypeClassMembers valsAndMembers typeClasses =
|> fmap splitMap
valsAndMembersToEnv ::
- [Either (String, P.Constraint, ChildDeclaration) Declaration] -> TypeClassEnv
+ [Either (Text, P.Constraint, ChildDeclaration) Declaration] -> TypeClassEnv
valsAndMembersToEnv xs =
let (envUnhandledMembers, envValues) = partitionEithers xs
envTypeClasses = []
@@ -360,11 +384,11 @@ typeClassesToEnv classes =
--
data TypeClassEnv = TypeClassEnv
{ -- |
- -- Type class members which have not yet been dealt with. The String is the
+ -- Type class members which have not yet been dealt with. The Text is the
-- name of the type class they belong to, and the constraint is used to
-- make sure that they have the correct type if they get promoted.
--
- envUnhandledMembers :: [(String, P.Constraint, ChildDeclaration)]
+ envUnhandledMembers :: [(Text, P.Constraint, ChildDeclaration)]
-- |
-- A list of normal value declarations. Type class members will be added to
-- this list if their parent type class is not available.
@@ -428,7 +452,7 @@ handleEnv TypeClassEnv{..} =
_ ->
internalErrorInModule
("handleEnv: Bad child declaration passed to promoteChild: "
- ++ cdeclTitle)
+ ++ T.unpack cdeclTitle)
addConstraint constraint =
P.quantify . P.moveQuantifiersToFront . P.ConstrainedType [constraint]
@@ -448,7 +472,7 @@ filterDataConstructors
-> Map P.ModuleName [Declaration]
-> Map P.ModuleName [Declaration]
filterDataConstructors =
- filterExportedChildren isDataConstructor (T.unpack . P.runProperName)
+ filterExportedChildren isDataConstructor P.runProperName
-- |
-- Given a list of exported type class member names, remove any data
@@ -460,12 +484,12 @@ filterTypeClassMembers
-> Map P.ModuleName [Declaration]
-> Map P.ModuleName [Declaration]
filterTypeClassMembers =
- filterExportedChildren isTypeClassMember (T.unpack . P.showIdent)
+ filterExportedChildren isTypeClassMember P.showIdent
filterExportedChildren
:: (Functor f)
=> (ChildDeclaration -> Bool)
- -> (name -> String)
+ -> (name -> Text)
-> [name]
-> f [Declaration]
-> f [Declaration]
@@ -504,7 +528,7 @@ typeClassConstraintFor :: Declaration -> Maybe P.Constraint
typeClassConstraintFor Declaration{..} =
case declInfo of
TypeClassDeclaration tyArgs _ _ ->
- Just (P.Constraint (P.Qualified Nothing (P.ProperName (T.pack declTitle))) (mkConstraint (map (first T.pack) tyArgs)) Nothing)
+ Just (P.Constraint (P.Qualified Nothing (P.ProperName declTitle)) (mkConstraint tyArgs) Nothing)
_ ->
Nothing
where
diff --git a/src/Language/PureScript/Docs/Convert/Single.hs b/src/Language/PureScript/Docs/Convert/Single.hs
index 0743560..36dbc36 100644
--- a/src/Language/PureScript/Docs/Convert/Single.hs
+++ b/src/Language/PureScript/Docs/Convert/Single.hs
@@ -5,24 +5,19 @@ module Language.PureScript.Docs.Convert.Single
import Prelude.Compat
-import Control.Arrow (first)
import Control.Category ((>>>))
import Control.Monad
-import Data.Bifunctor (bimap)
import Data.Either
import Data.List (nub)
-import Data.Maybe (mapMaybe)
+import Data.Maybe (mapMaybe, fromMaybe)
import Data.Monoid ((<>))
import Data.Text (Text)
import qualified Data.Text as T
-import qualified Data.Vector as V
import Language.PureScript.Docs.Types
import qualified Language.PureScript as P
--- TODO (Christoph): Get rid of the T.unpack s
-
-- |
-- Convert a single Module, but ignore re-exports; any re-exported types or
-- values will not appear in the result.
@@ -48,14 +43,14 @@ convertSingleModule m@(P.Module _ coms moduleName _ _) =
-- In the second pass, we go over all of the Left values and augment the
-- relevant declarations, leaving only the augmented Right values.
--
--- Note that in the Left case, we provide a [String] as well as augment
--- information. The [String] value should be a list of titles of declarations
+-- Note that in the Left case, we provide a [Text] as well as augment
+-- information. The [Text] value should be a list of titles of declarations
-- that the augmentation should apply to. For example, for a type instance
-- declaration, that would be any types or type classes mentioned in the
-- instance. For a fixity declaration, it would be just the relevant operator's
-- name.
type IntermediateDeclaration
- = Either ([String], DeclarationAugment) Declaration
+ = Either ([Text], DeclarationAugment) Declaration
-- | Some data which will be used to augment a Declaration in the
-- output.
@@ -88,6 +83,7 @@ getDeclarationTitle (P.ValueDeclaration name _ _ _) = Just (P.showIdent name)
getDeclarationTitle (P.ExternDeclaration name _) = Just (P.showIdent name)
getDeclarationTitle (P.DataDeclaration _ name _ _) = Just (P.runProperName name)
getDeclarationTitle (P.ExternDataDeclaration name _) = Just (P.runProperName name)
+getDeclarationTitle (P.ExternKindDeclaration name) = Just (P.runProperName name)
getDeclarationTitle (P.TypeSynonymDeclaration name _ _) = Just (P.runProperName name)
getDeclarationTitle (P.TypeClassDeclaration name _ _ _ _) = Just (P.runProperName name)
getDeclarationTitle (P.TypeInstanceDeclaration name _ _ _ _) = Just (P.showIdent name)
@@ -99,7 +95,7 @@ getDeclarationTitle _ = Nothing
-- | Create a basic Declaration value.
mkDeclaration :: Text -> DeclarationInfo -> Declaration
mkDeclaration title info =
- Declaration { declTitle = T.unpack title
+ Declaration { declTitle = title
, declComments = Nothing
, declSourceSpan = Nothing
, declChildren = []
@@ -121,42 +117,29 @@ convertDeclaration (P.ExternDeclaration _ ty) title =
convertDeclaration (P.DataDeclaration dtype _ args ctors) title =
Just (Right (mkDeclaration title info) { declChildren = children })
where
- info = DataDeclaration dtype (map (first T.unpack) args)
+ info = DataDeclaration dtype args
children = map convertCtor ctors
convertCtor (ctor', tys) =
- ChildDeclaration (T.unpack (P.runProperName ctor')) Nothing Nothing (ChildDataConstructor tys)
+ ChildDeclaration (P.runProperName ctor') Nothing Nothing (ChildDataConstructor tys)
convertDeclaration (P.ExternDataDeclaration _ kind') title =
basicDeclaration title (ExternDataDeclaration kind')
+convertDeclaration (P.ExternKindDeclaration _) title =
+ basicDeclaration title ExternKindDeclaration
convertDeclaration (P.TypeSynonymDeclaration _ args ty) title =
- basicDeclaration title (TypeSynonymDeclaration (map (first T.unpack) args) ty)
+ basicDeclaration title (TypeSynonymDeclaration args ty)
convertDeclaration (P.TypeClassDeclaration _ args implies fundeps ds) title =
Just (Right (mkDeclaration title info) { declChildren = children })
where
- info = TypeClassDeclaration (map (first T.unpack) args) implies (map (bimap (map T.unpack) (map T.unpack)) fundeps')
+ info = TypeClassDeclaration args implies (convertFundepsToStrings args fundeps)
children = map convertClassMember ds
convertClassMember (P.PositionedDeclaration _ _ d) =
convertClassMember d
convertClassMember (P.TypeDeclaration ident' ty) =
- ChildDeclaration (T.unpack (P.showIdent ident')) Nothing Nothing (ChildTypeClassMember ty)
+ ChildDeclaration (P.showIdent ident') Nothing Nothing (ChildTypeClassMember ty)
convertClassMember _ =
P.internalError "convertDeclaration: Invalid argument to convertClassMember."
- fundeps' = map (\(P.FunctionalDependency from to) -> toArgs from to) fundeps
- where
- argsVec = V.fromList (map fst args)
- getArg i =
- maybe
- (P.internalError $ unlines
- [ "convertDeclaration: Functional dependency index"
- , show i
- , "is bigger than arguments list"
- , show (map fst args)
- , "Functional dependencies are"
- , show fundeps
- ]
- ) id $ argsVec V.!? i
- toArgs from to = (map getArg from, map getArg to)
convertDeclaration (P.TypeInstanceDeclaration _ constraints className tys _) title =
- Just (Left (T.unpack classNameString : map T.unpack typeNameStrings, AugmentChild childDecl))
+ Just (Left (classNameString : typeNameStrings, AugmentChild childDecl))
where
classNameString = unQual className
typeNameStrings = nub (concatMap (P.everythingOnTypes (++) extractProperNames) tys)
@@ -165,7 +148,7 @@ convertDeclaration (P.TypeInstanceDeclaration _ constraints className tys _) tit
extractProperNames (P.TypeConstructor n) = [unQual n]
extractProperNames _ = []
- childDecl = ChildDeclaration (T.unpack title) Nothing Nothing (ChildInstance constraints classApp)
+ childDecl = ChildDeclaration title Nothing Nothing (ChildInstance constraints classApp)
classApp = foldl P.TypeApp (P.TypeConstructor (fmap P.coerceProperName className)) tys
convertDeclaration (P.ValueFixityDeclaration fixity (P.Qualified mn alias) _) title =
Just $ Right $ mkDeclaration title (AliasDeclaration fixity (P.Qualified mn (Right alias)))
@@ -189,25 +172,24 @@ convertDeclaration (P.PositionedDeclaration srcSpan com d') title =
withAugmentChild f (t, AugmentChild d) = (t, AugmentChild (f d))
convertDeclaration _ _ = Nothing
-convertComments :: [P.Comment] -> Maybe String
+convertComments :: [P.Comment] -> Maybe Text
convertComments cs = do
let raw = concatMap toLines cs
let docs = mapMaybe stripPipe raw
guard (not (null docs))
- pure (unlines docs)
+ pure (T.unlines docs)
where
- toLines (P.LineComment s) = [T.unpack s]
- toLines (P.BlockComment s) = lines (T.unpack s)
-
- stripPipe s' =
- case dropWhile (== ' ') s' of
- ('|':' ':s) ->
- Just s
- ('|':s) ->
- Just s
- _ ->
- Nothing
+ toLines (P.LineComment s) = [s]
+ toLines (P.BlockComment s) = T.lines s
+
+ stripPipe =
+ T.dropWhile (== ' ')
+ >>> T.stripPrefix "|"
+ >>> fmap (dropPrefix " ")
+
+ dropPrefix prefix str =
+ fromMaybe str (T.stripPrefix prefix str)
-- | Go through a PureScript module and extract a list of Bookmarks; references
-- to data types or values, to be used as a kind of index. These are used for
@@ -216,8 +198,7 @@ collectBookmarks :: InPackage P.Module -> [Bookmark]
collectBookmarks (Local m) = map Local (collectBookmarks' m)
collectBookmarks (FromDep pkg m) = map (FromDep pkg) (collectBookmarks' m)
-collectBookmarks' :: P.Module -> [(P.ModuleName, String)]
+collectBookmarks' :: P.Module -> [(P.ModuleName, Text)]
collectBookmarks' m =
map (P.getModuleName m, )
- (mapMaybe (fmap T.unpack . getDeclarationTitle)
- (P.exportedDeclarations m))
+ (mapMaybe getDeclarationTitle (P.exportedDeclarations m))
diff --git a/src/Language/PureScript/Docs/Prim.hs b/src/Language/PureScript/Docs/Prim.hs
new file mode 100644
index 0000000..41b53dc
--- /dev/null
+++ b/src/Language/PureScript/Docs/Prim.hs
@@ -0,0 +1,244 @@
+-- | This module provides documentation for the builtin Prim module.
+module Language.PureScript.Docs.Prim (primDocsModule) where
+
+import Prelude.Compat hiding (fail)
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import Language.PureScript.Docs.Types
+import qualified Language.PureScript as P
+
+primDocsModule :: Module
+primDocsModule = Module
+ { modName = P.moduleNameFromString "Prim"
+ , modComments = Just "The Prim module is embedded in the PureScript compiler in order to provide compiler support for certain types &mdash; for example, value literals, or syntax sugar."
+ , modDeclarations =
+ [ function
+ , array
+ , record
+ , number
+ , int
+ , string
+ , char
+ , boolean
+ , partial
+ , fail
+ , typeConcat
+ , typeString
+ , kindType
+ , kindEffect
+ , kindSymbol
+ ]
+ , modReExports = []
+ }
+
+unsafeLookup :: forall v (a :: P.ProperNameType).
+ Map.Map (P.Qualified (P.ProperName a)) v -> String -> Text -> v
+unsafeLookup m errorMsg name = go name
+ where
+ go = fromJust' . flip Map.lookup m . P.primName
+
+ fromJust' (Just x) = x
+ fromJust' _ = P.internalError $ errorMsg ++ show name
+
+primKind :: Text -> Text -> Declaration
+primKind title comments =
+ if Set.member (P.primName title) P.primKinds
+ then Declaration
+ { declTitle = title
+ , declComments = Just comments
+ , declSourceSpan = Nothing
+ , declChildren = []
+ , declInfo = ExternKindDeclaration
+ }
+ else P.internalError $ "Docs.Prim: No such Prim kind: " ++ T.unpack title
+
+lookupPrimTypeKind :: Text -> P.Kind
+lookupPrimTypeKind = fst . unsafeLookup P.primTypes "Docs.Prim: No such Prim type: "
+
+primType :: Text -> Text -> Declaration
+primType title comments = Declaration
+ { declTitle = title
+ , declComments = Just comments
+ , declSourceSpan = Nothing
+ , declChildren = []
+ , declInfo = ExternDataDeclaration (lookupPrimTypeKind title)
+ }
+
+-- | Lookup the TypeClassData of a Prim class. This function is specifically
+-- not exported because it is partial.
+lookupPrimClass :: Text -> P.TypeClassData
+lookupPrimClass = unsafeLookup P.primClasses "Docs.Prim: No such Prim class: "
+
+primClass :: Text -> Text -> Declaration
+primClass title comments = Declaration
+ { declTitle = title
+ , declComments = Just comments
+ , declSourceSpan = Nothing
+ , declChildren = []
+ , declInfo =
+ let
+ tcd = lookupPrimClass title
+ args = P.typeClassArguments tcd
+ superclasses = P.typeClassSuperclasses tcd
+ fundeps = convertFundepsToStrings args (P.typeClassDependencies tcd)
+ in
+ TypeClassDeclaration args superclasses fundeps
+ }
+
+kindType :: Declaration
+kindType = primKind "Type" $ T.unlines
+ [ "`Type` (also known as `*`) is the kind of all proper types: those that"
+ , "classify value-level terms."
+ , "For example the type `Boolean` has kind `Type`; denoted by `Boolean :: Type`."
+ ]
+
+kindEffect :: Declaration
+kindEffect = primKind "Effect" $ T.unlines
+ [ "`Effect` (also known as `!`) is the kind of all effect types."
+ ]
+
+kindSymbol :: Declaration
+kindSymbol = primKind "Symbol" $ T.unlines
+ [ "`Symbol` is the kind of type-level strings."
+ , ""
+ , "Construct types of this kind using the same literal syntax as documented"
+ , "for strings."
+ ]
+
+function :: Declaration
+function = primType "Function" $ T.unlines
+ [ "A function, which takes values of the type specified by the first type"
+ , "parameter, and returns values of the type specified by the second."
+ , "In the JavaScript backend, this is a standard JavaScript Function."
+ , ""
+ , "The type constructor `(->)` is syntactic sugar for this type constructor."
+ , "It is recommended to use `(->)` rather than `Function`, where possible."
+ , ""
+ , "That is, prefer this:"
+ , ""
+ , " f :: Number -> Number"
+ , ""
+ , "to either of these:"
+ , ""
+ , " f :: Function Number Number"
+ , " f :: (->) Number Number"
+ ]
+
+array :: Declaration
+array = primType "Array" $ T.unlines
+ [ "An Array: a data structure supporting efficient random access. In"
+ , "the JavaScript backend, values of this type are represented as JavaScript"
+ , "Arrays at runtime."
+ , ""
+ , "Construct values using literals:"
+ , ""
+ , " x = [1,2,3,4,5] :: Array Int"
+ ]
+
+record :: Declaration
+record = primType "Record" $ T.unlines
+ [ "The type of records whose fields are known at compile time. In the"
+ , "JavaScript backend, values of this type are represented as JavaScript"
+ , "Objects at runtime."
+ , ""
+ , "The type signature here means that the `Record` type constructor takes"
+ , "a row of concrete types. For example:"
+ , ""
+ , " type Person = Record (name :: String, age :: Number)"
+ , ""
+ , "The syntactic sugar with curly braces `{ }` is generally preferred, though:"
+ , ""
+ , " type Person = { name :: String, age :: Number }"
+ ]
+
+number :: Declaration
+number = primType "Number" $ T.unlines
+ [ "A double precision floating point number (IEEE 754)."
+ , ""
+ , "Construct values of this type with literals:"
+ , ""
+ , " y = 35.23 :: Number"
+ , " z = 1.224e6 :: Number"
+ ]
+
+int :: Declaration
+int = primType "Int" $ T.unlines
+ [ "A 32-bit signed integer. See the purescript-integers package for details"
+ , "of how this is accomplished when compiling to JavaScript."
+ , ""
+ , "Construct values of this type with literals:"
+ , ""
+ , " x = 23 :: Int"
+ ]
+
+string :: Declaration
+string = primType "String" $ T.unlines
+ [ "A String. As in JavaScript, String values represent sequences of UTF-16"
+ , "code units, which are not required to form a valid encoding of Unicode"
+ , "text (for example, lone surrogates are permitted)."
+ , ""
+ , "Construct values of this type with literals, using double quotes `\"`:"
+ , ""
+ , " x = \"hello, world\" :: String"
+ , ""
+ , "Multi-line string literals are also supported with triple quotes (`\"\"\"`)."
+ ]
+
+char :: Declaration
+char = primType "Char" $ T.unlines
+ [ "A single character (UTF-16 code unit). The JavaScript representation is a"
+ , "normal String, which is guaranteed to contain one code unit. This means"
+ , "that astral plane characters (i.e. those with code point values greater"
+ , "than 0xFFFF) cannot be represented as Char values."
+ , ""
+ , "Construct values of this type with literals, using single quotes `'`:"
+ , ""
+ , " x = 'a' :: Char"
+ ]
+
+boolean :: Declaration
+boolean = primType "Boolean" $ T.unlines
+ [ "A JavaScript Boolean value."
+ , ""
+ , "Construct values of this type with the literals `true` and `false`."
+ ]
+
+partial :: Declaration
+partial = primClass "Partial" $ T.unlines
+ [ "The Partial type class is used to indicate that a function is *partial,*"
+ , "that is, it is not defined for all inputs. In practice, attempting to use"
+ , "a partial function with a bad input will usually cause an error to be"
+ , "thrown, although it is not safe to assume that this will happen in all"
+ , "cases. For more information, see"
+ , "[the Partial type class guide](https://github.com/purescript/documentation/blob/master/guides/The-Partial-type-class.md)."
+ ]
+
+fail :: Declaration
+fail = primClass "Fail" $ T.unlines
+ [ "The Fail type class is part of the custom type errors feature. To provide"
+ , "a custom type error when someone tries to use a particular instance,"
+ , "write that instance out with a Fail constraint."
+ , ""
+ , "For more information, see"
+ , "[the Custom Type Errors guide](https://github.com/purescript/documentation/blob/master/guides/Custom-Type-Errors.md)."
+ ]
+
+typeConcat :: Declaration
+typeConcat = primType "TypeConcat" $ T.unlines
+ [ "The TypeConcat type constructor concatenates two Symbols in a custom type"
+ , "error."
+ , ""
+ , "For more information, see"
+ , "[the Custom Type Errors guide](https://github.com/purescript/documentation/blob/master/guides/Custom-Type-Errors.md)."
+ ]
+
+typeString :: Declaration
+typeString = primType "TypeString" $ T.unlines
+ [ "The TypeString type constructor renders any concrete type into a Symbol"
+ , "in a custom type error."
+ , ""
+ , "For more information, see"
+ , "[the Custom Type Errors guide](https://github.com/purescript/documentation/blob/master/guides/Custom-Type-Errors.md)."
+ ]
diff --git a/src/Language/PureScript/Docs/Render.hs b/src/Language/PureScript/Docs/Render.hs
index 352bff9..639824c 100644
--- a/src/Language/PureScript/Docs/Render.hs
+++ b/src/Language/PureScript/Docs/Render.hs
@@ -13,16 +13,14 @@ import Prelude.Compat
import Data.Maybe (maybeToList)
import Data.Monoid ((<>))
-import qualified Data.Text as T
import Data.Text (Text)
+import qualified Data.Text as T
import Language.PureScript.Docs.RenderedCode
import Language.PureScript.Docs.Types
import Language.PureScript.Docs.Utils.MonoidExtras
import qualified Language.PureScript as P
--- TODO (Christoph): get rid of T.unpack's
-
renderDeclaration :: Declaration -> RenderedCode
renderDeclaration = renderDeclarationWithOptions defaultRenderTypeOptions
@@ -35,7 +33,7 @@ renderDeclarationWithOptions opts Declaration{..} =
, renderType' ty
]
DataDeclaration dtype args ->
- [ keyword (T.unpack (P.showDataDeclType dtype))
+ [ keyword (P.showDataDeclType dtype)
, renderType' (typeApp declTitle args)
]
ExternDataDeclaration kind' ->
@@ -76,20 +74,25 @@ renderDeclarationWithOptions opts Declaration{..} =
AliasDeclaration (P.Fixity associativity precedence) for@(P.Qualified _ alias) ->
[ keywordFixity associativity
- , syntax $ show precedence
+ , syntax $ T.pack $ show precedence
, ident $ renderQualAlias for
, keyword "as"
, ident $ adjustAliasName alias declTitle
]
+ ExternKindDeclaration ->
+ [ keywordKind
+ , renderKind (P.NamedKind (notQualified declTitle))
+ ]
+
where
renderType' :: P.Type -> RenderedCode
renderType' = renderTypeWithOptions opts
- renderQualAlias :: FixityAlias -> String
+ renderQualAlias :: FixityAlias -> Text
renderQualAlias (P.Qualified mn alias)
- | mn == currentModule opts = T.unpack (renderAlias id alias)
- | otherwise = T.unpack (renderAlias (\f -> P.showQualified f . P.Qualified mn) alias)
+ | mn == currentModule opts = renderAlias id alias
+ | otherwise = renderAlias (\f -> P.showQualified f . P.Qualified mn) alias
renderAlias
:: (forall a. (a -> Text) -> a -> Text)
@@ -99,8 +102,7 @@ renderDeclarationWithOptions opts Declaration{..} =
= either (("type " <>) . f P.runProperName)
$ either (f P.runIdent) (f P.runProperName)
- -- adjustAliasName (P.AliasType{}) title = drop 6 (init title)
- adjustAliasName _ title = tail (init title)
+ adjustAliasName _ title = T.tail (T.init title)
renderChildDeclaration :: ChildDeclaration -> RenderedCode
renderChildDeclaration = renderChildDeclarationWithOptions defaultRenderTypeOptions
@@ -146,15 +148,15 @@ renderConstraintsWithOptions opts constraints
mintersperse (syntax "," <> sp)
(map (renderConstraintWithOptions opts) constraints)
-notQualified :: String -> P.Qualified (P.ProperName a)
-notQualified = P.Qualified Nothing . P.ProperName . T.pack
+notQualified :: Text -> P.Qualified (P.ProperName a)
+notQualified = P.Qualified Nothing . P.ProperName
-typeApp :: String -> [(String, Maybe P.Kind)] -> P.Type
+typeApp :: Text -> [(Text, Maybe P.Kind)] -> P.Type
typeApp title typeArgs =
foldl P.TypeApp
(P.TypeConstructor (notQualified title))
(map toTypeVar typeArgs)
-toTypeVar :: (String, Maybe P.Kind) -> P.Type
-toTypeVar (s, Nothing) = P.TypeVar (T.pack s)
-toTypeVar (s, Just k) = P.KindedType (P.TypeVar (T.pack s)) k
+toTypeVar :: (Text, Maybe P.Kind) -> P.Type
+toTypeVar (s, Nothing) = P.TypeVar s
+toTypeVar (s, Just k) = P.KindedType (P.TypeVar s) k
diff --git a/src/Language/PureScript/Docs/RenderedCode/Render.hs b/src/Language/PureScript/Docs/RenderedCode/Render.hs
index bae5544..281cd6b 100644
--- a/src/Language/PureScript/Docs/RenderedCode/Render.hs
+++ b/src/Language/PureScript/Docs/RenderedCode/Render.hs
@@ -14,10 +14,9 @@ import Prelude.Compat
import Data.Maybe (fromMaybe)
import Data.Monoid ((<>))
-import qualified Data.Text as T
import Data.Text (Text)
-import Control.Arrow ((<+>), first)
+import Control.Arrow ((<+>))
import Control.PatternArrows as PA
import Language.PureScript.Crash
@@ -35,7 +34,7 @@ typeLiterals = mkPattern match
match TypeWildcard{} =
Just (syntax "_")
match (TypeVar var) =
- Just (ident (T.unpack var))
+ Just (ident var)
match (PrettyPrintObject row) =
Just $ mintersperse sp
[ syntax "{"
@@ -43,7 +42,7 @@ typeLiterals = mkPattern match
, syntax "}"
]
match (TypeConstructor (Qualified mn name)) =
- Just (ctor (T.unpack (runProperName name)) (maybeToContainingModule mn))
+ Just (ctor (runProperName name) (maybeToContainingModule mn))
match REmpty =
Just (syntax "()")
match row@RCons{} =
@@ -51,7 +50,7 @@ typeLiterals = mkPattern match
match (BinaryNoParensType op l r) =
Just $ renderTypeAtom l <> sp <> renderTypeAtom op <> sp <> renderTypeAtom r
match (TypeOp (Qualified mn op)) =
- Just (ident' (T.unpack (runOpName op)) (maybeToContainingModule mn))
+ Just (ident' (runOpName op) (maybeToContainingModule mn))
match _ =
Nothing
@@ -76,16 +75,14 @@ renderConstraints deps ty =
-- Render code representing a Row
--
renderRow :: Type -> RenderedCode
-renderRow = uncurry renderRow' . convertString . rowToList
+renderRow = uncurry renderRow' . rowToList
where
- convertString :: ([(Text, Type)], Type) -> ([(String, Type)], Type)
- convertString = first (map (first T.unpack))
renderRow' h t = renderHead h <> renderTail t
-renderHead :: [(String, Type)] -> RenderedCode
+renderHead :: [(Text, Type)] -> RenderedCode
renderHead = mintersperse (syntax "," <> sp) . map renderLabel
-renderLabel :: (String, Type) -> RenderedCode
+renderLabel :: (Text, Type) -> RenderedCode
renderLabel (label, ty) =
mintersperse sp
[ ident label
@@ -145,10 +142,10 @@ matchType = buildPrettyPrinter operators matchTypeAtom
, [ Wrap explicitParens $ \_ ty -> ty ]
]
-forall_ :: Pattern () Type ([String], Type)
+forall_ :: Pattern () Type ([Text], Type)
forall_ = mkPattern match
where
- match (PrettyPrintForAll idents ty) = Just (map T.unpack idents, ty)
+ match (PrettyPrintForAll idents ty) = Just (idents, ty)
match _ = Nothing
insertPlaceholders :: RenderTypeOptions -> Type -> Type
@@ -180,7 +177,7 @@ preprocessType opts = dePrim . insertPlaceholders opts
-- Render code representing a Kind
--
renderKind :: Kind -> RenderedCode
-renderKind = kind . T.unpack . prettyPrintKind
+renderKind = kind . prettyPrintKind
-- |
-- Render code representing a Type, as it should appear inside parentheses
diff --git a/src/Language/PureScript/Docs/RenderedCode/Types.hs b/src/Language/PureScript/Docs/RenderedCode/Types.hs
index 05bd8a1..ea42d66 100644
--- a/src/Language/PureScript/Docs/RenderedCode/Types.hs
+++ b/src/Language/PureScript/Docs/RenderedCode/Types.hs
@@ -29,6 +29,7 @@ module Language.PureScript.Docs.RenderedCode.Types
, keywordInstance
, keywordWhere
, keywordFixity
+ , keywordKind
) where
import Prelude.Compat
@@ -37,7 +38,7 @@ import Control.Monad.Error.Class (MonadError(..))
import Data.Aeson.BetterErrors
import qualified Data.Aeson as A
-import qualified Data.Text as T
+import Data.Text (Text)
import qualified Language.PureScript as P
@@ -46,11 +47,11 @@ import qualified Language.PureScript as P
-- multiple output formats. For example, plain text, or highlighted HTML.
--
data RenderedCodeElement
- = Syntax String
- | Ident String ContainingModule
- | Ctor String ContainingModule
- | Kind String
- | Keyword String
+ = Syntax Text
+ | Ident Text ContainingModule
+ | Ctor Text ContainingModule
+ | Kind Text
+ | Keyword Text
| Space
deriving (Show, Eq, Ord)
@@ -66,9 +67,9 @@ instance A.ToJSON RenderedCodeElement where
toJSON (Keyword str) =
A.toJSON ["keyword", str]
toJSON Space =
- A.toJSON ["space" :: String]
+ A.toJSON ["space" :: Text]
-asRenderedCodeElement :: Parse String RenderedCodeElement
+asRenderedCodeElement :: Parse Text RenderedCodeElement
asRenderedCodeElement =
a Syntax "syntax" <|>
asIdent <|>
@@ -80,14 +81,14 @@ asRenderedCodeElement =
where
p <|> q = catchError p (const q)
- a ctor' ctorStr = ctor' <$> (nth 0 (withString (eq ctorStr)) *> nth 1 asString)
- asIdent = nth 0 (withString (eq "ident")) *> (Ident <$> nth 1 asString <*> nth 2 asContainingModule)
- asCtor = nth 0 (withString (eq "ctor")) *> (Ctor <$> nth 1 asString <*> nth 2 asContainingModule)
- asSpace = nth 0 (withString (eq "space")) *> pure Space
+ a ctor' ctorStr = ctor' <$> (nth 0 (withText (eq ctorStr)) *> nth 1 asText)
+ asIdent = nth 0 (withText (eq "ident")) *> (Ident <$> nth 1 asText <*> nth 2 asContainingModule)
+ asCtor = nth 0 (withText (eq "ctor")) *> (Ctor <$> nth 1 asText <*> nth 2 asContainingModule)
+ asSpace = nth 0 (withText (eq "space")) *> pure Space
eq s s' = if s == s' then Right () else Left ""
- unableToParse = withString (Left . show)
+ unableToParse = withText Left
-- |
-- This type is isomorphic to 'Maybe' 'P.ModuleName'. It makes code a bit easier
@@ -103,7 +104,7 @@ instance A.ToJSON ContainingModule where
asContainingModule :: Parse e ContainingModule
asContainingModule =
- maybeToContainingModule <$> perhaps (P.moduleNameFromString . T.pack <$> asString)
+ maybeToContainingModule <$> perhaps (P.moduleNameFromString <$> asText)
-- |
-- Convert a 'Maybe' 'P.ModuleName' to a 'ContainingModule', using the obvious
@@ -139,7 +140,7 @@ newtype RenderedCode
instance A.ToJSON RenderedCode where
toJSON (RC elems) = A.toJSON elems
-asRenderedCode :: Parse String RenderedCode
+asRenderedCode :: Parse Text RenderedCode
asRenderedCode = RC <$> eachInArray asRenderedCodeElement
-- |
@@ -157,22 +158,22 @@ outputWith f = foldMap f . unRC
sp :: RenderedCode
sp = RC [Space]
-syntax :: String -> RenderedCode
+syntax :: Text -> RenderedCode
syntax x = RC [Syntax x]
-ident :: String -> RenderedCode
+ident :: Text -> RenderedCode
ident x = RC [Ident x ThisModule]
-ident' :: String -> ContainingModule -> RenderedCode
+ident' :: Text -> ContainingModule -> RenderedCode
ident' x m = RC [Ident x m]
-ctor :: String -> ContainingModule -> RenderedCode
+ctor :: Text -> ContainingModule -> RenderedCode
ctor x m = RC [Ctor x m]
-kind :: String -> RenderedCode
+kind :: Text -> RenderedCode
kind x = RC [Kind x]
-keyword :: String -> RenderedCode
+keyword :: Text -> RenderedCode
keyword kw = RC [Keyword kw]
keywordForall :: RenderedCode
@@ -200,3 +201,6 @@ keywordFixity :: P.Associativity -> RenderedCode
keywordFixity P.Infixl = keyword "infixl"
keywordFixity P.Infixr = keyword "infixr"
keywordFixity P.Infix = keyword "infix"
+
+keywordKind :: RenderedCode
+keywordKind = keyword "kind"
diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs
index 506d24c..69edffa 100644
--- a/src/Language/PureScript/Docs/Types.hs
+++ b/src/Language/PureScript/Docs/Types.hs
@@ -8,14 +8,16 @@ import Prelude.Compat
import Control.Arrow (first, (***))
import Control.Monad (when)
+import Control.Monad.Error.Class (catchError)
import Data.Aeson ((.=))
import Data.Aeson.BetterErrors
import Data.ByteString.Lazy (ByteString)
import Data.Either (isLeft, isRight)
-import Data.Maybe (mapMaybe)
+import Data.Maybe (mapMaybe, fromMaybe)
import Data.Text (Text)
import Data.Version
+import qualified Data.Vector as V
import qualified Data.Aeson as A
import qualified Data.Text as T
@@ -36,7 +38,7 @@ import Language.PureScript.Docs.RenderedCode as ReExports
data Package a = Package
{ pkgMeta :: PackageMeta
, pkgVersion :: Version
- , pkgVersionTag :: String
+ , pkgVersionTag :: Text
, pkgModules :: [Module]
, pkgBookmarks :: [Bookmark]
, pkgResolvedDependencies :: [(PackageName, Version)]
@@ -71,16 +73,16 @@ packageName = bowerName . pkgMeta
data Module = Module
{ modName :: P.ModuleName
- , modComments :: Maybe String
+ , modComments :: Maybe Text
, modDeclarations :: [Declaration]
-- Re-exported values from other modules
- , modReExports :: [(P.ModuleName, [Declaration])]
+ , modReExports :: [(InPackage P.ModuleName, [Declaration])]
}
deriving (Show, Eq, Ord)
data Declaration = Declaration
- { declTitle :: String
- , declComments :: Maybe String
+ { declTitle :: Text
+ , declComments :: Maybe Text
, declSourceSpan :: Maybe P.SourceSpan
, declChildren :: [ChildDeclaration]
, declInfo :: DeclarationInfo
@@ -107,7 +109,7 @@ data DeclarationInfo
-- newtype) and its type arguments. Constructors are represented as child
-- declarations.
--
- | DataDeclaration P.DataDeclType [(String, Maybe P.Kind)]
+ | DataDeclaration P.DataDeclType [(Text, Maybe P.Kind)]
-- |
-- A data type foreign import, with its kind.
@@ -117,30 +119,54 @@ data DeclarationInfo
-- |
-- A type synonym, with its type arguments and its type.
--
- | TypeSynonymDeclaration [(String, Maybe P.Kind)] P.Type
+ | TypeSynonymDeclaration [(Text, Maybe P.Kind)] P.Type
-- |
-- A type class, with its type arguments, its superclasses and functional
-- dependencies. Instances and members are represented as child declarations.
--
- | TypeClassDeclaration [(String, Maybe P.Kind)] [P.Constraint] [([String], [String])]
+ | TypeClassDeclaration [(Text, Maybe P.Kind)] [P.Constraint] [([Text], [Text])]
-- |
-- An operator alias declaration, with the member the alias is for and the
-- operator's fixity.
--
| AliasDeclaration P.Fixity FixityAlias
+
+ -- |
+ -- A kind declaration
+ --
+ | ExternKindDeclaration
deriving (Show, Eq, Ord)
+convertFundepsToStrings :: [(Text, Maybe P.Kind)] -> [P.FunctionalDependency] -> [([Text], [Text])]
+convertFundepsToStrings args fundeps =
+ map (\(P.FunctionalDependency from to) -> toArgs from to) fundeps
+ where
+ argsVec = V.fromList (map fst args)
+ getArg i =
+ fromMaybe
+ (P.internalError $ unlines
+ [ "convertDeclaration: Functional dependency index"
+ , show i
+ , "is bigger than arguments list"
+ , show (map fst args)
+ , "Functional dependencies are"
+ , show fundeps
+ ]
+ ) $ argsVec V.!? i
+ toArgs from to = (map getArg from, map getArg to)
+
type FixityAlias = P.Qualified (Either (P.ProperName 'P.TypeName) (Either P.Ident (P.ProperName 'P.ConstructorName)))
-declInfoToString :: DeclarationInfo -> String
+declInfoToString :: DeclarationInfo -> Text
declInfoToString (ValueDeclaration _) = "value"
declInfoToString (DataDeclaration _ _) = "data"
declInfoToString (ExternDataDeclaration _) = "externData"
declInfoToString (TypeSynonymDeclaration _ _) = "typeSynonym"
declInfoToString (TypeClassDeclaration _ _ _) = "typeClass"
declInfoToString (AliasDeclaration _ _) = "alias"
+declInfoToString ExternKindDeclaration = "kind"
isTypeClass :: Declaration -> Bool
isTypeClass Declaration{..} =
@@ -174,14 +200,20 @@ isTypeAlias Declaration{..} =
AliasDeclaration _ (P.Qualified _ d) -> isLeft d
_ -> False
+isKind :: Declaration -> Bool
+isKind Declaration{..} =
+ case declInfo of
+ ExternKindDeclaration{} -> True
+ _ -> False
+
-- | Discard any children which do not satisfy the given predicate.
filterChildren :: (ChildDeclaration -> Bool) -> Declaration -> Declaration
filterChildren p decl =
decl { declChildren = filter p (declChildren decl) }
data ChildDeclaration = ChildDeclaration
- { cdeclTitle :: String
- , cdeclComments :: Maybe String
+ { cdeclTitle :: Text
+ , cdeclComments :: Maybe Text
, cdeclSourceSpan :: Maybe P.SourceSpan
, cdeclInfo :: ChildDeclarationInfo
}
@@ -206,7 +238,7 @@ data ChildDeclarationInfo
| ChildTypeClassMember P.Type
deriving (Show, Eq, Ord)
-childDeclInfoToString :: ChildDeclarationInfo -> String
+childDeclInfoToString :: ChildDeclarationInfo -> Text
childDeclInfoToString (ChildInstance _ _) = "instance"
childDeclInfoToString (ChildDataConstructor _) = "dataConstructor"
childDeclInfoToString (ChildTypeClassMember _) = "typeClassMember"
@@ -224,11 +256,11 @@ isDataConstructor ChildDeclaration{..} =
_ -> False
newtype GithubUser
- = GithubUser { runGithubUser :: String }
+ = GithubUser { runGithubUser :: Text }
deriving (Show, Eq, Ord)
newtype GithubRepo
- = GithubRepo { runGithubRepo :: String }
+ = GithubRepo { runGithubRepo :: Text }
deriving (Show, Eq, Ord)
data PackageError
@@ -237,14 +269,14 @@ data PackageError
-- parser, and actual version used.
| ErrorInPackageMeta BowerError
| InvalidVersion
- | InvalidDeclarationType String
- | InvalidChildDeclarationType String
+ | InvalidDeclarationType Text
+ | InvalidChildDeclarationType Text
| InvalidFixity
- | InvalidKind String
- | InvalidDataDeclType String
+ | InvalidKind Text
+ | InvalidDataDeclType Text
deriving (Show, Eq, Ord)
-type Bookmark = InPackage (P.ModuleName, String)
+type Bookmark = InPackage (P.ModuleName, Text)
data InPackage a
= Local a
@@ -286,7 +318,7 @@ asPackage minimumVersion uploader = do
Package <$> key "packageMeta" asPackageMeta .! ErrorInPackageMeta
<*> key "version" asVersion
- <*> key "versionTag" asString
+ <*> key "versionTag" asText
<*> key "modules" (eachInArray asModule)
<*> key "bookmarks" asBookmarks .! ErrorInPackageMeta
<*> key "resolvedDependencies" asResolvedDependencies
@@ -317,15 +349,15 @@ displayPackageError e = case e of
InvalidVersion ->
"Invalid version"
InvalidDeclarationType str ->
- "Invalid declaration type: \"" <> T.pack str <> "\""
+ "Invalid declaration type: \"" <> str <> "\""
InvalidChildDeclarationType str ->
- "Invalid child declaration type: \"" <> T.pack str <> "\""
+ "Invalid child declaration type: \"" <> str <> "\""
InvalidFixity ->
"Invalid fixity"
InvalidKind str ->
- "Invalid kind: \"" <> T.pack str <> "\""
+ "Invalid kind: \"" <> str <> "\""
InvalidDataDeclType str ->
- "Invalid data declaration type: \"" <> T.pack str <> "\""
+ "Invalid data declaration type: \"" <> str <> "\""
where
(<>) = T.append
@@ -334,7 +366,7 @@ instance A.FromJSON a => A.FromJSON (Package a) where
(asPackage (Version [0,0,0,0] []) fromAesonParser)
asGithubUser :: Parse e GithubUser
-asGithubUser = GithubUser <$> asString
+asGithubUser = GithubUser <$> asText
instance A.FromJSON GithubUser where
parseJSON = toAesonParser' asGithubUser
@@ -351,22 +383,33 @@ parseVersion' str =
asModule :: Parse PackageError Module
asModule =
Module <$> key "name" (P.moduleNameFromString <$> asText)
- <*> key "comments" (perhaps asString)
+ <*> key "comments" (perhaps asText)
<*> key "declarations" (eachInArray asDeclaration)
<*> key "reExports" (eachInArray asReExport)
asDeclaration :: Parse PackageError Declaration
asDeclaration =
- Declaration <$> key "title" asString
- <*> key "comments" (perhaps asString)
+ Declaration <$> key "title" asText
+ <*> key "comments" (perhaps asText)
<*> key "sourceSpan" (perhaps asSourceSpan)
<*> key "children" (eachInArray asChildDeclaration)
<*> key "info" asDeclarationInfo
-asReExport :: Parse PackageError (P.ModuleName, [Declaration])
+asReExport :: Parse PackageError (InPackage P.ModuleName, [Declaration])
asReExport =
- (,) <$> key "moduleName" fromAesonParser
+ (,) <$> key "moduleName" asReExportModuleName
<*> key "declarations" (eachInArray asDeclaration)
+ where
+ -- This is to preserve backwards compatibility with 0.10.3 and earlier versions
+ -- of the compiler, where the modReExports field had the type
+ -- [(P.ModuleName, [Declaration])]. This should eventually be removed,
+ -- possibly at the same time as the next breaking change to this JSON format.
+ asReExportModuleName :: Parse PackageError (InPackage P.ModuleName)
+ asReExportModuleName =
+ asInPackage fromAesonParser .! ErrorInPackageMeta
+ <|> fmap Local fromAesonParser
+
+ (<|>) p q = catchError p (const q)
asInPackage :: Parse BowerError a -> Parse BowerError (InPackage a)
asInPackage inner =
@@ -396,7 +439,7 @@ asAssociativity = withString (maybe (Left InvalidFixity) Right . parseAssociativ
asDeclarationInfo :: Parse PackageError DeclarationInfo
asDeclarationInfo = do
- ty <- key "declType" asString
+ ty <- key "declType" asText
case ty of
"value" ->
ValueDeclaration <$> key "type" asType
@@ -415,13 +458,15 @@ asDeclarationInfo = do
"alias" ->
AliasDeclaration <$> key "fixity" asFixity
<*> key "alias" asFixityAlias
+ "kind" ->
+ pure ExternKindDeclaration
other ->
throwCustomError (InvalidDeclarationType other)
-asTypeArguments :: Parse PackageError [(String, Maybe P.Kind)]
+asTypeArguments :: Parse PackageError [(Text, Maybe P.Kind)]
asTypeArguments = eachInArray asTypeArgument
where
- asTypeArgument = (,) <$> nth 0 asString <*> nth 1 (perhaps asKind)
+ asTypeArgument = (,) <$> nth 0 asText <*> nth 1 (perhaps asKind)
asKind :: Parse e P.Kind
asKind = fromAesonParser
@@ -429,28 +474,28 @@ asKind = fromAesonParser
asType :: Parse e P.Type
asType = fromAesonParser
-asFunDeps :: Parse PackageError [([String], [String])]
+asFunDeps :: Parse PackageError [([Text], [Text])]
asFunDeps = eachInArray asFunDep
where
- asFunDep = (,) <$> nth 0 (eachInArray asString) <*> nth 1 (eachInArray asString)
+ asFunDep = (,) <$> nth 0 (eachInArray asText) <*> nth 1 (eachInArray asText)
asDataDeclType :: Parse PackageError P.DataDeclType
asDataDeclType =
- withString $ \s -> case s of
+ withText $ \s -> case s of
"data" -> Right P.Data
"newtype" -> Right P.Newtype
other -> Left (InvalidDataDeclType other)
asChildDeclaration :: Parse PackageError ChildDeclaration
asChildDeclaration =
- ChildDeclaration <$> key "title" asString
- <*> key "comments" (perhaps asString)
+ ChildDeclaration <$> key "title" asText
+ <*> key "comments" (perhaps asText)
<*> key "sourceSpan" (perhaps asSourceSpan)
<*> key "info" asChildDeclarationInfo
asChildDeclarationInfo :: Parse PackageError ChildDeclarationInfo
asChildDeclarationInfo = do
- ty <- key "declType" asString
+ ty <- key "declType" asText
case ty of
"instance" ->
ChildInstance <$> key "dependencies" (eachInArray asConstraint)
@@ -483,7 +528,7 @@ asBookmarks = eachInArray asBookmark
asBookmark :: Parse BowerError Bookmark
asBookmark =
asInPackage ((,) <$> nth 0 (P.moduleNameFromString <$> asText)
- <*> nth 1 asString)
+ <*> nth 1 asText)
asResolvedDependencies :: Parse PackageError [(PackageName, Version)]
asResolvedDependencies =
@@ -493,8 +538,8 @@ asResolvedDependencies =
mapLeft _ (Right x) = Right x
asGithub :: Parse e (GithubUser, GithubRepo)
-asGithub = (,) <$> nth 0 (GithubUser <$> asString)
- <*> nth 1 (GithubRepo <$> asString)
+asGithub = (,) <$> nth 0 (GithubUser <$> asText)
+ <*> nth 1 (GithubRepo <$> asText)
asSourceSpan :: Parse e P.SourceSpan
asSourceSpan = P.SourceSpan <$> key "name" asString
@@ -562,6 +607,7 @@ instance A.ToJSON DeclarationInfo where
TypeSynonymDeclaration args ty -> ["arguments" .= args, "type" .= ty]
TypeClassDeclaration args super fundeps -> ["arguments" .= args, "superclasses" .= super, "fundeps" .= fundeps]
AliasDeclaration fixity alias -> ["fixity" .= fixity, "alias" .= alias]
+ ExternKindDeclaration -> []
instance A.ToJSON ChildDeclarationInfo where
toJSON info = A.object $ "declType" .= childDeclInfoToString info : props
diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs
index 01adeed..a62315f 100644
--- a/src/Language/PureScript/Environment.hs
+++ b/src/Language/PureScript/Environment.hs
@@ -8,11 +8,13 @@ import Data.Aeson.TH
import qualified Data.Aeson as A
import qualified Data.Map as M
import qualified Data.Set as S
-import Data.Maybe (fromMaybe)
+import Data.Maybe (fromMaybe, mapMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import Data.List (nub)
+import Data.Tree (Tree, rootLabel)
import qualified Data.Graph as G
+import Data.Foldable (toList)
import Language.PureScript.Crash
import Language.PureScript.Kinds
@@ -36,6 +38,8 @@ data Environment = Environment
-- ^ Available type class dictionaries
, typeClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData
-- ^ Type classes
+ , kinds :: S.Set (Qualified (ProperName 'KindName))
+ -- ^ Kinds in scope
} deriving Show
-- | Information about a type class
@@ -55,6 +59,8 @@ data TypeClassData = TypeClassData
-- ^ A set of indexes of type argument that are fully determined by other
-- arguments via functional dependencies. This can be computed from both
-- typeClassArguments and typeClassDependencies.
+ , typeClassCoveringSets :: S.Set (S.Set Int)
+ -- ^ A sets of arguments that can be used to infer all other arguments.
} deriving Show
-- | A functional dependency indicates a relationship between two sets of
@@ -70,11 +76,14 @@ data FunctionalDependency = FunctionalDependency
-- The initial environment with no values and only the default javascript types defined
--
initEnvironment :: Environment
-initEnvironment = Environment M.empty primTypes M.empty M.empty M.empty primClasses
+initEnvironment = Environment M.empty primTypes M.empty M.empty M.empty primClasses primKinds
-- |
--- A constructor for TypeClassData that computes which type class arguments are fully determined.
+-- A constructor for TypeClassData that computes which type class arguments are fully determined
+-- and argument covering sets.
-- Fully determined means that this argument cannot be used when selecting a type class instance.
+-- A covering set is a minimal collection of arguments that can be used to find an instance and
+-- therefore determine all other type arguments.
--
-- An example of the difference between determined and fully determined would be with the class:
-- ```class C a b c | a -> b, b -> a, b -> c```
@@ -82,7 +91,8 @@ initEnvironment = Environment M.empty primTypes M.empty M.empty M.empty primClas
-- Both `a` and `b` can be used in selecting a type class instance. However, `c` cannot - it is
-- fully determined by `a` and `b`.
--
--- Define a graph of type class arguments with edges being fundep determiners to determined.
+-- Define a graph of type class arguments with edges being fundep determiners to determined. Each
+-- argument also has a self looping edge.
-- An argument is fully determined if doesn't appear at the start of a path of strongly connected components.
-- An argument is not fully determined otherwise.
--
@@ -95,26 +105,51 @@ makeTypeClassData
-> [Constraint]
-> [FunctionalDependency]
-> TypeClassData
-makeTypeClassData args m s deps = TypeClassData args m s deps determinedArgs
+makeTypeClassData args m s deps = TypeClassData args m s deps determinedArgs coveringSets
where
+ argumentIndicies = [0 .. length args - 1]
+
+ -- each argument determines themselves
+ identities = (\i -> (i, [i])) <$> argumentIndicies
+
-- list all the edges in the graph: for each fundep an edge exists for each determiner to each determined
- contributingDeps = M.fromListWith (++) $ do
+ contributingDeps = M.fromListWith (++) $ identities ++ do
fd <- deps
src <- fdDeterminers fd
(src, fdDetermined fd) : map (, []) (fdDetermined fd)
- -- here we build a graph of which arguments determine other arguments
- (depGraph, _, fromKey) = G.graphFromEdges ((\(n, v) -> (n, n, nub v)) <$> M.toList contributingDeps)
+ -- build a graph of which arguments determine other arguments
+ (depGraph, fromVertex, fromKey) = G.graphFromEdges ((\(n, v) -> (n, n, nub v)) <$> M.toList contributingDeps)
-- do there exist any arguments that contribute to `arg` that `arg` doesn't contribute to
+ isFunDepDetermined :: Int -> Bool
isFunDepDetermined arg = case fromKey arg of
- Nothing -> False -- not mentioned in fundeps
+ Nothing -> internalError "Unknown argument index in makeTypeClassData"
Just v -> let contributesToVar = G.reachable (G.transposeG depGraph) v
varContributesTo = G.reachable depGraph v
in any (\r -> not (r `elem` varContributesTo)) contributesToVar
-- find all the arguments that are determined
- determinedArgs = S.fromList $ filter isFunDepDetermined [0 .. length args - 1]
+ determinedArgs :: S.Set Int
+ determinedArgs = S.fromList $ filter isFunDepDetermined argumentIndicies
+
+ argFromVertex :: G.Vertex -> Int
+ argFromVertex index = let (_, arg, _) = fromVertex index in arg
+
+ isVertexDetermined :: G.Vertex -> Bool
+ isVertexDetermined = isFunDepDetermined . argFromVertex
+
+ -- from an scc find the non-determined args
+ sccNonDetermined :: Tree G.Vertex -> Maybe [Int]
+ sccNonDetermined tree
+ -- if any arg in an scc is determined then all of them are
+ | isVertexDetermined (rootLabel tree) = Nothing
+ | otherwise = Just (argFromVertex <$> toList tree)
+
+ -- find the covering sets
+ coveringSets :: S.Set (S.Set Int)
+ coveringSets = let funDepSets = sequence (mapMaybe sccNonDetermined (G.scc depGraph))
+ in S.fromList (S.fromList <$> funDepSets)
-- |
-- The visibility of a name in scope
@@ -209,6 +244,21 @@ instance A.FromJSON DataDeclType where
primName :: Text -> Qualified (ProperName a)
primName = Qualified (Just $ ModuleName [ProperName C.prim]) . ProperName
+primKind :: Text -> Kind
+primKind = NamedKind . primName
+
+-- |
+-- Kinds in prim
+--
+kindType :: Kind
+kindType = primKind C.typ
+
+kindEffect :: Kind
+kindEffect = primKind C.effect
+
+kindSymbol :: Kind
+kindSymbol = primKind C.symbol
+
-- |
-- Construct a type in the Prim module
--
@@ -286,6 +336,16 @@ function :: Type -> Type -> Type
function t1 = TypeApp (TypeApp tyFunction t1)
-- |
+-- The primitive kinds
+primKinds :: S.Set (Qualified (ProperName 'KindName))
+primKinds =
+ S.fromList
+ [ primName C.typ
+ , primName C.effect
+ , primName C.symbol
+ ]
+
+-- |
-- The primitive types in the external javascript environment with their
-- associated kinds. There are also pseudo `Fail` and `Partial` types
-- that correspond to the classes with the same names.
@@ -293,18 +353,18 @@ function t1 = TypeApp (TypeApp tyFunction t1)
primTypes :: M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind)
primTypes =
M.fromList
- [ (primName "Function", (FunKind Star (FunKind Star Star), ExternData))
- , (primName "Array", (FunKind Star Star, ExternData))
- , (primName "Record", (FunKind (Row Star) Star, ExternData))
- , (primName "String", (Star, ExternData))
- , (primName "Char", (Star, ExternData))
- , (primName "Number", (Star, ExternData))
- , (primName "Int", (Star, ExternData))
- , (primName "Boolean", (Star, ExternData))
- , (primName "Partial", (Star, ExternData))
- , (primName "Fail", (FunKind Symbol Star, ExternData))
- , (primName "TypeString", (FunKind Star Symbol, ExternData))
- , (primName "TypeConcat", (FunKind Symbol (FunKind Symbol Symbol), ExternData))
+ [ (primName "Function", (FunKind kindType (FunKind kindType kindType), ExternData))
+ , (primName "Array", (FunKind kindType kindType, ExternData))
+ , (primName "Record", (FunKind (Row kindType) kindType, ExternData))
+ , (primName "String", (kindType, ExternData))
+ , (primName "Char", (kindType, ExternData))
+ , (primName "Number", (kindType, ExternData))
+ , (primName "Int", (kindType, ExternData))
+ , (primName "Boolean", (kindType, ExternData))
+ , (primName "Partial", (kindType, ExternData))
+ , (primName "Fail", (FunKind kindSymbol kindType, ExternData))
+ , (primName "TypeString", (FunKind kindType kindSymbol, ExternData))
+ , (primName "TypeConcat", (FunKind kindSymbol (FunKind kindSymbol kindSymbol), ExternData))
]
-- |
@@ -316,7 +376,7 @@ primClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData
primClasses =
M.fromList
[ (primName "Partial", (makeTypeClassData [] [] [] []))
- , (primName "Fail", (makeTypeClassData [("message", Just Symbol)] [] [] []))
+ , (primName "Fail", (makeTypeClassData [("message", Just kindSymbol)] [] [] []))
]
-- |
diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs
index 40ee521..74831b4 100644
--- a/src/Language/PureScript/Errors.hs
+++ b/src/Language/PureScript/Errors.hs
@@ -289,8 +289,8 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse
gTypeSearch (TSBefore env) = pure (TSBefore env)
gTypeSearch (TSAfter result) = TSAfter <$> traverse (traverse f) result
-wikiUri :: ErrorMessage -> Text
-wikiUri e = "https://github.com/purescript/purescript/wiki/Error-Code-" <> errorCode e
+errorDocUri :: ErrorMessage -> Text
+errorDocUri e = "https://github.com/purescript/documentation/blob/master/errors/" <> errorCode e <> ".md"
-- TODO Other possible suggestions:
-- WildcardInferredType - source span not small enough
@@ -373,7 +373,7 @@ data PPEOptions = PPEOptions
{ ppeCodeColor :: Maybe (ANSI.ColorIntensity, ANSI.Color) -- ^ Color code with this color... or not
, ppeFull :: Bool -- ^ Should write a full error message?
, ppeLevel :: Level -- ^ Should this report an error or a warning?
- , ppeShowWiki :: Bool -- ^ Should show a link to error message's wiki page?
+ , ppeShowDocs :: Bool -- ^ Should show a link to error message's doc page?
}
-- | Default options for PPEOptions
@@ -382,7 +382,7 @@ defaultPPEOptions = PPEOptions
{ ppeCodeColor = Just defaultCodeColor
, ppeFull = False
, ppeLevel = Error
- , ppeShowWiki = True
+ , ppeShowDocs = True
}
@@ -390,7 +390,7 @@ defaultPPEOptions = PPEOptions
-- Pretty print a single error, simplifying if necessary
--
prettyPrintSingleError :: PPEOptions -> ErrorMessage -> Box.Box
-prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalState defaultUnknownMap $ do
+prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalState defaultUnknownMap $ do
em <- onTypesInErrorMessageM replaceUnknowns (if full then e else simplifyErrorMessage e)
um <- get
return (prettyPrintErrorMessage um em)
@@ -405,10 +405,10 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS
] ++
maybe [] (return . Box.moveDown 1) typeInformation ++
[ Box.moveDown 1 $ paras
- [ line $ "See " <> wikiUri e <> " for more information, "
+ [ line $ "See " <> errorDocUri e <> " for more information, "
, line $ "or to contribute content related to this " <> levelText <> "."
]
- | showWiki
+ | showDocs
]
where
typeInformation :: Maybe Box.Box
@@ -716,7 +716,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS
, Box.vcat Box.left (map typeAtomAsBox ts)
]
, line "is an orphan instance."
- , line "An orphan instance is an instance which is defined in neither the class module nor the data type module."
+ , line "An orphan instance is one which is defined in a module that is unrelated to either the class or the collection of data types that the instance is defined for."
, line "Consider moving the instance, if possible, or using a newtype wrapper."
]
renderSimpleErrorMessage (InvalidNewtype name) =
@@ -1030,6 +1030,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS
nameType (DctorName _) = "data constructor"
nameType (TyClassName _) = "type class"
nameType (ModName _) = "module"
+ nameType (KiName _) = "kind"
runName :: Qualified Name -> Text
runName (Qualified mn (IdentName name)) =
@@ -1044,6 +1045,8 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS
showQualified runProperName (Qualified mn name)
runName (Qualified mn (TyClassName name)) =
showQualified runProperName (Qualified mn name)
+ runName (Qualified mn (KiName name)) =
+ showQualified runProperName (Qualified mn name)
runName (Qualified Nothing (ModName name)) =
runModuleName name
runName (Qualified _ ModName{}) =
@@ -1148,6 +1151,8 @@ prettyPrintRef (TypeInstanceRef ident) =
Just $ showIdent ident
prettyPrintRef (ModuleRef name) =
Just $ "module " <> runModuleName name
+prettyPrintRef (KindRef pn) =
+ Just $ "kind " <> runProperName pn
prettyPrintRef (ReExportRef _ _) =
Nothing
prettyPrintRef (PositionedDeclarationRef _ _ ref) =
diff --git a/src/Language/PureScript/Errors/JSON.hs b/src/Language/PureScript/Errors/JSON.hs
index 8b0eadc..c7f085c 100644
--- a/src/Language/PureScript/Errors/JSON.hs
+++ b/src/Language/PureScript/Errors/JSON.hs
@@ -52,7 +52,7 @@ toJSONError verbose level e =
JSONError (toErrorPosition <$> sspan)
(P.renderBox (P.prettyPrintSingleError (P.PPEOptions Nothing verbose level False) (P.stripModuleAndSpan e)))
(P.errorCode e)
- (P.wikiUri e)
+ (P.errorDocUri e)
(P.spanName <$> sspan)
(P.runModuleName <$> P.errorModule e)
(toSuggestion e)
diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs
index 12f04ad..a75d094 100644
--- a/src/Language/PureScript/Externs.hs
+++ b/src/Language/PureScript/Externs.hs
@@ -24,6 +24,7 @@ import Data.Text (Text)
import qualified Data.Text as T
import Data.Version (showVersion)
import qualified Data.Map as M
+import qualified Data.Set as S
import Language.PureScript.AST
import Language.PureScript.Crash
@@ -133,6 +134,10 @@ data ExternsDeclaration =
, edInstanceTypes :: [Type]
, edInstanceConstraints :: Maybe [Constraint]
}
+ -- | A kind declaration
+ | EDKind
+ { edKindName :: ProperName 'KindName
+ }
deriving Show
-- | Convert an externs file back into a module
@@ -145,6 +150,7 @@ applyExternsFileToEnvironment ExternsFile{..} = flip (foldl' applyDecl) efDeclar
applyDecl env (EDDataConstructor pn dTy tNm ty nms) = env { dataConstructors = M.insert (qual pn) (dTy, tNm, ty, nms) (dataConstructors env) }
applyDecl env (EDValue ident ty) = env { names = M.insert (Qualified (Just efModuleName) ident) (ty, External, Defined) (names env) }
applyDecl env (EDClass pn args members cs deps) = env { typeClasses = M.insert (qual pn) (makeTypeClassData args members cs deps) (typeClasses env) }
+ applyDecl env (EDKind pn) = env { kinds = S.insert (qual pn) (kinds env) }
applyDecl env (EDInstance className ident tys cs) = env { typeClassDictionaries = updateMap (updateMap (M.insert (qual ident) dict) className) (Just efModuleName) (typeClassDictionaries env) }
where
dict :: NamedDict
@@ -220,6 +226,9 @@ moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..}
, m2 <- M.elems m1
, TypeClassDictionaryInScope{..} <- maybeToList (M.lookup (Qualified (Just mn) ident) m2)
]
+ toExternsDeclaration (KindRef pn)
+ | Qualified (Just mn) pn `S.member` kinds env
+ = [ EDKind pn ]
toExternsDeclaration _ = []
$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsImport)
diff --git a/src/Language/PureScript/Ide/Externs.hs b/src/Language/PureScript/Ide/Externs.hs
index d02f6bf..e50fb12 100644
--- a/src/Language/PureScript/Ide/Externs.hs
+++ b/src/Language/PureScript/Ide/Externs.hs
@@ -94,6 +94,7 @@ convertDecl P.EDDataConstructor{..} = Just $ IdeDeclDataConstructor $
convertDecl P.EDValue{..} = Just $ IdeDeclValue $
IdeValue edValueName edValueType
convertDecl P.EDClass{..} = Just (IdeDeclTypeClass edClassName)
+convertDecl P.EDKind{..} = Just (IdeDeclKind edKindName)
convertDecl P.EDInstance{} = Nothing
convertOperator :: P.ExternsFixity -> IdeDeclaration
@@ -137,9 +138,12 @@ annotateModule (defs, types) (moduleName, decls) =
annotateValue (op ^. ideValueOpAlias & valueOperatorAliasT) (IdeDeclValueOperator op)
IdeDeclTypeOperator op ->
annotateType (op ^. ideTypeOpAlias & typeOperatorAliasT) (IdeDeclTypeOperator op)
+ IdeDeclKind i ->
+ annotateKind (i ^. properNameT) (IdeDeclKind i)
where
- annotateFunction x = IdeDeclarationAnn (ann { annLocation = Map.lookup (Left (P.runIdent x)) defs
+ annotateFunction x = IdeDeclarationAnn (ann { annLocation = Map.lookup (IdeNSValue (P.runIdent x)) defs
, annTypeAnnotation = Map.lookup x types
})
- annotateValue x = IdeDeclarationAnn (ann {annLocation = Map.lookup (Left x) defs})
- annotateType x = IdeDeclarationAnn (ann {annLocation = Map.lookup (Right x) defs})
+ annotateValue x = IdeDeclarationAnn (ann {annLocation = Map.lookup (IdeNSValue x) defs})
+ annotateType x = IdeDeclarationAnn (ann {annLocation = Map.lookup (IdeNSType x) defs})
+ annotateKind x = IdeDeclarationAnn (ann {annLocation = Map.lookup (IdeNSKind x) defs})
diff --git a/src/Language/PureScript/Ide/SourceFile.hs b/src/Language/PureScript/Ide/SourceFile.hs
index c0b9695..21f1e0c 100644
--- a/src/Language/PureScript/Ide/SourceFile.hs
+++ b/src/Language/PureScript/Ide/SourceFile.hs
@@ -92,25 +92,26 @@ extractSpans
-- ^ The surrounding span
-> P.Declaration
-- ^ The declaration to extract spans from
- -> [(Either Text Text, P.SourceSpan)]
- -- ^ A @Right@ corresponds to a type level declaration, and a @Left@ to a
- -- value level one
+ -> [(IdeDeclNamespace, P.SourceSpan)]
+ -- ^ Declarations and their source locations
extractSpans ss d = case d of
P.PositionedDeclaration ss' _ d' ->
extractSpans ss' d'
P.ValueDeclaration i _ _ _ ->
- [(Left (P.runIdent i), ss)]
+ [(IdeNSValue (P.runIdent i), ss)]
P.TypeSynonymDeclaration name _ _ ->
- [(Right (P.runProperName name), ss)]
+ [(IdeNSType (P.runProperName name), ss)]
P.TypeClassDeclaration name _ _ _ members ->
- (Right (P.runProperName name), ss) : concatMap (extractSpans' ss) members
+ (IdeNSType (P.runProperName name), ss) : concatMap (extractSpans' ss) members
P.DataDeclaration _ name _ ctors ->
- (Right (P.runProperName name), ss)
- : map (\(cname, _) -> (Left (P.runProperName cname), ss)) ctors
+ (IdeNSType (P.runProperName name), ss)
+ : map (\(cname, _) -> (IdeNSValue (P.runProperName cname), ss)) ctors
P.ExternDeclaration ident _ ->
- [(Left (P.runIdent ident), ss)]
+ [(IdeNSValue (P.runIdent ident), ss)]
P.ExternDataDeclaration name _ ->
- [(Right (P.runProperName name), ss)]
+ [(IdeNSType (P.runProperName name), ss)]
+ P.ExternKindDeclaration name ->
+ [(IdeNSKind (P.runProperName name), ss)]
_ -> []
where
-- We need this special case to be able to also get the position info for
@@ -121,5 +122,5 @@ extractSpans ss d = case d of
P.PositionedDeclaration ssP' _ dP' ->
extractSpans' ssP' dP'
P.TypeDeclaration ident _ ->
- [(Left (P.runIdent ident), ssP)]
+ [(IdeNSValue (P.runIdent ident), ssP)]
_ -> []
diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs
index 3408e34..75e5d25 100644
--- a/src/Language/PureScript/Ide/Types.hs
+++ b/src/Language/PureScript/Ide/Types.hs
@@ -36,6 +36,7 @@ data IdeDeclaration
| IdeDeclTypeClass (P.ProperName 'P.ClassName)
| IdeDeclValueOperator IdeValueOperator
| IdeDeclTypeOperator IdeTypeOperator
+ | IdeDeclKind (P.ProperName 'P.KindName)
deriving (Show, Eq, Ord)
data IdeValue = IdeValue
@@ -102,7 +103,7 @@ emptyAnn = Annotation Nothing Nothing Nothing
type Module = (P.ModuleName, [IdeDeclarationAnn])
-type DefinitionSites a = Map (Either Text Text) a
+type DefinitionSites a = Map IdeDeclNamespace a
type TypeAnnotations = Map P.Ident P.Type
newtype AstData a = AstData (Map P.ModuleName (DefinitionSites a, TypeAnnotations))
-- ^ SourceSpans for the definition sites of Values and Types aswell as type
@@ -214,6 +215,7 @@ identifierFromDeclarationRef :: P.DeclarationRef -> Text
identifierFromDeclarationRef (P.TypeRef name _) = P.runProperName name
identifierFromDeclarationRef (P.ValueRef ident) = P.runIdent ident
identifierFromDeclarationRef (P.TypeClassRef name) = P.runProperName name
+identifierFromDeclarationRef (P.KindRef name) = P.runProperName name
identifierFromDeclarationRef _ = ""
data Success =
@@ -293,3 +295,12 @@ instance ToJSON PursuitResponse where
, "package" .= package
, "text" .= text
]
+
+data IdeDeclNamespace =
+ -- | An identifier in the value namespace
+ IdeNSValue Text
+ -- | An identifier in the type namespace
+ | IdeNSType Text
+ -- | An identifier in the kind namespace
+ | IdeNSKind Text
+ deriving (Show, Eq, Ord)
diff --git a/src/Language/PureScript/Ide/Util.hs b/src/Language/PureScript/Ide/Util.hs
index 0a61278..3345b9b 100644
--- a/src/Language/PureScript/Ide/Util.hs
+++ b/src/Language/PureScript/Ide/Util.hs
@@ -49,6 +49,7 @@ identifierFromIdeDeclaration d = case d of
IdeDeclTypeClass name -> P.runProperName name
IdeDeclValueOperator op -> op ^. ideValueOpName & P.runOpName
IdeDeclTypeOperator op -> op ^. ideTypeOpName & P.runOpName
+ IdeDeclKind name -> P.runProperName name
discardAnn :: IdeDeclarationAnn -> IdeDeclaration
discardAnn (IdeDeclarationAnn _ d) = d
@@ -73,6 +74,7 @@ completionFromMatch (Match (m, IdeDeclarationAnn ann decl)) =
(P.runOpName op, maybe (showFixity precedence associativity (valueOperatorAliasT ref) op) prettyTypeT typeP)
IdeDeclTypeOperator (IdeTypeOperator op ref precedence associativity kind) ->
(P.runOpName op, maybe (showFixity precedence associativity (typeOperatorAliasT ref) op) (toS . P.prettyPrintKind) kind)
+ IdeDeclKind k -> (P.runProperName k, "kind")
complModule = P.runModuleName m
diff --git a/src/Language/PureScript/Interactive.hs b/src/Language/PureScript/Interactive.hs
index b926383..db1cce7 100644
--- a/src/Language/PureScript/Interactive.hs
+++ b/src/Language/PureScript/Interactive.hs
@@ -200,6 +200,8 @@ handleShowImportedModules = do
Just $ N.runIdent ident
showRef (P.ModuleRef name) =
Just $ "module " <> N.runModuleName name
+ showRef (P.KindRef pn) =
+ Just $ "kind " <> N.runProperName pn
showRef (P.ReExportRef _ _) =
Nothing
showRef (P.PositionedDeclarationRef _ _ ref) =
diff --git a/src/Language/PureScript/Interactive/Message.hs b/src/Language/PureScript/Interactive/Message.hs
index 97ef4cb..e340da1 100644
--- a/src/Language/PureScript/Interactive/Message.hs
+++ b/src/Language/PureScript/Interactive/Message.hs
@@ -27,8 +27,8 @@ helpMessage = "The following commands are available:\n\n " ++
]
extraHelp =
- "Further information is available on the PureScript wiki:\n" ++
- " --> https://github.com/purescript/purescript/wiki/psci"
+ "Further information is available on the PureScript documentation repository:\n" ++
+ " --> https://github.com/purescript/documentation/blob/master/PSCi.md"
-- | The welcome prologue.
prologueMessage :: String
@@ -48,7 +48,7 @@ supportModuleMessage = unlines
, ""
, " psc-package install psci-support"
, ""
- , "For help getting started, visit http://wiki.purescript.org/PSCi"
+ , "For help getting started, visit https://github.com/purescript/documentation/blob/master/PSCi.md"
]
-- | The quit message.
diff --git a/src/Language/PureScript/Interactive/Parser.hs b/src/Language/PureScript/Interactive/Parser.hs
index e310543..160a04b 100644
--- a/src/Language/PureScript/Interactive/Parser.hs
+++ b/src/Language/PureScript/Interactive/Parser.hs
@@ -114,6 +114,7 @@ acceptable P.ExternDeclaration{} = True
acceptable P.ExternDataDeclaration{} = True
acceptable P.TypeClassDeclaration{} = True
acceptable P.TypeInstanceDeclaration{} = True
+acceptable P.ExternKindDeclaration{} = True
acceptable _ = False
parseReplQuery' :: String -> Either String ReplQuery
diff --git a/src/Language/PureScript/Kinds.hs b/src/Language/PureScript/Kinds.hs
index 519584e..78d126b 100644
--- a/src/Language/PureScript/Kinds.hs
+++ b/src/Language/PureScript/Kinds.hs
@@ -6,20 +6,18 @@ import Prelude.Compat
import qualified Data.Aeson.TH as A
+import Language.PureScript.Names
+
-- | The data type of kinds
data Kind
-- | Unification variable of type Kind
= KUnknown Int
- -- | The kind of types
- | Star
- -- | The kind of effects
- | Bang
-- | Kinds for labelled, unordered rows without duplicates
| Row Kind
-- | Function kinds
| FunKind Kind Kind
- -- | Type-level strings
- | Symbol
+ -- | A named kind
+ | NamedKind (Qualified (ProperName 'KindName))
deriving (Show, Eq, Ord)
$(A.deriveJSON A.defaultOptions ''Kind)
diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs
index 508a256..8ca8fcc 100644
--- a/src/Language/PureScript/Names.hs
+++ b/src/Language/PureScript/Names.hs
@@ -24,6 +24,7 @@ data Name
| DctorName (ProperName 'ConstructorName)
| TyClassName (ProperName 'ClassName)
| ModName ModuleName
+ | KiName (ProperName 'KindName)
deriving (Eq, Show)
getIdentName :: Name -> Maybe Ident
@@ -117,7 +118,12 @@ instance FromJSON (ProperName a) where
-- |
-- The closed set of proper name types.
--
-data ProperNameType = TypeName | ConstructorName | ClassName | Namespace
+data ProperNameType
+ = TypeName
+ | ConstructorName
+ | ClassName
+ | KindName
+ | Namespace
-- |
-- Coerces a ProperName from one ProperNameType to another. This should be used
diff --git a/src/Language/PureScript/Parser/Common.hs b/src/Language/PureScript/Parser/Common.hs
index 67b4205..d60a394 100644
--- a/src/Language/PureScript/Parser/Common.hs
+++ b/src/Language/PureScript/Parser/Common.hs
@@ -32,6 +32,12 @@ typeName :: TokenParser (ProperName 'TypeName)
typeName = ProperName <$> tyname
-- |
+-- Parse a proper name for a kind.
+--
+kindName :: TokenParser (ProperName 'KindName)
+kindName = ProperName <$> kiname
+
+-- |
-- Parse a proper name for a data constructor.
--
dataConstructorName :: TokenParser (ProperName 'ConstructorName)
diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs
index eea6165..161a9b2 100644
--- a/src/Language/PureScript/Parser/Declarations.hs
+++ b/src/Language/PureScript/Parser/Declarations.hs
@@ -109,12 +109,16 @@ parseValueDeclaration = do
return $ maybe value (`Let` value) whereClause
parseExternDeclaration :: TokenParser Declaration
-parseExternDeclaration = reserved "foreign" *> indented *> reserved "import" *> indented *>
- (ExternDataDeclaration <$> (reserved "data" *> indented *> typeName)
- <*> (indented *> doubleColon *> parseKind)
- <|> (do ident <- parseIdent
- ty <- indented *> doubleColon *> noWildcards parsePolyType
- return $ ExternDeclaration ident ty))
+parseExternDeclaration = reserved "foreign" *> indented *> reserved "import" *> indented *> parseExternAlt where
+ parseExternAlt = parseExternData <|> P.try parseExternKind <|> parseExternTerm
+
+ parseExternData = ExternDataDeclaration <$> (reserved "data" *> indented *> typeName)
+ <*> (indented *> doubleColon *> parseKind)
+
+ parseExternKind = ExternKindDeclaration <$> (reserved "kind" *> indented *> kindName)
+
+ parseExternTerm = ExternDeclaration <$> parseIdent
+ <*> (indented *> doubleColon *> noWildcards parsePolyType)
parseAssociativity :: TokenParser Associativity
parseAssociativity =
@@ -163,7 +167,8 @@ parseImportDeclaration' = do
parseDeclarationRef :: TokenParser DeclarationRef
parseDeclarationRef =
withSourceSpan PositionedDeclarationRef
- $ (ValueRef <$> parseIdent)
+ $ (KindRef <$> P.try (reserved "kind" *> kindName))
+ <|> (ValueRef <$> parseIdent)
<|> (ValueOpRef <$> parens parseOperator)
<|> parseTypeRef
<|> (TypeClassRef <$> (reserved "class" *> properName))
diff --git a/src/Language/PureScript/Parser/Kinds.hs b/src/Language/PureScript/Parser/Kinds.hs
index 6e0c09f..a0517bf 100644
--- a/src/Language/PureScript/Parser/Kinds.hs
+++ b/src/Language/PureScript/Parser/Kinds.hs
@@ -5,6 +5,7 @@ module Language.PureScript.Parser.Kinds (parseKind) where
import Prelude.Compat
+import Language.PureScript.Environment
import Language.PureScript.Kinds
import Language.PureScript.Parser.Common
import Language.PureScript.Parser.Lexer
@@ -13,26 +14,27 @@ import qualified Text.Parsec as P
import qualified Text.Parsec.Expr as P
parseStar :: TokenParser Kind
-parseStar = const Star <$> symbol' "*"
+parseStar = const kindType <$> symbol' "*"
parseBang :: TokenParser Kind
-parseBang = const Bang <$> symbol' "!"
+parseBang = const kindEffect <$> symbol' "!"
-parseSymbol :: TokenParser Kind
-parseSymbol = const Symbol <$> uname' "Symbol"
+parseNamedKind :: TokenParser Kind
+parseNamedKind = NamedKind <$> parseQualified kindName
-parseTypeAtom :: TokenParser Kind
-parseTypeAtom = indented *> P.choice
+parseKindAtom :: TokenParser Kind
+parseKindAtom = indented *> P.choice
[ parseStar
, parseBang
- , parseSymbol
+ , parseNamedKind
, parens parseKind
]
+
-- |
-- Parse a kind
--
parseKind :: TokenParser Kind
-parseKind = P.buildExpressionParser operators parseTypeAtom P.<?> "kind"
+parseKind = P.buildExpressionParser operators parseKindAtom P.<?> "kind"
where
operators = [ [ P.Prefix (symbol' "#" >> return Row) ]
, [ P.Infix (rarrow >> return FunKind) P.AssocRight ] ]
diff --git a/src/Language/PureScript/Parser/Lexer.hs b/src/Language/PureScript/Parser/Lexer.hs
index cbe90f5..59eff68 100644
--- a/src/Language/PureScript/Parser/Lexer.hs
+++ b/src/Language/PureScript/Parser/Lexer.hs
@@ -43,6 +43,7 @@ module Language.PureScript.Parser.Lexer
, lname'
, qualifier
, tyname
+ , kiname
, dconsname
, uname
, uname'
@@ -474,6 +475,12 @@ tyname = token go P.<?> "type name"
go (UName s) = Just s
go _ = Nothing
+kiname :: TokenParser Text
+kiname = token go P.<?> "kind name"
+ where
+ go (UName s) = Just s
+ go _ = Nothing
+
dconsname :: TokenParser Text
dconsname = token go P.<?> "data constructor name"
where
diff --git a/src/Language/PureScript/Pretty/Kinds.hs b/src/Language/PureScript/Pretty/Kinds.hs
index 364ace9..0ec29ba 100644
--- a/src/Language/PureScript/Pretty/Kinds.hs
+++ b/src/Language/PureScript/Pretty/Kinds.hs
@@ -16,15 +16,14 @@ import Data.Text (Text)
import Language.PureScript.Crash
import Language.PureScript.Kinds
+import Language.PureScript.Names
import Language.PureScript.Pretty.Common
typeLiterals :: Pattern () Kind String
typeLiterals = mkPattern match
where
- match Star = Just "*"
- match Bang = Just "!"
- match Symbol = Just "Symbol"
match (KUnknown u) = Just $ 'u' : show u
+ match (NamedKind name) = Just $ T.unpack (showQualified runProperName name)
match _ = Nothing
matchRow :: Pattern () Kind ((), Kind)
diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs
index 72b1734..14838c5 100644
--- a/src/Language/PureScript/Pretty/Values.hs
+++ b/src/Language/PureScript/Pretty/Values.hs
@@ -54,15 +54,15 @@ prettyPrintValue d (IfThenElse cond th el) =
// moveRight 2 (vcat left [ text "then " <> prettyPrintValueAtom (d - 1) th
, text "else " <> prettyPrintValueAtom (d - 1) el
])
-prettyPrintValue d (Accessor prop val) = prettyPrintValueAtom (d - 1) val <> textT ("." Monoid.<> prettyPrintObjectKey prop)
-prettyPrintValue d (ObjectUpdate o ps) = prettyPrintValueAtom (d - 1) o <> text " " <> list '{' '}' (\(key, val) -> textT (key Monoid.<> " = ") <> prettyPrintValue (d - 1) val) ps
+prettyPrintValue d (Accessor prop val) = prettyPrintValueAtom (d - 1) val `before` textT ("." Monoid.<> prettyPrintObjectKey prop)
+prettyPrintValue d (ObjectUpdate o ps) = prettyPrintValueAtom (d - 1) o `beforeWithSpace` list '{' '}' (\(key, val) -> textT (key Monoid.<> " = ") <> prettyPrintValue (d - 1) val) ps
prettyPrintValue d (App val arg) = prettyPrintValueAtom (d - 1) val `beforeWithSpace` prettyPrintValueAtom (d - 1) arg
prettyPrintValue d (Abs (Left arg) val) = text ('\\' : T.unpack (showIdent arg) ++ " -> ") // moveRight 2 (prettyPrintValue (d - 1) val)
prettyPrintValue d (Abs (Right arg) val) = text ('\\' : T.unpack (prettyPrintBinder arg) ++ " -> ") // moveRight 2 (prettyPrintValue (d - 1) val)
prettyPrintValue d (TypeClassDictionaryConstructorApp className ps) =
text (T.unpack (runProperName (disqualify className)) ++ " ") <> prettyPrintValueAtom (d - 1) ps
prettyPrintValue d (Case values binders) =
- (text "case " <> foldl1 beforeWithSpace (map (prettyPrintValueAtom (d - 1)) values) <> text " of") //
+ (text "case " <> foldr beforeWithSpace (text "of") (map (prettyPrintValueAtom (d - 1)) values)) //
moveRight 2 (vcat left (map (prettyPrintCaseAlternative (d - 1)) binders))
prettyPrintValue d (Let ds val) =
text "let" //
@@ -96,7 +96,7 @@ prettyPrintValueAtom d (BinaryNoParens op lhs rhs) =
prettyPrintValue (d - 1) lhs `beforeWithSpace` printOp op `beforeWithSpace` prettyPrintValue (d - 1) rhs
where
printOp (Op (Qualified _ name)) = text $ T.unpack $ runOpName name
- printOp expr = text "`" <> prettyPrintValue (d - 1) expr <> text "`"
+ printOp expr = text "`" <> prettyPrintValue (d - 1) expr `before` text "`"
prettyPrintValueAtom d (TypedValue _ val _) = prettyPrintValueAtom d val
prettyPrintValueAtom d (PositionedValue _ _ val) = prettyPrintValueAtom d val
prettyPrintValueAtom d (Parens expr) = (text "(" <> prettyPrintValue d expr) `before` text ")"
diff --git a/src/Language/PureScript/Publish.hs b/src/Language/PureScript/Publish.hs
index 83589ba..136991a 100644
--- a/src/Language/PureScript/Publish.hs
+++ b/src/Language/PureScript/Publish.hs
@@ -23,7 +23,7 @@ module Language.PureScript.Publish
import Prelude ()
import Prelude.Compat hiding (userError)
-import Control.Arrow ((***))
+import Control.Arrow ((***), first)
import Control.Category ((>>>))
import Control.Exception (catch, try)
import Control.Monad.Error.Class (MonadError(..))
@@ -35,12 +35,13 @@ import Data.Aeson.BetterErrors
import Data.Char (isSpace)
import Data.Foldable (traverse_)
import Data.Function (on)
-import Data.List (stripPrefix, isSuffixOf, (\\), nubBy)
+import Data.List (stripPrefix, (\\), nubBy)
import Data.List.NonEmpty (NonEmpty(..))
import Data.List.Split (splitOn)
import Data.Maybe
import Data.Version
import qualified Data.SPDX as SPDX
+import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TL
@@ -65,7 +66,7 @@ import qualified Language.PureScript.Docs as D
data PublishOptions = PublishOptions
{ -- | How to obtain the version tag and version that the data being
-- generated will refer to.
- publishGetVersion :: PrepareM (String, Version)
+ publishGetVersion :: PrepareM (Text, Version)
, -- | What to do when the working tree is dirty
publishWorkingTreeDirty :: PrepareM ()
}
@@ -184,21 +185,20 @@ checkCleanWorkingTree opts = do
unless (status == Clean) $
publishWorkingTreeDirty opts
-getVersionFromGitTag :: PrepareM (String, Version)
+getVersionFromGitTag :: PrepareM (Text, Version)
getVersionFromGitTag = do
out <- readProcess' "git" ["tag", "--list", "--points-at", "HEAD"] ""
let vs = map trimWhitespace (lines out)
case mapMaybe parseMay vs of
[] -> userError TagMustBeCheckedOut
- [x] -> return x
+ [x] -> return (first T.pack x)
xs -> userError (AmbiguousVersions (map snd xs))
where
trimWhitespace =
dropWhile isSpace >>> reverse >>> dropWhile isSpace >>> reverse
- parseMay str =
- (str,) <$> D.parseVersion' (dropPrefix "v" str)
- dropPrefix prefix str =
- fromMaybe str (stripPrefix prefix str)
+ parseMay str = do
+ digits <- stripPrefix "v" str
+ (str,) <$> D.parseVersion' digits
getBowerRepositoryInfo :: PackageMeta -> PrepareM (D.GithubUser, D.GithubRepo)
getBowerRepositoryInfo = either (userError . BadRepositoryField) return . tryExtract
@@ -209,7 +209,7 @@ getBowerRepositoryInfo = either (userError . BadRepositoryField) return . tryExt
Just Repository{..} -> do
unless (repositoryType == "git")
(Left (BadRepositoryType repositoryType))
- maybe (Left NotOnGithub) Right (extractGithub repositoryUrl)
+ maybe (Left NotOnGithub) Right (extractGithub (T.pack repositoryUrl))
checkLicense :: PackageMeta -> PrepareM ()
checkLicense pkgMeta =
@@ -226,9 +226,9 @@ checkLicense pkgMeta =
isValidSPDX :: String -> Bool
isValidSPDX = (== 1) . length . SPDX.parseExpression
-extractGithub :: String -> Maybe (D.GithubUser, D.GithubRepo)
+extractGithub :: Text -> Maybe (D.GithubUser, D.GithubRepo)
extractGithub = stripGitHubPrefixes
- >>> fmap (splitOn "/")
+ >>> fmap (T.splitOn "/")
>=> takeTwo
>>> fmap (D.GithubUser *** (D.GithubRepo . dropDotGit))
@@ -237,18 +237,18 @@ extractGithub = stripGitHubPrefixes
takeTwo [x, y] = Just (x, y)
takeTwo _ = Nothing
- stripGitHubPrefixes :: String -> Maybe String
+ stripGitHubPrefixes :: Text -> Maybe Text
stripGitHubPrefixes = stripPrefixes [ "git://github.com/"
, "https://github.com/"
, "git@github.com:"
]
- stripPrefixes :: [String] -> String -> Maybe String
- stripPrefixes prefixes str = msum $ (`stripPrefix` str) <$> prefixes
+ stripPrefixes :: [Text] -> Text -> Maybe Text
+ stripPrefixes prefixes str = msum $ (`T.stripPrefix` str) <$> prefixes
- dropDotGit :: String -> String
+ dropDotGit :: Text -> Text
dropDotGit str
- | ".git" `isSuffixOf` str = take (length str - 4) str
+ | ".git" `T.isSuffixOf` str = T.take (T.length str - 4) str
| otherwise = str
readProcess' :: String -> [String] -> String -> PrepareM String
@@ -265,12 +265,12 @@ data DependencyStatus
-- _resolution key. This can be caused by adding the dependency using
-- `bower link`, or simply copying it into bower_components instead of
-- installing it normally.
- | ResolvedOther String
- -- ^ Resolved, but to something other than a version. The String argument
+ | ResolvedOther Text
+ -- ^ Resolved, but to something other than a version. The Text argument
-- is the resolution type. The values it can take that I'm aware of are
-- "commit" and "branch".
- | ResolvedVersion String
- -- ^ Resolved to a version. The String argument is the resolution tag (eg,
+ | ResolvedVersion Text
+ -- ^ Resolved to a version. The Text argument is the resolution tag (eg,
-- "v0.1.0").
deriving (Show, Eq)
@@ -341,9 +341,9 @@ asDependencyStatus = do
else
key "pkgMeta" $
keyOrDefault "_resolution" NoResolution $ do
- type_ <- key "type" asString
+ type_ <- key "type" asText
case type_ of
- "version" -> ResolvedVersion <$> key "tag" asString
+ "version" -> ResolvedVersion <$> key "tag" asText
other -> return (ResolvedOther other)
warnUndeclared :: [PackageName] -> [PackageName] -> PrepareM ()
@@ -374,15 +374,16 @@ handleDeps deps = do
bowerDir pkgName = "bower_components/" ++ runPackageName pkgName
-- Try to extract a version, and warn if unsuccessful.
+ tryExtractVersion' :: (PackageName, Text) -> PrepareM (Maybe (PackageName, Version))
tryExtractVersion' pair =
maybe (warn (UnacceptableVersion pair) >> return Nothing)
(return . Just)
(tryExtractVersion pair)
-tryExtractVersion :: (PackageName, String) -> Maybe (PackageName, Version)
+tryExtractVersion :: (PackageName, Text) -> Maybe (PackageName, Version)
tryExtractVersion (pkgName, tag) =
- let tag' = fromMaybe tag (stripPrefix "v" tag)
- in (pkgName,) <$> D.parseVersion' tag'
+ let tag' = fromMaybe tag (T.stripPrefix "v" tag)
+ in (pkgName,) <$> D.parseVersion' (T.unpack tag')
-- | Returns whether it looks like there is a purescript package checked out
-- in the given directory.
diff --git a/src/Language/PureScript/Publish/ErrorsWarnings.hs b/src/Language/PureScript/Publish/ErrorsWarnings.hs
index db7d7de..597b2a4 100644
--- a/src/Language/PureScript/Publish/ErrorsWarnings.hs
+++ b/src/Language/PureScript/Publish/ErrorsWarnings.hs
@@ -24,6 +24,7 @@ import Data.Maybe
import Data.Monoid
import Data.Version
import qualified Data.List.NonEmpty as NonEmpty
+import Data.Text (Text)
import qualified Data.Text as T
import Language.PureScript.Publish.BoxesHelpers
@@ -43,7 +44,7 @@ data PackageError
data PackageWarning
= NoResolvedVersion PackageName
| UndeclaredDependency PackageName
- | UnacceptableVersion (PackageName, String)
+ | UnacceptableVersion (PackageName, Text)
| DirtyWorkingTree_Warn
deriving (Show)
@@ -147,9 +148,8 @@ displayUserError e = case e of
, "version."
])
, spacer
- , para "Note: tagged versions must be in one of the following forms:"
- , indented (para "* v{MAJOR}.{MINOR}.{PATCH} (example: \"v1.6.2\")")
- , indented (para "* {MAJOR}.{MINOR}.{PATCH} (example: \"1.6.2\")")
+ , para "Note: tagged versions must be in the form"
+ , indented (para "v{MAJOR}.{MINOR}.{PATCH} (example: \"v1.6.2\")")
, spacer
, para (concat
[ "If the version you are publishing is not yet tagged, you might "
@@ -311,7 +311,7 @@ displayOtherError e = case e of
data CollectedWarnings = CollectedWarnings
{ noResolvedVersions :: [PackageName]
, undeclaredDependencies :: [PackageName]
- , unacceptableVersions :: [(PackageName, String)]
+ , unacceptableVersions :: [(PackageName, Text)]
, dirtyWorkingTree :: Any
}
deriving (Show, Eq, Ord)
@@ -387,7 +387,7 @@ warnUndeclaredDependencies pkgNames =
])
: bulletedList runPackageName (NonEmpty.toList pkgNames)
-warnUnacceptableVersions :: NonEmpty (PackageName, String) -> Box
+warnUnacceptableVersions :: NonEmpty (PackageName, Text) -> Box
warnUnacceptableVersions pkgs =
let singular = NonEmpty.length pkgs == 1
pl a b = if singular then b else a
@@ -414,7 +414,7 @@ warnUnacceptableVersions pkgs =
])
]
where
- showTuple (pkgName, tag) = runPackageName pkgName ++ "#" ++ tag
+ showTuple (pkgName, tag) = runPackageName pkgName ++ "#" ++ T.unpack tag
warnDirtyWorkingTree :: Box
warnDirtyWorkingTree =
diff --git a/src/Language/PureScript/Sugar.hs b/src/Language/PureScript/Sugar.hs
index 7ec61cf..0a1d272 100644
--- a/src/Language/PureScript/Sugar.hs
+++ b/src/Language/PureScript/Sugar.hs
@@ -62,6 +62,6 @@ desugar externs =
>=> desugarImports externs
>=> rebracket externs
>=> traverse checkFixityExports
- >=> traverse deriveInstances
+ >=> traverse (deriveInstances externs)
>=> desugarTypeClasses externs
>=> traverse createBindingGroupsModule
diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs
index a7cd113..4d0d7a5 100644
--- a/src/Language/PureScript/Sugar/BindingGroups.hs
+++ b/src/Language/PureScript/Sugar/BindingGroups.hs
@@ -73,6 +73,7 @@ createBindingGroups moduleName = mapM f <=< handleDecls
valueVerts = map (\d -> (d, declIdent d, usedIdents moduleName d `intersect` allIdents)) values
bindingGroupDecls <- parU (stronglyConnComp valueVerts) (toBindingGroup moduleName)
return $ filter isImportDecl ds ++
+ filter isExternKindDecl ds ++
filter isExternDataDecl ds ++
dataBindingGroupDecls ++
filter isTypeClassDeclaration ds ++
diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs
index 2d2a483..a0ffbfa 100644
--- a/src/Language/PureScript/Sugar/Names.hs
+++ b/src/Language/PureScript/Sugar/Names.hs
@@ -25,6 +25,7 @@ import Language.PureScript.AST
import Language.PureScript.Crash
import Language.PureScript.Errors
import Language.PureScript.Externs
+import Language.PureScript.Kinds
import Language.PureScript.Linter.Imports
import Language.PureScript.Names
import Language.PureScript.Sugar.Names.Env
@@ -98,6 +99,9 @@ desugarImportsWithEnv externs modules = do
exportedRefs :: Ord a => (DeclarationRef -> Maybe a) -> M.Map a ModuleName
exportedRefs f = M.fromList $ (, efModuleName) <$> mapMaybe f efExports
+ exportedKinds :: M.Map (ProperName 'KindName) ModuleName
+ exportedKinds = exportedRefs getKindRef
+
updateEnv :: ([Module], Env) -> Module -> m ([Module], Env)
updateEnv (ms, env) m@(Module ss _ mn _ refs) = do
members <- findExportable m
@@ -128,6 +132,7 @@ elaborateExports exps (Module ss coms mn decls refs) =
++ go TypeClassRef exportedTypeClasses
++ go ValueRef exportedValues
++ go ValueOpRef exportedValueOps
+ ++ go KindRef exportedKinds
++ maybe [] (filter isModuleRef) refs
where
@@ -165,17 +170,24 @@ renameInModule imports (Module ss coms mn decls exps) =
updateDecl (_, bound) d@(PositionedDeclaration pos _ _) =
return ((Just pos, bound), d)
updateDecl (pos, bound) (DataDeclaration dtype name args dctors) =
- (,) (pos, bound) <$> (DataDeclaration dtype name args <$> traverse (sndM (traverse (updateTypesEverywhere pos))) dctors)
+ (,) (pos, bound) <$> (DataDeclaration dtype name <$> updateTypeArguments pos args
+ <*> traverse (sndM (traverse (updateTypesEverywhere pos))) dctors)
updateDecl (pos, bound) (TypeSynonymDeclaration name ps ty) =
- (,) (pos, bound) <$> (TypeSynonymDeclaration name ps <$> updateTypesEverywhere pos ty)
+ (,) (pos, bound) <$> (TypeSynonymDeclaration name <$> updateTypeArguments pos ps
+ <*> updateTypesEverywhere pos ty)
updateDecl (pos, bound) (TypeClassDeclaration className args implies deps ds) =
- (,) (pos, bound) <$> (TypeClassDeclaration className args <$> updateConstraints pos implies <*> pure deps <*> pure ds)
+ (,) (pos, bound) <$> (TypeClassDeclaration className <$> updateTypeArguments pos args
+ <*> updateConstraints pos implies
+ <*> pure deps
+ <*> pure ds)
updateDecl (pos, bound) (TypeInstanceDeclaration name cs cn ts ds) =
(,) (pos, bound) <$> (TypeInstanceDeclaration name <$> updateConstraints pos cs <*> updateClassName cn pos <*> traverse (updateTypesEverywhere pos) ts <*> pure ds)
updateDecl (pos, bound) (TypeDeclaration name ty) =
(,) (pos, bound) <$> (TypeDeclaration name <$> updateTypesEverywhere pos ty)
updateDecl (pos, bound) (ExternDeclaration name ty) =
(,) (pos, name : bound) <$> (ExternDeclaration name <$> updateTypesEverywhere pos ty)
+ updateDecl (pos, bound) (ExternDataDeclaration name ki) =
+ (,) (pos, bound) <$> (ExternDataDeclaration name <$> updateKindsEverywhere pos ki)
updateDecl (pos, bound) (TypeFixityDeclaration fixity alias op) =
(,) (pos, bound) <$> (TypeFixityDeclaration fixity <$> updateTypeName alias pos <*> pure op)
updateDecl (pos, bound) (ValueFixityDeclaration fixity (Qualified mn' (Left alias)) op) =
@@ -238,6 +250,19 @@ renameInModule imports (Module ss coms mn decls exps) =
letBoundVariable (PositionedDeclaration _ _ d) = letBoundVariable d
letBoundVariable _ = Nothing
+ updateKindsEverywhere :: Maybe SourceSpan -> Kind -> m Kind
+ updateKindsEverywhere pos = everywhereOnKindsM updateKind
+ where
+ updateKind :: Kind -> m Kind
+ updateKind (NamedKind name) = NamedKind <$> updateKindName name pos
+ updateKind k = return k
+
+ updateTypeArguments
+ :: (Traversable f, Traversable g)
+ => Maybe SourceSpan
+ -> f (a, g Kind) -> m (f (a, g Kind))
+ updateTypeArguments pos = traverse (sndM (traverse (updateKindsEverywhere pos)))
+
updateTypesEverywhere :: Maybe SourceSpan -> Type -> m Type
updateTypesEverywhere pos = everywhereOnTypesM updateType
where
@@ -245,16 +270,17 @@ renameInModule imports (Module ss coms mn decls exps) =
updateType (TypeOp name) = TypeOp <$> updateTypeOpName name pos
updateType (TypeConstructor name) = TypeConstructor <$> updateTypeName name pos
updateType (ConstrainedType cs t) = ConstrainedType <$> traverse updateInConstraint cs <*> pure t
+ updateType (KindedType t k) = KindedType t <$> updateKindsEverywhere pos k
updateType t = return t
updateInConstraint :: Constraint -> m Constraint
updateInConstraint (Constraint name ts info) =
Constraint <$> updateClassName name pos <*> pure ts <*> pure info
updateConstraints :: Maybe SourceSpan -> [Constraint] -> m [Constraint]
- updateConstraints pos = traverse $ \(Constraint name ts info) ->
- Constraint
- <$> updateClassName name pos
- <*> traverse (updateTypesEverywhere pos) ts
+ updateConstraints pos = traverse $ \(Constraint name ts info) ->
+ Constraint
+ <$> updateClassName name pos
+ <*> traverse (updateTypesEverywhere pos) ts
<*> pure info
updateTypeName
@@ -290,6 +316,12 @@ renameInModule imports (Module ss coms mn decls exps) =
-> m (Qualified (OpName 'ValueOpName))
updateValueOpName = update (importedValueOps imports) ValOpName
+ updateKindName
+ :: Qualified (ProperName 'KindName)
+ -> Maybe SourceSpan
+ -> m (Qualified (ProperName 'KindName))
+ updateKindName = update (importedKinds imports) KiName
+
-- Update names so unqualified references become qualified, and locally
-- qualified references are replaced with their canoncial qualified names
-- (e.g. M.Map -> Data.Map.Map).
diff --git a/src/Language/PureScript/Sugar/Names/Env.hs b/src/Language/PureScript/Sugar/Names/Env.hs
index 36c5700..7b527e4 100644
--- a/src/Language/PureScript/Sugar/Names/Env.hs
+++ b/src/Language/PureScript/Sugar/Names/Env.hs
@@ -16,6 +16,7 @@ module Language.PureScript.Sugar.Names.Env
, exportTypeClass
, exportValue
, exportValueOp
+ , exportKind
, getExports
, checkImportConflicts
) where
@@ -71,27 +72,27 @@ type ImportMap a = M.Map (Qualified a) [ImportRecord a]
data Imports = Imports
{
-- |
- -- Local names for types within a module mapped to to their qualified names
+ -- Local names for types within a module mapped to their qualified names
--
importedTypes :: ImportMap (ProperName 'TypeName)
-- |
- -- Local names for type operators within a module mapped to to their qualified names
+ -- Local names for type operators within a module mapped to their qualified names
--
, importedTypeOps :: ImportMap (OpName 'TypeOpName)
-- |
- -- Local names for data constructors within a module mapped to to their qualified names
+ -- Local names for data constructors within a module mapped to their qualified names
--
, importedDataConstructors :: ImportMap (ProperName 'ConstructorName)
-- |
- -- Local names for classes within a module mapped to to their qualified names
+ -- Local names for classes within a module mapped to their qualified names
--
, importedTypeClasses :: ImportMap (ProperName 'ClassName)
-- |
- -- Local names for values within a module mapped to to their qualified names
+ -- Local names for values within a module mapped to their qualified names
--
, importedValues :: ImportMap Ident
-- |
- -- Local names for value operators within a module mapped to to their qualified names
+ -- Local names for value operators within a module mapped to their qualified names
--
, importedValueOps :: ImportMap (OpName 'ValueOpName)
-- |
@@ -104,10 +105,14 @@ data Imports = Imports
-- The "as" names of modules that have been imported qualified.
--
, importedQualModules :: S.Set ModuleName
+ -- |
+ -- Local names for kinds within a module mapped to their qualified names
+ --
+ , importedKinds :: ImportMap (ProperName 'KindName)
} deriving (Show)
nullImports :: Imports
-nullImports = Imports M.empty M.empty M.empty M.empty M.empty M.empty S.empty S.empty
+nullImports = Imports M.empty M.empty M.empty M.empty M.empty M.empty S.empty S.empty M.empty
-- |
-- An 'Imports' value with imports for the `Prim` module.
@@ -117,6 +122,7 @@ primImports =
nullImports
{ importedTypes = M.fromList $ mkEntries `concatMap` M.keys primTypes
, importedTypeClasses = M.fromList $ mkEntries `concatMap` M.keys primClasses
+ , importedKinds = M.fromList $ mkEntries `concatMap` S.toList primKinds
}
where
mkEntries :: Qualified a -> [(Qualified a, [ImportRecord a])]
@@ -155,13 +161,17 @@ data Exports = Exports
-- from.
--
, exportedValueOps :: M.Map (OpName 'ValueOpName) ModuleName
+ -- |
+ -- The exported kinds along with the module they originally came from.
+ --
+ , exportedKinds :: M.Map (ProperName 'KindName) ModuleName
} deriving (Show)
-- |
-- An empty 'Exports' value.
--
nullExports :: Exports
-nullExports = Exports M.empty M.empty M.empty M.empty M.empty
+nullExports = Exports M.empty M.empty M.empty M.empty M.empty M.empty
-- |
-- The imports and exports for a collection of modules. The 'SourceSpan' is used
@@ -196,10 +206,12 @@ primExports =
nullExports
{ exportedTypes = M.fromList $ mkTypeEntry `map` M.keys primTypes
, exportedTypeClasses = M.fromList $ mkClassEntry `map` M.keys primClasses
+ , exportedKinds = M.fromList $ mkKindEntry `map` S.toList primKinds
}
where
mkTypeEntry (Qualified mn name) = (name, ([], fromJust mn))
mkClassEntry (Qualified mn name) = (name, fromJust mn)
+ mkKindEntry (Qualified mn name) = (name, fromJust mn)
-- | Environment which only contains the Prim module.
primEnv :: Env
@@ -317,6 +329,19 @@ exportValueOp exps op mn = do
return $ exps { exportedValueOps = valueOps }
-- |
+-- Safely adds a kind to some exports, returning an error if a conflict occurs.
+--
+exportKind
+ :: MonadError MultipleErrors m
+ => Exports
+ -> ProperName 'KindName
+ -> ModuleName
+ -> m Exports
+exportKind exps name mn = do
+ kinds <- addExport KiName name mn (exportedKinds exps)
+ return $ exps { exportedKinds = kinds }
+
+-- |
-- Adds an entry to a list of exports unless it is already present, in which
-- case an error is returned.
--
diff --git a/src/Language/PureScript/Sugar/Names/Exports.hs b/src/Language/PureScript/Sugar/Names/Exports.hs
index 51facc0..ac502f5 100644
--- a/src/Language/PureScript/Sugar/Names/Exports.hs
+++ b/src/Language/PureScript/Sugar/Names/Exports.hs
@@ -19,7 +19,7 @@ import Language.PureScript.AST
import Language.PureScript.Crash
import Language.PureScript.Errors
import Language.PureScript.Names
-import Language.PureScript.Sugar.Names.Env
+import Language.PureScript.Sugar.Names.Env
import Language.PureScript.Sugar.Names.Common (warnDuplicateRefs)
-- |
@@ -51,6 +51,8 @@ findExportable (Module _ _ mn ds _) =
exportTypeOp exps op mn
updateExports exps (ExternDeclaration name _) =
exportValue exps name mn
+ updateExports exps (ExternKindDeclaration pn) =
+ exportKind exps pn mn
updateExports exps (PositionedDeclaration pos _ d) =
rethrowWithPosition pos $ updateExports exps d
updateExports exps _ = return exps
@@ -61,21 +63,21 @@ findExportable (Module _ _ mn ds _) =
--
resolveExports
:: forall m
- . (MonadError MultipleErrors m, MonadWriter MultipleErrors m)
- => Env
- -> SourceSpan
+ . (MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+ => Env
+ -> SourceSpan
-> ModuleName
-> Imports
-> Exports
-> [DeclarationRef]
-> m Exports
-resolveExports env ss mn imps exps refs =
- warnAndRethrow (addHint (ErrorInModule mn)) $ do
+resolveExports env ss mn imps exps refs =
+ warnAndRethrow (addHint (ErrorInModule mn)) $ do
filtered <- filterModule mn exps refs
- exps' <- foldM elaborateModuleExports filtered refs
- warnDuplicateRefs ss DuplicateExportRef refs
- return exps'
-
+ exps' <- foldM elaborateModuleExports filtered refs
+ warnDuplicateRefs ss DuplicateExportRef refs
+ return exps'
+
where
-- Takes the current module's imports, the accumulated list of exports, and a
@@ -83,19 +85,21 @@ resolveExports env ss mn imps exps refs =
-- module, export anything from the imports that matches for that module.
elaborateModuleExports :: Exports -> DeclarationRef -> m Exports
elaborateModuleExports result (PositionedDeclarationRef pos _ r) =
- warnAndRethrowWithPosition pos $ elaborateModuleExports result r
+ warnAndRethrowWithPosition pos $ elaborateModuleExports result r
elaborateModuleExports result (ModuleRef name) | name == mn = do
let types' = exportedTypes result `M.union` exportedTypes exps
let typeOps' = exportedTypeOps result `M.union` exportedTypeOps exps
let classes' = exportedTypeClasses result `M.union` exportedTypeClasses exps
let values' = exportedValues result `M.union` exportedValues exps
let valueOps' = exportedValueOps result `M.union` exportedValueOps exps
+ let kinds' = exportedKinds result `M.union` exportedKinds exps
return result
{ exportedTypes = types'
, exportedTypeOps = typeOps'
, exportedTypeClasses = classes'
, exportedValues = values'
, exportedValueOps = valueOps'
+ , exportedKinds = kinds'
}
elaborateModuleExports result (ModuleRef name) = do
let isPseudo = isPseudoModule name
@@ -107,11 +111,13 @@ resolveExports env ss mn imps exps refs =
reClasses <- extract isPseudo name TyClassName (importedTypeClasses imps)
reValues <- extract isPseudo name IdentName (importedValues imps)
reValueOps <- extract isPseudo name ValOpName (importedValueOps imps)
+ reKinds <- extract isPseudo name KiName (importedKinds imps)
foldM (\exps' ((tctor, dctors), mn') -> exportType ReExport exps' tctor dctors mn') result (resolveTypeExports reTypes reDctors)
>>= flip (foldM (uncurry . exportTypeOp)) (map resolveTypeOp reTypeOps)
>>= flip (foldM (uncurry . exportTypeClass ReExport)) (map resolveClass reClasses)
>>= flip (foldM (uncurry . exportValue)) (map resolveValue reValues)
>>= flip (foldM (uncurry . exportValueOp)) (map resolveValueOp reValueOps)
+ >>= flip (foldM (uncurry . exportKind)) (map resolveKind reKinds)
elaborateModuleExports result _ = return result
-- Extracts a list of values for a module based on a lookup table. If the
@@ -146,6 +152,7 @@ resolveExports env ss mn imps exps refs =
|| any (isQualifiedWith mn') (f (importedTypeClasses imps))
|| any (isQualifiedWith mn') (f (importedValues imps))
|| any (isQualifiedWith mn') (f (importedValueOps imps))
+ || any (isQualifiedWith mn') (f (importedKinds imps))
-- Check whether a module name refers to a module that has been imported
-- without qualification into an import scope.
@@ -203,6 +210,14 @@ resolveExports env ss mn imps exps refs =
. fromMaybe (internalError "Missing value in resolveValueOp")
$ resolve exportedValueOps op
+ -- Looks up an imported kind and re-qualifies it with the original
+ -- module it came from.
+ resolveKind :: Qualified (ProperName 'KindName) -> (ProperName 'KindName, ModuleName)
+ resolveKind kind
+ = splitQual
+ . fromMaybe (internalError "Missing value in resolveKind")
+ $ resolve exportedKinds kind
+
resolve
:: Ord a
=> (Exports -> M.Map a ModuleName)
@@ -237,12 +252,14 @@ filterModule mn exps refs = do
classes <- foldM (filterExport TyClassName getTypeClassRef exportedTypeClasses) M.empty refs
values <- foldM (filterExport IdentName getValueRef exportedValues) M.empty refs
valueOps <- foldM (filterExport ValOpName getValueOpRef exportedValueOps) M.empty refs
+ kinds <- foldM (filterExport KiName getKindRef exportedKinds) M.empty refs
return Exports
{ exportedTypes = types
, exportedTypeOps = typeOps
, exportedTypeClasses = classes
, exportedValues = values
, exportedValueOps = valueOps
+ , exportedKinds = kinds
}
where
diff --git a/src/Language/PureScript/Sugar/Names/Imports.hs b/src/Language/PureScript/Sugar/Names/Imports.hs
index 616921b..9250038 100644
--- a/src/Language/PureScript/Sugar/Names/Imports.hs
+++ b/src/Language/PureScript/Sugar/Names/Imports.hs
@@ -130,6 +130,8 @@ resolveImport importModule exps imps impQual = resolveByType
checkImportExists TyClassName (exportedTypeClasses exps) name
check (ModuleRef name) | isHiding =
throwError . errorMessage $ ImportHidingModule name
+ check (KindRef name) = do
+ checkImportExists KiName (exportedKinds exps) name
check r = internalError $ "Invalid argument to checkRefs: " ++ show r
-- Check that an explicitly imported item exists in the module it is being imported from
@@ -181,6 +183,7 @@ resolveImport importModule exps imps impQual = resolveByType
>>= flip (foldM (\m (name, _) -> importer m (ValueRef name))) (M.toList (exportedValues exps))
>>= flip (foldM (\m (name, _) -> importer m (ValueOpRef name))) (M.toList (exportedValueOps exps))
>>= flip (foldM (\m (name, _) -> importer m (TypeClassRef name))) (M.toList (exportedTypeClasses exps))
+ >>= flip (foldM (\m (name, _) -> importer m (KindRef name))) (M.toList (exportedKinds exps))
importRef :: ImportProvenance -> Imports -> DeclarationRef -> m Imports
importRef prov imp (PositionedDeclarationRef pos _ r) =
@@ -205,6 +208,9 @@ resolveImport importModule exps imps impQual = resolveByType
importRef prov imp (TypeClassRef name) = do
let typeClasses' = updateImports (importedTypeClasses imp) (exportedTypeClasses exps) id name prov
return $ imp { importedTypeClasses = typeClasses' }
+ importRef prov imp (KindRef name) = do
+ let kinds' = updateImports (importedKinds imp) (exportedKinds exps) id name prov
+ return $ imp { importedKinds = kinds' }
importRef _ _ TypeInstanceRef{} = internalError "TypeInstanceRef in importRef"
importRef _ _ ModuleRef{} = internalError "ModuleRef in importRef"
importRef _ _ ReExportRef{} = internalError "ReExportRef in importRef"
diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs
index fbf0be8..8b5ad3c 100755
--- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs
+++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs
@@ -3,77 +3,102 @@
--
module Language.PureScript.Sugar.TypeClasses.Deriving (deriveInstances) where
-import Prelude.Compat
-
-import Control.Arrow (second)
-import Control.Monad (replicateM)
-import Control.Monad.Error.Class (MonadError(..))
-import Control.Monad.Supply.Class (MonadSupply)
-
-import Data.List (foldl', find, sortBy, unzip5)
-import Data.Maybe (fromMaybe)
-import Data.Ord (comparing)
-import Data.Text (Text)
-
-import Language.PureScript.AST
-import Language.PureScript.Crash
-import Language.PureScript.Environment
-import Language.PureScript.Errors
-import Language.PureScript.Names
-import Language.PureScript.Types
-import Language.PureScript.TypeChecker (checkNewtype)
+import Prelude.Compat
+
+import Control.Arrow (second)
+import Control.Monad (replicateM, zipWithM)
+import Control.Monad.Error.Class (MonadError(..))
+import Control.Monad.Supply.Class (MonadSupply)
+import Data.List (foldl', find, sortBy, unzip5)
+import qualified Data.Map as M
+import Data.Maybe (fromMaybe, mapMaybe)
+import Data.Ord (comparing)
+import Data.Text (Text)
+import Language.PureScript.AST
import qualified Language.PureScript.Constants as C
+import Language.PureScript.Crash
+import Language.PureScript.Environment
+import Language.PureScript.Errors
+import Language.PureScript.Externs
+import Language.PureScript.Kinds
+import Language.PureScript.Names
+import Language.PureScript.Types
+import Language.PureScript.TypeChecker (checkNewtype)
+import Language.PureScript.TypeChecker.Synonyms (SynonymMap, replaceAllTypeSynonymsM)
-- | Elaborates deriving instance declarations by code generation.
deriveInstances
- :: (MonadError MultipleErrors m, MonadSupply m)
- => Module
+ :: forall m
+ . (MonadError MultipleErrors m, MonadSupply m)
+ => [ExternsFile]
+ -> Module
-> m Module
-deriveInstances (Module ss coms mn ds exts) = Module ss coms mn <$> mapM (deriveInstance mn ds) ds <*> pure exts
+deriveInstances externs (Module ss coms mn ds exts) =
+ Module ss coms mn <$> mapM (deriveInstance mn synonyms ds) ds <*> pure exts
+ where
+ -- We need to collect type synonym information, since synonyms will not be
+ -- removed until later, during type checking.
+ synonyms :: SynonymMap
+ synonyms =
+ M.fromList $ (externs >>= \ExternsFile{..} -> mapMaybe (fromExternsDecl efModuleName) efDeclarations)
+ ++ mapMaybe fromLocalDecl ds
+ where
+ fromExternsDecl mn' (EDTypeSynonym name args ty) = Just (Qualified (Just mn') name, (args, ty))
+ fromExternsDecl _ _ = Nothing
+
+ fromLocalDecl (TypeSynonymDeclaration name args ty) = do
+ Just (Qualified (Just mn) name, (args, ty))
+ fromLocalDecl (PositionedDeclaration _ _ d) = fromLocalDecl d
+ fromLocalDecl _ = Nothing
-- | Takes a declaration, and if the declaration is a deriving TypeInstanceDeclaration,
-- elaborates that into an instance declaration via code generation.
deriveInstance
:: (MonadError MultipleErrors m, MonadSupply m)
=> ModuleName
+ -> SynonymMap
-> [Declaration]
-> Declaration
-> m Declaration
-deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@[ty] DerivedInstance)
+deriveInstance mn syns ds (TypeInstanceDeclaration nm deps className tys@[ty] DerivedInstance)
| className == Qualified (Just dataGeneric) (ProperName C.generic)
, Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor ty
, mn == fromMaybe mn mn'
- = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveGeneric mn ds tyCon args
+ = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveGeneric mn syns ds tyCon args
| className == Qualified (Just dataEq) (ProperName "Eq")
, Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty
, mn == fromMaybe mn mn'
- = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveEq mn ds tyCon
+ = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveEq mn syns ds tyCon
| className == Qualified (Just dataOrd) (ProperName "Ord")
, Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty
, mn == fromMaybe mn mn'
- = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveOrd mn ds tyCon
-deriveInstance mn ds (TypeInstanceDeclaration nm deps className [wrappedTy, unwrappedTy] DerivedInstance)
+ = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveOrd mn syns ds tyCon
+ | className == Qualified (Just dataFunctor) (ProperName "Functor")
+ , Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty
+ , mn == fromMaybe mn mn'
+ = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveFunctor mn syns ds tyCon
+deriveInstance mn syns ds (TypeInstanceDeclaration nm deps className [wrappedTy, unwrappedTy] DerivedInstance)
| className == Qualified (Just dataNewtype) (ProperName "Newtype")
, Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor wrappedTy
, mn == fromMaybe mn mn'
- = do (inst, actualUnwrappedTy) <- deriveNewtype mn ds tyCon args unwrappedTy
+ = do (inst, actualUnwrappedTy) <- deriveNewtype mn syns ds tyCon args unwrappedTy
return $ TypeInstanceDeclaration nm deps className [wrappedTy, actualUnwrappedTy] (ExplicitInstance inst)
-deriveInstance mn ds (TypeInstanceDeclaration nm deps className [actualTy, repTy] DerivedInstance)
+deriveInstance mn syns ds (TypeInstanceDeclaration nm deps className [actualTy, repTy] DerivedInstance)
| className == Qualified (Just dataGenericRep) (ProperName C.generic)
, Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor actualTy
, mn == fromMaybe mn mn'
- = do (inst, inferredRepTy) <- deriveGenericRep mn ds tyCon args repTy
+ = do (inst, inferredRepTy) <- deriveGenericRep mn syns ds tyCon args repTy
return $ TypeInstanceDeclaration nm deps className [actualTy, inferredRepTy] (ExplicitInstance inst)
-deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance)
+deriveInstance _ _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance)
= throwError . errorMessage $ CannotDerive className tys
-deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@(_ : _) NewtypeInstance)
+deriveInstance mn syns ds (TypeInstanceDeclaration nm deps className tys@(_ : _) NewtypeInstance)
| Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor (last tys)
, mn == fromMaybe mn mn'
- = TypeInstanceDeclaration nm deps className tys . NewtypeInstanceWithDictionary <$> deriveNewtypeInstance className ds tys tyCon args
-deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys NewtypeInstance)
+ = TypeInstanceDeclaration nm deps className tys . NewtypeInstanceWithDictionary <$> deriveNewtypeInstance syns className ds tys tyCon args
+deriveInstance _ _ _ (TypeInstanceDeclaration _ _ className tys NewtypeInstance)
= throwError . errorMessage $ InvalidNewtypeInstance className tys
-deriveInstance mn ds (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> deriveInstance mn ds d
-deriveInstance _ _ e = return e
+deriveInstance mn syns ds (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> deriveInstance mn syns ds d
+deriveInstance _ _ _ e = return e
unwrapTypeConstructor :: Type -> Maybe (Qualified (ProperName 'TypeName), [Type])
unwrapTypeConstructor = fmap (second reverse) . go
@@ -87,13 +112,14 @@ unwrapTypeConstructor = fmap (second reverse) . go
deriveNewtypeInstance
:: forall m
. MonadError MultipleErrors m
- => Qualified (ProperName 'ClassName)
+ => SynonymMap
+ -> Qualified (ProperName 'ClassName)
-> [Declaration]
-> [Type]
-> ProperName 'TypeName
-> [Type]
-> m Expr
-deriveNewtypeInstance className ds tys tyConNm dargs = do
+deriveNewtypeInstance syns className ds tys tyConNm dargs = do
tyCon <- findTypeDecl tyConNm ds
go tyCon
where
@@ -109,7 +135,8 @@ deriveNewtypeInstance className ds tys tyConNm dargs = do
-- type argument
| Just wrapped' <- stripRight (takeReverse (length tyArgNames - length dargs) tyArgNames) wrapped =
do let subst = zipWith (\(name, _) t -> (name, t)) tyArgNames dargs
- return (DeferredDictionary className (init tys ++ [replaceAllTypeVars subst wrapped']))
+ wrapped'' <- replaceAllTypeSynonymsM syns wrapped'
+ return (DeferredDictionary className (init tys ++ [replaceAllTypeVars subst wrapped'']))
go (PositionedDeclaration _ _ d) = go d
go _ = throwError . errorMessage $ InvalidNewtypeInstance className tys
@@ -143,14 +170,18 @@ dataOrd = ModuleName [ ProperName "Data", ProperName "Ord" ]
dataNewtype :: ModuleName
dataNewtype = ModuleName [ ProperName "Data", ProperName "Newtype" ]
+dataFunctor :: ModuleName
+dataFunctor = ModuleName [ ProperName "Data", ProperName "Functor" ]
+
deriveGeneric
:: forall m. (MonadError MultipleErrors m, MonadSupply m)
=> ModuleName
+ -> SynonymMap
-> [Declaration]
-> ProperName 'TypeName
-> [Type]
-> m [Declaration]
-deriveGeneric mn ds tyConNm dargs = do
+deriveGeneric mn syns ds tyConNm dargs = do
tyCon <- findTypeDecl tyConNm ds
toSpine <- mkSpineFunction tyCon
fromSpine <- mkFromSpineFunction tyCon
@@ -174,12 +205,12 @@ deriveGeneric mn ds tyConNm dargs = do
mkCtorClause :: (ProperName 'ConstructorName, [Type]) -> m CaseAlternative
mkCtorClause (ctorName, tys) = do
idents <- replicateM (length tys) freshIdent'
- return $ CaseAlternative [ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)] (Right (caseResult idents))
- where
- caseResult idents =
- App (prodConstructor (Literal . StringLiteral . showQualified runProperName $ Qualified (Just mn) ctorName))
- . Literal . ArrayLiteral
- $ zipWith toSpineFun (map (Var . Qualified Nothing) idents) tys
+ tys' <- mapM (replaceAllTypeSynonymsM syns) tys
+ let caseResult =
+ App (prodConstructor (Literal . StringLiteral . showQualified runProperName $ Qualified (Just mn) ctorName))
+ . Literal . ArrayLiteral
+ $ zipWith toSpineFun (map (Var . Qualified Nothing) idents) tys'
+ return $ CaseAlternative [ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)] (Right caseResult)
toSpineFun :: Expr -> Type -> Expr
toSpineFun i r | Just rec <- objectType r =
@@ -314,12 +345,13 @@ deriveGenericRep
:: forall m
. (MonadError MultipleErrors m, MonadSupply m)
=> ModuleName
+ -> SynonymMap
-> [Declaration]
-> ProperName 'TypeName
-> [Type]
-> Type
-> m ([Declaration], Type)
-deriveGenericRep mn ds tyConNm tyConArgs repTy = do
+deriveGenericRep mn syns ds tyConNm tyConArgs repTy = do
checkIsWildcard tyConNm repTy
go =<< findTypeDecl tyConNm ds
where
@@ -370,7 +402,8 @@ deriveGenericRep mn ds tyConNm tyConArgs repTy = do
:: (ProperName 'ConstructorName, [Type])
-> m (Type, CaseAlternative, CaseAlternative)
makeInst (ctorName, args) = do
- (ctorTy, matchProduct, ctorArgs, matchCtor, mkProduct) <- makeProduct args
+ args' <- mapM (replaceAllTypeSynonymsM syns) args
+ (ctorTy, matchProduct, ctorArgs, matchCtor, mkProduct) <- makeProduct args'
return ( TypeApp (TypeApp (TypeConstructor constructor)
(TypeLevelString (runProperName ctorName)))
ctorTy
@@ -494,10 +527,11 @@ checkIsWildcard tyConNm _ =
deriveEq ::
forall m. (MonadError MultipleErrors m, MonadSupply m)
=> ModuleName
+ -> SynonymMap
-> [Declaration]
-> ProperName 'TypeName
-> m [Declaration]
-deriveEq mn ds tyConNm = do
+deriveEq mn syns ds tyConNm = do
tyCon <- findTypeDecl tyConNm ds
eqFun <- mkEqFunction tyCon
return [ ValueDeclaration (Ident C.eq) Public [] (Right eqFun) ]
@@ -527,7 +561,8 @@ deriveEq mn ds tyConNm = do
mkCtorClause (ctorName, tys) = do
identsL <- replicateM (length tys) (freshIdent "l")
identsR <- replicateM (length tys) (freshIdent "r")
- let tests = zipWith3 toEqTest (map (Var . Qualified Nothing) identsL) (map (Var . Qualified Nothing) identsR) tys
+ tys' <- mapM (replaceAllTypeSynonymsM syns) tys
+ let tests = zipWith3 toEqTest (map (Var . Qualified Nothing) identsL) (map (Var . Qualified Nothing) identsR) tys'
return $ CaseAlternative [caseBinder identsL, caseBinder identsR] (Right (conjAll tests))
where
caseBinder idents = ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)
@@ -546,10 +581,11 @@ deriveEq mn ds tyConNm = do
deriveOrd ::
forall m. (MonadError MultipleErrors m, MonadSupply m)
=> ModuleName
+ -> SynonymMap
-> [Declaration]
-> ProperName 'TypeName
-> m [Declaration]
-deriveOrd mn ds tyConNm = do
+deriveOrd mn syns ds tyConNm = do
tyCon <- findTypeDecl tyConNm ds
compareFun <- mkCompareFunction tyCon
return [ ValueDeclaration (Ident C.compare) Public [] (Right compareFun) ]
@@ -590,7 +626,8 @@ deriveOrd mn ds tyConNm = do
mkCtorClauses ((ctorName, tys), isLast) = do
identsL <- replicateM (length tys) (freshIdent "l")
identsR <- replicateM (length tys) (freshIdent "r")
- let tests = zipWith3 toOrdering (map (Var . Qualified Nothing) identsL) (map (Var . Qualified Nothing) identsR) tys
+ tys' <- mapM (replaceAllTypeSynonymsM syns) tys
+ let tests = zipWith3 toOrdering (map (Var . Qualified Nothing) identsL) (map (Var . Qualified Nothing) identsR) tys'
extras | not isLast = [ CaseAlternative [ ConstructorBinder (Qualified (Just mn) ctorName) (replicate (length tys) NullBinder)
, NullBinder
]
@@ -632,12 +669,13 @@ deriveNewtype
:: forall m
. (MonadError MultipleErrors m, MonadSupply m)
=> ModuleName
+ -> SynonymMap
-> [Declaration]
-> ProperName 'TypeName
-> [Type]
-> Type
-> m ([Declaration], Type)
-deriveNewtype mn ds tyConNm tyConArgs unwrappedTy = do
+deriveNewtype mn syns ds tyConNm tyConArgs unwrappedTy = do
checkIsWildcard tyConNm unwrappedTy
go =<< findTypeDecl tyConNm ds
where
@@ -649,7 +687,8 @@ deriveNewtype mn ds tyConNm tyConArgs unwrappedTy = do
wrappedIdent <- freshIdent "n"
unwrappedIdent <- freshIdent "a"
let (ctorName, [ty]) = head dctors
- inst =
+ ty' <- replaceAllTypeSynonymsM syns ty
+ let inst =
[ ValueDeclaration (Ident "wrap") Public [] $ Right $
Constructor (Qualified (Just mn) ctorName)
, ValueDeclaration (Ident "unwrap") Public [] $ Right $
@@ -660,7 +699,7 @@ deriveNewtype mn ds tyConNm tyConArgs unwrappedTy = do
]
]
subst = zipWith ((,) . fst) args tyConArgs
- return (inst, replaceAllTypeVars subst ty)
+ return (inst, replaceAllTypeVars subst ty')
go (PositionedDeclaration _ _ d) = go d
go _ = internalError "deriveNewtype go: expected DataDeclaration"
@@ -702,3 +741,70 @@ decomposeRec :: Type -> [(Text, Type)]
decomposeRec = sortBy (comparing fst) . go
where go (RCons str typ typs) = (str, typ) : decomposeRec typs
go _ = []
+
+deriveFunctor
+ :: forall m
+ . (MonadError MultipleErrors m, MonadSupply m)
+ => ModuleName
+ -> SynonymMap
+ -> [Declaration]
+ -> ProperName 'TypeName
+ -> m [Declaration]
+deriveFunctor mn syns ds tyConNm = do
+ tyCon <- findTypeDecl tyConNm ds
+ mapFun <- mkMapFunction tyCon
+ return [ ValueDeclaration (Ident C.map) Public [] (Right mapFun) ]
+ where
+ mkMapFunction :: Declaration -> m Expr
+ mkMapFunction (DataDeclaration _ _ tys ctors) = case reverse tys of
+ [] -> throwError . errorMessage $ KindsDoNotUnify (FunKind kindType kindType) kindType
+ ((iTy, _) : _) -> do
+ f <- freshIdent "f"
+ m <- freshIdent "m"
+ lam f . lamCase m <$> mapM (mkCtorClause iTy f) ctors
+ mkMapFunction (PositionedDeclaration _ _ d) = mkMapFunction d
+ mkMapFunction _ = internalError "mkMapFunction: expected DataDeclaration"
+
+ mkCtorClause :: Text -> Ident -> (ProperName 'ConstructorName, [Type]) -> m CaseAlternative
+ mkCtorClause iTyName f (ctorName, ctorTys) = do
+ idents <- replicateM (length ctorTys) (freshIdent "v")
+ ctorTys' <- mapM (replaceAllTypeSynonymsM syns) ctorTys
+ args <- zipWithM transformArg idents ctorTys'
+ let ctor = Constructor (Qualified (Just mn) ctorName)
+ rebuilt = foldl App ctor args
+ caseBinder = ConstructorBinder (Qualified (Just mn) ctorName) (VarBinder <$> idents)
+ return $ CaseAlternative [caseBinder] (Right rebuilt)
+ where
+ fVar = mkVar f
+ mapVar = mkVarMn (Just dataFunctor) (Ident C.map)
+
+ -- TODO: deal with type synonyms, ala https://github.com/purescript/purescript/pull/2516
+ transformArg :: Ident -> Type -> m Expr
+ transformArg ident = fmap (foldr App (mkVar ident)) . goType where
+
+ goType :: Type -> m (Maybe Expr)
+ -- argument matches the index type
+ goType (TypeVar t) | t == iTyName = return (Just fVar)
+
+ -- records
+ goType recTy | Just row <- objectType recTy =
+ traverse buildUpdate (decomposeRec row) >>= (traverse buildRecord . justUpdates)
+ where
+ justUpdates :: [Maybe (Text, Expr)] -> Maybe [(Text, Expr)]
+ justUpdates = foldMap (fmap return)
+
+ buildUpdate :: (Text, Type) -> m (Maybe (Text, Expr))
+ buildUpdate (lbl, ty) = do upd <- goType ty
+ return ((lbl,) <$> upd)
+
+ buildRecord :: [(Text, Expr)] -> m Expr
+ buildRecord updates = do arg <- freshIdent "o"
+ let argVar = mkVar arg
+ mkAssignment (l, x) = (l, App x (Accessor l argVar))
+ return (lam arg (ObjectUpdate argVar (mkAssignment <$> updates)))
+
+ -- under a `* -> *`, just assume functor for now
+ goType (TypeApp _ t) = fmap (App mapVar) <$> goType t
+
+ -- otherwise do nothing - will fail type checking if type does actually contain index
+ goType _ = return Nothing
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
index 9b6e1bb..c94e828 100644
--- a/src/Language/PureScript/TypeChecker.hs
+++ b/src/Language/PureScript/TypeChecker.hs
@@ -18,7 +18,7 @@ import Control.Monad.Supply.Class (MonadSupply)
import Control.Monad.Writer.Class (MonadWriter(..))
import Control.Lens ((^..), _1, _2)
-import Data.Foldable (for_, traverse_)
+import Data.Foldable (for_, traverse_, toList)
import Data.List (nub, nubBy, (\\), sort, group)
import Data.Maybe
import qualified Data.Map as M
@@ -274,11 +274,15 @@ typeCheckAll moduleName _ = traverse go
env <- getEnv
putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (kind, ExternData) (types env) }
return d
+ go (d@(ExternKindDeclaration name)) = do
+ env <- getEnv
+ putEnv $ env { kinds = S.insert (Qualified (Just moduleName) name) (kinds env) }
+ return d
go (d@(ExternDeclaration name ty)) = do
warnAndRethrow (addHint (ErrorInForeignImport name)) $ do
env <- getEnv
kind <- kindOf ty
- guardWith (errorMessage (ExpectedType ty kind)) $ kind == Star
+ guardWith (errorMessage (ExpectedType ty kind)) $ kind == kindType
case M.lookup (Qualified (Just moduleName) name) (names env) of
Just _ -> throwError . errorMessage $ RedefinedIdent name
Nothing -> putEnv (env { names = M.insert (Qualified (Just moduleName) name) (ty, External, Defined) (names env) })
@@ -294,7 +298,7 @@ typeCheckAll moduleName _ = traverse go
Nothing -> internalError "typeCheckAll: Encountered unknown type class in instance declaration"
Just typeClass -> do
sequence_ (zipWith (checkTypeClassInstance typeClass) [0..] tys)
- checkOrphanInstance dictName className tys
+ checkOrphanInstance dictName className typeClass tys
_ <- traverseTypeInstanceBody checkInstanceMembers body
let dict = TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) [] className tys (Just deps)
addTypeClassDictionaries (Just moduleName) . M.singleton className $ M.singleton (tcdValue dict) dict
@@ -320,19 +324,35 @@ typeCheckAll moduleName _ = traverse go
| otherwise = firstDuplicate xs
firstDuplicate _ = Nothing
- checkOrphanInstance :: Ident -> Qualified (ProperName 'ClassName) -> [Type] -> m ()
- checkOrphanInstance dictName className@(Qualified (Just mn') _) tys'
- | moduleName == mn' || any checkType tys' = return ()
+ checkOrphanInstance :: Ident -> Qualified (ProperName 'ClassName) -> TypeClassData -> [Type] -> m ()
+ checkOrphanInstance dictName className@(Qualified (Just mn') _) typeClass tys'
+ | moduleName == mn' || moduleName `S.member` nonOrphanModules = return ()
| otherwise = throwError . errorMessage $ OrphanInstance dictName className tys'
where
- checkType :: Type -> Bool
- checkType (TypeVar _) = False
- checkType (TypeLevelString _) = False
- checkType (TypeConstructor (Qualified (Just mn'') _)) = moduleName == mn''
- checkType (TypeConstructor (Qualified Nothing _)) = internalError "Unqualified type name in checkOrphanInstance"
- checkType (TypeApp t1 _) = checkType t1
- checkType _ = internalError "Invalid type in instance in checkOrphanInstance"
- checkOrphanInstance _ _ _ = internalError "Unqualified class name in checkOrphanInstance"
+ typeModule :: Type -> Maybe ModuleName
+ typeModule (TypeVar _) = Nothing
+ typeModule (TypeLevelString _) = Nothing
+ typeModule (TypeConstructor (Qualified (Just mn'') _)) = Just mn''
+ typeModule (TypeConstructor (Qualified Nothing _)) = internalError "Unqualified type name in checkOrphanInstance"
+ typeModule (TypeApp t1 _) = typeModule t1
+ typeModule _ = internalError "Invalid type in instance in checkOrphanInstance"
+
+ modulesByTypeIndex :: M.Map Int (Maybe ModuleName)
+ modulesByTypeIndex = M.fromList (zip [0 ..] (typeModule <$> tys'))
+
+ lookupModule :: Int -> S.Set ModuleName
+ lookupModule idx = case M.lookup idx modulesByTypeIndex of
+ Just ms -> S.fromList (toList ms)
+ Nothing -> internalError "Unknown type index in checkOrphanInstance"
+
+ -- If the instance is declared in a module that wouldn't be found based on a covering set
+ -- then it is considered an orphan - because we'd have a situation in which we expect an
+ -- instance but can't find it. So a valid module must be applicable across *all* covering
+ -- sets - therefore we take the intersection of covering set modules.
+ nonOrphanModules :: S.Set ModuleName
+ nonOrphanModules = foldl1 S.intersection (foldMap lookupModule `S.map` typeClassCoveringSets typeClass)
+
+ checkOrphanInstance _ _ _ _ = internalError "Unqualified class name in checkOrphanInstance"
-- |
-- This function adds the argument kinds for a type constructor so that they may appear in the externs file,
diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs
index a857cdf..ae5374f 100644
--- a/src/Language/PureScript/TypeChecker/Entailment.hs
+++ b/src/Language/PureScript/TypeChecker/Entailment.hs
@@ -45,6 +45,10 @@ data Evidence
-- ^ An existing named instance
| IsSymbolInstance Text
-- ^ Computed instance of the IsSymbol type class for a given Symbol literal
+ | CompareSymbolInstance
+ -- ^ Computed instance of CompareSymbol
+ | AppendSymbolInstance
+ -- ^ Computed instance of AppendSymbol
deriving (Eq)
-- | Extract the identifier of a named instance
@@ -138,7 +142,18 @@ entails SolverOptions{..} constraint context hints =
solve constraint
where
forClassName :: InstanceContext -> Qualified (ProperName 'ClassName) -> [Type] -> [TypeClassDict]
- forClassName _ C.IsSymbol [TypeLevelString sym] = [TypeClassDictionaryInScope (IsSymbolInstance sym) [] C.IsSymbol [TypeLevelString sym] Nothing]
+ forClassName _ C.IsSymbol [TypeLevelString sym] =
+ [TypeClassDictionaryInScope (IsSymbolInstance sym) [] C.IsSymbol [TypeLevelString sym] Nothing]
+ forClassName _ C.CompareSymbol [arg0@(TypeLevelString lhs), arg1@(TypeLevelString rhs), _] =
+ let ordering = case compare lhs rhs of
+ LT -> C.orderingLT
+ EQ -> C.orderingEQ
+ GT -> C.orderingGT
+ args = [arg0, arg1, TypeConstructor ordering]
+ in [TypeClassDictionaryInScope CompareSymbolInstance [] C.CompareSymbol args Nothing]
+ forClassName _ C.AppendSymbol [arg0@(TypeLevelString lhs), arg1@(TypeLevelString rhs), _] =
+ let args = [arg0, arg1, TypeLevelString (lhs <> rhs)]
+ in [TypeClassDictionaryInScope AppendSymbolInstance [] C.AppendSymbol args Nothing]
forClassName ctx cn@(Qualified (Just mn) _) tys = concatMap (findDicts ctx cn) (nub (Nothing : Just mn : map Just (mapMaybe ctorModules tys)))
forClassName _ _ _ = internalError "forClassName: expected qualified class name"
@@ -146,6 +161,7 @@ entails SolverOptions{..} constraint context hints =
ctorModules (TypeConstructor (Qualified (Just mn) _)) = Just mn
ctorModules (TypeConstructor (Qualified Nothing _)) = internalError "ctorModules: unqualified type name"
ctorModules (TypeApp ty _) = ctorModules ty
+ ctorModules (KindedType ty _) = ctorModules ty
ctorModules _ = Nothing
findDicts :: InstanceContext -> Qualified (ProperName 'ClassName) -> Maybe ModuleName -> [TypeClassDict]
@@ -266,6 +282,7 @@ entails SolverOptions{..} constraint context hints =
canBeGeneralized :: Type -> Bool
canBeGeneralized TUnknown{} = True
+ canBeGeneralized (KindedType t _) = canBeGeneralized t
canBeGeneralized _ = False
-- |
@@ -291,9 +308,13 @@ entails SolverOptions{..} constraint context hints =
-- Make a dictionary from subgoal dictionaries by applying the correct function
mkDictionary :: Evidence -> Maybe [Expr] -> Expr
mkDictionary (NamedInstance n) args = foldl App (Var n) (fold args)
- mkDictionary (IsSymbolInstance sym) _ = TypeClassDictionaryConstructorApp C.IsSymbol (Literal (ObjectLiteral fields)) where
- fields = [ ("reflectSymbol", Abs (Left (Ident C.__unused)) (Literal (StringLiteral sym)))
- ]
+ mkDictionary (IsSymbolInstance sym) _ =
+ let fields = [ ("reflectSymbol", Abs (Left (Ident C.__unused)) (Literal (StringLiteral sym))) ] in
+ TypeClassDictionaryConstructorApp C.IsSymbol (Literal (ObjectLiteral fields))
+ mkDictionary CompareSymbolInstance _ =
+ TypeClassDictionaryConstructorApp C.CompareSymbol (Literal (ObjectLiteral []))
+ mkDictionary AppendSymbolInstance _ =
+ TypeClassDictionaryConstructorApp C.AppendSymbol (Literal (ObjectLiteral []))
-- Turn a DictionaryValue into a Expr
subclassDictionaryValue :: Expr -> Qualified (ProperName a) -> Integer -> Expr
@@ -346,6 +367,8 @@ matches deps TypeClassDictionaryInScope{..} tys = do
-- and return a substitution from type variables to types which makes the type heads unify.
--
typeHeadsAreEqual :: Type -> Type -> (Bool, Matching [Type])
+ typeHeadsAreEqual (KindedType t1 _) t2 = typeHeadsAreEqual t1 t2
+ typeHeadsAreEqual t1 (KindedType t2 _) = typeHeadsAreEqual t1 t2
typeHeadsAreEqual (TUnknown u1) (TUnknown u2) | u1 == u2 = (True, M.empty)
typeHeadsAreEqual (Skolem _ s1 _ _) (Skolem _ s2 _ _) | s1 == s2 = (True, M.empty)
typeHeadsAreEqual t (TypeVar v) = (True, M.singleton v [t])
@@ -365,6 +388,8 @@ matches deps TypeClassDictionaryInScope{..} tys = do
sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ]
go :: [(Text, Type)] -> Type -> [(Text, Type)] -> Type -> (Bool, Matching [Type])
+ go l (KindedType t1 _) r t2 = go l t1 r t2
+ go l t1 r (KindedType t2 _) = go l t1 r t2
go [] REmpty [] REmpty = (True, M.empty)
go [] (TUnknown u1) [] (TUnknown u2) | u1 == u2 = (True, M.empty)
go [] (TypeVar v1) [] (TypeVar v2) | v1 == v2 = (True, M.empty)
@@ -386,6 +411,8 @@ matches deps TypeClassDictionaryInScope{..} tys = do
-- which was _not_ solved, i.e. one which was inferred by a functional
-- dependency.
typesAreEqual :: Type -> Type -> Bool
+ typesAreEqual (KindedType t1 _) t2 = typesAreEqual t1 t2
+ typesAreEqual t1 (KindedType t2 _) = typesAreEqual t1 t2
typesAreEqual (TUnknown u1) (TUnknown u2) | u1 == u2 = True
typesAreEqual (Skolem _ s1 _ _) (Skolem _ s2 _ _) = s1 == s2
typesAreEqual (TypeVar v1) (TypeVar v2) = v1 == v2
@@ -403,6 +430,8 @@ matches deps TypeClassDictionaryInScope{..} tys = do
in all (uncurry typesAreEqual) int && go sd1 r1' sd2 r2'
where
go :: [(Text, Type)] -> Type -> [(Text, Type)] -> Type -> Bool
+ go l (KindedType t1 _) r t2 = go l t1 r t2
+ go l t1 r (KindedType t2 _) = go l t1 r t2
go [] (TUnknown u1) [] (TUnknown u2) | u1 == u2 = True
go [] (Skolem _ s1 _ _) [] (Skolem _ s2 _ _) = s1 == s2
go [] REmpty [] REmpty = True
diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs
index fedd623..05e7a1e 100644
--- a/src/Language/PureScript/TypeChecker/Kinds.hs
+++ b/src/Language/PureScript/TypeChecker/Kinds.hs
@@ -85,9 +85,7 @@ unifyKinds k1 k2 = do
go (KUnknown u1) (KUnknown u2) | u1 == u2 = return ()
go (KUnknown u) k = solveKind u k
go k (KUnknown u) = solveKind u k
- go Star Star = return ()
- go Bang Bang = return ()
- go Symbol Symbol = return ()
+ go (NamedKind k1') (NamedKind k2') | k1' == k2' = return ()
go (Row k1') (Row k2') = go k1' k2'
go (FunKind k1' k2') (FunKind k3 k4) = do
go k1' k3
@@ -182,15 +180,15 @@ solveTypes
solveTypes isData ts kargs tyCon = do
ks <- traverse (fmap fst . infer) ts
when isData $ do
- unifyKinds tyCon (foldr FunKind Star kargs)
- forM_ ks $ \k -> unifyKinds k Star
+ unifyKinds tyCon (foldr FunKind kindType kargs)
+ forM_ ks $ \k -> unifyKinds k kindType
unless isData $
unifyKinds tyCon (foldr FunKind (head ks) kargs)
return tyCon
--- | Default all unknown kinds to the Star kind of types
+-- | Default all unknown kinds to the kindType kind of types
starIfUnknown :: Kind -> Kind
-starIfUnknown (KUnknown _) = Star
+starIfUnknown (KUnknown _) = kindType
starIfUnknown (Row k) = Row (starIfUnknown k)
starIfUnknown (FunKind k1 k2) = FunKind (starIfUnknown k1) (starIfUnknown k2)
starIfUnknown k = k
@@ -211,8 +209,8 @@ infer' (ForAll ident ty _) = do
k1 <- freshKind
Just moduleName <- checkCurrentModule <$> get
(k2, args) <- bindLocalTypeVariables moduleName [(ProperName ident, k1)] $ infer ty
- unifyKinds k2 Star
- return (Star, (ident, k1) : args)
+ unifyKinds k2 kindType
+ return (kindType, (ident, k1) : args)
infer' (KindedType ty k) = do
(k', args) <- infer ty
unifyKinds k k'
@@ -224,14 +222,14 @@ infer' other = (, []) <$> go other
k1 <- freshKind
Just moduleName <- checkCurrentModule <$> get
k2 <- bindLocalTypeVariables moduleName [(ProperName ident, k1)] $ go ty
- unifyKinds k2 Star
- return Star
+ unifyKinds k2 kindType
+ return kindType
go (KindedType ty k) = do
k' <- go ty
unifyKinds k k'
return k'
go TypeWildcard{} = freshKind
- go (TypeLevelString _) = return Symbol
+ go (TypeLevelString _) = return kindSymbol
go (TypeVar v) = do
Just moduleName <- checkCurrentModule <$> get
lookupTypeVariable moduleName (Qualified Nothing (ProperName v))
@@ -260,8 +258,8 @@ infer' other = (, []) <$> go other
go (ConstrainedType deps ty) = do
forM_ deps $ \(Constraint className tys _) -> do
k <- go $ foldl TypeApp (TypeConstructor (fmap coerceProperName className)) tys
- unifyKinds k Star
+ unifyKinds k kindType
k <- go ty
- unifyKinds k Star
- return Star
+ unifyKinds k kindType
+ return kindType
go ty = internalError $ "Invalid argument to infer: " ++ show ty
diff --git a/src/Language/PureScript/TypeChecker/Synonyms.hs b/src/Language/PureScript/TypeChecker/Synonyms.hs
index 829ec57..08016b2 100644
--- a/src/Language/PureScript/TypeChecker/Synonyms.hs
+++ b/src/Language/PureScript/TypeChecker/Synonyms.hs
@@ -4,44 +4,59 @@
-- Functions for replacing fully applied type synonyms
--
module Language.PureScript.TypeChecker.Synonyms
- ( replaceAllTypeSynonyms
+ ( SynonymMap
+ , replaceAllTypeSynonyms
+ , replaceAllTypeSynonymsM
) where
-import Prelude.Compat
+import Prelude.Compat
-import Control.Monad.Error.Class (MonadError(..))
-import Control.Monad.State
-
-import Data.Maybe (fromMaybe)
+import Control.Monad.Error.Class (MonadError(..))
+import Control.Monad.State
+import Data.Maybe (fromMaybe)
import qualified Data.Map as M
-
-import Language.PureScript.Environment
-import Language.PureScript.Errors
-import Language.PureScript.TypeChecker.Monad
-import Language.PureScript.Types
-
--- |
--- Replace fully applied type synonyms.
---
-replaceAllTypeSynonyms' :: Environment -> Type -> Either MultipleErrors Type
-replaceAllTypeSynonyms' env = everywhereOnTypesTopDownM try
+import Data.Text (Text)
+import Language.PureScript.Environment
+import Language.PureScript.Errors
+import Language.PureScript.Kinds
+import Language.PureScript.Names
+import Language.PureScript.TypeChecker.Monad
+import Language.PureScript.Types
+
+-- | Type synonym information (arguments with kinds, aliased type), indexed by name
+type SynonymMap = M.Map (Qualified (ProperName 'TypeName)) ([(Text, Maybe Kind)], Type)
+
+replaceAllTypeSynonyms'
+ :: SynonymMap
+ -> Type
+ -> Either MultipleErrors Type
+replaceAllTypeSynonyms' syns = everywhereOnTypesTopDownM try
where
try :: Type -> Either MultipleErrors Type
try t = fromMaybe t <$> go 0 [] t
go :: Int -> [Type] -> Type -> Either MultipleErrors (Maybe Type)
go c args (TypeConstructor ctor)
- | Just (synArgs, body) <- M.lookup ctor (typeSynonyms env)
+ | Just (synArgs, body) <- M.lookup ctor syns
, c == length synArgs
= let repl = replaceAllTypeVars (zip (map fst synArgs) args) body
in Just <$> try repl
- | Just (synArgs, _) <- M.lookup ctor (typeSynonyms env)
+ | Just (synArgs, _) <- M.lookup ctor syns
, length synArgs > c
= throwError . errorMessage $ PartiallyAppliedSynonym ctor
go c args (TypeApp f arg) = go (c + 1) (arg : args) f
go _ _ _ = return Nothing
+-- | Replace fully applied type synonyms
replaceAllTypeSynonyms :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m) => Type -> m Type
replaceAllTypeSynonyms d = do
env <- getEnv
- either throwError return $ replaceAllTypeSynonyms' env d
+ either throwError return $ replaceAllTypeSynonyms' (typeSynonyms env) d
+
+-- | Replace fully applied type synonyms by explicitly providing a 'SynonymMap'.
+replaceAllTypeSynonymsM
+ :: MonadError MultipleErrors m
+ => SynonymMap
+ -> Type
+ -> m Type
+replaceAllTypeSynonymsM syns = either throwError pure . replaceAllTypeSynonyms' syns
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index e417a4a..665f569 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -240,7 +240,7 @@ checkTypeKind ::
Type ->
Kind ->
m ()
-checkTypeKind ty kind = guardWith (errorMessage (ExpectedType ty kind)) $ kind == Star
+checkTypeKind ty kind = guardWith (errorMessage (ExpectedType ty kind)) $ kind == kindType
-- | Remove any ForAlls and ConstrainedType constructors in a type by introducing new unknowns
-- or TypeClassDictionary values.
diff --git a/tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs b/tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs
index 61021cc..01f474a 100644
--- a/tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs
+++ b/tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs
@@ -28,7 +28,7 @@ outputFileShouldBe :: [Text] -> IO ()
outputFileShouldBe expectation = do
outFp <- (</> "src" </> "ImportsSpecOut.tmp") <$> Integration.projectDirectory
outRes <- readUTF8FileT outFp
- shouldBe (T.lines outRes) expectation
+ shouldBe (T.strip <$> T.lines outRes) expectation
spec :: Spec
spec = beforeAll_ setup . describe "Adding imports" $ do
diff --git a/tests/Language/PureScript/Ide/ImportsSpec.hs b/tests/Language/PureScript/Ide/ImportsSpec.hs
index bba7441..e830ed0 100644
--- a/tests/Language/PureScript/Ide/ImportsSpec.hs
+++ b/tests/Language/PureScript/Ide/ImportsSpec.hs
@@ -74,7 +74,7 @@ spec = do
addDtorImport i t mn is =
prettyPrintImportSection (addExplicitImport' (IdeDeclDataConstructor (IdeDataConstructor (P.ProperName i) t wildcard)) mn is)
addTypeImport i mn is =
- prettyPrintImportSection (addExplicitImport' (IdeDeclType (IdeType (P.ProperName i) P.Star)) mn is)
+ prettyPrintImportSection (addExplicitImport' (IdeDeclType (IdeType (P.ProperName i) P.kindType)) mn is)
it "adds an implicit unqualified import" $
shouldBe
(addImplicitImport' simpleFileImports (P.moduleNameFromString "Data.Map"))
@@ -143,7 +143,7 @@ spec = do
moduleName = (P.moduleNameFromString "Control.Monad")
addImport imports import' = addExplicitImport' import' moduleName imports
valueImport ident = (IdeDeclValue (IdeValue (P.Ident ident) wildcard))
- typeImport name = (IdeDeclType (IdeType (P.ProperName name) P.Star))
+ typeImport name = (IdeDeclType (IdeType (P.ProperName name) P.kindType))
classImport name = (IdeDeclTypeClass (P.ProperName name))
dtorImport name typeName = (IdeDeclDataConstructor (IdeDataConstructor (P.ProperName name) (P.ProperName typeName) wildcard))
-- expect any list of provided identifiers, when imported, to come out as specified
diff --git a/tests/Language/PureScript/Ide/ReexportsSpec.hs b/tests/Language/PureScript/Ide/ReexportsSpec.hs
index d5d394c..adbdc74 100644
--- a/tests/Language/PureScript/Ide/ReexportsSpec.hs
+++ b/tests/Language/PureScript/Ide/ReexportsSpec.hs
@@ -18,7 +18,7 @@ d = IdeDeclarationAnn emptyAnn
valueA, typeA, classA, dtorA1, dtorA2 :: IdeDeclarationAnn
valueA = d (IdeDeclValue (IdeValue (P.Ident "valueA") P.REmpty))
-typeA = d (IdeDeclType (IdeType(P.ProperName "TypeA") P.Star))
+typeA = d (IdeDeclType (IdeType(P.ProperName "TypeA") P.kindType))
classA = d (IdeDeclTypeClass (P.ProperName "ClassA"))
dtorA1 = d (IdeDeclDataConstructor (IdeDataConstructor (P.ProperName "DtorA1") (P.ProperName "TypeA") P.REmpty))
dtorA2 = d (IdeDeclDataConstructor (IdeDataConstructor (P.ProperName "DtorA2") (P.ProperName "TypeA") P.REmpty))
diff --git a/tests/Language/PureScript/Ide/SourceFileSpec.hs b/tests/Language/PureScript/Ide/SourceFileSpec.hs
index ac53dde..eae3de7 100644
--- a/tests/Language/PureScript/Ide/SourceFileSpec.hs
+++ b/tests/Language/PureScript/Ide/SourceFileSpec.hs
@@ -6,6 +6,7 @@ import Protolude
import qualified Language.PureScript as P
import Language.PureScript.Ide.SourceFile
+import Language.PureScript.Ide.Types
import Test.Hspec
span0, span1, span2 :: P.SourceSpan
@@ -13,7 +14,7 @@ span0 = P.SourceSpan "ModuleLevel" (P.SourcePos 0 0) (P.SourcePos 1 1)
span1 = P.SourceSpan "" (P.SourcePos 1 1) (P.SourcePos 2 2)
span2 = P.SourceSpan "" (P.SourcePos 2 2) (P.SourcePos 3 3)
-typeAnnotation1, value1, synonym1, class1, class2, data1, data2, foreign1, foreign2, member1 :: P.Declaration
+typeAnnotation1, value1, synonym1, class1, class2, data1, data2, foreign1, foreign2, foreign3, member1 :: P.Declaration
typeAnnotation1 = P.TypeDeclaration (P.Ident "value1") P.REmpty
value1 = P.ValueDeclaration (P.Ident "value1") P.Public [] (Left [])
synonym1 = P.TypeSynonymDeclaration (P.ProperName "Synonym1") [] P.REmpty
@@ -23,28 +24,31 @@ class2 = P.TypeClassDeclaration (P.ProperName "Class2") [] [] []
data1 = P.DataDeclaration P.Newtype (P.ProperName "Data1") [] []
data2 = P.DataDeclaration P.Data (P.ProperName "Data2") [] [(P.ProperName "Cons1", [])]
foreign1 = P.ExternDeclaration (P.Ident "foreign1") P.REmpty
-foreign2 = P.ExternDataDeclaration (P.ProperName "Foreign2") P.Star
+foreign2 = P.ExternDataDeclaration (P.ProperName "Foreign2") P.kindType
+foreign3 = P.ExternKindDeclaration (P.ProperName "Foreign3")
member1 = P.TypeDeclaration (P.Ident "member1") P.REmpty
spec :: Spec
spec = do
describe "Extracting Spans" $ do
it "extracts a span for a value declaration" $
- extractSpans span0 (P.PositionedDeclaration span1 [] value1) `shouldBe` [(Left "value1", span1)]
+ extractSpans span0 (P.PositionedDeclaration span1 [] value1) `shouldBe` [(IdeNSValue "value1", span1)]
it "extracts a span for a type synonym declaration" $
- extractSpans span0 (P.PositionedDeclaration span1 [] synonym1) `shouldBe` [(Right "Synonym1", span1)]
+ extractSpans span0 (P.PositionedDeclaration span1 [] synonym1) `shouldBe` [(IdeNSType "Synonym1", span1)]
it "extracts a span for a typeclass declaration" $
- extractSpans span0 (P.PositionedDeclaration span1 [] class1) `shouldBe` [(Right "Class1", span1)]
+ extractSpans span0 (P.PositionedDeclaration span1 [] class1) `shouldBe` [(IdeNSType "Class1", span1)]
it "extracts spans for a typeclass declaration and its members" $
- extractSpans span0 (P.PositionedDeclaration span1 [] class2) `shouldBe` [(Right "Class2", span1), (Left "member1", span2)]
+ extractSpans span0 (P.PositionedDeclaration span1 [] class2) `shouldBe` [(IdeNSType "Class2", span1), (IdeNSValue "member1", span2)]
it "extracts a span for a data declaration" $
- extractSpans span0 (P.PositionedDeclaration span1 [] data1) `shouldBe` [(Right "Data1", span1)]
+ extractSpans span0 (P.PositionedDeclaration span1 [] data1) `shouldBe` [(IdeNSType "Data1", span1)]
it "extracts spans for a data declaration and its constructors" $
- extractSpans span0 (P.PositionedDeclaration span1 [] data2) `shouldBe` [(Right "Data2", span1), (Left "Cons1", span1)]
+ extractSpans span0 (P.PositionedDeclaration span1 [] data2) `shouldBe` [(IdeNSType "Data2", span1), (IdeNSValue "Cons1", span1)]
it "extracts a span for a foreign declaration" $
- extractSpans span0 (P.PositionedDeclaration span1 [] foreign1) `shouldBe` [(Left "foreign1", span1)]
+ extractSpans span0 (P.PositionedDeclaration span1 [] foreign1) `shouldBe` [(IdeNSValue "foreign1", span1)]
it "extracts a span for a data foreign declaration" $
- extractSpans span0 (P.PositionedDeclaration span1 [] foreign2) `shouldBe` [(Right "Foreign2", span1)]
+ extractSpans span0 (P.PositionedDeclaration span1 [] foreign2) `shouldBe` [(IdeNSType "Foreign2", span1)]
+ it "extracts a span for a foreign kind declaration" $
+ extractSpans span0 (P.PositionedDeclaration span1 [] foreign3) `shouldBe` [(IdeNSKind "Foreign3", span1)]
describe "Type annotations" $ do
it "extracts a type annotation" $
extractTypeAnnotations [typeAnnotation1] `shouldBe` [(P.Ident "value1", P.REmpty)]
diff --git a/tests/Language/PureScript/Ide/StateSpec.hs b/tests/Language/PureScript/Ide/StateSpec.hs
index 2779662..5126fe2 100644
--- a/tests/Language/PureScript/Ide/StateSpec.hs
+++ b/tests/Language/PureScript/Ide/StateSpec.hs
@@ -24,7 +24,7 @@ typeOperator =
testModule :: Module
testModule = (mn "Test", [ d (IdeDeclValue (IdeValue (P.Ident "function") P.REmpty))
, d (IdeDeclDataConstructor (IdeDataConstructor (P.ProperName "Cons") (P.ProperName "List") (P.REmpty)))
- , d (IdeDeclType (IdeType (P.ProperName "List") P.Star))
+ , d (IdeDeclType (IdeType (P.ProperName "List") P.kindType))
, valueOperator Nothing
, ctorOperator Nothing
, typeOperator Nothing
@@ -48,4 +48,4 @@ spec = describe "resolving operators" $ do
it "resolves the type for a constructor operator" $
resolveOperatorsForModule testState (snd testModule) `shouldSatisfy` elem (ctorOperator (Just P.REmpty))
it "resolves the kind for a type operator" $
- resolveOperatorsForModule testState (snd testModule) `shouldSatisfy` elem (typeOperator (Just P.Star))
+ resolveOperatorsForModule testState (snd testModule) `shouldSatisfy` elem (typeOperator (Just P.kindType))
diff --git a/tests/Main.hs b/tests/Main.hs
index 61d1824..acfce36 100644
--- a/tests/Main.hs
+++ b/tests/Main.hs
@@ -13,6 +13,7 @@ import qualified TestDocs
import qualified TestPsci
import qualified TestPscIde
import qualified TestPscPublish
+import qualified TestPrimDocs
import qualified TestUtils
import System.IO (hSetEncoding, stdout, stderr, utf8)
@@ -28,6 +29,7 @@ main = do
TestCompiler.main
heading "Documentation test suite"
TestDocs.main
+ TestPrimDocs.main
heading "psc-publish test suite"
TestPscPublish.main
heading "psci test suite"
diff --git a/tests/TestCompiler.hs b/tests/TestCompiler.hs
index 4fc8552..86a6ef3 100644
--- a/tests/TestCompiler.hs
+++ b/tests/TestCompiler.hs
@@ -61,13 +61,13 @@ main = hspec spec
spec :: Spec
spec = do
- (supportExterns, passingTestCases, warningTestCases, failingTestCases) <- runIO $ do
+ (supportExterns, supportForeigns, passingTestCases, warningTestCases, failingTestCases) <- runIO $ do
cwd <- getCurrentDirectory
let passing = cwd </> "examples" </> "passing"
let warning = cwd </> "examples" </> "warning"
let failing = cwd </> "examples" </> "failing"
let supportDir = cwd </> "tests" </> "support" </> "bower_components"
- let supportFiles ext = Glob.globDir1 (Glob.compile ("purescript-*/**/*." ++ ext)) supportDir
+ let supportFiles ext = Glob.globDir1 (Glob.compile ("purescript-*/src/**/*." ++ ext)) supportDir
passingFiles <- getTestFiles passing <$> testGlob passing
warningFiles <- getTestFiles warning <$> testGlob warning
failingFiles <- getTestFiles failing <$> testGlob failing
@@ -77,10 +77,10 @@ spec = do
modules <- ExceptT . return $ P.parseModulesFromFiles id supportPursFiles
foreigns <- inferForeignModules modules
externs <- ExceptT . fmap fst . runTest $ P.make (makeActions foreigns) (map snd modules)
- return (zip (map snd modules) externs)
+ return (zip (map snd modules) externs, foreigns)
case supportExterns of
Left errs -> fail (P.prettyPrintMultipleErrors P.defaultPPEOptions errs)
- Right externs -> return (externs, passingFiles, warningFiles, failingFiles)
+ Right (externs, foreigns) -> return (externs, foreigns, passingFiles, warningFiles, failingFiles)
outputFile <- runIO $ do
tmp <- getTemporaryDirectory
@@ -90,21 +90,21 @@ spec = do
context "Passing examples" $
forM_ passingTestCases $ \testPurs ->
it ("'" <> takeFileName (getTestMain testPurs) <> "' should compile and run without error") $
- assertCompiles supportExterns testPurs outputFile
+ assertCompiles supportExterns supportForeigns testPurs outputFile
context "Warning examples" $
forM_ warningTestCases $ \testPurs -> do
let mainPath = getTestMain testPurs
expectedWarnings <- runIO $ getShouldWarnWith mainPath
it ("'" <> takeFileName mainPath <> "' should compile with warning(s) '" <> intercalate "', '" expectedWarnings <> "'") $
- assertCompilesWithWarnings supportExterns testPurs expectedWarnings
+ assertCompilesWithWarnings supportExterns supportForeigns testPurs expectedWarnings
context "Failing examples" $
forM_ failingTestCases $ \testPurs -> do
let mainPath = getTestMain testPurs
expectedFailures <- runIO $ getShouldFailWith mainPath
it ("'" <> takeFileName mainPath <> "' should fail with '" <> intercalate "', '" expectedFailures <> "'") $
- assertDoesNotCompile supportExterns testPurs expectedFailures
+ assertDoesNotCompile supportExterns supportForeigns testPurs expectedFailures
where
@@ -197,27 +197,29 @@ runTest = P.runMake P.defaultOptions
compile
:: [(P.Module, P.ExternsFile)]
+ -> M.Map P.ModuleName FilePath
-> [FilePath]
-> ([P.Module] -> IO ())
-> IO (Either P.MultipleErrors [P.ExternsFile], P.MultipleErrors)
-compile supportExterns inputFiles check = silence $ runTest $ do
+compile supportExterns supportForeigns inputFiles check = silence $ runTest $ do
fs <- liftIO $ readInput inputFiles
ms <- P.parseModulesFromFiles id fs
foreigns <- inferForeignModules ms
liftIO (check (map snd ms))
- let actions = makeActions foreigns
+ let actions = makeActions (foreigns `M.union` supportForeigns)
case ms of
[singleModule] -> pure <$> P.rebuildModule actions (map snd supportExterns) (snd singleModule)
_ -> P.make actions (map fst supportExterns ++ map snd ms)
assert
:: [(P.Module, P.ExternsFile)]
+ -> M.Map P.ModuleName FilePath
-> [FilePath]
-> ([P.Module] -> IO ())
-> (Either P.MultipleErrors P.MultipleErrors -> IO (Maybe String))
-> Expectation
-assert supportExterns inputFiles check f = do
- (e, w) <- compile supportExterns inputFiles check
+assert supportExterns supportForeigns inputFiles check f = do
+ (e, w) <- compile supportExterns supportForeigns inputFiles check
maybeErr <- f (const w <$> e)
maybe (return ()) expectationFailure maybeErr
@@ -235,11 +237,12 @@ checkShouldFailWith expected errs =
assertCompiles
:: [(P.Module, P.ExternsFile)]
+ -> M.Map P.ModuleName FilePath
-> [FilePath]
-> Handle
-> Expectation
-assertCompiles supportExterns inputFiles outputFile =
- assert supportExterns inputFiles checkMain $ \e ->
+assertCompiles supportExterns supportForeigns inputFiles outputFile =
+ assert supportExterns supportForeigns inputFiles checkMain $ \e ->
case e of
Left errs -> return . Just . P.prettyPrintMultipleErrors P.defaultPPEOptions $ errs
Right _ -> do
@@ -260,11 +263,12 @@ assertCompiles supportExterns inputFiles outputFile =
assertCompilesWithWarnings
:: [(P.Module, P.ExternsFile)]
+ -> M.Map P.ModuleName FilePath
-> [FilePath]
-> [String]
-> Expectation
-assertCompilesWithWarnings supportExterns inputFiles shouldWarnWith =
- assert supportExterns inputFiles checkMain $ \e ->
+assertCompilesWithWarnings supportExterns supportForeigns inputFiles shouldWarnWith =
+ assert supportExterns supportForeigns inputFiles checkMain $ \e ->
case e of
Left errs ->
return . Just . P.prettyPrintMultipleErrors P.defaultPPEOptions $ errs
@@ -279,11 +283,12 @@ assertCompilesWithWarnings supportExterns inputFiles shouldWarnWith =
assertDoesNotCompile
:: [(P.Module, P.ExternsFile)]
+ -> M.Map P.ModuleName FilePath
-> [FilePath]
-> [String]
-> Expectation
-assertDoesNotCompile supportExterns inputFiles shouldFailWith =
- assert supportExterns inputFiles noPreCheck $ \e ->
+assertDoesNotCompile supportExterns supportForeigns inputFiles shouldFailWith =
+ assert supportExterns supportForeigns inputFiles noPreCheck $ \e ->
case e of
Left errs ->
return $ if null shouldFailWith
diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs
index c689437..c995336 100644
--- a/tests/TestDocs.hs
+++ b/tests/TestDocs.hs
@@ -1,18 +1,21 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE OverloadedStrings #-}
module TestDocs where
import Prelude ()
import Prelude.Compat
-import Data.Version (Version(..))
+import Control.Arrow (first)
+import Data.Version (Version(..))
import Data.Monoid
import Data.Maybe (fromMaybe)
import Data.List ((\\))
import Data.Foldable
+import Data.Text (Text)
import qualified Data.Text as T
import System.Exit
@@ -22,6 +25,8 @@ import Language.PureScript.Docs.AsMarkdown (codeToString)
import qualified Language.PureScript.Publish as Publish
import qualified Language.PureScript.Publish.ErrorsWarnings as Publish
+import Web.Bower.PackageMeta (parsePackageName)
+
import TestUtils
publishOpts :: Publish.PublishOptions
@@ -37,7 +42,7 @@ main = pushd "examples/docs" $ do
case res of
Left e -> Publish.printErrorToStdout e >> exitFailure
Right Docs.Package{..} ->
- forM_ testCases $ \(P.moduleNameFromString . T.pack -> mn, pragmas) ->
+ forM_ testCases $ \(P.moduleNameFromString -> mn, pragmas) ->
let mdl = takeJust ("module not found in docs: " ++ T.unpack (P.runModuleName mn))
(find ((==) mn . Docs.modName) pkgModules)
in forM_ pragmas (`runAssertionIO` mdl)
@@ -49,25 +54,31 @@ takeJust msg = fromMaybe (error msg)
data Assertion
-- | Assert that a particular declaration is documented with the given
-- children
- = ShouldBeDocumented P.ModuleName String [String]
+ = ShouldBeDocumented P.ModuleName Text [Text]
-- | Assert that a particular declaration is not documented
- | ShouldNotBeDocumented P.ModuleName String
+ | ShouldNotBeDocumented P.ModuleName Text
-- | Assert that a particular declaration exists, but without a particular
-- child.
- | ChildShouldNotBeDocumented P.ModuleName String String
+ | ChildShouldNotBeDocumented P.ModuleName Text Text
-- | Assert that a particular declaration has a particular type class
-- constraint.
- | ShouldBeConstrained P.ModuleName String String
+ | ShouldBeConstrained P.ModuleName Text Text
-- | Assert that a particular typeclass declaration has a functional
-- dependency list.
- | ShouldHaveFunDeps P.ModuleName String [([String],[String])]
+ | ShouldHaveFunDeps P.ModuleName Text [([Text],[Text])]
-- | Assert that a particular value declaration exists, and its type
-- satisfies the given predicate.
- | ValueShouldHaveTypeSignature P.ModuleName String (ShowFn (P.Type -> Bool))
+ | ValueShouldHaveTypeSignature P.ModuleName Text (ShowFn (P.Type -> Bool))
-- | Assert that a particular type alias exists, and its corresponding
-- type, when rendered, matches a given string exactly
-- fields: module, type synonym name, expected type
- | TypeSynonymShouldRenderAs P.ModuleName String String
+ | TypeSynonymShouldRenderAs P.ModuleName Text Text
+ -- | Assert that a documented declaration includes a documentation comment
+ -- containing a particular string
+ | ShouldHaveDocComment P.ModuleName Text Text
+ -- | Assert that there should be some declarations re-exported from a
+ -- particular module in a particular package.
+ | ShouldHaveReExport (Docs.InPackage P.ModuleName)
deriving (Show)
newtype ShowFn a = ShowFn a
@@ -77,28 +88,34 @@ instance Show (ShowFn a) where
data AssertionFailure
-- | A declaration was not documented, but should have been
- = NotDocumented P.ModuleName String
+ = NotDocumented P.ModuleName Text
-- | A child declaration was not documented, but should have been
- | ChildrenNotDocumented P.ModuleName String [String]
+ | ChildrenNotDocumented P.ModuleName Text [Text]
-- | A declaration was documented, but should not have been
- | Documented P.ModuleName String
+ | Documented P.ModuleName Text
-- | A child declaration was documented, but should not have been
- | ChildDocumented P.ModuleName String String
+ | ChildDocumented P.ModuleName Text Text
-- | A constraint was missing.
- | ConstraintMissing P.ModuleName String String
+ | ConstraintMissing P.ModuleName Text Text
-- | A functional dependency was missing.
- | FunDepMissing P.ModuleName String [([String], [String])]
+ | FunDepMissing P.ModuleName Text [([Text], [Text])]
-- | A declaration had the wrong "type" (ie, value, type, type class)
-- Fields: declaration title, expected "type", actual "type".
- | WrongDeclarationType P.ModuleName String String String
+ | WrongDeclarationType P.ModuleName Text Text Text
-- | A value declaration had the wrong type (in the sense of "type
-- checking"), eg, because the inferred type was used when the explicit type
-- should have been.
-- Fields: module name, declaration name, actual type.
- | ValueDeclarationWrongType P.ModuleName String P.Type
+ | ValueDeclarationWrongType P.ModuleName Text P.Type
-- | A Type synonym has been rendered in an unexpected format
-- Fields: module name, declaration name, expected rendering, actual rendering
- | TypeSynonymMismatch P.ModuleName String String String
+ | TypeSynonymMismatch P.ModuleName Text Text Text
+ -- | A doc comment was not found or did not match what was expected
+ -- Fields: module name, expected substring, actual comments
+ | DocCommentMissing P.ModuleName Text (Maybe Text)
+ -- | A module was missing re-exports from a particular module.
+ -- Fields: module name, expected re-export, actual re-exports.
+ | ReExportMissing P.ModuleName (Docs.InPackage P.ModuleName) [Docs.InPackage P.ModuleName]
deriving (Show)
data AssertionResult
@@ -135,75 +152,84 @@ runAssertion assertion Docs.Module{..} =
Fail (NotDocumented mn decl)
ShouldBeConstrained mn decl tyClass ->
- case find ((==) decl . Docs.declTitle) (declarationsFor mn) of
- Nothing ->
- Fail (NotDocumented mn decl)
- Just Docs.Declaration{..} ->
- case declInfo of
- Docs.ValueDeclaration ty ->
- if checkConstrained ty tyClass
- then Pass
- else Fail (ConstraintMissing mn decl tyClass)
- _ ->
- Fail (WrongDeclarationType mn decl "value"
- (Docs.declInfoToString declInfo))
+ findDecl mn decl $ \Docs.Declaration{..} ->
+ case declInfo of
+ Docs.ValueDeclaration ty ->
+ if checkConstrained ty tyClass
+ then Pass
+ else Fail (ConstraintMissing mn decl tyClass)
+ _ ->
+ Fail (WrongDeclarationType mn decl "value"
+ (Docs.declInfoToString declInfo))
ShouldHaveFunDeps mn decl fds ->
- case find ((==) decl . Docs.declTitle) (declarationsFor mn) of
- Nothing ->
- Fail (NotDocumented mn decl)
- Just Docs.Declaration{..} ->
- case declInfo of
- Docs.TypeClassDeclaration _ _ fundeps ->
- if fundeps == fds
- then Pass
- else Fail (FunDepMissing mn decl fds)
- _ ->
- Fail (WrongDeclarationType mn decl "value"
- (Docs.declInfoToString declInfo))
+ findDecl mn decl $ \Docs.Declaration{..} ->
+ case declInfo of
+ Docs.TypeClassDeclaration _ _ fundeps ->
+ if fundeps == fds
+ then Pass
+ else Fail (FunDepMissing mn decl fds)
+ _ ->
+ Fail (WrongDeclarationType mn decl "value"
+ (Docs.declInfoToString declInfo))
ValueShouldHaveTypeSignature mn decl (ShowFn tyPredicate) ->
- case find ((==) decl . Docs.declTitle) (declarationsFor mn) of
- Nothing ->
- Fail (NotDocumented mn decl)
- Just Docs.Declaration{..} ->
- case declInfo of
- Docs.ValueDeclaration ty ->
- if tyPredicate ty
- then Pass
- else Fail
- (ValueDeclarationWrongType mn decl ty)
- _ ->
- Fail (WrongDeclarationType mn decl "value"
- (Docs.declInfoToString declInfo))
+ findDecl mn decl $ \Docs.Declaration{..} ->
+ case declInfo of
+ Docs.ValueDeclaration ty ->
+ if tyPredicate ty
+ then Pass
+ else Fail
+ (ValueDeclarationWrongType mn decl ty)
+ _ ->
+ Fail (WrongDeclarationType mn decl "value"
+ (Docs.declInfoToString declInfo))
TypeSynonymShouldRenderAs mn decl expected ->
- case find ((==) decl . Docs.declTitle) (declarationsFor mn) of
- Nothing ->
- Fail (NotDocumented mn decl)
- Just Docs.Declaration{..} ->
- case declInfo of
- Docs.TypeSynonymDeclaration [] ty ->
- let actual = codeToString (Docs.renderType ty) in
- if actual == expected
- then Pass
- else Fail (TypeSynonymMismatch mn decl expected actual)
- _ ->
- Fail (WrongDeclarationType mn decl "synonym"
- (Docs.declInfoToString declInfo))
+ findDecl mn decl $ \Docs.Declaration{..} ->
+ case declInfo of
+ Docs.TypeSynonymDeclaration [] ty ->
+ let actual = codeToString (Docs.renderType ty) in
+ if actual == expected
+ then Pass
+ else Fail (TypeSynonymMismatch mn decl expected actual)
+ _ ->
+ Fail (WrongDeclarationType mn decl "synonym"
+ (Docs.declInfoToString declInfo))
+
+ ShouldHaveDocComment mn decl expected ->
+ findDecl mn decl $ \Docs.Declaration{..} ->
+ if maybe False (expected `T.isInfixOf`) declComments
+ then Pass
+ else Fail (DocCommentMissing mn decl declComments)
+
+ ShouldHaveReExport reExp ->
+ let
+ reExps = map fst modReExports
+ in
+ if reExp `elem` reExps
+ then Pass
+ else Fail (ReExportMissing modName reExp reExps)
where
declarationsFor mn =
if mn == modName
then modDeclarations
- else fromMaybe [] (lookup mn modReExports)
+ else fromMaybe [] (lookup mn (map (first Docs.ignorePackage) modReExports))
findChildren title =
fmap childrenTitles . find ((==) title . Docs.declTitle)
+ findDecl mn title f =
+ case find ((==) title . Docs.declTitle) (declarationsFor mn) of
+ Nothing ->
+ Fail (NotDocumented mn title)
+ Just decl ->
+ f decl
+
childrenTitles = map Docs.cdeclTitle . Docs.declChildren
-checkConstrained :: P.Type -> String -> Bool
+checkConstrained :: P.Type -> Text -> Bool
checkConstrained ty tyClass =
-- Note that we don't recurse on ConstrainedType if none of the constraints
-- match; this is by design, as constraints should be moved to the front
@@ -217,7 +243,7 @@ checkConstrained ty tyClass =
False
where
matches className =
- (==) className . T.unpack . P.runProperName . P.disqualify . P.constraintClass
+ (==) className . P.runProperName . P.disqualify . P.constraintClass
runAssertionIO :: Assertion -> Docs.Module -> IO ()
runAssertionIO assertion mdl = do
@@ -228,7 +254,7 @@ runAssertionIO assertion mdl = do
putStrLn ("Failed: " <> show reason)
exitFailure
-testCases :: [(String, [Assertion])]
+testCases :: [(Text, [Assertion])]
testCases =
[ ("Example",
[ -- From dependencies
@@ -238,7 +264,12 @@ testCases =
-- From local files
, ShouldBeDocumented (n "Example2") "one" []
, ShouldNotBeDocumented (n "Example2") "two"
+
+ -- Re-exports
+ , ShouldHaveReExport (Docs.FromDep (pkg "purescript-prelude") (n "Prelude"))
+ , ShouldHaveReExport (Docs.Local (n "Example2"))
])
+
, ("Example2",
[ ShouldBeDocumented (n "Example2") "one" []
, ShouldBeDocumented (n "Example2") "two" []
@@ -319,10 +350,15 @@ testCases =
, ValueShouldHaveTypeSignature (n "TypeOpAliases") "test4" (renderedType "forall a b c d. ((a ~> b) ~> c) ~> d")
, ValueShouldHaveTypeSignature (n "TypeOpAliases") "third" (renderedType "forall a b c. a × b × c -> c")
])
+
+ , ("DocComments",
+ [ ShouldHaveDocComment (n "DocComments") "example" " example == 0"
+ ])
]
where
n = P.moduleNameFromString . T.pack
+ pkg str = let Right p = parsePackageName str in p
hasTypeVar varName =
getAny . P.everythingOnTypes (<>) (Any . isVar varName)
diff --git a/tests/TestPrimDocs.hs b/tests/TestPrimDocs.hs
new file mode 100644
index 0000000..9309684
--- /dev/null
+++ b/tests/TestPrimDocs.hs
@@ -0,0 +1,30 @@
+module TestPrimDocs where
+
+import Control.Monad
+import Data.List ((\\))
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import qualified Language.PureScript as P
+import qualified Language.PureScript.Docs as D
+import qualified Language.PureScript.Docs.AsMarkdown as D
+
+main :: IO ()
+main = do
+ putStrLn "Test that there are no bottoms hiding in primDocsModule"
+ seq (D.runDocs (D.modulesAsMarkdown [D.primDocsModule])) (return ())
+
+ putStrLn "Test that Prim is fully documented"
+ let actualPrimNames =
+ -- note that prim type classes are listed in P.primTypes
+ (map (P.runProperName . P.disqualify . fst) $ Map.toList P.primTypes) ++
+ (map (P.runProperName . P.disqualify) $ Set.toList P.primKinds)
+ let documentedPrimNames = map D.declTitle (D.modDeclarations D.primDocsModule)
+
+ let undocumentedNames = actualPrimNames \\ documentedPrimNames
+ let extraNames = documentedPrimNames \\ actualPrimNames
+
+ when (not (null undocumentedNames)) $
+ error $ "Undocumented Prim names: " ++ show undocumentedNames
+
+ when (not (null extraNames)) $
+ error $ "Extra Prim names: " ++ show undocumentedNames
diff --git a/tests/TestPscPublish.hs b/tests/TestPscPublish.hs
index 05c082f..14bd037 100644
--- a/tests/TestPscPublish.hs
+++ b/tests/TestPscPublish.hs
@@ -1,20 +1,12 @@
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
-{-# OPTIONS_GHC -fno-warn-unused-imports #-}
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE OverloadedStrings #-}
module TestPscPublish where
-import Control.Monad
-import Control.Applicative
-import Control.Exception
-import System.Process
-import System.Directory
-import System.IO
-import System.Exit
-import qualified Data.ByteString.Lazy as BL
+import System.Exit (exitFailure)
import Data.ByteString.Lazy (ByteString)
import qualified Data.Aeson as A
-import Data.Aeson.BetterErrors
import Data.Version
import Language.PureScript.Docs
diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs
index cf67a38..67e3fbf 100644
--- a/tests/TestUtils.hs
+++ b/tests/TestUtils.hs
@@ -57,6 +57,8 @@ supportModules =
, "Control.Alternative"
, "Control.Applicative"
, "Control.Apply"
+ , "Control.Biapplicative"
+ , "Control.Biapply"
, "Control.Bind"
, "Control.Category"
, "Control.Comonad"
@@ -72,6 +74,15 @@ supportModules =
, "Control.MonadZero"
, "Control.Plus"
, "Control.Semigroupoid"
+ , "Data.Bifoldable"
+ , "Data.Bifunctor"
+ , "Data.Bifunctor.Clown"
+ , "Data.Bifunctor.Flip"
+ , "Data.Bifunctor.Join"
+ , "Data.Bifunctor.Joker"
+ , "Data.Bifunctor.Product"
+ , "Data.Bifunctor.Wrap"
+ , "Data.Bitraversable"
, "Data.Boolean"
, "Data.BooleanAlgebra"
, "Data.Bounded"
@@ -79,18 +90,24 @@ supportModules =
, "Data.Eq"
, "Data.EuclideanRing"
, "Data.Field"
+ , "Data.Foldable"
, "Data.Function"
, "Data.Function.Uncurried"
, "Data.Functor"
, "Data.Functor.Invariant"
, "Data.Generic.Rep"
- , "Data.Generic.Rep.Monoid"
, "Data.Generic.Rep.Eq"
+ , "Data.Generic.Rep.Monoid"
, "Data.Generic.Rep.Ord"
, "Data.Generic.Rep.Semigroup"
+ , "Data.Generic.Rep.Show"
, "Data.HeytingAlgebra"
+ , "Data.Maybe"
+ , "Data.Maybe.First"
+ , "Data.Maybe.Last"
, "Data.Monoid"
, "Data.Monoid.Additive"
+ , "Data.Monoid.Alternate"
, "Data.Monoid.Conj"
, "Data.Monoid.Disj"
, "Data.Monoid.Dual"
@@ -104,8 +121,9 @@ supportModules =
, "Data.Ring"
, "Data.Semigroup"
, "Data.Semiring"
- , "Data.Symbol"
, "Data.Show"
+ , "Data.Symbol"
+ , "Data.Traversable"
, "Data.Unit"
, "Data.Void"
, "Partial"
@@ -113,6 +131,11 @@ supportModules =
, "Prelude"
, "Test.Assert"
, "Test.Main"
+ , "Type.Data.Ordering"
+ , "Type.Data.Symbol"
+ , "Type.Equality"
+ , "Type.Prelude"
+ , "Type.Proxy"
, "Unsafe.Coerce"
]
diff --git a/tests/support/bower.json b/tests/support/bower.json
index 2de10e8..c6a7173 100644
--- a/tests/support/bower.json
+++ b/tests/support/bower.json
@@ -1,16 +1,17 @@
{
"name": "purescript-test-suite-support",
"dependencies": {
- "purescript-assert": "1.0.0-rc.1",
- "purescript-console": "1.0.0-rc.1",
- "purescript-eff": "1.0.0-rc.1",
- "purescript-functions": "1.0.0-rc.1",
- "purescript-prelude": "1.1.0",
- "purescript-st": "1.0.0-rc.1",
+ "purescript-assert": "2.0.0",
+ "purescript-console": "2.0.0",
+ "purescript-eff": "2.0.0",
+ "purescript-functions": "2.0.0",
+ "purescript-prelude": "2.1.0",
+ "purescript-st": "2.0.0",
"purescript-partial": "1.1.2",
- "purescript-newtype": "0.1.0",
- "purescript-generics-rep": "2.0.0",
- "purescript-symbols": "^1.0.1",
- "purescript-unsafe-coerce": "^1.0.0"
+ "purescript-newtype": "1.1.0",
+ "purescript-generics-rep": "4.0.0",
+ "purescript-symbols": "^2.0.0",
+ "purescript-typelevel-prelude": "https://github.com/purescript/purescript-typelevel-prelude.git#29a7123a0c29c85d4b923fcf4a7df8e45ebf9bac",
+ "purescript-unsafe-coerce": "^2.0.0"
}
}