summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2017-02-07 03:28:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2017-02-07 03:28:00 (GMT)
commitc46fd8243f86cc697fd14c94b2db85ed5067580c (patch)
tree08f31d8fe691471112c123a9d18e4ce90cd1cae4
parent393ecc8ee0178ccac2b9ae81e74708f0d17b2ca5 (diff)
version 0.10.60.10.6
-rw-r--r--CONTRIBUTORS.md4
-rw-r--r--LICENSE310
-rw-r--r--examples/docs/src/ExplicitTypeSignatures.purs2
-rw-r--r--examples/failing/2445.purs6
-rw-r--r--examples/failing/2542.purs9
-rw-r--r--examples/failing/2601.purs7
-rw-r--r--examples/failing/BindInDo-2.purs9
-rw-r--r--examples/failing/BindInDo.purs9
-rw-r--r--examples/failing/ImportModule.purs2
-rw-r--r--examples/failing/MPTCs.purs2
-rw-r--r--examples/failing/TooFewClassInstanceArgs.purs8
-rw-r--r--examples/passing/2136.purs9
-rw-r--r--examples/passing/2288.purs19
-rw-r--r--examples/passing/NestedRecordUpdate.purs24
-rw-r--r--examples/passing/NestedRecordUpdateWildcards.purs20
-rw-r--r--examples/warning/2542.purs16
-rw-r--r--examples/warning/CustomWarning.purs9
-rw-r--r--psc-docs/Main.hs4
-rw-r--r--psc-ide-client/Main.hs2
-rw-r--r--psc-ide-server/Main.hs24
-rw-r--r--psc-package/Main.hs67
-rw-r--r--psc-publish/Main.hs3
-rw-r--r--purescript.cabal42
-rw-r--r--src/Language/PureScript/AST/Declarations.hs49
-rw-r--r--src/Language/PureScript/AST/Traversals.hs7
-rw-r--r--src/Language/PureScript/CodeGen/JS.hs90
-rw-r--r--src/Language/PureScript/CodeGen/JS/AST.hs9
-rw-r--r--src/Language/PureScript/CodeGen/JS/Optimizer.hs2
-rw-r--r--src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs17
-rw-r--r--src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs178
-rw-r--r--src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs14
-rw-r--r--src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs23
-rw-r--r--src/Language/PureScript/Constants.hs263
-rw-r--r--src/Language/PureScript/Crash.hs38
-rw-r--r--src/Language/PureScript/Docs.hs5
-rw-r--r--src/Language/PureScript/Docs/AsHtml.hs299
-rw-r--r--src/Language/PureScript/Docs/AsMarkdown.hs10
-rw-r--r--src/Language/PureScript/Docs/Convert.hs72
-rw-r--r--src/Language/PureScript/Docs/Convert/ReExports.hs7
-rw-r--r--src/Language/PureScript/Docs/Convert/Single.hs27
-rw-r--r--src/Language/PureScript/Docs/ParseAndBookmark.hs97
-rw-r--r--src/Language/PureScript/Docs/ParseInPackage.hs73
-rw-r--r--src/Language/PureScript/Docs/Prim.hs9
-rw-r--r--src/Language/PureScript/Docs/Render.hs44
-rw-r--r--src/Language/PureScript/Docs/RenderedCode.hs17
-rw-r--r--src/Language/PureScript/Docs/RenderedCode/RenderKind.hs57
-rw-r--r--src/Language/PureScript/Docs/RenderedCode/RenderType.hs (renamed from src/Language/PureScript/Docs/RenderedCode/Render.hs)57
-rw-r--r--src/Language/PureScript/Docs/RenderedCode/Types.hs327
-rw-r--r--src/Language/PureScript/Docs/Types.hs244
-rw-r--r--src/Language/PureScript/Environment.hs9
-rw-r--r--src/Language/PureScript/Errors.hs190
-rw-r--r--src/Language/PureScript/Ide.hs52
-rw-r--r--src/Language/PureScript/Ide/CaseSplit.hs12
-rw-r--r--src/Language/PureScript/Ide/Command.hs4
-rw-r--r--src/Language/PureScript/Ide/Completion.hs3
-rw-r--r--src/Language/PureScript/Ide/Conversions.hs29
-rw-r--r--src/Language/PureScript/Ide/Error.hs9
-rw-r--r--src/Language/PureScript/Ide/Externs.hs35
-rw-r--r--src/Language/PureScript/Ide/Filter.hs2
-rw-r--r--src/Language/PureScript/Ide/Imports.hs16
-rw-r--r--src/Language/PureScript/Ide/Logging.hs4
-rw-r--r--src/Language/PureScript/Ide/Rebuild.hs58
-rw-r--r--src/Language/PureScript/Ide/Reexports.hs54
-rw-r--r--src/Language/PureScript/Ide/SourceFile.hs11
-rw-r--r--src/Language/PureScript/Ide/State.hs101
-rw-r--r--src/Language/PureScript/Ide/Types.hs43
-rw-r--r--src/Language/PureScript/Ide/Util.hs49
-rw-r--r--src/Language/PureScript/Make.hs174
-rw-r--r--src/Language/PureScript/ModuleDependencies.hs118
-rw-r--r--src/Language/PureScript/PSString.hs10
-rw-r--r--src/Language/PureScript/Parser/Common.hs122
-rw-r--r--src/Language/PureScript/Parser/Declarations.hs214
-rw-r--r--src/Language/PureScript/Pretty/Common.hs2
-rw-r--r--src/Language/PureScript/Pretty/JS.hs36
-rw-r--r--src/Language/PureScript/Pretty/Types.hs86
-rw-r--r--src/Language/PureScript/Pretty/Values.hs10
-rw-r--r--src/Language/PureScript/Publish.hs59
-rw-r--r--src/Language/PureScript/Publish/ErrorsWarnings.hs6
-rw-r--r--src/Language/PureScript/Sugar/DoNotation.hs9
-rw-r--r--src/Language/PureScript/Sugar/ObjectWildcards.hs79
-rw-r--r--src/Language/PureScript/TypeChecker.hs8
-rw-r--r--src/Language/PureScript/TypeChecker/Entailment.hs20
-rw-r--r--src/Language/PureScript/TypeChecker/Types.hs38
-rw-r--r--src/Language/PureScript/Types.hs2
-rw-r--r--stack.yaml3
-rw-r--r--tests/Language/PureScript/Ide/FilterSpec.hs2
-rw-r--r--tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs83
-rw-r--r--tests/Language/PureScript/Ide/ImportsSpec.hs67
-rw-r--r--tests/Language/PureScript/Ide/Integration.hs273
-rw-r--r--tests/Language/PureScript/Ide/MatcherSpec.hs13
-rw-r--r--tests/Language/PureScript/Ide/RebuildSpec.hs78
-rw-r--r--tests/Language/PureScript/Ide/ReexportsSpec.hs28
-rw-r--r--tests/Language/PureScript/Ide/SourceFile/IntegrationSpec.hs41
-rw-r--r--tests/Language/PureScript/Ide/SourceFileSpec.hs70
-rw-r--r--tests/Language/PureScript/Ide/StateSpec.hs66
-rw-r--r--tests/Language/PureScript/Ide/Test.hs135
-rw-r--r--tests/TestDocs.hs12
-rw-r--r--tests/TestPscIde.hs8
-rw-r--r--tests/TestPscPublish.hs12
-rw-r--r--tests/TestUtils.hs1
-rw-r--r--tests/support/pscide/src/SourceFileSpec.purs10
101 files changed, 3257 insertions, 1961 deletions
diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md
index 192f952..45057f1 100644
--- a/CONTRIBUTORS.md
+++ b/CONTRIBUTORS.md
@@ -76,6 +76,7 @@ This file lists the contributors to the PureScript compiler project, and the ter
- [@sharkdp](https://github.com/sharkdp) (David Peter) My existing contributions and all future contributions until further notice are Copyright David Peter, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
- [@soupi](https://github.com/soupi) (Gil Mizrahi) My existing contributions and all future contributions until further notice are Copyright Gil Mizrahi, 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).
- [@sztupi](https://github.com/sztupi) (Attila Sztupak) My existing contributions and all future contributions until further notice are Copyright Attila Sztupak, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
+- [@taktoa](https://github.com/taktoa) (Remy Goldschmidt) My existing contributions and all future contributions until further notice are Copyright Remy Goldschmidt, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
- [@taku0](https://github.com/taku0) - My existing contributions and all future contributions until further notice are Copyright taku0, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
- [@tfausak](https://github.com/tfausak) (Taylor Fausak) My existing contributions and all future contributions until further notice are Copyright Taylor Fausak, 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).
- [@tmcgilchrist](https://github.com/tmcgilchrist) (Tim McGilchrist) My existing contributions and all future contributions until further notice are Copyright Tim McGilchrist, 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).
@@ -87,6 +88,9 @@ This file lists the contributors to the PureScript compiler project, and the ter
- [@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).
+- [@matthewleon](https://github.com/matthewleon) (Matthew Leon) My existing contributions and all future contributions until further notice are Copyright Matthew Leon, 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).
+- [@alexbiehl](https://github.com/alexbiehl) (Alexander Biehl) My existing contributions and all future contributions until further notice are Copyright Alexander Biehl, 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).
+- [@noraesae](https://github.com/noraesae) (Hyunje Jun) My existing contributions and all future contributions until further notice are Copyright Hyunje Jun, 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 550b1b6..2272766 100644
--- a/LICENSE
+++ b/LICENSE
@@ -48,6 +48,7 @@ PureScript uses the following Haskell library packages. Their license files foll
bytestring-builder
case-insensitive
cereal
+ cheapskate
clock
cmdargs
comonad
@@ -58,7 +59,13 @@ PureScript uses the following Haskell library packages. Their license files foll
contravariant
cookie
cryptonite
+ css-text
+ data-default
data-default-class
+ data-default-instances-base
+ data-default-instances-containers
+ data-default-instances-dlist
+ data-default-instances-old-locale
data-ordlist
deepseq
directory
@@ -142,6 +149,7 @@ PureScript uses the following Haskell library packages. Their license files foll
system-fileio
system-filepath
tagged
+ tagsoup
template-haskell
temporary
terminfo
@@ -152,6 +160,7 @@ PureScript uses the following Haskell library packages. Their license files foll
transformers-base
transformers-compat
turtle
+ uniplate
unix
unix-compat
unix-time
@@ -172,6 +181,7 @@ PureScript uses the following Haskell library packages. Their license files foll
x509-store
x509-system
x509-validation
+ xss-sanitize
zlib
Glob LICENSE file:
@@ -1311,6 +1321,39 @@ cereal LICENSE file:
ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.
+cheapskate LICENSE file:
+
+ Copyright (c) 2013, John MacFarlane
+
+ 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 John MacFarlane 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.
+
clock LICENSE file:
Copyright (c) 2009-2012, Cetin Sert
@@ -1606,6 +1649,63 @@ cryptonite LICENSE file:
OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
SUCH DAMAGE.
+css-text LICENSE file:
+
+ The following license covers this documentation, and the source code, except
+ where otherwise indicated.
+
+ Copyright 2010, Michael Snoyman. All rights reserved.
+
+ Redistribution and use in source and binary forms, with or without
+ modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright notice, this
+ list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above copyright notice,
+ this list of conditions and the following disclaimer in the documentation
+ and/or other materials provided with the distribution.
+
+ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR
+ IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
+ MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO
+ EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,
+ INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
+ NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,
+ OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+ LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
+ OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+ ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+data-default LICENSE file:
+
+ Copyright (c) 2013 Lukas Mai
+
+ All rights reserved.
+
+ Redistribution and use in source and binary forms, with or without modification,
+ are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright notice, this
+ list of conditions and the following disclaimer.
+ * Redistributions in binary form must reproduce the above copyright notice,
+ this list of conditions and the following disclaimer in the documentation
+ and/or other materials provided with the distribution.
+ * Neither the name of the author nor the names of 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 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 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.
+
data-default-class LICENSE file:
Copyright (c) 2013 Lukas Mai
@@ -1635,6 +1735,122 @@ data-default-class 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.
+data-default-instances-base LICENSE file:
+
+ Copyright (c) 2013 Lukas Mai
+
+ All rights reserved.
+
+ Redistribution and use in source and binary forms, with or without modification,
+ are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright notice, this
+ list of conditions and the following disclaimer.
+ * Redistributions in binary form must reproduce the above copyright notice,
+ this list of conditions and the following disclaimer in the documentation
+ and/or other materials provided with the distribution.
+ * Neither the name of the author nor the names of 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 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 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.
+
+data-default-instances-containers LICENSE file:
+
+ Copyright (c) 2013 Lukas Mai
+
+ All rights reserved.
+
+ Redistribution and use in source and binary forms, with or without modification,
+ are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright notice, this
+ list of conditions and the following disclaimer.
+ * Redistributions in binary form must reproduce the above copyright notice,
+ this list of conditions and the following disclaimer in the documentation
+ and/or other materials provided with the distribution.
+ * Neither the name of the author nor the names of his contributors
+ may be used to endorse or promote products derived from this software
+ without specific prior written permission.
+
+ 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 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-default-instances-dlist LICENSE file:
+
+ Copyright (c) 2013 Lukas Mai
+
+ All rights reserved.
+
+ Redistribution and use in source and binary forms, with or without modification,
+ are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright notice, this
+ list of conditions and the following disclaimer.
+ * Redistributions in binary form must reproduce the above copyright notice,
+ this list of conditions and the following disclaimer in the documentation
+ and/or other materials provided with the distribution.
+ * Neither the name of the author nor the names of his contributors
+ may be used to endorse or promote products derived from this software
+ without specific prior written permission.
+
+ 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 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-default-instances-old-locale LICENSE file:
+
+ Copyright (c) 2013 Lukas Mai
+
+ All rights reserved.
+
+ Redistribution and use in source and binary forms, with or without modification,
+ are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright notice, this
+ list of conditions and the following disclaimer.
+ * Redistributions in binary form must reproduce the above copyright notice,
+ this list of conditions and the following disclaimer in the documentation
+ and/or other materials provided with the distribution.
+ * Neither the name of the author nor the names of his contributors
+ may be used to endorse or promote products derived from this software
+ without specific prior written permission.
+
+ 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 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:
Copyright (c) 2009-2010, Melding Monads
@@ -4366,6 +4582,39 @@ tagged 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.
+tagsoup LICENSE file:
+
+ Copyright Neil Mitchell 2006-2016.
+ All rights reserved.
+
+ Redistribution and use in source and binary forms, with or without
+ modification, are permitted provided that the following conditions are
+ met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Neil Mitchell nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+ "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+ LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+ A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+ OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+ SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+ LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+ DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+ THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+ (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
template-haskell LICENSE file:
@@ -4649,6 +4898,39 @@ turtle 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.
+uniplate LICENSE file:
+
+ Copyright Neil Mitchell 2006-2013.
+ All rights reserved.
+
+ Redistribution and use in source and binary forms, with or without
+ modification, are permitted provided that the following conditions are
+ met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Neil Mitchell nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+ "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+ LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+ A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+ OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+ SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+ LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+ DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+ THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+ (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
unix LICENSE file:
The Glasgow Haskell Compiler License
@@ -5238,6 +5520,34 @@ x509-validation LICENSE file:
OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
SUCH DAMAGE.
+xss-sanitize LICENSE file:
+
+ The following license covers this documentation, and the source code, except
+ where otherwise indicated.
+
+ Copyright 2010, Greg Weber. All rights reserved.
+
+ Redistribution and use in source and binary forms, with or without
+ modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright notice, this
+ list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above copyright notice,
+ this list of conditions and the following disclaimer in the documentation
+ and/or other materials provided with the distribution.
+
+ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR
+ IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
+ MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO
+ EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,
+ INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
+ NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,
+ OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+ LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
+ OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+ ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
zlib LICENSE file:
Copyright (c) 2006-2016, Duncan Coutts
diff --git a/examples/docs/src/ExplicitTypeSignatures.purs b/examples/docs/src/ExplicitTypeSignatures.purs
index f9fa06f..396ca14 100644
--- a/examples/docs/src/ExplicitTypeSignatures.purs
+++ b/examples/docs/src/ExplicitTypeSignatures.purs
@@ -14,5 +14,3 @@ anInt = 0
-- This should infer a type.
aNumber = 1.0
-
-foreign import nestedForAll :: forall c. (forall a b. c)
diff --git a/examples/failing/2445.purs b/examples/failing/2445.purs
new file mode 100644
index 0000000..10ad41a
--- /dev/null
+++ b/examples/failing/2445.purs
@@ -0,0 +1,6 @@
+-- @shouldFailWith ErrorParsingModule
+module Main where
+
+data X a = X
+
+eg = \(X :: (forall a. X a)) -> X
diff --git a/examples/failing/2542.purs b/examples/failing/2542.purs
new file mode 100644
index 0000000..9c2b347
--- /dev/null
+++ b/examples/failing/2542.purs
@@ -0,0 +1,9 @@
+-- @shouldFailWith UndefinedTypeVariable
+module Main where
+
+type T = forall a. Array a
+
+foo :: T
+foo = bar where
+ bar :: Array a
+ bar = []
diff --git a/examples/failing/2601.purs b/examples/failing/2601.purs
new file mode 100644
index 0000000..00dc25f
--- /dev/null
+++ b/examples/failing/2601.purs
@@ -0,0 +1,7 @@
+-- @shouldFailWith KindsDoNotUnify
+module Main where
+
+type Syn (a :: * -> *) = String
+
+val :: Syn Int
+val = "bad"
diff --git a/examples/failing/BindInDo-2.purs b/examples/failing/BindInDo-2.purs
new file mode 100644
index 0000000..a8c0d15
--- /dev/null
+++ b/examples/failing/BindInDo-2.purs
@@ -0,0 +1,9 @@
+-- @shouldFailWith CannotUseBindWithDo
+module Main where
+
+import Prelude
+
+foo = do
+ let bind = 42
+ x <- [4, 5, 6]
+ pure x
diff --git a/examples/failing/BindInDo.purs b/examples/failing/BindInDo.purs
new file mode 100644
index 0000000..d4f3286
--- /dev/null
+++ b/examples/failing/BindInDo.purs
@@ -0,0 +1,9 @@
+-- @shouldFailWith CannotUseBindWithDo
+module Main where
+
+import Prelude
+
+foo = do
+ bind <- [1,2,3]
+ x <- [4, 5, 6]
+ pure x
diff --git a/examples/failing/ImportModule.purs b/examples/failing/ImportModule.purs
index ba3da26..a996fbc 100644
--- a/examples/failing/ImportModule.purs
+++ b/examples/failing/ImportModule.purs
@@ -1,4 +1,4 @@
--- @shouldFailWith UnknownName
+-- @shouldFailWith ModuleNotFound
module Main where
import M1
diff --git a/examples/failing/MPTCs.purs b/examples/failing/MPTCs.purs
index c5917cf..16a7822 100644
--- a/examples/failing/MPTCs.purs
+++ b/examples/failing/MPTCs.purs
@@ -1,4 +1,4 @@
--- @shouldFailWith KindsDoNotUnify
+-- @shouldFailWith ClassInstanceArityMismatch
module Main where
import Prelude
diff --git a/examples/failing/TooFewClassInstanceArgs.purs b/examples/failing/TooFewClassInstanceArgs.purs
new file mode 100644
index 0000000..2d612c9
--- /dev/null
+++ b/examples/failing/TooFewClassInstanceArgs.purs
@@ -0,0 +1,8 @@
+-- @shouldFailWith ClassInstanceArityMismatch
+module Main where
+
+import Prelude
+
+class Foo a b
+
+instance fooString :: Foo String
diff --git a/examples/passing/2136.purs b/examples/passing/2136.purs
new file mode 100644
index 0000000..98c3972
--- /dev/null
+++ b/examples/passing/2136.purs
@@ -0,0 +1,9 @@
+module Main where
+
+import Prelude
+import Control.Monad.Eff.Console (log)
+
+main =
+ if (negate (bottom :: Int) > top)
+ then log "Fail"
+ else log "Done"
diff --git a/examples/passing/2288.purs b/examples/passing/2288.purs
new file mode 100644
index 0000000..78c8ab4
--- /dev/null
+++ b/examples/passing/2288.purs
@@ -0,0 +1,19 @@
+module Main where
+
+import Prelude
+import Control.Monad.Eff
+import Control.Monad.Eff.Console
+import Data.Array
+import Data.Array.Partial as P
+import Partial.Unsafe
+
+length :: forall a. Array a -> Int
+length = go 0 where
+ go acc arr =
+ if null arr
+ then acc
+ else go (acc + 1) (unsafePartial P.tail arr)
+
+main = do
+ logShow (length (1 .. 10000))
+ log "Done"
diff --git a/examples/passing/NestedRecordUpdate.purs b/examples/passing/NestedRecordUpdate.purs
new file mode 100644
index 0000000..60eef8f
--- /dev/null
+++ b/examples/passing/NestedRecordUpdate.purs
@@ -0,0 +1,24 @@
+module Main where
+
+import Prelude
+import Control.Monad.Eff.Console
+
+type T = { foo :: Int, bar :: { baz :: Int, qux :: { lhs :: Int, rhs :: Int } } }
+
+init :: T
+init = { foo: 1, bar: { baz: 2, qux: { lhs: 3, rhs: 4 } } }
+
+updated :: T
+updated = init { foo = 10, bar { baz = 20, qux { lhs = 30, rhs = 40 } } }
+
+expected :: T
+expected = { foo: 10, bar: { baz: 20, qux: { lhs: 30, rhs: 40 } } }
+
+check l r =
+ l.foo == r.foo &&
+ l.bar.baz == r.bar.baz &&
+ l.bar.qux.lhs == r.bar.qux.lhs &&
+ l.bar.qux.rhs == r.bar.qux.rhs
+
+main = do
+ when (check updated expected) $ log "Done"
diff --git a/examples/passing/NestedRecordUpdateWildcards.purs b/examples/passing/NestedRecordUpdateWildcards.purs
new file mode 100644
index 0000000..7c99276
--- /dev/null
+++ b/examples/passing/NestedRecordUpdateWildcards.purs
@@ -0,0 +1,20 @@
+module Main where
+
+import Prelude
+import Control.Monad.Eff.Console
+
+update = _ { foo = _, bar { baz = _, qux = _ } }
+
+init = { foo: 1, bar: { baz: 2, qux: 3 } }
+
+after = update init 10 20 30
+
+expected = { foo: 10, bar: { baz: 20, qux: 30 } }
+
+check l r =
+ l.foo == r.foo &&
+ l.bar.baz == r.bar.baz &&
+ l.bar.qux == r.bar.qux
+
+main = do
+ when (check after expected) $ log "Done"
diff --git a/examples/warning/2542.purs b/examples/warning/2542.purs
new file mode 100644
index 0000000..8a13518
--- /dev/null
+++ b/examples/warning/2542.purs
@@ -0,0 +1,16 @@
+-- @shouldWarnWith MissingTypeDeclaration
+module Main where
+
+import Control.Monad.Eff.Console
+
+type T = forall a. Array a
+
+-- | Note: This should not raise a `ShadowedTypeVar` warning as the
+-- | type `a` introduced in `T` should not be in scope
+-- | in the definition of `bar`.
+foo :: T
+foo = bar where
+ bar :: forall a. Array a
+ bar = []
+
+main = log "Done"
diff --git a/examples/warning/CustomWarning.purs b/examples/warning/CustomWarning.purs
new file mode 100644
index 0000000..25540c6
--- /dev/null
+++ b/examples/warning/CustomWarning.purs
@@ -0,0 +1,9 @@
+-- @shouldWarnWith UserDefinedWarning
+module Main where
+
+foo :: forall t. Warn (TypeConcat "Custom warning " (TypeString t)) => t -> t
+foo x = x
+
+bar :: Int
+bar = foo 42
+
diff --git a/psc-docs/Main.hs b/psc-docs/Main.hs
index a1ca8ec..e6ffe6d 100644
--- a/psc-docs/Main.hs
+++ b/psc-docs/Main.hs
@@ -60,8 +60,8 @@ docgen (PSCDocsOptions fmt inputGlob output) = do
Etags -> dumpTags input dumpEtags
Ctags -> dumpTags input dumpCtags
Markdown -> do
- ms <- runExceptT (D.parseAndBookmark input []
- >>= (fst >>> D.convertModulesInPackage))
+ ms <- runExceptT (D.parseFilesInPackages input []
+ >>= uncurry D.convertModulesInPackage)
>>= successOrExit
case output of
diff --git a/psc-ide-client/Main.hs b/psc-ide-client/Main.hs
index 932a4b2..8d47074 100644
--- a/psc-ide-client/Main.hs
+++ b/psc-ide-client/Main.hs
@@ -35,6 +35,8 @@ main = do
client :: PortID -> IO ()
client port = do
+ hSetEncoding stdin utf8
+ hSetEncoding stdout utf8
h <-
connectTo "127.0.0.1" port `catch`
(\(SomeException e) ->
diff --git a/psc-ide-server/Main.hs b/psc-ide-server/Main.hs
index 7bdb9b6..8b214c8 100644
--- a/psc-ide-server/Main.hs
+++ b/psc-ide-server/Main.hs
@@ -29,6 +29,7 @@ import "monad-logger" Control.Monad.Logger
import qualified Data.Text.IO as T
import qualified Data.ByteString.Lazy.Char8 as BS8
import Data.Version (showVersion)
+import GHC.IO.Exception (IOErrorType(..), IOException(..))
import Language.PureScript.Ide
import Language.PureScript.Ide.Command
import Language.PureScript.Ide.Util
@@ -130,9 +131,9 @@ startServer port env = withSocketsDo $ do
where
loop :: (Ide m, MonadLogger m) => Socket -> m ()
loop sock = do
- accepted <- runExceptT $ acceptCommand sock
+ accepted <- runExceptT (acceptCommand sock)
case accepted of
- Left err -> $(logDebug) err
+ Left err -> $(logError) err
Right (cmd, h) -> do
case decodeT cmd of
Just cmd' -> do
@@ -144,14 +145,21 @@ startServer port env = withSocketsDo $ do
-- $(logDebug) ("Answer was: " <> T.pack (show result))
liftIO (hFlush stdout)
case result of
- Right r -> liftIO $ BS8.hPutStrLn h (Aeson.encode r)
- Left err -> liftIO $ BS8.hPutStrLn h (Aeson.encode err)
+ Right r -> liftIO $ catchGoneHandle (BS8.hPutStrLn h (Aeson.encode r))
+ Left err -> liftIO $ catchGoneHandle (BS8.hPutStrLn h (Aeson.encode err))
Nothing -> do
- $(logDebug) ("Parsing the command failed. Command: " <> cmd)
+ $(logError) ("Parsing the command failed. Command: " <> cmd)
liftIO $ do
- T.hPutStrLn h (encodeT (GeneralError "Error parsing Command."))
+ catchGoneHandle (T.hPutStrLn h (encodeT (GeneralError "Error parsing Command.")))
hFlush stdout
- liftIO (hClose h)
+ liftIO $ catchGoneHandle (hClose h)
+
+catchGoneHandle :: IO () -> IO ()
+catchGoneHandle =
+ handle (\e -> case e of
+ IOError { ioe_type = ResourceVanished } ->
+ putText ("[Error] psc-ide-server tried interact with the handle, but the connection was already gone.")
+ _ -> throwIO e)
acceptCommand :: (MonadIO m, MonadLogger m, MonadError Text m)
=> Socket -> m (Text, Handle)
@@ -167,7 +175,7 @@ acceptCommand sock = do
case cmd' of
Nothing -> throwError "Connection was closed before any input arrived"
Just cmd -> do
- $(logDebug) cmd
+ $(logDebug) ("Received command: " <> cmd)
pure (cmd, h)
where
acceptConnection = liftIO $ do
diff --git a/psc-package/Main.hs b/psc-package/Main.hs
index 71d9560..897515b 100644
--- a/psc-package/Main.hs
+++ b/psc-package/Main.hs
@@ -28,9 +28,12 @@ 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, s, x)
+import Turtle hiding (echo, fold, s, x)
import qualified Turtle
+echoT :: Text -> IO ()
+echoT = Turtle.printf (Turtle.s % "\n")
+
packageFile :: Path.FilePath
packageFile = "psc-package.json"
@@ -56,12 +59,12 @@ readPackageFile :: IO PackageConfig
readPackageFile = do
exists <- testfile packageFile
unless exists $ do
- echo "psc-package.json does not exist"
+ echoT "psc-package.json does not exist"
exit (ExitFailure 1)
mpkg <- Aeson.decodeStrict . encodeUtf8 <$> readTextFile packageFile
case mpkg of
Nothing -> do
- echo "Unable to parse psc-package.json"
+ echoT "Unable to parse psc-package.json"
exit (ExitFailure 1)
Just pkg -> return pkg
@@ -124,13 +127,13 @@ listRemoteTags
:: Text
-- ^ repo
-> Turtle.Shell Text
-listRemoteTags from =
- inproc "git"
- [ "ls-remote"
- , "-q"
- , "-t"
- , from
- ] empty
+listRemoteTags from = let gitProc = inproc "git"
+ [ "ls-remote"
+ , "-q"
+ , "-t"
+ , from
+ ] empty
+ in lineToText <$> gitProc
getPackageSet :: PackageConfig -> IO ()
getPackageSet PackageConfig{ source, set } = do
@@ -143,12 +146,12 @@ readPackageSet PackageConfig{ set } = do
let dbFile = ".psc-package" </> fromText set </> ".set" </> "packages.json"
exists <- testfile dbFile
unless exists $ do
- echo $ format (fp%" does not exist") dbFile
+ echoT $ format (fp%" does not exist") dbFile
exit (ExitFailure 1)
mdb <- Aeson.decodeStrict . encodeUtf8 <$> readTextFile dbFile
case mdb of
Nothing -> do
- echo "Unable to parse packages.json"
+ echoT "Unable to parse packages.json"
exit (ExitFailure 1)
Just db -> return db
@@ -159,7 +162,7 @@ writePackageSet PackageConfig{ set } =
installOrUpdate :: Text -> Text -> PackageInfo -> IO Turtle.FilePath
installOrUpdate set pkgName PackageInfo{ repo, version } = do
- echo ("Updating " <> pkgName)
+ echoT ("Updating " <> pkgName)
let pkgDir = ".psc-package" </> fromText set </> fromText pkgName </> fromText version
exists <- testdir pkgDir
unless exists . void $ cloneShallow repo version pkgDir
@@ -170,7 +173,7 @@ getTransitiveDeps db depends = do
pkgs <- for depends $ \pkg ->
case Map.lookup pkg db of
Nothing -> do
- echo ("Package " <> pkg <> " does not exist in package set")
+ echoT ("Package " <> pkg <> " does not exist in package set")
exit (ExitFailure 1)
Just PackageInfo{ dependencies } -> return (pkg : dependencies)
let unique = Set.toList (foldMap Set.fromList pkgs)
@@ -181,16 +184,16 @@ updateImpl config@PackageConfig{ depends } = do
getPackageSet config
db <- readPackageSet config
trans <- getTransitiveDeps db depends
- echo ("Updating " <> pack (show (length trans)) <> " packages...")
+ echoT ("Updating " <> pack (show (length trans)) <> " packages...")
for_ trans $ \(pkgName, pkg) -> installOrUpdate (set config) pkgName pkg
initialize :: IO ()
initialize = do
exists <- testfile "psc-package.json"
when exists $ do
- echo "psc-package.json already exists"
+ echoT "psc-package.json already exists"
exit (ExitFailure 1)
- echo "Initializing new project in current directory"
+ echoT "Initializing new project in current directory"
pkgName <- pathToTextUnsafe . Path.filename <$> pwd
let pkg = defaultPackage pkgName
writePackageFile pkg
@@ -200,7 +203,7 @@ update :: IO ()
update = do
pkg <- readPackageFile
updateImpl pkg
- echo "Update complete"
+ echoT "Update complete"
install :: String -> IO ()
install pkgName = do
@@ -208,7 +211,7 @@ install pkgName = do
let pkg' = pkg { depends = nub (pack pkgName : depends pkg) }
updateImpl pkg'
writePackageFile pkg'
- echo "psc-package.json file was updated"
+ echoT "psc-package.json file was updated"
uninstall :: String -> IO ()
uninstall pkgName = do
@@ -216,20 +219,20 @@ uninstall pkgName = do
let pkg' = pkg { depends = filter (/= pack pkgName) $ depends pkg }
updateImpl pkg'
writePackageFile pkg'
- echo "psc-package.json file was updated"
+ echoT "psc-package.json file was updated"
listDependencies :: IO ()
listDependencies = do
pkg@PackageConfig{ depends } <- readPackageFile
db <- readPackageSet pkg
trans <- getTransitiveDeps db depends
- traverse_ (echo . fst) trans
+ traverse_ (echoT . fst) trans
listPackages :: IO ()
listPackages = do
pkg <- readPackageFile
db <- readPackageSet pkg
- traverse_ echo (fmt <$> Map.assocs db)
+ traverse_ echoT (fmt <$> Map.assocs db)
where
fmt :: (Text, PackageInfo) -> Text
fmt (name, PackageInfo{ version }) = name <> " (" <> version <> ")"
@@ -251,7 +254,7 @@ listSourcePaths = do
pkg@PackageConfig{ depends } <- readPackageFile
db <- readPackageSet pkg
paths <- getSourcePaths pkg db depends
- traverse_ (echo . pathToTextUnsafe) paths
+ traverse_ (echoT . pathToTextUnsafe) paths
exec :: Text -> IO ()
exec exeName = do
@@ -267,11 +270,11 @@ 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!"
+ echoT ("Checking " <> pack (show (Map.size db)) <> " packages for updates.")
+ echoT "Warning: this could take some time!"
newDb <- Map.fromList <$> (for (Map.toList db) $ \(name, p@PackageInfo{ repo, version }) -> do
- echo ("Checking package " <> name)
+ echoT ("Checking package " <> name)
tagLines <- Turtle.fold (listRemoteTags repo) Foldl.list
let tags = mapMaybe parseTag tagLines
newVersion <- case parseVersion version of
@@ -280,7 +283,7 @@ checkForUpdates applyMinorUpdates applyMajorUpdates = do
case filter (isMinorReleaseFrom parts) tags of
[] -> pure version
minorReleases -> do
- echo ("New minor release available")
+ echoT ("New minor release available")
case applyMinorUpdates of
True -> do
let latestMinorRelease = maximum minorReleases
@@ -290,7 +293,7 @@ checkForUpdates applyMinorUpdates applyMajorUpdates = do
case filter (isMajorReleaseFrom parts) tags of
[] -> applyMinor
newReleases -> do
- echo ("New major release available")
+ echoT ("New major release available")
case applyMajorUpdates of
True -> do
let latestRelease = maximum newReleases
@@ -298,7 +301,7 @@ checkForUpdates applyMinorUpdates applyMajorUpdates = do
False -> applyMinor
in applyMajor
_ -> do
- echo "Unable to parse version string"
+ echoT "Unable to parse version string"
pure version
pure (name, p { version = newVersion }))
@@ -345,15 +348,15 @@ verifyPackageSet = do
pkg <- readPackageFile
db <- readPackageSet pkg
- echo ("Verifying " <> pack (show (Map.size db)) <> " packages.")
- echo "Warning: this could take some time!"
+ echoT ("Verifying " <> pack (show (Map.size db)) <> " packages.")
+ echoT "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)
+ echoT ("Verifying package " <> name)
let srcGlobs = map (pathToTextUnsafe . (</> ("src" </> "**" </> "*.purs")) . dirFor) (name : dependencies)
procs "psc" srcGlobs empty
diff --git a/psc-publish/Main.hs b/psc-publish/Main.hs
index 5d2e902..fd84ec4 100644
--- a/psc-publish/Main.hs
+++ b/psc-publish/Main.hs
@@ -2,10 +2,12 @@
module Main where
+import Control.Monad.IO.Class (liftIO)
import Data.Version (Version(..), showVersion)
import qualified Data.Aeson as A
import qualified Data.ByteString.Lazy.Char8 as BL
import Data.Monoid ((<>))
+import Data.Time.Clock (getCurrentTime)
import Options.Applicative (Parser, ParseError (..))
import qualified Options.Applicative as Opts
@@ -25,6 +27,7 @@ dryRunOptions :: PublishOptions
dryRunOptions = defaultPublishOptions
{ publishGetVersion = return dummyVersion
, publishWorkingTreeDirty = warn DirtyWorkingTree_Warn
+ , publishGetTagTime = const (liftIO getCurrentTime)
}
where dummyVersion = ("0.0.0", Version [0,0,0] [])
diff --git a/purescript.cabal b/purescript.cabal
index 1ba5bb2..45b2f80 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,5 +1,5 @@
name: purescript
-version: 0.10.5
+version: 0.10.6
cabal-version: >=1.8
build-type: Simple
license: BSD3
@@ -117,12 +117,15 @@ library
aeson-better-errors >= 0.8,
ansi-terminal >= 0.6.2 && < 0.7,
base-compat >=0.6.0,
+ blaze-html >= 0.8.1 && < 0.9,
bower-json >= 1.0.0.1 && < 1.1,
boxes >= 0.1.4 && < 0.2.0,
bytestring -any,
+ cheapskate >= 0.1 && < 0.2,
containers -any,
clock -any,
data-ordlist >= 0.4.7.0,
+ deepseq -any,
directory >= 1.2,
dlist -any,
edit-distance -any,
@@ -266,9 +269,11 @@ library
Language.PureScript.Docs.Types
Language.PureScript.Docs.RenderedCode
Language.PureScript.Docs.RenderedCode.Types
- Language.PureScript.Docs.RenderedCode.Render
+ Language.PureScript.Docs.RenderedCode.RenderType
+ Language.PureScript.Docs.RenderedCode.RenderKind
Language.PureScript.Docs.AsMarkdown
- Language.PureScript.Docs.ParseAndBookmark
+ Language.PureScript.Docs.AsHtml
+ Language.PureScript.Docs.ParseInPackage
Language.PureScript.Docs.Utils.MonoidExtras
Language.PureScript.Publish
@@ -280,7 +285,6 @@ library
Language.PureScript.Ide.CaseSplit
Language.PureScript.Ide.Command
Language.PureScript.Ide.Completion
- Language.PureScript.Ide.Conversions
Language.PureScript.Ide.Externs
Language.PureScript.Ide.Error
Language.PureScript.Ide.Filter
@@ -347,7 +351,7 @@ executable psc
filepath -any,
Glob >= 0.7 && < 0.8,
mtl -any,
- optparse-applicative >= 0.12.1,
+ optparse-applicative >= 0.13.0,
parsec -any,
text -any,
time -any,
@@ -374,7 +378,7 @@ executable psci
haskeline >= 0.7.0.0,
http-types == 0.9.*,
mtl -any,
- optparse-applicative >= 0.12.1,
+ optparse-applicative >= 0.13.0,
parsec -any,
process -any,
stm >= 0.2.4.0,
@@ -400,7 +404,7 @@ executable psc-docs
filepath -any,
Glob -any,
mtl -any,
- optparse-applicative >= 0.12.1,
+ optparse-applicative >= 0.13.0,
process -any,
split -any,
text -any,
@@ -420,7 +424,9 @@ executable psc-publish
purescript -any,
aeson >= 0.8 && < 1.0,
bytestring -any,
- optparse-applicative -any
+ optparse-applicative -any,
+ time -any,
+ transformers -any
main-is: Main.hs
other-modules: Paths_purescript
buildable: True
@@ -438,7 +444,7 @@ executable psc-package
optparse-applicative -any,
system-filepath -any,
text -any,
- turtle <1.3
+ turtle ==1.3.*
main-is: Main.hs
other-modules: Paths_purescript
buildable: True
@@ -452,7 +458,7 @@ executable psc-hierarchy
filepath -any,
Glob -any,
mtl -any,
- optparse-applicative >= 0.12.1,
+ optparse-applicative >= 0.13.0,
parsec -any,
process -any,
text -any
@@ -475,7 +481,7 @@ executable psc-bundle
filepath -any,
Glob -any,
mtl -any,
- optparse-applicative >= 0.12.1,
+ optparse-applicative >= 0.13.0,
sourcemap >= 0.1.6,
transformers -any,
transformers-compat -any,
@@ -492,18 +498,16 @@ executable psc-ide-server
aeson >= 0.8 && < 1.0,
bytestring -any,
purescript -any,
- base-compat >=0.6.0,
directory -any,
filepath -any,
monad-logger -any,
mtl -any,
network -any,
- optparse-applicative >= 0.12.1,
+ optparse-applicative >= 0.13.0,
protolude >= 0.1.6,
stm -any,
text -any,
- transformers -any,
- transformers-compat -any
+ transformers -any
ghc-options: -Wall -O2 -threaded
hs-source-dirs: psc-ide-server
@@ -516,7 +520,7 @@ executable psc-ide-client
bytestring -any,
mtl -any,
network -any,
- optparse-applicative >= 0.12.1,
+ optparse-applicative >= 0.13.0,
text -any
ghc-options: -Wall -O2
hs-source-dirs: psc-ide-client
@@ -538,6 +542,8 @@ test-suite tests
hspec -any,
hspec-discover -any,
HUnit -any,
+ lens -any,
+ monad-logger -any,
mtl -any,
optparse-applicative -any,
parsec -any,
@@ -562,14 +568,12 @@ test-suite tests
TestPsci
TestPscIde
PscIdeSpec
+ Language.PureScript.Ide.Test
Language.PureScript.Ide.FilterSpec
Language.PureScript.Ide.ImportsSpec
- Language.PureScript.Ide.Imports.IntegrationSpec
- Language.PureScript.Ide.Integration
Language.PureScript.Ide.MatcherSpec
Language.PureScript.Ide.RebuildSpec
Language.PureScript.Ide.ReexportsSpec
- Language.PureScript.Ide.SourceFile.IntegrationSpec
Language.PureScript.Ide.SourceFileSpec
Language.PureScript.Ide.StateSpec
buildable: True
diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs
index 8be4193..6544cae 100644
--- a/src/Language/PureScript/AST/Declarations.hs
+++ b/src/Language/PureScript/AST/Declarations.hs
@@ -1,4 +1,6 @@
{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveTraversable #-}
-- |
-- Data types for modules and declarations
@@ -43,7 +45,8 @@ data TypeSearch
-- | A type of error messages
data SimpleErrorMessage
- = ErrorParsingFFIModule FilePath (Maybe Bundle.ErrorMessage)
+ = ModuleNotFound ModuleName
+ | ErrorParsingFFIModule FilePath (Maybe Bundle.ErrorMessage)
| ErrorParsingModule P.ParseError
| MissingFFIModule ModuleName
| MultipleFFIModules ModuleName [FilePath]
@@ -134,10 +137,14 @@ data SimpleErrorMessage
| CaseBinderLengthDiffers Int [Binder]
| IncorrectAnonymousArgument
| InvalidOperatorInBinder (Qualified (OpName 'ValueOpName)) (Qualified Ident)
- | DeprecatedRequirePath
| CannotGeneralizeRecursiveFunction Ident Type
| CannotDeriveNewtypeForData (ProperName 'TypeName)
| ExpectedWildcard (ProperName 'TypeName)
+ | CannotUseBindWithDo
+ -- | instance name, type class, expected argument count, actual argument count
+ | ClassInstanceArityMismatch Ident (Qualified (ProperName 'ClassName)) Int Int
+ -- | a user-defined warning raised by using the Warn type class
+ | UserDefinedWarning Type
deriving (Show)
-- | Error message hints, providing more detailed information about failure.
@@ -581,6 +588,11 @@ data Expr
--
| ObjectUpdate Expr [(PSString, Expr)]
-- |
+ -- Object updates with nested support: `x { foo { bar = e } }`
+ -- Replaced during desugaring into a `Let` and nested `ObjectUpdate`s
+ --
+ | ObjectUpdateNested Expr (PathTree Expr)
+ -- |
-- Function introduction
--
| Abs (Either Ident Binder) Expr
@@ -695,5 +707,38 @@ data DoNotationElement
| PositionedDoNotationElement SourceSpan [Comment] DoNotationElement
deriving (Show)
+
+-- For a record update such as:
+--
+-- x { foo = 0
+-- , bar { baz = 1
+-- , qux = 2 } }
+--
+-- We represent the updates as the `PathTree`:
+--
+-- [ ("foo", Leaf 3)
+-- , ("bar", Branch [ ("baz", Leaf 1)
+-- , ("qux", Leaf 2) ]) ]
+--
+-- Which we then convert to an expression representing the following:
+--
+-- let x' = x
+-- in x' { foo = 0
+-- , bar = x'.bar { baz = 1
+-- , qux = 2 } }
+--
+-- The `let` here is required to prevent re-evaluating the object expression `x`.
+-- However we don't generate this when using an anonymous argument for the object.
+--
+
+newtype PathTree t = PathTree (AssocList PSString (PathNode t))
+ deriving (Show, Eq, Ord, Functor, Foldable, Traversable)
+
+data PathNode t = Leaf t | Branch (PathTree t)
+ deriving (Show, Eq, Ord, Functor, Foldable, Traversable)
+
+newtype AssocList k t = AssocList { runAssocList :: [(k, t)] }
+ deriving (Show, Eq, Ord, Foldable, Functor, Traversable)
+
$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''DeclarationRef)
$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ImportDeclarationType)
diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs
index e15b30d..169bd67 100644
--- a/src/Language/PureScript/AST/Traversals.hs
+++ b/src/Language/PureScript/AST/Traversals.hs
@@ -48,6 +48,7 @@ everywhereOnValues f g h = (f', g', h')
g' (TypeClassDictionaryConstructorApp name v) = g (TypeClassDictionaryConstructorApp name (g' v))
g' (Accessor prop v) = g (Accessor prop (g' v))
g' (ObjectUpdate obj vs) = g (ObjectUpdate (g' obj) (map (fmap g') vs))
+ g' (ObjectUpdateNested obj vs) = g (ObjectUpdateNested (g' obj) (fmap g' vs))
g' (Abs name v) = g (Abs name (g' v))
g' (App v1 v2) = g (App (g' v1) (g' v2))
g' (IfThenElse v1 v2 v3) = g (IfThenElse (g' v1) (g' v2) (g' v3))
@@ -115,6 +116,7 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)
g' (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> (g v >>= g')
g' (Accessor prop v) = Accessor prop <$> (g v >>= g')
g' (ObjectUpdate obj vs) = ObjectUpdate <$> (g obj >>= g') <*> traverse (sndM (g' <=< g)) vs
+ g' (ObjectUpdateNested obj vs) = ObjectUpdateNested <$> (g obj >>= g') <*> traverse (g' <=< g) vs
g' (Abs name v) = Abs name <$> (g v >>= g')
g' (App v1 v2) = App <$> (g v1 >>= g') <*> (g v2 >>= g')
g' (IfThenElse v1 v2 v3) = IfThenElse <$> (g v1 >>= g') <*> (g v2 >>= g') <*> (g v3 >>= g')
@@ -182,6 +184,7 @@ everywhereOnValuesM f g h = (f', g', h')
g' (TypeClassDictionaryConstructorApp name v) = (TypeClassDictionaryConstructorApp name <$> g' v) >>= g
g' (Accessor prop v) = (Accessor prop <$> g' v) >>= g
g' (ObjectUpdate obj vs) = (ObjectUpdate <$> g' obj <*> traverse (sndM g') vs) >>= g
+ g' (ObjectUpdateNested obj vs) = (ObjectUpdateNested <$> g' obj <*> traverse g' vs) >>= g
g' (Abs name v) = (Abs name <$> g' v) >>= g
g' (App v1 v2) = (App <$> g' v1 <*> g' v2) >>= g
g' (IfThenElse v1 v2 v3) = (IfThenElse <$> g' v1 <*> g' v2 <*> g' v3) >>= g
@@ -254,6 +257,7 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j')
g' v@(TypeClassDictionaryConstructorApp _ v1) = g v <> g' v1
g' v@(Accessor _ v1) = g v <> g' v1
g' v@(ObjectUpdate obj vs) = foldl (<>) (g v <> g' obj) (map (g' . snd) vs)
+ g' v@(ObjectUpdateNested obj vs) = foldl (<>) (g v <> g' obj) (fmap g' vs)
g' v@(Abs _ v1) = g v <> g' v1
g' v@(App v1 v2) = g v <> g' v1 <> g' v2
g' v@(IfThenElse v1 v2 v3) = g v <> g' v1 <> g' v2 <> g' v3
@@ -331,6 +335,7 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'
g' s (TypeClassDictionaryConstructorApp _ v1) = g'' s v1
g' s (Accessor _ v1) = g'' s v1
g' s (ObjectUpdate obj vs) = foldl (<>) (g'' s obj) (map (g'' s . snd) vs)
+ g' s (ObjectUpdateNested obj vs) = foldl (<>) (g'' s obj) (fmap (g'' s) vs)
g' s (Abs _ v1) = g'' s v1
g' s (App v1 v2) = g'' s v1 <> g'' s v2
g' s (IfThenElse v1 v2 v3) = g'' s v1 <> g'' s v2 <> g'' s v3
@@ -410,6 +415,7 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j
g' s (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> g'' s v
g' s (Accessor prop v) = Accessor prop <$> g'' s v
g' s (ObjectUpdate obj vs) = ObjectUpdate <$> g'' s obj <*> traverse (sndM (g'' s)) vs
+ g' s (ObjectUpdateNested obj vs) = ObjectUpdateNested <$> g'' s obj <*> traverse (g'' s) vs
g' s (Abs name v) = Abs name <$> g'' s v
g' s (App v1 v2) = App <$> g'' s v1 <*> g'' s v2
g' s (IfThenElse v1 v2 v3) = IfThenElse <$> g'' s v1 <*> g'' s v2 <*> g'' s v3
@@ -500,6 +506,7 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)
g' s (TypeClassDictionaryConstructorApp _ v1) = g'' s v1
g' s (Accessor _ v1) = g'' s v1
g' s (ObjectUpdate obj vs) = g'' s obj <> foldMap (g'' s . snd) vs
+ g' s (ObjectUpdateNested obj vs) = g'' s obj <> foldMap (g'' s) vs
g' s (Abs (Left name) v1) =
let s' = S.insert name s
in g'' s' v1
diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index 0abc9de..2631d62 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -35,7 +35,7 @@ import Language.PureScript.Errors (ErrorMessageHint(..), SimpleErrorMessage(..),
errorMessage, rethrowWithPosition, addHint)
import Language.PureScript.Names
import Language.PureScript.Options
-import Language.PureScript.PSString (PSString, mkString, decodeString)
+import Language.PureScript.PSString (PSString, mkString)
import Language.PureScript.Traversals (sndM)
import qualified Language.PureScript.Constants as C
@@ -69,7 +69,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
let standardExps = exps \\ foreignExps
let exps' = JSObjectLiteral Nothing $ map (mkString . runIdent &&& JSVar Nothing . identToJs) standardExps
++ map (mkString . runIdent &&& foreignIdent) foreignExps
- return $ moduleBody ++ [JSAssignment Nothing (JSAccessor Nothing "exports" (JSVar Nothing "module")) exps']
+ return $ moduleBody ++ [JSAssignment Nothing (accessorString "exports" (JSVar Nothing "module")) exps']
where
@@ -138,8 +138,8 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
-- Generate code in the simplified Javascript intermediate representation for a declaration
--
bindToJs :: Bind Ann -> m [JS]
- bindToJs (NonRec ann ident val) = return <$> nonRecToJS ann ident val
- bindToJs (Rec vals) = forM vals (uncurry . uncurry $ nonRecToJS)
+ bindToJs (NonRec ann ident val) = nonRecToJS ann ident val
+ bindToJs (Rec vals) = concat <$> forM vals (uncurry . uncurry $ nonRecToJS)
-- |
-- Generate code in the simplified Javascript intermediate representation for a single non-recursive
@@ -147,15 +147,22 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
--
-- The main purpose of this function is to handle code generation for comments.
--
- nonRecToJS :: Ann -> Ident -> Expr Ann -> m JS
+ nonRecToJS :: Ann -> Ident -> Expr Ann -> m [JS]
nonRecToJS a i e@(extractAnn -> (_, com, _, _)) | not (null com) = do
withoutComment <- asks optionsNoComments
if withoutComment
then nonRecToJS a i (modifyAnn removeComments e)
- else JSComment Nothing com <$> nonRecToJS a i (modifyAnn removeComments e)
+ else withHead (JSComment Nothing com) <$> nonRecToJS a i (modifyAnn removeComments e)
+ where
+ withHead _ [] = []
+ withHead f (x:xs) = f x : xs
nonRecToJS (ss, _, _, _) ident val = do
- js <- valueToJs val
- withPos ss $ JSVariableIntroduction Nothing (identToJs ident) (Just js)
+ case constructorToJs ident val of
+ Just jss ->
+ traverse (withPos ss) jss
+ Nothing -> do
+ js <- valueToJs val
+ return <$> (withPos ss $ JSVariableIntroduction Nothing (identToJs ident) (Just js))
withPos :: Maybe SourceSpan -> JS -> m JS
withPos (Just ss) js = do
@@ -182,12 +189,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
accessor (GenIdent _ _) = internalError "GenIdent in accessor"
accessorString :: PSString -> JS -> JS
- accessorString prop =
- case decodeString prop of
- Just s | not (identNeedsEscaping s) ->
- JSAccessor Nothing s
- _ ->
- JSIndexer Nothing (JSStringLiteral Nothing prop)
+ accessorString prop = JSIndexer Nothing (JSStringLiteral Nothing prop)
-- |
-- Generate code in the simplified Javascript intermediate representation for a value or expression.
@@ -201,9 +203,9 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
valueToJs' (Literal (pos, _, _, _) l) =
maybe id rethrowWithPosition pos $ literalToValueJS l
valueToJs' (Var (_, _, _, Just (IsConstructor _ [])) name) =
- return $ JSAccessor Nothing "value" $ qualifiedToJS id name
+ return $ accessorString "value" $ qualifiedToJS id name
valueToJs' (Var (_, _, _, Just (IsConstructor _ _)) name) =
- return $ JSAccessor Nothing "create" $ qualifiedToJS id name
+ return $ accessorString "create" $ qualifiedToJS id name
valueToJs' (Accessor _ prop val) =
accessorString prop <$> valueToJs val
valueToJs' (ObjectUpdate _ o ps) = do
@@ -256,23 +258,37 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
JSObjectLiteral Nothing [("create",
JSFunction Nothing Nothing ["value"]
(JSBlock Nothing [JSReturn Nothing $ JSVar Nothing "value"]))])
- valueToJs' (Constructor _ _ (ProperName ctor) []) =
- return $ iife (properToJs ctor) [ JSFunction Nothing (Just (properToJs ctor)) [] (JSBlock Nothing [])
- , JSAssignment Nothing (JSAccessor Nothing "value" (JSVar Nothing (properToJs ctor)))
- (JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing (properToJs ctor)) []) ]
- valueToJs' (Constructor _ _ (ProperName ctor) fields) =
- let constructor =
- let body = [ JSAssignment Nothing (JSAccessor Nothing (identToJs f) (JSVar Nothing "this")) (var f) | f <- fields ]
- in JSFunction Nothing (Just (properToJs ctor)) (identToJs `map` fields) (JSBlock Nothing body)
- createFn =
- let body = JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing (properToJs ctor)) (var `map` fields)
- in foldr (\f inner -> JSFunction Nothing Nothing [identToJs f] (JSBlock Nothing [JSReturn Nothing inner])) body fields
- in return $ iife (properToJs ctor) [ constructor
- , JSAssignment Nothing (JSAccessor Nothing "create" (JSVar Nothing (properToJs ctor))) createFn
- ]
-
- iife :: Text -> [JS] -> JS
- iife v exprs = JSApp Nothing (JSFunction Nothing Nothing [] (JSBlock Nothing $ exprs ++ [JSReturn Nothing $ JSVar Nothing v])) []
+ valueToJs' (Constructor _ _ (ProperName ctor) _) =
+ internalError $ "Unexpected constructor definition: " ++ T.unpack ctor
+
+ -- |
+ -- Attempt to generate code in the simplified JS intermediate representation for a constructor definition.
+ -- If the argument is not a constructor, this returns Nothing.
+ --
+ constructorToJs :: Ident -> Expr Ann -> Maybe [JS]
+ constructorToJs ident (Constructor _ _ (ProperName ctor) fs) =
+ Just jss
+ where
+ mkAccessor name = JSAssignment Nothing (accessorString name (JSVar Nothing (identToJs ident)))
+ jss = case fs of
+ [] ->
+ [ JSVariableIntroduction Nothing (identToJs ident) (Just $
+ JSFunction Nothing (Just (properToJs ctor)) [] (JSBlock Nothing []))
+ , mkAccessor "value" $
+ JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing (identToJs ident)) []
+ ]
+ fields ->
+ let constructor =
+ let body = [ JSAssignment Nothing ((accessorString $ mkString $ identToJs f) (JSVar Nothing "this")) (var f) | f <- fields ]
+ in JSFunction Nothing (Just (properToJs ctor)) (identToJs `map` fields) (JSBlock Nothing body)
+ createFn =
+ let body = JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing (properToJs ctor)) (var `map` fields)
+ in foldr (\f inner -> JSFunction Nothing Nothing [identToJs f] (JSBlock Nothing [JSReturn Nothing inner])) body fields
+ in [ constructor
+ , mkAccessor "create" createFn
+ ]
+ constructorToJs _ _ =
+ Nothing
literalToValueJS :: Literal (Expr Ann) -> m JS
literalToValueJS (NumericLiteral (Left i)) = return $ JSNumericLiteral Nothing (Left i)
@@ -299,7 +315,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 "call" (JSAccessor Nothing "hasOwnProperty" (JSObjectLiteral Nothing []))) [jsEvaluatedObj, jsKey]
+ cond = JSApp Nothing (accessorString "call" (accessorString "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
@@ -356,7 +372,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
valueError _ l@(JSNumericLiteral _ _) = l
valueError _ l@(JSStringLiteral _ _) = l
valueError _ l@(JSBooleanLiteral _ _) = l
- valueError s _ = JSAccessor Nothing "name" . JSAccessor Nothing "constructor" $ JSVar Nothing s
+ valueError s _ = accessorString "name" . accessorString "constructor" $ JSVar Nothing s
guardsToJs :: Either [(Guard Ann, Expr Ann)] (Expr Ann) -> m [JS]
guardsToJs (Left gs) = forM gs $ \(cond, val) -> do
@@ -397,7 +413,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
argVar <- freshName
done'' <- go remain done'
js <- binderToJs argVar done'' binder
- return (JSVariableIntroduction Nothing argVar (Just (JSAccessor Nothing (identToJs field) (JSVar Nothing varName))) : js)
+ return (JSVariableIntroduction Nothing argVar (Just $ accessorString (mkString $ identToJs field) $ JSVar Nothing varName) : js)
binderToJs' _ _ ConstructorBinder{} =
internalError "binderToJs: Invalid ConstructorBinder in binderToJs"
binderToJs' varName done (NamedBinder _ ident binder) = do
@@ -426,7 +442,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
return (JSVariableIntroduction Nothing propVar (Just (accessorString prop (JSVar Nothing varName))) : js)
literalToBinderJS varName done (ArrayLiteral bs) = do
js <- go done 0 bs
- return [JSIfElse Nothing (JSBinary Nothing EqualTo (JSAccessor Nothing "length" (JSVar Nothing varName)) (JSNumericLiteral Nothing (Left (fromIntegral $ length bs)))) (JSBlock Nothing js) Nothing]
+ return [JSIfElse Nothing (JSBinary Nothing EqualTo (accessorString "length" (JSVar Nothing varName)) (JSNumericLiteral Nothing (Left (fromIntegral $ length bs)))) (JSBlock Nothing js) Nothing]
where
go :: [JS] -> Integer -> [Binder Ann] -> m [JS]
go done' _ [] = return done'
diff --git a/src/Language/PureScript/CodeGen/JS/AST.hs b/src/Language/PureScript/CodeGen/JS/AST.hs
index 8f3583c..a8c196f 100644
--- a/src/Language/PureScript/CodeGen/JS/AST.hs
+++ b/src/Language/PureScript/CodeGen/JS/AST.hs
@@ -159,10 +159,6 @@ data JS
--
| JSObjectLiteral (Maybe SourceSpan) [(PSString, JS)]
-- |
- -- An object property accessor expression
- --
- | JSAccessor (Maybe SourceSpan) Text JS
- -- |
-- A function introduction (optional name, arguments, body)
--
| JSFunction (Maybe SourceSpan) (Maybe Text) [Text] JS
@@ -259,7 +255,6 @@ withSourceSpan withSpan = go
go (JSArrayLiteral _ js) = JSArrayLiteral ss js
go (JSIndexer _ j1 j2) = JSIndexer ss j1 j2
go (JSObjectLiteral _ js) = JSObjectLiteral ss js
- go (JSAccessor _ prop j) = JSAccessor ss prop j
go (JSFunction _ name args j) = JSFunction ss name args j
go (JSApp _ j js) = JSApp ss j js
go (JSVar _ s) = JSVar ss s
@@ -293,7 +288,6 @@ getSourceSpan = go
go (JSArrayLiteral ss _) = ss
go (JSIndexer ss _ _) = ss
go (JSObjectLiteral ss _) = ss
- go (JSAccessor ss _ _) = ss
go (JSFunction ss _ _ _) = ss
go (JSApp ss _ _) = ss
go (JSVar ss _) = ss
@@ -328,7 +322,6 @@ everywhereOnJS f = go
go (JSArrayLiteral ss js) = f (JSArrayLiteral ss (map go js))
go (JSIndexer ss j1 j2) = f (JSIndexer ss (go j1) (go j2))
go (JSObjectLiteral ss js) = f (JSObjectLiteral ss (map (fmap go) js))
- go (JSAccessor ss prop j) = f (JSAccessor ss prop (go j))
go (JSFunction ss name args j) = f (JSFunction ss name args (go j))
go (JSApp ss j js) = f (JSApp ss (go j) (map go js))
go (JSConditional ss j1 j2 j3) = f (JSConditional ss (go j1) (go j2) (go j3))
@@ -359,7 +352,6 @@ everywhereOnJSTopDownM f = f >=> go
go (JSArrayLiteral ss js) = JSArrayLiteral ss <$> traverse f' js
go (JSIndexer ss j1 j2) = JSIndexer ss <$> f' j1 <*> f' j2
go (JSObjectLiteral ss js) = JSObjectLiteral ss <$> traverse (sndM f') js
- go (JSAccessor ss prop j) = JSAccessor ss prop <$> f' j
go (JSFunction ss name args j) = JSFunction ss name args <$> f' j
go (JSApp ss j js) = JSApp ss <$> f' j <*> traverse f' js
go (JSConditional ss j1 j2 j3) = JSConditional ss <$> f' j1 <*> f' j2 <*> f' j3
@@ -386,7 +378,6 @@ everythingOnJS (<>) f = go
go j@(JSArrayLiteral _ js) = foldl (<>) (f j) (map go js)
go j@(JSIndexer _ j1 j2) = f j <> go j1 <> go j2
go j@(JSObjectLiteral _ js) = foldl (<>) (f j) (map (go . snd) js)
- go j@(JSAccessor _ _ j1) = f j <> go j1
go j@(JSFunction _ _ _ j1) = f j <> go j1
go j@(JSApp _ j1 js) = foldl (<>) (f j <> go j1) (map go js)
go j@(JSConditional _ j1 j2 j3) = f j <> go j1 <> go j2 <> go j3
diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer.hs b/src/Language/PureScript/CodeGen/JS/Optimizer.hs
index c504a77..69f9b5b 100644
--- a/src/Language/PureScript/CodeGen/JS/Optimizer.hs
+++ b/src/Language/PureScript/CodeGen/JS/Optimizer.hs
@@ -46,7 +46,7 @@ optimize js = do
optimize' :: (MonadReader Options m, MonadSupply m) => JS -> m JS
optimize' js = do
opts <- ask
- js' <- untilFixedPoint (inlineFnComposition . tidyUp . applyAll
+ js' <- untilFixedPoint (inlineFnComposition . inlineUnsafePartial . tidyUp . applyAll
[ inlineCommonValues
, inlineCommonOperators
]) js
diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs
index 3fc9ca3..763626a 100644
--- a/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs
+++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs
@@ -11,7 +11,7 @@ import Data.Maybe (fromMaybe)
import Language.PureScript.Crash
import Language.PureScript.CodeGen.JS.AST
-import Language.PureScript.PSString (mkString)
+import Language.PureScript.PSString (PSString)
applyAll :: [a -> a] -> a -> a
applyAll = foldl' (.) id
@@ -55,7 +55,6 @@ isUsed var1 = everythingOnJS (||) check
targetVariable :: JS -> Text
targetVariable (JSVar _ var) = var
-targetVariable (JSAccessor _ _ tgt) = targetVariable tgt
targetVariable (JSIndexer _ _ tgt) = targetVariable tgt
targetVariable _ = internalError "Invalid argument to targetVariable"
@@ -70,16 +69,10 @@ removeFromBlock :: ([JS] -> [JS]) -> JS -> JS
removeFromBlock go (JSBlock ss sts) = JSBlock ss (go sts)
removeFromBlock _ js = js
-isFn :: (Text, Text) -> JS -> Bool
-isFn (moduleName, fnName) (JSAccessor _ x (JSVar _ y)) =
- x == fnName && y == moduleName
-isFn (moduleName, fnName) (JSIndexer _ (JSStringLiteral _ x) (JSVar _ y)) =
- x == mkString fnName && y == moduleName
-isFn _ _ = False
-
-isDict :: (Text, Text) -> JS -> Bool
-isDict (moduleName, dictName) (JSAccessor _ x (JSVar _ y)) = x == dictName && y == moduleName
+isDict :: (Text, PSString) -> JS -> Bool
+isDict (moduleName, dictName) (JSIndexer _ (JSStringLiteral _ x) (JSVar _ y)) =
+ x == dictName && y == moduleName
isDict _ _ = False
-isDict' :: [(Text, Text)] -> JS -> Bool
+isDict' :: [(Text, PSString)] -> JS -> Bool
isDict' xs js = any (`isDict` js) xs
diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs
index 753b63d..deea258 100644
--- a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs
+++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs
@@ -6,6 +6,7 @@ module Language.PureScript.CodeGen.JS.Optimizer.Inliner
, inlineCommonValues
, inlineCommonOperators
, inlineFnComposition
+ , inlineUnsafePartial
, etaConvert
, unThunk
, evaluateIifes
@@ -17,9 +18,11 @@ import Control.Monad.Supply.Class (MonadSupply, freshName)
import Data.Maybe (fromMaybe)
import Data.Monoid ((<>))
+import Data.String (IsString, fromString)
import Data.Text (Text)
import qualified Data.Text as T
+import Language.PureScript.PSString (PSString)
import Language.PureScript.CodeGen.JS.AST
import Language.PureScript.CodeGen.JS.Optimizer.Common
import qualified Language.PureScript.Constants as C
@@ -33,7 +36,6 @@ shouldInline (JSVar _ _) = True
shouldInline (JSNumericLiteral _ _) = True
shouldInline (JSStringLiteral _ _) = True
shouldInline (JSBooleanLiteral _ _) = True
-shouldInline (JSAccessor _ _ val) = shouldInline val
shouldInline (JSIndexer _ index val) = shouldInline index && shouldInline val
shouldInline _ = False
@@ -65,6 +67,8 @@ evaluateIifes = everywhereOnJS convert
where
convert :: JS -> JS
convert (JSApp _ (JSFunction _ Nothing [] (JSBlock _ [JSReturn _ ret])) []) = ret
+ convert (JSApp _ (JSFunction _ Nothing idents (JSBlock _ [JSReturn ss ret])) [])
+ | not (any (`isReassigned` ret) idents) = replaceIdents (map (, JSVar ss C.undefined) idents) ret
convert js = js
inlineVariables :: JS -> JS
@@ -82,15 +86,17 @@ inlineCommonValues = everywhereOnJS convert
where
convert :: JS -> JS
convert (JSApp ss fn [dict])
- | isDict' [semiringNumber, semiringInt] dict && isFn fnZero fn = JSNumericLiteral ss (Left 0)
- | isDict' [semiringNumber, semiringInt] dict && isFn fnOne fn = JSNumericLiteral ss (Left 1)
- | isDict boundedBoolean dict && isFn fnBottom fn = JSBooleanLiteral ss False
- | isDict boundedBoolean dict && isFn fnTop fn = JSBooleanLiteral ss True
+ | isDict' [semiringNumber, semiringInt] dict && isDict fnZero fn = JSNumericLiteral ss (Left 0)
+ | isDict' [semiringNumber, semiringInt] dict && isDict fnOne fn = JSNumericLiteral ss (Left 1)
+ | isDict boundedBoolean dict && isDict fnBottom fn = JSBooleanLiteral ss False
+ | isDict boundedBoolean dict && isDict fnTop fn = JSBooleanLiteral ss True
+ convert (JSApp ss (JSApp _ fn [dict]) [x])
+ | isDict ringInt dict && isDict fnNegate fn = JSBinary ss BitwiseOr (JSUnary ss Negate x) (JSNumericLiteral ss (Left 0))
convert (JSApp ss (JSApp _ (JSApp _ fn [dict]) [x]) [y])
- | isDict semiringInt dict && isFn fnAdd fn = intOp ss Add x y
- | isDict semiringInt dict && isFn fnMultiply fn = intOp ss Multiply x y
- | isDict euclideanRingInt dict && isFn fnDivide fn = intOp ss Divide x y
- | isDict ringInt dict && isFn fnSubtract fn = intOp ss Subtract x y
+ | isDict semiringInt dict && isDict fnAdd fn = intOp ss Add x y
+ | isDict semiringInt dict && isDict fnMultiply fn = intOp ss Multiply x y
+ | isDict euclideanRingInt dict && isDict fnDivide fn = intOp ss Divide x y
+ | isDict ringInt dict && isDict fnSubtract fn = intOp ss Subtract x y
convert other = other
fnZero = (C.dataSemiring, C.zero)
fnOne = (C.dataSemiring, C.one)
@@ -100,17 +106,16 @@ inlineCommonValues = everywhereOnJS convert
fnDivide = (C.dataEuclideanRing, C.div)
fnMultiply = (C.dataSemiring, C.mul)
fnSubtract = (C.dataRing, C.sub)
+ fnNegate = (C.dataRing, C.negate)
intOp ss op x y = JSBinary ss BitwiseOr (JSBinary ss op x y) (JSNumericLiteral ss (Left 0))
inlineCommonOperators :: JS -> JS
-inlineCommonOperators = applyAll $
+inlineCommonOperators = everywhereOnJSTopDown $ applyAll $
[ binary semiringNumber opAdd Add
, binary semiringNumber opMul Multiply
, binary ringNumber opSub Subtract
, unary ringNumber opNegate Negate
- , binary ringInt opSub Subtract
- , unary ringInt opNegate Negate
, binary euclideanRingNumber opDiv Divide
, binary euclideanRingInt opMod Modulus
@@ -167,39 +172,33 @@ inlineCommonOperators = applyAll $
] ++
[ fn | i <- [0..10], fn <- [ mkFn i, runFn i ] ]
where
- binary :: (Text, Text) -> (Text, Text) -> BinaryOperator -> JS -> JS
- binary dict fns op = everywhereOnJS convert
- where
+ binary :: (Text, PSString) -> (Text, PSString) -> BinaryOperator -> JS -> JS
+ binary dict fns op = convert where
convert :: JS -> JS
- convert (JSApp ss (JSApp _ (JSApp _ fn [dict']) [x]) [y]) | isDict dict dict' && isFn fns fn = JSBinary ss op x y
+ convert (JSApp ss (JSApp _ (JSApp _ fn [dict']) [x]) [y]) | isDict dict dict' && isDict fns fn = JSBinary ss op x y
convert other = other
- binary' :: Text -> Text -> BinaryOperator -> JS -> JS
- binary' moduleName opString op = everywhereOnJS convert
- where
+ binary' :: Text -> PSString -> BinaryOperator -> JS -> JS
+ binary' moduleName opString op = convert where
convert :: JS -> JS
- convert (JSApp ss (JSApp _ fn [x]) [y]) | isFn (moduleName, opString) fn = JSBinary ss op x y
+ convert (JSApp ss (JSApp _ fn [x]) [y]) | isDict (moduleName, opString) fn = JSBinary ss op x y
convert other = other
- unary :: (Text, Text) -> (Text, Text) -> UnaryOperator -> JS -> JS
- unary dicts fns op = everywhereOnJS convert
- where
+ unary :: (Text, PSString) -> (Text, PSString) -> UnaryOperator -> JS -> JS
+ unary dicts fns op = convert where
convert :: JS -> JS
- convert (JSApp ss (JSApp _ fn [dict']) [x]) | isDict dicts dict' && isFn fns fn = JSUnary ss op x
+ convert (JSApp ss (JSApp _ fn [dict']) [x]) | isDict dicts dict' && isDict fns fn = JSUnary ss op x
convert other = other
- unary' :: Text -> Text -> UnaryOperator -> JS -> JS
- unary' moduleName fnName op = everywhereOnJS convert
- where
+ unary' :: Text -> PSString -> UnaryOperator -> JS -> JS
+ unary' moduleName fnName op = convert where
convert :: JS -> JS
- convert (JSApp ss fn [x]) | isFn (moduleName, fnName) fn = JSUnary ss op x
+ convert (JSApp ss fn [x]) | isDict (moduleName, fnName) fn = JSUnary ss op x
convert other = other
mkFn :: Int -> JS -> JS
- mkFn 0 = everywhereOnJS convert
- where
+ mkFn 0 = convert where
convert :: JS -> JS
convert (JSApp _ mkFnN [JSFunction s1 Nothing [_] (JSBlock s2 js)]) | isNFn C.mkFn 0 mkFnN =
JSFunction s1 Nothing [] (JSBlock s2 js)
convert other = other
- mkFn n = everywhereOnJS convert
- where
+ mkFn n = convert where
convert :: JS -> JS
convert orig@(JSApp ss mkFnN [fn]) | isNFn C.mkFn n mkFnN =
case collectArgs n [] fn of
@@ -213,12 +212,12 @@ inlineCommonOperators = applyAll $
isNFn :: Text -> Int -> JS -> Bool
isNFn prefix n (JSVar _ name) = name == (prefix <> T.pack (show n))
- isNFn prefix n (JSAccessor _ name (JSVar _ dataFunctionUncurried)) | dataFunctionUncurried == C.dataFunctionUncurried = name == (prefix <> T.pack (show n))
+ isNFn prefix n (JSIndexer _ (JSStringLiteral _ name) (JSVar _ dataFunctionUncurried)) | dataFunctionUncurried == C.dataFunctionUncurried =
+ name == fromString (T.unpack prefix <> show n)
isNFn _ _ _ = False
runFn :: Int -> JS -> JS
- runFn n = everywhereOnJS convert
- where
+ runFn n = convert where
convert :: JS -> JS
convert js = fromMaybe js $ go n [] js
@@ -228,26 +227,26 @@ inlineCommonOperators = applyAll $
go _ _ _ = Nothing
inlineNonClassFunction :: (JS -> Bool) -> (JS -> JS -> JS) -> JS -> JS
- inlineNonClassFunction p f = everywhereOnJS convert
- where
+ inlineNonClassFunction p f = convert where
convert :: JS -> JS
convert (JSApp _ (JSApp _ op' [x]) [y]) | p op' = f x y
convert other = other
- isModFn :: (Text, Text) -> JS -> Bool
- isModFn (m, op) (JSAccessor _ op' (JSVar _ m')) = m == m' && op == op'
+ isModFn :: (Text, PSString) -> JS -> Bool
+ isModFn (m, op) (JSIndexer _ (JSStringLiteral _ op') (JSVar _ m')) =
+ m == m' && op == op'
isModFn _ _ = False
- isModFnWithDict :: (Text, Text) -> JS -> Bool
- isModFnWithDict (m, op) (JSApp _ (JSAccessor _ op' (JSVar _ m')) [JSVar _ _]) = m == m' && op == op'
+ isModFnWithDict :: (Text, PSString) -> JS -> Bool
+ isModFnWithDict (m, op) (JSApp _ (JSIndexer _ (JSStringLiteral _ op') (JSVar _ m')) [JSVar _ _]) =
+ m == m' && op == op'
isModFnWithDict _ _ = False
-- (f <<< g $ x) = f (g x)
-- (f <<< g) = \x -> f (g x)
-inlineFnComposition :: (MonadSupply m) => JS -> m JS
-inlineFnComposition = everywhereOnJSTopDownM convert
- where
- convert :: (MonadSupply m) => JS -> m JS
+inlineFnComposition :: forall m. MonadSupply m => JS -> m JS
+inlineFnComposition = everywhereOnJSTopDownM convert where
+ convert :: JS -> m JS
convert (JSApp s1 (JSApp s2 (JSApp _ (JSApp _ fn [dict']) [x]) [y]) [z])
| isFnCompose dict' fn = return $ JSApp s1 x [JSApp s2 y [z]]
| isFnComposeFlipped dict' fn = return $ JSApp s2 y [JSApp s1 x [z]]
@@ -260,118 +259,127 @@ inlineFnComposition = everywhereOnJSTopDownM convert
return $ JSFunction ss Nothing [arg] (JSBlock ss [JSReturn Nothing $ JSApp Nothing y [JSApp Nothing x [JSVar Nothing arg]]])
convert other = return other
isFnCompose :: JS -> JS -> Bool
- isFnCompose dict' fn = isDict semigroupoidFn dict' && isFn fnCompose fn
+ isFnCompose dict' fn = isDict semigroupoidFn dict' && isDict fnCompose fn
isFnComposeFlipped :: JS -> JS -> Bool
- isFnComposeFlipped dict' fn = isDict semigroupoidFn dict' && isFn fnComposeFlipped fn
- fnCompose :: (Text, Text)
+ isFnComposeFlipped dict' fn = isDict semigroupoidFn dict' && isDict fnComposeFlipped fn
+ fnCompose :: forall a b. (IsString a, IsString b) => (a, b)
fnCompose = (C.controlSemigroupoid, C.compose)
- fnComposeFlipped :: (Text, Text)
+ fnComposeFlipped :: forall a b. (IsString a, IsString b) => (a, b)
fnComposeFlipped = (C.controlSemigroupoid, C.composeFlipped)
-semiringNumber :: (Text, Text)
+inlineUnsafePartial :: JS -> JS
+inlineUnsafePartial = everywhereOnJSTopDown convert where
+ convert (JSApp ss (JSIndexer _ (JSStringLiteral _ unsafePartial) (JSVar _ partialUnsafe)) [ comp ])
+ | unsafePartial == C.unsafePartial && partialUnsafe == C.partialUnsafe
+ -- Apply to undefined here, the application should be optimized away
+ -- if it is safe to do so
+ = JSApp ss comp [ JSVar ss C.undefined ]
+ convert other = other
+
+semiringNumber :: forall a b. (IsString a, IsString b) => (a, b)
semiringNumber = (C.dataSemiring, C.semiringNumber)
-semiringInt :: (Text, Text)
+semiringInt :: forall a b. (IsString a, IsString b) => (a, b)
semiringInt = (C.dataSemiring, C.semiringInt)
-ringNumber :: (Text, Text)
+ringNumber :: forall a b. (IsString a, IsString b) => (a, b)
ringNumber = (C.dataRing, C.ringNumber)
-ringInt :: (Text, Text)
+ringInt :: forall a b. (IsString a, IsString b) => (a, b)
ringInt = (C.dataRing, C.ringInt)
-euclideanRingNumber :: (Text, Text)
+euclideanRingNumber :: forall a b. (IsString a, IsString b) => (a, b)
euclideanRingNumber = (C.dataEuclideanRing, C.euclideanRingNumber)
-euclideanRingInt :: (Text, Text)
+euclideanRingInt :: forall a b. (IsString a, IsString b) => (a, b)
euclideanRingInt = (C.dataEuclideanRing, C.euclideanRingInt)
-eqNumber :: (Text, Text)
+eqNumber :: forall a b. (IsString a, IsString b) => (a, b)
eqNumber = (C.dataEq, C.eqNumber)
-eqInt :: (Text, Text)
+eqInt :: forall a b. (IsString a, IsString b) => (a, b)
eqInt = (C.dataEq, C.eqInt)
-eqString :: (Text, Text)
+eqString :: forall a b. (IsString a, IsString b) => (a, b)
eqString = (C.dataEq, C.eqString)
-eqChar :: (Text, Text)
+eqChar :: forall a b. (IsString a, IsString b) => (a, b)
eqChar = (C.dataEq, C.eqChar)
-eqBoolean :: (Text, Text)
+eqBoolean :: forall a b. (IsString a, IsString b) => (a, b)
eqBoolean = (C.dataEq, C.eqBoolean)
-ordBoolean :: (Text, Text)
+ordBoolean :: forall a b. (IsString a, IsString b) => (a, b)
ordBoolean = (C.dataOrd, C.ordBoolean)
-ordNumber :: (Text, Text)
+ordNumber :: forall a b. (IsString a, IsString b) => (a, b)
ordNumber = (C.dataOrd, C.ordNumber)
-ordInt :: (Text, Text)
+ordInt :: forall a b. (IsString a, IsString b) => (a, b)
ordInt = (C.dataOrd, C.ordInt)
-ordString :: (Text, Text)
+ordString :: forall a b. (IsString a, IsString b) => (a, b)
ordString = (C.dataOrd, C.ordString)
-ordChar :: (Text, Text)
+ordChar :: forall a b. (IsString a, IsString b) => (a, b)
ordChar = (C.dataOrd, C.ordChar)
-semigroupString :: (Text, Text)
+semigroupString :: forall a b. (IsString a, IsString b) => (a, b)
semigroupString = (C.dataSemigroup, C.semigroupString)
-boundedBoolean :: (Text, Text)
+boundedBoolean :: forall a b. (IsString a, IsString b) => (a, b)
boundedBoolean = (C.dataBounded, C.boundedBoolean)
-heytingAlgebraBoolean :: (Text, Text)
+heytingAlgebraBoolean :: forall a b. (IsString a, IsString b) => (a, b)
heytingAlgebraBoolean = (C.dataHeytingAlgebra, C.heytingAlgebraBoolean)
-semigroupoidFn :: (Text, Text)
+semigroupoidFn :: forall a b. (IsString a, IsString b) => (a, b)
semigroupoidFn = (C.controlSemigroupoid, C.semigroupoidFn)
-opAdd :: (Text, Text)
+opAdd :: forall a b. (IsString a, IsString b) => (a, b)
opAdd = (C.dataSemiring, C.add)
-opMul :: (Text, Text)
+opMul :: forall a b. (IsString a, IsString b) => (a, b)
opMul = (C.dataSemiring, C.mul)
-opEq :: (Text, Text)
+opEq :: forall a b. (IsString a, IsString b) => (a, b)
opEq = (C.dataEq, C.eq)
-opNotEq :: (Text, Text)
+opNotEq :: forall a b. (IsString a, IsString b) => (a, b)
opNotEq = (C.dataEq, C.notEq)
-opLessThan :: (Text, Text)
+opLessThan :: forall a b. (IsString a, IsString b) => (a, b)
opLessThan = (C.dataOrd, C.lessThan)
-opLessThanOrEq :: (Text, Text)
+opLessThanOrEq :: forall a b. (IsString a, IsString b) => (a, b)
opLessThanOrEq = (C.dataOrd, C.lessThanOrEq)
-opGreaterThan :: (Text, Text)
+opGreaterThan :: forall a b. (IsString a, IsString b) => (a, b)
opGreaterThan = (C.dataOrd, C.greaterThan)
-opGreaterThanOrEq :: (Text, Text)
+opGreaterThanOrEq :: forall a b. (IsString a, IsString b) => (a, b)
opGreaterThanOrEq = (C.dataOrd, C.greaterThanOrEq)
-opAppend :: (Text, Text)
+opAppend :: forall a b. (IsString a, IsString b) => (a, b)
opAppend = (C.dataSemigroup, C.append)
-opSub :: (Text, Text)
+opSub :: forall a b. (IsString a, IsString b) => (a, b)
opSub = (C.dataRing, C.sub)
-opNegate :: (Text, Text)
+opNegate :: forall a b. (IsString a, IsString b) => (a, b)
opNegate = (C.dataRing, C.negate)
-opDiv :: (Text, Text)
+opDiv :: forall a b. (IsString a, IsString b) => (a, b)
opDiv = (C.dataEuclideanRing, C.div)
-opMod :: (Text, Text)
+opMod :: forall a b. (IsString a, IsString b) => (a, b)
opMod = (C.dataEuclideanRing, C.mod)
-opConj :: (Text, Text)
+opConj :: forall a b. (IsString a, IsString b) => (a, b)
opConj = (C.dataHeytingAlgebra, C.conj)
-opDisj :: (Text, Text)
+opDisj :: forall a b. (IsString a, IsString b) => (a, b)
opDisj = (C.dataHeytingAlgebra, C.disj)
-opNot :: (Text, Text)
+opNot :: forall a b. (IsString a, IsString b) => (a, b)
opNot = (C.dataHeytingAlgebra, C.not)
diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs
index bb37d2c..0d545a8 100644
--- a/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs
+++ b/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs
@@ -64,11 +64,11 @@ magicDo' = everywhereOnJS undo . everywhereOnJSTopDown convert
isPure (JSApp _ fn [dict]) | isDict (C.eff, C.applicativeEffDictionary) dict && isPurePoly fn = True
isPure _ = False
-- Check if an expression represents the polymorphic >>= function
- isBindPoly = isFn (C.controlBind, C.bind)
+ isBindPoly = isDict (C.controlBind, C.bind)
-- Check if an expression represents the polymorphic pure or return function
- isPurePoly = isFn (C.controlApplicative, C.pure')
+ isPurePoly = isDict (C.controlApplicative, C.pure')
-- Check if an expression represents a function in the Eff module
- isEffFunc name (JSAccessor _ name' (JSVar _ eff)) = eff == C.eff && name == name'
+ isEffFunc name (JSIndexer _ (JSStringLiteral _ name') (JSVar _ eff)) = eff == C.eff && name == name'
isEffFunc _ _ = False
-- Remove __do function applications which remain after desugaring
@@ -107,14 +107,14 @@ inlineST = everywhereOnJS convertBlock
convert agg (JSApp s1 f [arg]) | isSTFunc C.newSTRef f =
JSFunction s1 Nothing [] (JSBlock s1 [JSReturn s1 $ if agg then arg else JSObjectLiteral s1 [(mkString C.stRefValue, arg)]])
convert agg (JSApp _ (JSApp s1 f [ref]) []) | isSTFunc C.readSTRef f =
- if agg then ref else JSAccessor s1 C.stRefValue ref
+ if agg then ref else JSIndexer s1 (JSStringLiteral s1 C.stRefValue) ref
convert agg (JSApp _ (JSApp _ (JSApp s1 f [ref]) [arg]) []) | isSTFunc C.writeSTRef f =
- if agg then JSAssignment s1 ref arg else JSAssignment s1 (JSAccessor s1 C.stRefValue ref) arg
+ if agg then JSAssignment s1 ref arg else JSAssignment s1 (JSIndexer s1 (JSStringLiteral s1 C.stRefValue) ref) arg
convert agg (JSApp _ (JSApp _ (JSApp s1 f [ref]) [func]) []) | isSTFunc C.modifySTRef f =
- if agg then JSAssignment s1 ref (JSApp s1 func [ref]) else JSAssignment s1 (JSAccessor s1 C.stRefValue ref) (JSApp s1 func [JSAccessor s1 C.stRefValue ref])
+ if agg then JSAssignment s1 ref (JSApp s1 func [ref]) else JSAssignment s1 (JSIndexer s1 (JSStringLiteral s1 C.stRefValue) ref) (JSApp s1 func [JSIndexer s1 (JSStringLiteral s1 C.stRefValue) ref])
convert _ other = other
-- Check if an expression represents a function in the ST module
- isSTFunc name (JSAccessor _ name' (JSVar _ st)) = st == C.st && name == name'
+ isSTFunc name (JSIndexer _ (JSStringLiteral _ name') (JSVar _ st)) = st == C.st && name == name'
isSTFunc _ _ = False
-- Find all ST Refs initialized in this block
findSTRefsIn = everythingOnJS (++) isSTRef
diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs
index 0a3850d..1b3f080 100644
--- a/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs
+++ b/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs
@@ -80,7 +80,17 @@ tco' = everywhereOnJS convert
countSelfCallsUnderFunctions _ = 0
countSelfCallsWithFnArgs :: JS -> Int
- countSelfCallsWithFnArgs ret = if isSelfCallWithFnArgs ident ret [] then 1 else 0
+ countSelfCallsWithFnArgs = go [] where
+ go acc (JSVar _ ident')
+ | ident == ident' && any hasFunction acc = 1
+ go acc (JSApp _ fn args) = go (args ++ acc) fn
+ go _ _ = 0
+
+ hasFunction :: JS -> Bool
+ hasFunction = getAny . everythingOnJS mappend (Any . isFunction)
+ where
+ isFunction JSFunction{} = True
+ isFunction _ = False
toLoop :: Text -> [Text] -> JS -> JS
toLoop ident allArgs js = JSBlock rootSS $
@@ -108,14 +118,3 @@ tco' = everywhereOnJS convert
isSelfCall ident (JSApp _ (JSVar _ ident') _) = ident == ident'
isSelfCall ident (JSApp _ fn _) = isSelfCall ident fn
isSelfCall _ _ = False
-
- isSelfCallWithFnArgs :: Text -> JS -> [JS] -> Bool
- isSelfCallWithFnArgs ident (JSVar _ ident') args | ident == ident' && any hasFunction args = True
- isSelfCallWithFnArgs ident (JSApp _ fn args) acc = isSelfCallWithFnArgs ident fn (args ++ acc)
- isSelfCallWithFnArgs _ _ _ = False
-
- hasFunction :: JS -> Bool
- hasFunction = getAny . everythingOnJS mappend (Any . isFunction)
- where
- isFunction JSFunction{} = True
- isFunction _ = False
diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs
index 3d9351d..baf9c10 100644
--- a/src/Language/PureScript/Constants.hs
+++ b/src/Language/PureScript/Constants.hs
@@ -2,319 +2,319 @@
module Language.PureScript.Constants where
import Prelude.Compat
-import Data.Text (Text)
+import Data.String (IsString)
import Language.PureScript.Names
-- Operators
-($) :: Text
+($) :: forall a. (IsString a) => a
($) = "$"
-apply :: Text
+apply :: forall a. (IsString a) => a
apply = "apply"
-(#) :: Text
+(#) :: forall a. (IsString a) => a
(#) = "#"
-applyFlipped :: Text
+applyFlipped :: forall a. (IsString a) => a
applyFlipped = "applyFlipped"
-(<>) :: Text
+(<>) :: forall a. (IsString a) => a
(<>) = "<>"
-(++) :: Text
+(++) :: forall a. (IsString a) => a
(++) = "++"
-append :: Text
+append :: forall a. (IsString a) => a
append = "append"
-(>>=) :: Text
+(>>=) :: forall a. (IsString a) => a
(>>=) = ">>="
-bind :: Text
+bind :: forall a. (IsString a) => a
bind = "bind"
-(+) :: Text
+(+) :: forall a. (IsString a) => a
(+) = "+"
-add :: Text
+add :: forall a. (IsString a) => a
add = "add"
-(-) :: Text
+(-) :: forall a. (IsString a) => a
(-) = "-"
-sub :: Text
+sub :: forall a. (IsString a) => a
sub = "sub"
-(*) :: Text
+(*) :: forall a. (IsString a) => a
(*) = "*"
-mul :: Text
+mul :: forall a. (IsString a) => a
mul = "mul"
-(/) :: Text
+(/) :: forall a. (IsString a) => a
(/) = "/"
-div :: Text
+div :: forall a. (IsString a) => a
div = "div"
-(%) :: Text
+(%) :: forall a. (IsString a) => a
(%) = "%"
-mod :: Text
+mod :: forall a. (IsString a) => a
mod = "mod"
-(<) :: Text
+(<) :: forall a. (IsString a) => a
(<) = "<"
-lessThan :: Text
+lessThan :: forall a. (IsString a) => a
lessThan = "lessThan"
-(>) :: Text
+(>) :: forall a. (IsString a) => a
(>) = ">"
-greaterThan :: Text
+greaterThan :: forall a. (IsString a) => a
greaterThan = "greaterThan"
-(<=) :: Text
+(<=) :: forall a. (IsString a) => a
(<=) = "<="
-lessThanOrEq :: Text
+lessThanOrEq :: forall a. (IsString a) => a
lessThanOrEq = "lessThanOrEq"
-(>=) :: Text
+(>=) :: forall a. (IsString a) => a
(>=) = ">="
-greaterThanOrEq :: Text
+greaterThanOrEq :: forall a. (IsString a) => a
greaterThanOrEq = "greaterThanOrEq"
-(==) :: Text
+(==) :: forall a. (IsString a) => a
(==) = "=="
-eq :: Text
+eq :: forall a. (IsString a) => a
eq = "eq"
-(/=) :: Text
+(/=) :: forall a. (IsString a) => a
(/=) = "/="
-notEq :: Text
+notEq :: forall a. (IsString a) => a
notEq = "notEq"
-compare :: Text
+compare :: forall a. (IsString a) => a
compare = "compare"
-(&&) :: Text
+(&&) :: forall a. (IsString a) => a
(&&) = "&&"
-conj :: Text
+conj :: forall a. (IsString a) => a
conj = "conj"
-(||) :: Text
+(||) :: forall a. (IsString a) => a
(||) = "||"
-disj :: Text
+disj :: forall a. (IsString a) => a
disj = "disj"
-unsafeIndex :: Text
+unsafeIndex :: forall a. (IsString a) => a
unsafeIndex = "unsafeIndex"
-or :: Text
+or :: forall a. (IsString a) => a
or = "or"
-and :: Text
+and :: forall a. (IsString a) => a
and = "and"
-xor :: Text
+xor :: forall a. (IsString a) => a
xor = "xor"
-(<<<) :: Text
+(<<<) :: forall a. (IsString a) => a
(<<<) = "<<<"
-compose :: Text
+compose :: forall a. (IsString a) => a
compose = "compose"
-(>>>) :: Text
+(>>>) :: forall a. (IsString a) => a
(>>>) = ">>>"
-composeFlipped :: Text
+composeFlipped :: forall a. (IsString a) => a
composeFlipped = "composeFlipped"
-map :: Text
+map :: forall a. (IsString a) => a
map = "map"
-- Functions
-negate :: Text
+negate :: forall a. (IsString a) => a
negate = "negate"
-not :: Text
+not :: forall a. (IsString a) => a
not = "not"
-shl :: Text
+shl :: forall a. (IsString a) => a
shl = "shl"
-shr :: Text
+shr :: forall a. (IsString a) => a
shr = "shr"
-zshr :: Text
+zshr :: forall a. (IsString a) => a
zshr = "zshr"
-complement :: Text
+complement :: forall a. (IsString a) => a
complement = "complement"
-- Prelude Values
-zero :: Text
+zero :: forall a. (IsString a) => a
zero = "zero"
-one :: Text
+one :: forall a. (IsString a) => a
one = "one"
-bottom :: Text
+bottom :: forall a. (IsString a) => a
bottom = "bottom"
-top :: Text
+top :: forall a. (IsString a) => a
top = "top"
-return :: Text
+return :: forall a. (IsString a) => a
return = "return"
-pure' :: Text
+pure' :: forall a. (IsString a) => a
pure' = "pure"
-returnEscaped :: Text
+returnEscaped :: forall a. (IsString a) => a
returnEscaped = "$return"
-untilE :: Text
+untilE :: forall a. (IsString a) => a
untilE = "untilE"
-whileE :: Text
+whileE :: forall a. (IsString a) => a
whileE = "whileE"
-runST :: Text
+runST :: forall a. (IsString a) => a
runST = "runST"
-stRefValue :: Text
+stRefValue :: forall a. (IsString a) => a
stRefValue = "value"
-newSTRef :: Text
+newSTRef :: forall a. (IsString a) => a
newSTRef = "newSTRef"
-readSTRef :: Text
+readSTRef :: forall a. (IsString a) => a
readSTRef = "readSTRef"
-writeSTRef :: Text
+writeSTRef :: forall a. (IsString a) => a
writeSTRef = "writeSTRef"
-modifySTRef :: Text
+modifySTRef :: forall a. (IsString a) => a
modifySTRef = "modifySTRef"
-mkFn :: Text
+mkFn :: forall a. (IsString a) => a
mkFn = "mkFn"
-runFn :: Text
+runFn :: forall a. (IsString a) => a
runFn = "runFn"
-unit :: Text
+unit :: forall a. (IsString a) => a
unit = "unit"
-- Prim values
-undefined :: Text
+undefined :: forall a. (IsString a) => a
undefined = "undefined"
-- Type Class Dictionary Names
-monadEffDictionary :: Text
+monadEffDictionary :: forall a. (IsString a) => a
monadEffDictionary = "monadEff"
-applicativeEffDictionary :: Text
+applicativeEffDictionary :: forall a. (IsString a) => a
applicativeEffDictionary = "applicativeEff"
-bindEffDictionary :: Text
+bindEffDictionary :: forall a. (IsString a) => a
bindEffDictionary = "bindEff"
-semiringNumber :: Text
+semiringNumber :: forall a. (IsString a) => a
semiringNumber = "semiringNumber"
-semiringInt :: Text
+semiringInt :: forall a. (IsString a) => a
semiringInt = "semiringInt"
-ringNumber :: Text
+ringNumber :: forall a. (IsString a) => a
ringNumber = "ringNumber"
-ringInt :: Text
+ringInt :: forall a. (IsString a) => a
ringInt = "ringInt"
-moduloSemiringNumber :: Text
+moduloSemiringNumber :: forall a. (IsString a) => a
moduloSemiringNumber = "moduloSemiringNumber"
-moduloSemiringInt :: Text
+moduloSemiringInt :: forall a. (IsString a) => a
moduloSemiringInt = "moduloSemiringInt"
-euclideanRingNumber :: Text
+euclideanRingNumber :: forall a. (IsString a) => a
euclideanRingNumber = "euclideanRingNumber"
-euclideanRingInt :: Text
+euclideanRingInt :: forall a. (IsString a) => a
euclideanRingInt = "euclideanRingInt"
-ordBoolean :: Text
+ordBoolean :: forall a. (IsString a) => a
ordBoolean = "ordBoolean"
-ordNumber :: Text
+ordNumber :: forall a. (IsString a) => a
ordNumber = "ordNumber"
-ordInt :: Text
+ordInt :: forall a. (IsString a) => a
ordInt = "ordInt"
-ordString :: Text
+ordString :: forall a. (IsString a) => a
ordString = "ordString"
-ordChar :: Text
+ordChar :: forall a. (IsString a) => a
ordChar = "ordChar"
-eqNumber :: Text
+eqNumber :: forall a. (IsString a) => a
eqNumber = "eqNumber"
-eqInt :: Text
+eqInt :: forall a. (IsString a) => a
eqInt = "eqInt"
-eqString :: Text
+eqString :: forall a. (IsString a) => a
eqString = "eqString"
-eqChar :: Text
+eqChar :: forall a. (IsString a) => a
eqChar = "eqChar"
-eqBoolean :: Text
+eqBoolean :: forall a. (IsString a) => a
eqBoolean = "eqBoolean"
-boundedBoolean :: Text
+boundedBoolean :: forall a. (IsString a) => a
boundedBoolean = "boundedBoolean"
-booleanAlgebraBoolean :: Text
+booleanAlgebraBoolean :: forall a. (IsString a) => a
booleanAlgebraBoolean = "booleanAlgebraBoolean"
-heytingAlgebraBoolean :: Text
+heytingAlgebraBoolean :: forall a. (IsString a) => a
heytingAlgebraBoolean = "heytingAlgebraBoolean"
-semigroupString :: Text
+semigroupString :: forall a. (IsString a) => a
semigroupString = "semigroupString"
-semigroupoidFn :: Text
+semigroupoidFn :: forall a. (IsString a) => a
semigroupoidFn = "semigroupoidFn"
-- Generic Deriving
-generic :: Text
+generic :: forall a. (IsString a) => a
generic = "Generic"
-toSpine :: Text
+toSpine :: forall a. (IsString a) => a
toSpine = "toSpine"
-fromSpine :: Text
+fromSpine :: forall a. (IsString a) => a
fromSpine = "fromSpine"
-toSignature :: Text
+toSignature :: forall a. (IsString a) => a
toSignature = "toSignature"
-- Data.Symbol
@@ -352,12 +352,12 @@ orderingGT = Qualified (Just typeDataOrdering) (ProperName "GT")
-- Main module
-main :: Text
+main :: forall a. (IsString a) => a
main = "main"
-- Prim
-partial :: Text
+partial :: forall a. (IsString a) => a
partial = "Partial"
pattern Prim :: ModuleName
@@ -369,78 +369,87 @@ pattern Partial = Qualified (Just Prim) (ProperName "Partial")
pattern Fail :: Qualified (ProperName 'ClassName)
pattern Fail = Qualified (Just Prim) (ProperName "Fail")
-typ :: Text
+pattern Warn :: Qualified (ProperName 'ClassName)
+pattern Warn = Qualified (Just Prim) (ProperName "Warn")
+
+typ :: forall a. (IsString a) => a
typ = "Type"
-effect :: Text
+effect :: forall a. (IsString a) => a
effect = "Effect"
-symbol :: Text
+symbol :: forall a. (IsString a) => a
symbol = "Symbol"
-- Code Generation
-__superclass_ :: Text
+__superclass_ :: forall a. (IsString a) => a
__superclass_ = "__superclass_"
-__unused :: Text
+__unused :: forall a. (IsString a) => a
__unused = "__unused"
-- Modules
-prim :: Text
+prim :: forall a. (IsString a) => a
prim = "Prim"
-prelude :: Text
+prelude :: forall a. (IsString a) => a
prelude = "Prelude"
-dataArray :: Text
+dataArray :: forall a. (IsString a) => a
dataArray = "Data_Array"
-eff :: Text
+eff :: forall a. (IsString a) => a
eff = "Control_Monad_Eff"
-st :: Text
+st :: forall a. (IsString a) => a
st = "Control_Monad_ST"
-controlApplicative :: Text
+controlApplicative :: forall a. (IsString a) => a
controlApplicative = "Control_Applicative"
-controlSemigroupoid :: Text
+controlSemigroupoid :: forall a. (IsString a) => a
controlSemigroupoid = "Control_Semigroupoid"
-controlBind :: Text
+controlBind :: forall a. (IsString a) => a
controlBind = "Control_Bind"
-dataBounded :: Text
+dataBounded :: forall a. (IsString a) => a
dataBounded = "Data_Bounded"
-dataSemigroup :: Text
+dataSemigroup :: forall a. (IsString a) => a
dataSemigroup = "Data_Semigroup"
-dataHeytingAlgebra :: Text
+dataHeytingAlgebra :: forall a. (IsString a) => a
dataHeytingAlgebra = "Data_HeytingAlgebra"
-dataEq :: Text
+dataEq :: forall a. (IsString a) => a
dataEq = "Data_Eq"
-dataOrd :: Text
+dataOrd :: forall a. (IsString a) => a
dataOrd = "Data_Ord"
-dataSemiring :: Text
+dataSemiring :: forall a. (IsString a) => a
dataSemiring = "Data_Semiring"
-dataRing :: Text
+dataRing :: forall a. (IsString a) => a
dataRing = "Data_Ring"
-dataEuclideanRing :: Text
+dataEuclideanRing :: forall a. (IsString a) => a
dataEuclideanRing = "Data_EuclideanRing"
-dataFunction :: Text
+dataFunction :: forall a. (IsString a) => a
dataFunction = "Data_Function"
-dataFunctionUncurried :: Text
+dataFunctionUncurried :: forall a. (IsString a) => a
dataFunctionUncurried = "Data_Function_Uncurried"
-dataIntBits :: Text
+dataIntBits :: forall a. (IsString a) => a
dataIntBits = "Data_Int_Bits"
+
+partialUnsafe :: forall a. (IsString a) => a
+partialUnsafe = "Partial_Unsafe"
+
+unsafePartial :: forall a. (IsString a) => a
+unsafePartial = "unsafePartial"
diff --git a/src/Language/PureScript/Crash.hs b/src/Language/PureScript/Crash.hs
index 4acdea1..1ce2f09 100644
--- a/src/Language/PureScript/Crash.hs
+++ b/src/Language/PureScript/Crash.hs
@@ -1,11 +1,27 @@
-module Language.PureScript.Crash where
-
-import Prelude.Compat
-
--- | Exit with an error message and a crash report link.
-internalError :: String -> a
-internalError =
- error
- . ("An internal error ocurred during compilation: " ++)
- . (++ "\nPlease report this at https://github.com/purescript/purescript/issues")
- . show
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ImplicitParams #-}
+
+module Language.PureScript.Crash where
+
+import Prelude.Compat
+
+import qualified GHC.Stack
+
+-- | A compatibility wrapper for the @GHC.Stack.HasCallStack@ constraint.
+#if __GLASGOW_HASKELL__ >= 800
+type HasCallStack = GHC.Stack.HasCallStack
+#elif MIN_VERSION_GLASGOW_HASKELL(7,10,2,0)
+type HasCallStack = (?callStack :: GHC.Stack.CallStack)
+#else
+import GHC.Exts (Constraint)
+-- CallStack wasn't present in GHC 7.10.1
+type HasCallStack = (() :: Constraint)
+#endif
+
+-- | Exit with an error message and a crash report link.
+internalError :: HasCallStack => String -> a
+internalError =
+ error
+ . ("An internal error occurred during compilation: " ++)
+ . (++ "\nPlease report this at https://github.com/purescript/purescript/issues")
+ . show
diff --git a/src/Language/PureScript/Docs.hs b/src/Language/PureScript/Docs.hs
index 9f36874..7773952 100644
--- a/src/Language/PureScript/Docs.hs
+++ b/src/Language/PureScript/Docs.hs
@@ -8,8 +8,7 @@ module Language.PureScript.Docs (
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.ParseInPackage as Docs
import Language.PureScript.Docs.Render as Docs
-import Language.PureScript.Docs.RenderedCode.Render as Docs
-import Language.PureScript.Docs.RenderedCode.Types as Docs
+import Language.PureScript.Docs.RenderedCode as Docs
import Language.PureScript.Docs.Types as Docs
diff --git a/src/Language/PureScript/Docs/AsHtml.hs b/src/Language/PureScript/Docs/AsHtml.hs
new file mode 100644
index 0000000..dd311e0
--- /dev/null
+++ b/src/Language/PureScript/Docs/AsHtml.hs
@@ -0,0 +1,299 @@
+
+-- | Functions for rendering generated documentation from PureScript code as
+-- HTML.
+
+module Language.PureScript.Docs.AsHtml (
+ HtmlOutput(..),
+ HtmlOutputModule(..),
+ HtmlRenderContext(..),
+ nullRenderContext,
+ declNamespace,
+ packageAsHtml,
+ moduleAsHtml,
+ makeFragment,
+ renderMarkdown
+) where
+
+import Prelude
+import Control.Arrow (second)
+import Control.Category ((>>>))
+import Control.Monad (unless)
+import Data.Char (isUpper)
+import Data.Monoid ((<>))
+import Data.Foldable (for_)
+import Data.String (fromString)
+
+import Data.Text (Text)
+import qualified Data.Text as T
+
+import Text.Blaze.Html5 as H hiding (map)
+import qualified Text.Blaze.Html5.Attributes as A
+import qualified Cheapskate
+
+import qualified Language.PureScript as P
+
+import Language.PureScript.Docs.Types
+import Language.PureScript.Docs.RenderedCode hiding (sp)
+import qualified Language.PureScript.Docs.Render as Render
+
+declNamespace :: Declaration -> Namespace
+declNamespace = declInfoNamespace . declInfo
+
+data HtmlOutput a = HtmlOutput
+ { htmlIndex :: [(Maybe Char, a)]
+ , htmlModules :: [(P.ModuleName, HtmlOutputModule a)]
+ }
+ deriving (Show, Functor)
+
+data HtmlOutputModule a = HtmlOutputModule
+ { htmlOutputModuleLocals :: a
+ , htmlOutputModuleReExports :: [(InPackage P.ModuleName, a)]
+ }
+ deriving (Show, Functor)
+
+data HtmlRenderContext = HtmlRenderContext
+ { currentModuleName :: P.ModuleName
+ , buildDocLink :: Namespace -> Text -> ContainingModule -> Maybe DocLink
+ , renderDocLink :: DocLink -> Text
+ , renderSourceLink :: P.SourceSpan -> Text
+ }
+
+-- |
+-- An HtmlRenderContext for when you don't want to render any links.
+nullRenderContext :: P.ModuleName -> HtmlRenderContext
+nullRenderContext mn = HtmlRenderContext
+ { currentModuleName = mn
+ , buildDocLink = const (const (const Nothing))
+ , renderDocLink = const ""
+ , renderSourceLink = const ""
+ }
+
+packageAsHtml :: (P.ModuleName -> HtmlRenderContext) -> Package a -> HtmlOutput Html
+packageAsHtml getHtmlCtx Package{..} =
+ HtmlOutput indexFile modules
+ where
+ indexFile = []
+ modules = map (\m -> moduleAsHtml (getHtmlCtx (modName m)) m) pkgModules
+
+moduleAsHtml :: HtmlRenderContext -> Module -> (P.ModuleName, HtmlOutputModule Html)
+moduleAsHtml r Module{..} = (modName, HtmlOutputModule modHtml reexports)
+ where
+ renderDecl = declAsHtml r
+ modHtml = do
+ for_ modComments renderMarkdown
+ for_ modDeclarations renderDecl
+ reexports =
+ map (second (foldMap renderDecl)) modReExports
+
+-- renderIndex :: LinksContext -> [(Maybe Char, Html)]
+-- renderIndex LinksContext{..} = go ctxBookmarks
+-- where
+-- go = takeLocals
+-- >>> groupIndex getIndex renderEntry
+-- >>> map (second (ul . mconcat))
+--
+-- getIndex (_, title_) = do
+-- c <- textHeadMay title_
+-- guard (toUpper c `elem` ['A'..'Z'])
+-- pure c
+--
+-- textHeadMay t =
+-- case T.length t of
+-- 0 -> Nothing
+-- _ -> Just (T.index t 0)
+--
+-- renderEntry (mn, title_) =
+-- li $ do
+-- let url = T.pack (filePathFor mn `relativeTo` "index") <> "#" <> title_
+-- code $
+-- a ! A.href (v url) $ text title_
+-- sp
+-- text ("(" <> P.runModuleName mn <> ")")
+--
+-- groupIndex :: Ord i => (a -> Maybe i) -> (a -> b) -> [a] -> [(Maybe i, [b])]
+-- groupIndex f g =
+-- map (second DList.toList) . M.toList . foldr go' M.empty . sortBy (comparing f)
+-- where
+-- go' x = insertOrAppend (f x) (g x)
+-- insertOrAppend idx val m =
+-- let cur = M.findWithDefault DList.empty idx m
+-- new = DList.snoc cur val
+-- in M.insert idx new m
+
+declAsHtml :: HtmlRenderContext -> Declaration -> Html
+declAsHtml r d@Declaration{..} = do
+ let declFragment = makeFragment (declInfoNamespace declInfo) declTitle
+ H.div ! A.class_ "decl" ! A.id (v (T.drop 1 declFragment)) $ do
+ h3 ! A.class_ "decl__title clearfix" $ do
+ a ! A.class_ "decl__anchor" ! A.href (v declFragment) $ "#"
+ text declTitle
+ for_ declSourceSpan (linkToSource r)
+
+ H.div ! A.class_ "decl__body" $ do
+ case declInfo of
+ AliasDeclaration fixity alias_ ->
+ renderAlias fixity alias_
+ _ ->
+ pre ! A.class_ "decl__signature" $ code $
+ codeAsHtml r (Render.renderDeclaration d)
+
+ for_ declComments renderMarkdown
+
+ let (instances, dctors, members) = partitionChildren declChildren
+
+ unless (null dctors) $ do
+ h4 "Constructors"
+ renderChildren r dctors
+
+ unless (null members) $ do
+ h4 "Members"
+ renderChildren r members
+
+ unless (null instances) $ do
+ h4 "Instances"
+ renderChildren r instances
+ where
+ linkToSource :: HtmlRenderContext -> P.SourceSpan -> Html
+ linkToSource ctx srcspan =
+ H.span ! A.class_ "decl__source" $
+ a ! A.href (v (renderSourceLink ctx srcspan)) $ text "Source"
+
+renderChildren :: HtmlRenderContext -> [ChildDeclaration] -> Html
+renderChildren _ [] = return ()
+renderChildren r xs = ul $ mapM_ go xs
+ where
+ go decl = item decl . code . codeAsHtml r . Render.renderChildDeclaration $ decl
+ item decl = let fragment = makeFragment (childDeclInfoNamespace (cdeclInfo decl)) (cdeclTitle decl)
+ in li ! A.id (v (T.drop 1 fragment))
+
+codeAsHtml :: HtmlRenderContext -> RenderedCode -> Html
+codeAsHtml r = outputWith elemAsHtml
+ where
+ elemAsHtml e = case e of
+ Syntax x ->
+ withClass "syntax" (text x)
+ Keyword x ->
+ withClass "keyword" (text x)
+ Space ->
+ text " "
+ Symbol ns name link_ ->
+ case link_ of
+ Link mn ->
+ let
+ class_ = if startsWithUpper name then "ctor" else "ident"
+ in
+ linkToDecl ns name mn (withClass class_ (text name))
+ NoLink ->
+ text name
+
+ linkToDecl = linkToDeclaration r
+
+ startsWithUpper :: Text -> Bool
+ startsWithUpper str =
+ if T.null str
+ then False
+ else isUpper (T.index str 0)
+
+renderLink :: HtmlRenderContext -> DocLink -> Html -> Html
+renderLink r link_@DocLink{..} =
+ a ! A.href (v (renderDocLink r link_ <> fragmentFor link_))
+ ! A.title (v fullyQualifiedName)
+ where
+ fullyQualifiedName = case linkLocation of
+ SameModule -> fq (currentModuleName r) linkTitle
+ LocalModule _ modName -> fq modName linkTitle
+ DepsModule _ _ _ modName -> fq modName linkTitle
+ BuiltinModule modName -> fq modName linkTitle
+
+ fq mn str = P.runModuleName mn <> "." <> str
+
+makeFragment :: Namespace -> Text -> Text
+makeFragment ns = (prefix <>) . escape
+ where
+ prefix = case ns of
+ TypeLevel -> "#t:"
+ ValueLevel -> "#v:"
+ KindLevel -> "#k:"
+
+ -- TODO
+ escape = id
+
+fragmentFor :: DocLink -> Text
+fragmentFor l = makeFragment (linkNamespace l) (linkTitle l)
+
+linkToDeclaration ::
+ HtmlRenderContext ->
+ Namespace ->
+ Text ->
+ ContainingModule ->
+ Html ->
+ Html
+linkToDeclaration r ns target containMn =
+ maybe id (renderLink r) (buildDocLink r ns target containMn)
+
+renderAlias :: P.Fixity -> FixityAlias -> Html
+renderAlias (P.Fixity associativity precedence) alias_ =
+ p $ do
+ -- TODO: Render a link
+ toHtml $ "Operator alias for " <> P.showQualified showAliasName alias_ <> " "
+ em $
+ text ("(" <> associativityStr <> " / precedence " <> T.pack (show precedence) <> ")")
+ where
+ showAliasName (Left valueAlias) = P.runProperName valueAlias
+ showAliasName (Right typeAlias) = case typeAlias of
+ (Left identifier) -> P.runIdent identifier
+ (Right properName) -> P.runProperName properName
+ associativityStr = case associativity of
+ P.Infixl -> "left-associative"
+ P.Infixr -> "right-associative"
+ P.Infix -> "non-associative"
+
+-- | Render Markdown to HTML. Safe for untrusted input. Relative links are
+-- | removed.
+renderMarkdown :: Text -> H.Html
+renderMarkdown =
+ H.toMarkup . removeRelativeLinks . Cheapskate.markdown opts
+ where
+ opts = Cheapskate.def { Cheapskate.allowRawHtml = False }
+
+removeRelativeLinks :: Cheapskate.Doc -> Cheapskate.Doc
+removeRelativeLinks = Cheapskate.walk go
+ where
+ go :: Cheapskate.Inlines -> Cheapskate.Inlines
+ go = (>>= stripRelatives)
+
+ stripRelatives :: Cheapskate.Inline -> Cheapskate.Inlines
+ stripRelatives (Cheapskate.Link contents_ href _)
+ | isRelativeURI href = contents_
+ stripRelatives other = pure other
+
+ -- Tests for a ':' character in the first segment of a URI.
+ --
+ -- See Section 4.2 of RFC 3986:
+ -- https://tools.ietf.org/html/rfc3986#section-4.2
+ --
+ -- >>> isRelativeURI "http://example.com/" == False
+ -- >>> isRelativeURI "mailto:me@example.com" == False
+ -- >>> isRelativeURI "foo/bar" == True
+ -- >>> isRelativeURI "/bar" == True
+ -- >>> isRelativeURI "./bar" == True
+ isRelativeURI :: Text -> Bool
+ isRelativeURI =
+ T.takeWhile (/= '/') >>> T.all (/= ':')
+
+v :: Text -> AttributeValue
+v = toValue
+
+withClass :: String -> Html -> Html
+withClass className content = H.span ! A.class_ (fromString className) $ content
+
+partitionChildren ::
+ [ChildDeclaration] ->
+ ([ChildDeclaration], [ChildDeclaration], [ChildDeclaration])
+partitionChildren = foldl go ([], [], [])
+ where
+ go (instances, dctors, members) rcd =
+ case cdeclInfo rcd of
+ ChildInstance _ _ -> (rcd : instances, dctors, members)
+ ChildDataConstructor _ -> (instances, rcd : dctors, members)
+ ChildTypeClassMember _ -> (instances, dctors, rcd : members)
diff --git a/src/Language/PureScript/Docs/AsMarkdown.hs b/src/Language/PureScript/Docs/AsMarkdown.hs
index bcc258e..6cb3b4e 100644
--- a/src/Language/PureScript/Docs/AsMarkdown.hs
+++ b/src/Language/PureScript/Docs/AsMarkdown.hs
@@ -77,12 +77,10 @@ declAsMarkdown mn decl@Declaration{..} = do
codeToString :: RenderedCode -> Text
codeToString = outputWith elemAsMarkdown
where
- elemAsMarkdown (Syntax x) = x
- elemAsMarkdown (Ident x _) = x
- elemAsMarkdown (Ctor x _) = x
- elemAsMarkdown (Kind x) = x
- elemAsMarkdown (Keyword x) = x
- elemAsMarkdown Space = " "
+ elemAsMarkdown (Syntax x) = x
+ elemAsMarkdown (Keyword x) = x
+ elemAsMarkdown Space = " "
+ elemAsMarkdown (Symbol _ x _) = x
-- fixityAsMarkdown :: P.Fixity -> Docs
-- fixityAsMarkdown (P.Fixity associativity precedence) =
diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs
index 541d80b..a564e0a 100644
--- a/src/Language/PureScript/Docs/Convert.hs
+++ b/src/Language/PureScript/Docs/Convert.hs
@@ -3,28 +3,27 @@
module Language.PureScript.Docs.Convert
( convertModules
+ , convertModulesWithEnv
, convertModulesInPackage
- , collectBookmarks
+ , convertModulesInPackageWithEnv
) where
-import Prelude.Compat
+import Protolude hiding (check)
-import Control.Arrow ((&&&), second)
+import Control.Arrow ((&&&))
import Control.Category ((>>>))
-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 Data.Text (Text)
+import Data.String (String)
import Language.PureScript.Docs.Convert.ReExports (updateReExports)
-import Language.PureScript.Docs.Convert.Single (convertSingleModule, collectBookmarks)
+import Language.PureScript.Docs.Convert.Single (convertSingleModule)
import Language.PureScript.Docs.Types
import qualified Language.PureScript as P
import qualified Language.PureScript.Constants as C
+import Web.Bower.PackageMeta (PackageName)
+
import Text.Parsec (eof)
-- |
@@ -34,32 +33,36 @@ import Text.Parsec (eof)
--
convertModulesInPackage ::
(MonadError P.MultipleErrors m) =>
- [InPackage P.Module] ->
+ [P.Module] ->
+ Map P.ModuleName PackageName ->
m [Module]
-convertModulesInPackage modules =
+convertModulesInPackage modules modulesDeps =
+ fmap fst (convertModulesInPackageWithEnv modules modulesDeps)
+
+convertModulesInPackageWithEnv ::
+ (MonadError P.MultipleErrors m) =>
+ [P.Module] ->
+ Map P.ModuleName PackageName ->
+ m ([Module], P.Env)
+convertModulesInPackageWithEnv modules modulesDeps =
go modules
where
- localNames =
- map P.getModuleName (takeLocals modules)
go =
- map ignorePackage
- >>> convertModules withPackage
- >>> fmap (filter ((`elem` localNames) . modName))
+ convertModulesWithEnv withPackage
+ >>> fmap (first (filter (isLocal . 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)
+ case Map.lookup mn modulesDeps of
+ Just pkgName -> FromDep pkgName mn
+ Nothing -> Local mn
+
+ isLocal :: P.ModuleName -> Bool
+ isLocal = not . flip Map.member modulesDeps
-- |
-- Convert a group of modules to the intermediate format, designed for
--- producing documentation from. It is also necessary to pass an Env containing
--- imports/exports information about the list of modules, which is needed for
--- documenting re-exports.
+-- producing documentation from.
--
-- Note that the whole module dependency graph must be included in the list; if
-- some modules import things from other modules, then those modules must also
@@ -75,6 +78,14 @@ convertModules ::
[P.Module] ->
m [Module]
convertModules withPackage =
+ fmap fst . convertModulesWithEnv withPackage
+
+convertModulesWithEnv ::
+ (MonadError P.MultipleErrors m) =>
+ (P.ModuleName -> InPackage P.ModuleName) ->
+ [P.Module] ->
+ m ([Module], P.Env)
+convertModulesWithEnv withPackage =
P.sortModules
>>> fmap (fst >>> map importPrim)
>=> convertSorted withPackage
@@ -83,21 +94,22 @@ importPrim :: P.Module -> P.Module
importPrim = P.addDefaultImport (P.ModuleName [P.ProperName C.prim])
-- |
--- Convert a sorted list of modules.
+-- Convert a sorted list of modules, returning both the list of converted
+-- modules and the Env produced during desugaring.
--
convertSorted ::
(MonadError P.MultipleErrors m) =>
(P.ModuleName -> InPackage P.ModuleName) ->
[P.Module] ->
- m [Module]
+ m ([Module], P.Env)
convertSorted withPackage modules = do
(env, convertedModules) <- second (map convertSingleModule) <$> partiallyDesugar modules
modulesWithTypes <- typeCheckIfNecessary modules convertedModules
- let moduleMap = Map.fromList (map (modName &&& id) modulesWithTypes)
+ let moduleMap = Map.fromList (map (modName &&& identity) modulesWithTypes)
let traversalOrder = map P.getModuleName modules
- pure (Map.elems (updateReExports env traversalOrder withPackage moduleMap))
+ pure (Map.elems (updateReExports env traversalOrder withPackage moduleMap), env)
-- |
-- If any exported value declarations have either wildcard type signatures, or
@@ -166,7 +178,7 @@ insertValueTypes env m =
other
parseIdent =
- either (err . ("failed to parse Ident: " ++)) id . runParser P.parseIdent
+ either (err . ("failed to parse Ident: " ++)) identity . runParser P.parseIdent
lookupName name =
let key = P.Qualified (Just (modName m)) name
diff --git a/src/Language/PureScript/Docs/Convert/ReExports.hs b/src/Language/PureScript/Docs/Convert/ReExports.hs
index 044cf98..5946020 100644
--- a/src/Language/PureScript/Docs/Convert/ReExports.hs
+++ b/src/Language/PureScript/Docs/Convert/ReExports.hs
@@ -457,11 +457,8 @@ handleEnv TypeClassEnv{..} =
addConstraint constraint =
P.quantify . P.moveQuantifiersToFront . P.ConstrainedType [constraint]
-splitMap :: (Ord k) => Map k (v1, v2) -> (Map k v1, Map k v2)
-splitMap = foldl go (Map.empty, Map.empty) . Map.toList
- where
- go (m1, m2) (k, (v1, v2)) =
- (Map.insert k v1 m1, Map.insert k v2 m2)
+splitMap :: Map k (v1, v2) -> (Map k v1, Map k v2)
+splitMap = fmap fst &&& fmap snd
-- |
-- Given a list of exported constructor names, remove any data constructor
diff --git a/src/Language/PureScript/Docs/Convert/Single.hs b/src/Language/PureScript/Docs/Convert/Single.hs
index 36dbc36..9e07126 100644
--- a/src/Language/PureScript/Docs/Convert/Single.hs
+++ b/src/Language/PureScript/Docs/Convert/Single.hs
@@ -1,18 +1,11 @@
module Language.PureScript.Docs.Convert.Single
( convertSingleModule
- , collectBookmarks
) where
-import Prelude.Compat
+import Protolude
import Control.Category ((>>>))
-import Control.Monad
-import Data.Either
-import Data.List (nub)
-import Data.Maybe (mapMaybe, fromMaybe)
-import Data.Monoid ((<>))
-import Data.Text (Text)
import qualified Data.Text as T
import Language.PureScript.Docs.Types
@@ -67,7 +60,7 @@ data DeclarationAugment
-- the type synonym IntermediateDeclaration for more information.
augmentDeclarations :: [IntermediateDeclaration] -> [Declaration]
augmentDeclarations (partitionEithers -> (augments, toplevels)) =
- foldl go toplevels augments
+ foldl' go toplevels augments
where
go ds (parentTitles, a) =
map (\d ->
@@ -142,14 +135,14 @@ convertDeclaration (P.TypeInstanceDeclaration _ constraints className tys _) tit
Just (Left (classNameString : typeNameStrings, AugmentChild childDecl))
where
classNameString = unQual className
- typeNameStrings = nub (concatMap (P.everythingOnTypes (++) extractProperNames) tys)
+ typeNameStrings = ordNub (concatMap (P.everythingOnTypes (++) extractProperNames) tys)
unQual x = let (P.Qualified _ y) = x in P.runProperName y
extractProperNames (P.TypeConstructor n) = [unQual n]
extractProperNames _ = []
childDecl = ChildDeclaration title Nothing Nothing (ChildInstance constraints classApp)
- classApp = foldl P.TypeApp (P.TypeConstructor (fmap P.coerceProperName className)) tys
+ 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)))
convertDeclaration (P.TypeFixityDeclaration fixity (P.Qualified mn alias) _) title =
@@ -190,15 +183,3 @@ convertComments cs = do
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
--- generating links in the HTML documentation, for example.
-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, Text)]
-collectBookmarks' m =
- map (P.getModuleName m, )
- (mapMaybe getDeclarationTitle (P.exportedDeclarations m))
diff --git a/src/Language/PureScript/Docs/ParseAndBookmark.hs b/src/Language/PureScript/Docs/ParseAndBookmark.hs
deleted file mode 100644
index c45da01..0000000
--- a/src/Language/PureScript/Docs/ParseAndBookmark.hs
+++ /dev/null
@@ -1,97 +0,0 @@
-module Language.PureScript.Docs.ParseAndBookmark
- ( parseAndBookmark
- ) where
-
-import Prelude.Compat
-
-import Control.Arrow (first)
-import Control.Monad.Error.Class (MonadError(..))
-import Control.Monad.IO.Class (MonadIO(..))
-
-import qualified Data.Map as M
-import Data.Text (Text)
-
-import Language.PureScript.Docs.Convert (collectBookmarks)
-import Language.PureScript.Docs.Types
-import qualified Language.PureScript as P
-import System.IO.UTF8 (readUTF8FileT)
-import Web.Bower.PackageMeta (PackageName)
-
--- |
--- Given:
---
--- * A list of local source files
--- * A list of source files from external dependencies, together with their
--- package names
---
--- This function does the following:
---
--- * Parse all of the input and dependency source files
--- * Associate each dependency module with its package name, thereby
--- distinguishing these from local modules
--- * Collect a list of bookmarks from the whole set of source files
--- * Return the parsed modules and the bookmarks
-parseAndBookmark ::
- (MonadError P.MultipleErrors m, MonadIO m) =>
- [FilePath]
- -> [(PackageName, FilePath)]
- -> m ([InPackage P.Module], [Bookmark])
-parseAndBookmark inputFiles depsFiles = do
- inputFiles' <- traverse (parseAs Local) inputFiles
- depsFiles' <- traverse (\(pkgName, f) -> parseAs (FromDep pkgName) f) depsFiles
-
- addBookmarks <$> parseFiles (inputFiles' ++ depsFiles')
-
-parseFiles ::
- (MonadError P.MultipleErrors m) =>
- [(FileInfo, Text)]
- -> m [(FileInfo, P.Module)]
-parseFiles =
- throwLeft . P.parseModulesFromFiles fileInfoToString
-
-addBookmarks ::
- [(FileInfo, P.Module)]
- -> ([InPackage P.Module], [Bookmark])
-addBookmarks msInfo =
- let
- msDeps = getDepsModuleNames (map (\(fp, m) -> (,m) <$> fp) msInfo)
- msPackages = map (addPackage msDeps . snd) msInfo
- bookmarks = concatMap collectBookmarks msPackages
- in
- (msPackages, bookmarks)
-
-throwLeft :: (MonadError l m) => Either l r -> m r
-throwLeft = either throwError return
-
--- | Specifies whether a PureScript source file is considered as:
---
--- 1) with the `Local` constructor, a target source file, i.e., we want to see
--- its modules in the output
--- 2) with the `FromDep` constructor, a dependencies source file, i.e. we do
--- not want its modules in the output; it is there to enable desugaring, and
--- to ensure that links between modules are constructed correctly.
-type FileInfo = InPackage FilePath
-
-fileInfoToString :: FileInfo -> FilePath
-fileInfoToString (Local fn) = fn
-fileInfoToString (FromDep _ fn) = fn
-
-parseFile :: FilePath -> IO (FilePath, Text)
-parseFile input' = (,) input' <$> readUTF8FileT input'
-
-parseAs :: (MonadIO m) => (FilePath -> a) -> FilePath -> m (a, Text)
-parseAs g = fmap (first g) . liftIO . parseFile
-
-getDepsModuleNames :: [InPackage (FilePath, P.Module)] -> M.Map P.ModuleName PackageName
-getDepsModuleNames = foldl go M.empty
- where
- go deps p = deps # case p of
- Local _ -> id
- FromDep pkgName (_, m) -> M.insert (P.getModuleName m) pkgName
- (#) = flip ($)
-
-addPackage :: M.Map P.ModuleName PackageName -> P.Module -> InPackage P.Module
-addPackage depsModules m =
- case M.lookup (P.getModuleName m) depsModules of
- Just pkgName -> FromDep pkgName m
- Nothing -> Local m
diff --git a/src/Language/PureScript/Docs/ParseInPackage.hs b/src/Language/PureScript/Docs/ParseInPackage.hs
new file mode 100644
index 0000000..311980b
--- /dev/null
+++ b/src/Language/PureScript/Docs/ParseInPackage.hs
@@ -0,0 +1,73 @@
+module Language.PureScript.Docs.ParseInPackage
+ ( parseFilesInPackages
+ ) where
+
+import Protolude
+
+import qualified Data.Map as M
+
+import Language.PureScript.Docs.Types
+import qualified Language.PureScript as P
+import System.IO.UTF8 (readUTF8FileT)
+import Web.Bower.PackageMeta (PackageName)
+
+-- |
+-- Given:
+--
+-- * A list of local source files
+-- * A list of source files from external dependencies, together with their
+-- package names
+--
+-- This function does the following:
+--
+-- * Parse all of the input and dependency source files
+-- * Associate each dependency module with its package name, thereby
+-- distinguishing these from local modules
+-- * Return the parsed modules and a Map mapping module names to package
+-- names for modules which come from dependencies. If a module does not
+-- exist in the map, it can safely be assumed to be local.
+parseFilesInPackages ::
+ (MonadError P.MultipleErrors m, MonadIO m) =>
+ [FilePath]
+ -> [(PackageName, FilePath)]
+ -> m ([P.Module], Map P.ModuleName PackageName)
+parseFilesInPackages inputFiles depsFiles = do
+ inputFiles' <- traverse (readFileAs . Local) inputFiles
+ depsFiles' <- traverse (readFileAs . uncurry FromDep) depsFiles
+
+ modules <- parse (inputFiles' ++ depsFiles')
+
+ let mnMap = M.fromList (mapMaybe (\(inpkg, m) -> (P.getModuleName m,) <$> inPkgToMaybe inpkg) modules)
+
+ pure (map snd modules, mnMap)
+
+ where
+ parse ::
+ (MonadError P.MultipleErrors m) =>
+ [(FileInfo, Text)]
+ -> m [(FileInfo, P.Module)]
+ parse =
+ throwLeft . P.parseModulesFromFiles fileInfoToString
+
+ inPkgToMaybe = \case
+ Local _ -> Nothing
+ FromDep pkgName _ -> Just pkgName
+
+throwLeft :: (MonadError l m) => Either l r -> m r
+throwLeft = either throwError return
+
+-- | Specifies whether a PureScript source file is considered as:
+--
+-- 1) with the `Local` constructor, a target source file, i.e., we want to see
+-- its modules in the output
+-- 2) with the `FromDep` constructor, a dependencies source file, i.e. we do
+-- not want its modules in the output; it is there to enable desugaring, and
+-- to ensure that links between modules are constructed correctly.
+type FileInfo = InPackage FilePath
+
+fileInfoToString :: FileInfo -> FilePath
+fileInfoToString (Local fn) = fn
+fileInfoToString (FromDep _ fn) = fn
+
+readFileAs :: (MonadIO m) => FileInfo -> m (FileInfo, Text)
+readFileAs fi = liftIO . fmap ((fi,)) $ readUTF8FileT (ignorePackage fi)
diff --git a/src/Language/PureScript/Docs/Prim.hs b/src/Language/PureScript/Docs/Prim.hs
index 41b53dc..ba4d0e6 100644
--- a/src/Language/PureScript/Docs/Prim.hs
+++ b/src/Language/PureScript/Docs/Prim.hs
@@ -24,6 +24,7 @@ primDocsModule = Module
, boolean
, partial
, fail
+ , warn
, typeConcat
, typeString
, kindType
@@ -225,6 +226,14 @@ fail = primClass "Fail" $ T.unlines
, "[the Custom Type Errors guide](https://github.com/purescript/documentation/blob/master/guides/Custom-Type-Errors.md)."
]
+warn :: Declaration
+warn = primClass "Warn" $ T.unlines
+ [ "The Warn type class allows a custom compiler warning to be displayed."
+ , ""
+ , "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"
diff --git a/src/Language/PureScript/Docs/Render.hs b/src/Language/PureScript/Docs/Render.hs
index 639824c..b60cae8 100644
--- a/src/Language/PureScript/Docs/Render.hs
+++ b/src/Language/PureScript/Docs/Render.hs
@@ -28,7 +28,7 @@ renderDeclarationWithOptions :: RenderTypeOptions -> Declaration -> RenderedCode
renderDeclarationWithOptions opts Declaration{..} =
mintersperse sp $ case declInfo of
ValueDeclaration ty ->
- [ ident declTitle
+ [ ident' declTitle
, syntax "::"
, renderType' ty
]
@@ -70,40 +70,25 @@ renderDeclarationWithOptions opts Declaration{..} =
[idents from <> sp <> syntax "->" <> sp <> idents to | (from, to) <- fundeps ]
]
where
- idents = mintersperse sp . map ident
+ idents = mintersperse sp . map ident'
- AliasDeclaration (P.Fixity associativity precedence) for@(P.Qualified _ alias) ->
+ AliasDeclaration (P.Fixity associativity precedence) for ->
[ keywordFixity associativity
, syntax $ T.pack $ show precedence
- , ident $ renderQualAlias for
- , keyword "as"
- , ident $ adjustAliasName alias declTitle
+ , alias for
+ , keywordAs
+ , aliasName for declTitle
]
ExternKindDeclaration ->
[ keywordKind
- , renderKind (P.NamedKind (notQualified declTitle))
+ , kind (notQualified declTitle)
]
where
renderType' :: P.Type -> RenderedCode
renderType' = renderTypeWithOptions opts
- renderQualAlias :: FixityAlias -> Text
- renderQualAlias (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)
- -> Either (P.ProperName 'P.TypeName) (Either P.Ident (P.ProperName 'P.ConstructorName))
- -> Text
- renderAlias f
- = either (("type " <>) . f P.runProperName)
- $ either (f P.runIdent) (f P.runProperName)
-
- adjustAliasName _ title = T.tail (T.init title)
-
renderChildDeclaration :: ChildDeclaration -> RenderedCode
renderChildDeclaration = renderChildDeclarationWithOptions defaultRenderTypeOptions
@@ -113,18 +98,17 @@ renderChildDeclarationWithOptions opts ChildDeclaration{..} =
ChildInstance constraints ty ->
maybeToList (renderConstraints constraints) ++ [ renderType' ty ]
ChildDataConstructor args ->
- [ renderType' typeApp' ]
- where
- typeApp' = foldl P.TypeApp ctor' args
- ctor' = P.TypeConstructor (notQualified cdeclTitle)
+ [ dataCtor' cdeclTitle ]
+ ++ map renderTypeAtom' args
ChildTypeClassMember ty ->
- [ ident cdeclTitle
+ [ ident' cdeclTitle
, syntax "::"
, renderType' ty
]
where
renderType' = renderTypeWithOptions opts
+ renderTypeAtom' = renderTypeAtomWithOptions opts
renderConstraint :: P.Constraint -> RenderedCode
renderConstraint = renderConstraintWithOptions defaultRenderTypeOptions
@@ -151,6 +135,12 @@ renderConstraintsWithOptions opts constraints
notQualified :: Text -> P.Qualified (P.ProperName a)
notQualified = P.Qualified Nothing . P.ProperName
+ident' :: Text -> RenderedCode
+ident' = ident . P.Qualified Nothing . P.Ident
+
+dataCtor' :: Text -> RenderedCode
+dataCtor' = dataCtor . notQualified
+
typeApp :: Text -> [(Text, Maybe P.Kind)] -> P.Type
typeApp title typeArgs =
foldl P.TypeApp
diff --git a/src/Language/PureScript/Docs/RenderedCode.hs b/src/Language/PureScript/Docs/RenderedCode.hs
index 27de533..216eba3 100644
--- a/src/Language/PureScript/Docs/RenderedCode.hs
+++ b/src/Language/PureScript/Docs/RenderedCode.hs
@@ -1,8 +1,9 @@
-
--- | Data types and functions for representing a simplified form of PureScript
--- code, intended for use in e.g. HTML documentation.
-
-module Language.PureScript.Docs.RenderedCode (module RenderedCode) where
-
-import Language.PureScript.Docs.RenderedCode.Types as RenderedCode
-import Language.PureScript.Docs.RenderedCode.Render as RenderedCode
+
+-- | Data types and functions for representing a simplified form of PureScript
+-- code, intended for use in e.g. HTML documentation.
+
+module Language.PureScript.Docs.RenderedCode (module RenderedCode) where
+
+import Language.PureScript.Docs.RenderedCode.Types as RenderedCode
+import Language.PureScript.Docs.RenderedCode.RenderType as RenderedCode
+import Language.PureScript.Docs.RenderedCode.RenderKind as RenderedCode
diff --git a/src/Language/PureScript/Docs/RenderedCode/RenderKind.hs b/src/Language/PureScript/Docs/RenderedCode/RenderKind.hs
new file mode 100644
index 0000000..3539a12
--- /dev/null
+++ b/src/Language/PureScript/Docs/RenderedCode/RenderKind.hs
@@ -0,0 +1,57 @@
+-- | Functions for producing RenderedCode values from PureScript Kind values.
+--
+module Language.PureScript.Docs.RenderedCode.RenderKind
+ ( renderKind
+ ) where
+
+-- TODO: This is pretty much copied from Language.PureScript.Pretty.Kinds.
+-- Ideally we would unify the two.
+
+import Prelude.Compat
+
+import Control.Arrow (ArrowPlus(..))
+import Control.PatternArrows as PA
+
+import Data.Monoid ((<>))
+import Data.Maybe (fromMaybe)
+import qualified Data.Text as T
+
+import Language.PureScript.Crash
+import Language.PureScript.Kinds
+
+import Language.PureScript.Docs.RenderedCode.Types
+
+typeLiterals :: Pattern () Kind RenderedCode
+typeLiterals = mkPattern match
+ where
+ match (KUnknown u) =
+ Just $ typeVar $ T.cons 'k' (T.pack (show u))
+ match (NamedKind n) =
+ Just $ kind n
+ match _ = Nothing
+
+matchRow :: Pattern () Kind ((), Kind)
+matchRow = mkPattern match
+ where
+ match (Row k) = Just ((), k)
+ match _ = Nothing
+
+funKind :: Pattern () Kind (Kind, Kind)
+funKind = mkPattern match
+ where
+ match (FunKind arg ret) = Just (arg, ret)
+ match _ = Nothing
+
+-- | Generate RenderedCode value representing a Kind
+renderKind :: Kind -> RenderedCode
+renderKind
+ = fromMaybe (internalError "Incomplete pattern")
+ . PA.pattern matchKind ()
+ where
+ matchKind :: Pattern () Kind RenderedCode
+ matchKind = buildPrettyPrinter operators (typeLiterals <+> fmap parens matchKind)
+
+ operators :: OperatorTable () Kind RenderedCode
+ operators =
+ OperatorTable [ [ Wrap matchRow $ \_ k -> syntax "#" <> sp <> k]
+ , [ AssocR funKind $ \arg ret -> arg <> sp <> syntax "->" <> sp <> ret ] ]
diff --git a/src/Language/PureScript/Docs/RenderedCode/Render.hs b/src/Language/PureScript/Docs/RenderedCode/RenderType.hs
index b8d1008..0a697b8 100644
--- a/src/Language/PureScript/Docs/RenderedCode/Render.hs
+++ b/src/Language/PureScript/Docs/RenderedCode/RenderType.hs
@@ -1,13 +1,13 @@
-- | Functions for producing RenderedCode values from PureScript Type values.
-module Language.PureScript.Docs.RenderedCode.Render
+module Language.PureScript.Docs.RenderedCode.RenderType
( renderType
, renderTypeAtom
, renderRow
- , renderKind
, RenderTypeOptions(..)
, defaultRenderTypeOptions
, renderTypeWithOptions
+ , renderTypeAtomWithOptions
) where
import Prelude.Compat
@@ -20,39 +20,40 @@ import Control.Arrow ((<+>))
import Control.PatternArrows as PA
import Language.PureScript.Crash
-import Language.PureScript.Docs.RenderedCode.Types
-import Language.PureScript.Docs.Utils.MonoidExtras
import Language.PureScript.Environment
import Language.PureScript.Kinds
import Language.PureScript.Names
-import Language.PureScript.Pretty.Kinds
import Language.PureScript.Pretty.Types
import Language.PureScript.Types
import Language.PureScript.Label (Label)
+import Language.PureScript.Docs.RenderedCode.Types
+import Language.PureScript.Docs.Utils.MonoidExtras
+import Language.PureScript.Docs.RenderedCode.RenderKind (renderKind)
+
typeLiterals :: Pattern () Type RenderedCode
typeLiterals = mkPattern match
where
match TypeWildcard{} =
Just (syntax "_")
match (TypeVar var) =
- Just (ident var)
+ Just (typeVar var)
match (PrettyPrintObject row) =
Just $ mintersperse sp
[ syntax "{"
, renderRow row
, syntax "}"
]
- match (TypeConstructor (Qualified mn name)) =
- Just (ctor (runProperName name) (maybeToContainingModule mn))
+ match (TypeConstructor n) =
+ Just (typeCtor n)
match REmpty =
Just (syntax "()")
match row@RCons{} =
Just (syntax "(" <> renderRow row <> syntax ")")
match (BinaryNoParensType op l r) =
Just $ renderTypeAtom l <> sp <> renderTypeAtom op <> sp <> renderTypeAtom r
- match (TypeOp (Qualified mn op)) =
- Just (ident' (runOpName op) (maybeToContainingModule mn))
+ match (TypeOp n) =
+ Just (typeOp n)
match _ =
Nothing
@@ -87,7 +88,7 @@ renderHead = mintersperse (syntax "," <> sp) . map renderLabel
renderLabel :: (Label, Type) -> RenderedCode
renderLabel (label, ty) =
mintersperse sp
- [ syntax $ prettyPrintLabel label
+ [ typeVar $ prettyPrintLabel label
, syntax "::"
, renderType ty
]
@@ -139,7 +140,7 @@ matchType = buildPrettyPrinter operators matchTypeAtom
OperatorTable [ [ AssocL typeApp $ \f x -> f <> sp <> x ]
, [ AssocR appliedFunction $ \arg ret -> mintersperse sp [arg, syntax "->", ret] ]
, [ Wrap constrained $ \deps ty -> renderConstraints deps ty ]
- , [ Wrap forall_ $ \idents ty -> mconcat [syntax "forall", sp, mintersperse sp (map ident idents), syntax ".", sp, ty] ]
+ , [ Wrap forall_ $ \tyVars ty -> mconcat [keywordForall, sp, mintersperse sp (map typeVar tyVars), syntax ".", sp, ty] ]
, [ Wrap kinded $ \k ty -> mintersperse sp [ty, syntax "::", renderKind k] ]
, [ Wrap explicitParens $ \_ ty -> ty ]
]
@@ -154,12 +155,6 @@ insertPlaceholders :: RenderTypeOptions -> Type -> Type
insertPlaceholders opts =
everywhereOnTypesTopDown convertForAlls . everywhereOnTypes (convert opts)
-dePrim :: Type -> Type
-dePrim ty@(TypeConstructor (Qualified _ name))
- | ty == tyBoolean || ty == tyNumber || ty == tyString =
- TypeConstructor $ Qualified Nothing name
-dePrim other = other
-
convert :: RenderTypeOptions -> Type -> Type
convert _ (TypeApp (TypeApp f arg) ret) | f == tyFunction = PrettyPrintFunction arg ret
convert opts (TypeApp o r) | o == tyRecord && prettyPrintObjects opts = PrettyPrintObject r
@@ -173,28 +168,20 @@ convertForAlls (ForAll i ty _) = go [i] ty
convertForAlls other = other
preprocessType :: RenderTypeOptions -> Type -> Type
-preprocessType opts = dePrim . insertPlaceholders opts
+preprocessType opts = insertPlaceholders opts
+
-- |
--- Render code representing a Kind
+-- Render code representing a Type
--
-renderKind :: Kind -> RenderedCode
-renderKind = kind . prettyPrintKind
+renderType :: Type -> RenderedCode
+renderType = renderTypeWithOptions defaultRenderTypeOptions
-- |
-- Render code representing a Type, as it should appear inside parentheses
--
renderTypeAtom :: Type -> RenderedCode
-renderTypeAtom
- = fromMaybe (internalError "Incomplete pattern")
- . PA.pattern matchTypeAtom ()
- . preprocessType defaultRenderTypeOptions
-
--- |
--- Render code representing a Type
---
-renderType :: Type -> RenderedCode
-renderType = renderTypeWithOptions defaultRenderTypeOptions
+renderTypeAtom = renderTypeAtomWithOptions defaultRenderTypeOptions
data RenderTypeOptions = RenderTypeOptions
{ prettyPrintObjects :: Bool
@@ -213,3 +200,9 @@ renderTypeWithOptions opts
= fromMaybe (internalError "Incomplete pattern")
. PA.pattern matchType ()
. preprocessType opts
+
+renderTypeAtomWithOptions :: RenderTypeOptions -> Type -> RenderedCode
+renderTypeAtomWithOptions opts
+ = fromMaybe (internalError "Incomplete pattern")
+ . PA.pattern matchTypeAtom ()
+ . preprocessType opts
diff --git a/src/Language/PureScript/Docs/RenderedCode/Types.hs b/src/Language/PureScript/Docs/RenderedCode/Types.hs
index ea42d66..0d64e30 100644
--- a/src/Language/PureScript/Docs/RenderedCode/Types.hs
+++ b/src/Language/PureScript/Docs/RenderedCode/Types.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE DeriveGeneric #-}
-- | Data types and functions for representing a simplified form of PureScript
-- code, intended for use in e.g. HTML documentation.
@@ -11,15 +12,16 @@ module Language.PureScript.Docs.RenderedCode.Types
, containingModuleToMaybe
, maybeToContainingModule
, fromContainingModule
+ , fromQualified
+ , Namespace(..)
+ , Link(..)
+ , FixityAlias
, RenderedCode
, asRenderedCode
, outputWith
, sp
+ , parens
, syntax
- , ident
- , ident'
- , ctor
- , kind
, keyword
, keywordForall
, keywordData
@@ -30,105 +32,216 @@ module Language.PureScript.Docs.RenderedCode.Types
, keywordWhere
, keywordFixity
, keywordKind
+ , keywordAs
+ , ident
+ , dataCtor
+ , typeCtor
+ , typeOp
+ , typeVar
+ , kind
+ , alias
+ , aliasName
) where
import Prelude.Compat
+import GHC.Generics (Generic)
+import Control.DeepSeq (NFData)
import Control.Monad.Error.Class (MonadError(..))
-import Data.Aeson.BetterErrors
+import Data.Monoid ((<>))
+import Data.Aeson.BetterErrors (Parse, nth, withText, withValue, toAesonParser, perhaps, asText, eachInArray)
import qualified Data.Aeson as A
import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.ByteString.Lazy as BS
+import qualified Data.Text.Encoding as TE
-import qualified Language.PureScript as P
+import Language.PureScript.Names
+import Language.PureScript.AST (Associativity(..))
+import Language.PureScript.Crash (internalError)
--- |
--- A single element in a rendered code fragment. The intention is to support
--- multiple output formats. For example, plain text, or highlighted HTML.
---
-data RenderedCodeElement
- = Syntax Text
- | Ident Text ContainingModule
- | Ctor Text ContainingModule
- | Kind Text
- | Keyword Text
- | Space
- deriving (Show, Eq, Ord)
+-- | Given a list of actions, attempt them all, returning the first success.
+-- If all the actions fail, 'tryAll' returns the first argument.
+tryAll :: MonadError e m => m a -> [m a] -> m a
+tryAll = foldr $ \x y -> catchError x (const y)
-instance A.ToJSON RenderedCodeElement where
- toJSON (Syntax str) =
- A.toJSON ["syntax", str]
- toJSON (Ident str mn) =
- A.toJSON ["ident", A.toJSON str, A.toJSON mn]
- toJSON (Ctor str mn) =
- A.toJSON ["ctor", A.toJSON str, A.toJSON mn ]
- toJSON (Kind str) =
- A.toJSON ["kind", str]
- toJSON (Keyword str) =
- A.toJSON ["keyword", str]
- toJSON Space =
- A.toJSON ["space" :: Text]
-
-asRenderedCodeElement :: Parse Text RenderedCodeElement
-asRenderedCodeElement =
- a Syntax "syntax" <|>
- asIdent <|>
- asCtor <|>
- a Kind "kind" <|>
- a Keyword "keyword" <|>
- asSpace <|>
- unableToParse
+firstEq :: Text -> Parse Text a -> Parse Text a
+firstEq str p = nth 0 (withText (eq str)) *> p
where
- p <|> q = catchError p (const q)
+ eq s s' = if s == s' then Right () else Left ""
- 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
+-- |
+-- Try the given parsers in sequence. If all fail, fail with the given message,
+-- and include the JSON in the error.
+--
+tryParse :: Text -> [Parse Text a] -> Parse Text a
+tryParse msg =
+ tryAll (withValue (Left . (fullMsg <>) . showJSON))
- eq s s' = if s == s' then Right () else Left ""
+ where
+ fullMsg = "Invalid " <> msg <> ": "
- unableToParse = withText Left
+ showJSON :: A.Value -> Text
+ showJSON = TE.decodeUtf8 . BS.toStrict . A.encode
-- |
--- This type is isomorphic to 'Maybe' 'P.ModuleName'. It makes code a bit easier
--- to read, as the meaning is more explicit.
+-- This type is isomorphic to 'Maybe' 'ModuleName'. It makes code a bit
+-- easier to read, as the meaning is more explicit.
--
data ContainingModule
= ThisModule
- | OtherModule P.ModuleName
+ | OtherModule ModuleName
deriving (Show, Eq, Ord)
instance A.ToJSON ContainingModule where
- toJSON mn = A.toJSON (P.runModuleName <$> containingModuleToMaybe mn)
+ toJSON = A.toJSON . go
+ where
+ go = \case
+ ThisModule -> ["ThisModule"]
+ OtherModule mn -> ["OtherModule", runModuleName mn]
-asContainingModule :: Parse e ContainingModule
+instance A.FromJSON ContainingModule where
+ parseJSON = toAesonParser id asContainingModule
+
+asContainingModule :: Parse Text ContainingModule
asContainingModule =
- maybeToContainingModule <$> perhaps (P.moduleNameFromString <$> asText)
+ tryParse "containing module" $
+ current ++ backwardsCompat
+ where
+ current =
+ [ firstEq "ThisModule" (pure ThisModule)
+ , firstEq "OtherModule" (OtherModule <$> nth 1 asModuleName)
+ ]
+
+ -- For JSON produced by compilers up to 0.10.5.
+ backwardsCompat =
+ [ maybeToContainingModule <$> perhaps asModuleName
+ ]
+
+ asModuleName = moduleNameFromString <$> asText
-- |
--- Convert a 'Maybe' 'P.ModuleName' to a 'ContainingModule', using the obvious
+-- Convert a 'Maybe' 'ModuleName' to a 'ContainingModule', using the obvious
-- isomorphism.
--
-maybeToContainingModule :: Maybe P.ModuleName -> ContainingModule
+maybeToContainingModule :: Maybe ModuleName -> ContainingModule
maybeToContainingModule Nothing = ThisModule
maybeToContainingModule (Just mn) = OtherModule mn
-- |
--- Convert a 'ContainingModule' to a 'Maybe' 'P.ModuleName', using the obvious
+-- Convert a 'ContainingModule' to a 'Maybe' 'ModuleName', using the obvious
-- isomorphism.
--
-containingModuleToMaybe :: ContainingModule -> Maybe P.ModuleName
+containingModuleToMaybe :: ContainingModule -> Maybe ModuleName
containingModuleToMaybe ThisModule = Nothing
containingModuleToMaybe (OtherModule mn) = Just mn
-- |
-- A version of 'fromMaybe' for 'ContainingModule' values.
--
-fromContainingModule :: P.ModuleName -> ContainingModule -> P.ModuleName
+fromContainingModule :: ModuleName -> ContainingModule -> ModuleName
fromContainingModule def ThisModule = def
fromContainingModule _ (OtherModule mn) = mn
+fromQualified :: Qualified a -> (ContainingModule, a)
+fromQualified (Qualified mn x) =
+ (maybeToContainingModule mn, x)
+
+data Link
+ = NoLink
+ | Link ContainingModule
+ deriving (Show, Eq, Ord)
+
+instance A.ToJSON Link where
+ toJSON = \case
+ NoLink -> A.toJSON ["NoLink" :: Text]
+ Link mn -> A.toJSON ["Link", A.toJSON mn]
+
+asLink :: Parse Text Link
+asLink =
+ tryParse "link"
+ [ firstEq "NoLink" (pure NoLink)
+ , firstEq "Link" (Link <$> nth 1 asContainingModule)
+ ]
+
+instance A.FromJSON Link where
+ parseJSON = toAesonParser id asLink
+
+data Namespace
+ = ValueLevel
+ | TypeLevel
+ | KindLevel
+ deriving (Show, Eq, Ord, Generic)
+
+instance NFData Namespace
+
+instance A.ToJSON Namespace where
+ toJSON = A.toJSON . show
+
+asNamespace :: Parse Text Namespace
+asNamespace =
+ tryParse "namespace"
+ [ withText $ \case
+ "ValueLevel" -> Right ValueLevel
+ "TypeLevel" -> Right TypeLevel
+ "KindLevel" -> Right KindLevel
+ _ -> Left ""
+ ]
+
+instance A.FromJSON Namespace where
+ parseJSON = toAesonParser id asNamespace
+
+-- |
+-- A single element in a rendered code fragment. The intention is to support
+-- multiple output formats. For example, plain text, or highlighted HTML.
+--
+data RenderedCodeElement
+ = Syntax Text
+ | Keyword Text
+ | Space
+ -- | Any symbol which you might or might not want to link to, in any
+ -- namespace (value, type, or kind). Note that this is not related to the
+ -- kind called Symbol for type-level strings.
+ | Symbol Namespace Text Link
+ deriving (Show, Eq, Ord)
+
+instance A.ToJSON RenderedCodeElement where
+ toJSON (Syntax str) =
+ A.toJSON ["syntax", str]
+ toJSON (Keyword str) =
+ A.toJSON ["keyword", str]
+ toJSON Space =
+ A.toJSON ["space" :: Text]
+ toJSON (Symbol ns str link) =
+ A.toJSON ["symbol", A.toJSON ns, A.toJSON str, A.toJSON link]
+
+asRenderedCodeElement :: Parse Text RenderedCodeElement
+asRenderedCodeElement =
+ tryParse "RenderedCodeElement" $
+ [ a Syntax "syntax"
+ , a Keyword "keyword"
+ , asSpace
+ , asSymbol
+ ] ++ backwardsCompat
+ where
+ a ctor' ctorStr = firstEq ctorStr (ctor' <$> nth 1 asText)
+ asSymbol = firstEq "symbol" (Symbol <$> nth 1 asNamespace <*> nth 2 asText <*> nth 3 asLink)
+ asSpace = firstEq "space" (pure Space)
+
+ -- These will make some mistakes e.g. treating data constructors as types,
+ -- because the old code did not save information which is necessary to
+ -- distinguish these cases. This is the best we can do.
+ backwardsCompat =
+ [ oldAsIdent
+ , oldAsCtor
+ , oldAsKind
+ ]
+
+ oldAsIdent = firstEq "ident" (Symbol ValueLevel <$> nth 1 asText <*> nth 2 (Link <$> asContainingModule))
+ oldAsCtor = firstEq "ctor" (Symbol TypeLevel <$> nth 1 asText <*> nth 2 (Link <$> asContainingModule))
+ oldAsKind = firstEq "kind" (Symbol KindLevel <$> nth 1 asText <*> pure (Link ThisModule))
+
-- |
-- A type representing a highly simplified version of PureScript code, intended
-- for use in output formats like plain text or HTML.
@@ -158,21 +271,17 @@ outputWith f = foldMap f . unRC
sp :: RenderedCode
sp = RC [Space]
+-- |
+-- Wrap a RenderedCode value in parens.
+parens :: RenderedCode -> RenderedCode
+parens x = syntax "(" <> x <> syntax ")"
+
+-- possible TODO: instead of this function, export RenderedCode values for
+-- each syntax element, eg syntaxArr (== syntax "->"), syntaxLBrace,
+-- syntaxRBrace, etc.
syntax :: Text -> RenderedCode
syntax x = RC [Syntax x]
-ident :: Text -> RenderedCode
-ident x = RC [Ident x ThisModule]
-
-ident' :: Text -> ContainingModule -> RenderedCode
-ident' x m = RC [Ident x m]
-
-ctor :: Text -> ContainingModule -> RenderedCode
-ctor x m = RC [Ctor x m]
-
-kind :: Text -> RenderedCode
-kind x = RC [Kind x]
-
keyword :: Text -> RenderedCode
keyword kw = RC [Keyword kw]
@@ -197,10 +306,78 @@ keywordInstance = keyword "instance"
keywordWhere :: RenderedCode
keywordWhere = keyword "where"
-keywordFixity :: P.Associativity -> RenderedCode
-keywordFixity P.Infixl = keyword "infixl"
-keywordFixity P.Infixr = keyword "infixr"
-keywordFixity P.Infix = keyword "infix"
+keywordFixity :: Associativity -> RenderedCode
+keywordFixity Infixl = keyword "infixl"
+keywordFixity Infixr = keyword "infixr"
+keywordFixity Infix = keyword "infix"
keywordKind :: RenderedCode
keywordKind = keyword "kind"
+
+keywordAs :: RenderedCode
+keywordAs = keyword "as"
+
+ident :: Qualified Ident -> RenderedCode
+ident (fromQualified -> (mn, name)) =
+ RC [Symbol ValueLevel (runIdent name) (Link mn)]
+
+dataCtor :: Qualified (ProperName 'ConstructorName) -> RenderedCode
+dataCtor (fromQualified -> (mn, name)) =
+ RC [Symbol ValueLevel (runProperName name) (Link mn)]
+
+typeCtor :: Qualified (ProperName 'TypeName) -> RenderedCode
+typeCtor (fromQualified -> (mn, name)) =
+ RC [Symbol TypeLevel (runProperName name) (Link mn)]
+
+typeOp :: Qualified (OpName 'TypeOpName) -> RenderedCode
+typeOp (fromQualified -> (mn, name)) =
+ RC [Symbol TypeLevel (runOpName name) (Link mn)]
+
+typeVar :: Text -> RenderedCode
+typeVar x = RC [Symbol TypeLevel x NoLink]
+
+kind :: Qualified (ProperName 'KindName) -> RenderedCode
+kind (fromQualified -> (mn, name)) =
+ RC [Symbol KindLevel (runProperName name) (Link mn)]
+
+type FixityAlias = Qualified (Either (ProperName 'TypeName) (Either Ident (ProperName 'ConstructorName)))
+
+alias :: FixityAlias -> RenderedCode
+alias for =
+ prefix <> RC [Symbol ns name (Link mn)]
+ where
+ (ns, name, mn) = unpackFixityAlias for
+ prefix = case ns of
+ TypeLevel ->
+ keywordType <> sp
+ _ ->
+ mempty
+
+aliasName :: FixityAlias -> Text -> RenderedCode
+aliasName for name' =
+ let
+ (ns, _, _) = unpackFixityAlias for
+ unParen = T.tail . T.init
+ name = unParen name'
+ in
+ case ns of
+ ValueLevel ->
+ ident (Qualified Nothing (Ident name))
+ TypeLevel ->
+ typeCtor (Qualified Nothing (ProperName name))
+ KindLevel ->
+ internalError "Kind aliases are not supported"
+
+-- | Converts a FixityAlias into a different representation which is more
+-- useful to other functions in this module.
+unpackFixityAlias :: FixityAlias -> (Namespace, Text, ContainingModule)
+unpackFixityAlias (fromQualified -> (mn, x)) =
+ case x of
+ -- We add some seemingly superfluous type signatures here just to be extra
+ -- sure we are not mixing up our namespaces.
+ Left (n :: ProperName 'TypeName) ->
+ (TypeLevel, runProperName n, mn)
+ Right (Left n) ->
+ (ValueLevel, runIdent n, mn)
+ Right (Right (n :: ProperName 'ConstructorName)) ->
+ (ValueLevel, runProperName n, mn)
diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs
index 3616635..f18648b 100644
--- a/src/Language/PureScript/Docs/Types.hs
+++ b/src/Language/PureScript/Docs/Types.hs
@@ -4,23 +4,24 @@ module Language.PureScript.Docs.Types
)
where
-import Prelude.Compat
+import Protolude hiding (to, from)
+import Prelude (String, unlines, lookup)
-import Control.Arrow (first, (***))
-import Control.Monad (when)
-import Control.Monad.Error.Class (catchError)
+import Control.Arrow ((***))
-import Data.Monoid ((<>))
import Data.Aeson ((.=))
import Data.Aeson.BetterErrors
-import Data.ByteString.Lazy (ByteString)
-import Data.Either (isLeft, isRight)
-import Data.Maybe (mapMaybe, fromMaybe)
-import Data.Text (Text)
+ (Parse, ParseError, parse, keyOrDefault, throwCustomError, key, asText,
+ keyMay, withString, eachInArray, asNull, (.!), toAesonParser, toAesonParser',
+ fromAesonParser, perhaps, withText, asIntegral, nth, eachInObjectWithKey,
+ asString)
+import qualified Data.Map as Map
+import Data.Time.Clock (UTCTime)
+import qualified Data.Time.Format as TimeFormat
import Data.Version
-import qualified Data.Vector as V
import qualified Data.Aeson as A
import qualified Data.Text as T
+import qualified Data.Vector as V
import qualified Language.PureScript as P
@@ -31,7 +32,8 @@ import Web.Bower.PackageMeta hiding (Version, displayError)
import Language.PureScript.Docs.RenderedCode as ReExports
(RenderedCode, asRenderedCode,
ContainingModule(..), asContainingModule,
- RenderedCodeElement(..), asRenderedCodeElement)
+ RenderedCodeElement(..), asRenderedCodeElement,
+ Namespace(..), FixityAlias)
--------------------
-- Types
@@ -40,8 +42,12 @@ data Package a = Package
{ pkgMeta :: PackageMeta
, pkgVersion :: Version
, pkgVersionTag :: Text
+ -- TODO: When this field was introduced, it was given the Maybe type for the
+ -- sake of backwards compatibility, as older JSON blobs will not include the
+ -- field. It should eventually be changed to just UTCTime.
+ , pkgTagTime :: Maybe UTCTime
, pkgModules :: [Module]
- , pkgBookmarks :: [Bookmark]
+ , pkgModuleMap :: Map P.ModuleName PackageName
, pkgResolvedDependencies :: [(PackageName, Version)]
, pkgGithub :: (GithubUser, GithubRepo)
, pkgUploader :: a
@@ -62,8 +68,9 @@ verifyPackage verifiedUser Package{..} =
Package pkgMeta
pkgVersion
pkgVersionTag
+ pkgTagTime
pkgModules
- pkgBookmarks
+ pkgModuleMap
pkgResolvedDependencies
pkgGithub
verifiedUser
@@ -72,6 +79,29 @@ verifyPackage verifiedUser Package{..} =
packageName :: Package a -> PackageName
packageName = bowerName . pkgMeta
+-- |
+-- The time format used for serializing package tag times in the JSON format.
+-- This is the ISO 8601 date format which includes a time and a timezone.
+--
+jsonTimeFormat :: String
+jsonTimeFormat = "%Y-%m-%dT%H:%M:%S%z"
+
+-- |
+-- Convenience function for formatting a time in the format expected by this
+-- module.
+--
+formatTime :: UTCTime -> String
+formatTime =
+ TimeFormat.formatTime TimeFormat.defaultTimeLocale jsonTimeFormat
+
+-- |
+-- Convenience function for parsing a time in the format expected by this
+-- module.
+--
+parseTime :: String -> Maybe UTCTime
+parseTime =
+ TimeFormat.parseTimeM False TimeFormat.defaultTimeLocale jsonTimeFormat
+
data Module = Module
{ modName :: P.ModuleName
, modComments :: Maybe Text
@@ -158,8 +188,6 @@ convertFundepsToStrings args 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 -> Text
declInfoToString (ValueDeclaration _) = "value"
declInfoToString (DataDeclaration _ _) = "data"
@@ -169,6 +197,23 @@ declInfoToString (TypeClassDeclaration _ _ _) = "typeClass"
declInfoToString (AliasDeclaration _ _) = "alias"
declInfoToString ExternKindDeclaration = "kind"
+declInfoNamespace :: DeclarationInfo -> Namespace
+declInfoNamespace = \case
+ ValueDeclaration{} ->
+ ValueLevel
+ DataDeclaration{} ->
+ TypeLevel
+ ExternDataDeclaration{} ->
+ TypeLevel
+ TypeSynonymDeclaration{} ->
+ TypeLevel
+ TypeClassDeclaration{} ->
+ TypeLevel
+ AliasDeclaration _ alias ->
+ either (const TypeLevel) (const ValueLevel) (P.disqualify alias)
+ ExternKindDeclaration{} ->
+ KindLevel
+
isTypeClass :: Declaration -> Bool
isTypeClass Declaration{..} =
case declInfo of
@@ -244,6 +289,20 @@ childDeclInfoToString (ChildInstance _ _) = "instance"
childDeclInfoToString (ChildDataConstructor _) = "dataConstructor"
childDeclInfoToString (ChildTypeClassMember _) = "typeClassMember"
+childDeclInfoNamespace :: ChildDeclarationInfo -> Namespace
+childDeclInfoNamespace =
+ -- We could just write this as `const ValueLevel` but by doing it this way,
+ -- if another constructor is added, we get a warning which acts as a prompt
+ -- to update this, instead of having this function (possibly incorrectly)
+ -- just return ValueLevel for the new constructor.
+ \case
+ ChildInstance{} ->
+ ValueLevel
+ ChildDataConstructor{} ->
+ ValueLevel
+ ChildTypeClassMember{} ->
+ ValueLevel
+
isTypeClassMember :: ChildDeclaration -> Bool
isTypeClassMember ChildDeclaration{..} =
case cdeclInfo of
@@ -275,10 +334,9 @@ data PackageError
| InvalidFixity
| InvalidKind Text
| InvalidDataDeclType Text
+ | InvalidTime
deriving (Show, Eq, Ord)
-type Bookmark = InPackage (P.ModuleName, Text)
-
data InPackage a
= Local a
| FromDep PackageName a
@@ -299,13 +357,96 @@ ignorePackage :: InPackage a -> a
ignorePackage (Local x) = x
ignorePackage (FromDep _ x) = x
+----------------------------------------------------
+-- Types for links between declarations
+
+data LinksContext = LinksContext
+ { ctxGithub :: (GithubUser, GithubRepo)
+ , ctxModuleMap :: Map P.ModuleName PackageName
+ , ctxResolvedDependencies :: [(PackageName, Version)]
+ , ctxPackageName :: PackageName
+ , ctxVersion :: Version
+ , ctxVersionTag :: Text
+ }
+ deriving (Show, Eq, Ord)
+
+data DocLink = DocLink
+ { linkLocation :: LinkLocation
+ , linkTitle :: Text
+ , linkNamespace :: Namespace
+ }
+ deriving (Show, Eq, Ord)
+
+data LinkLocation
+ -- | A link to a declaration in the same module.
+ = SameModule
+
+ -- | A link to a declaration in a different module, but still in the current
+ -- package; we need to store the current module and the other declaration's
+ -- module.
+ | LocalModule P.ModuleName P.ModuleName
+
+ -- | A link to a declaration in a different package. We store: current module
+ -- name, name of the other package, version of the other package, and name of
+ -- the module in the other package that the declaration is in.
+ | DepsModule P.ModuleName PackageName Version P.ModuleName
+
+ -- | A link to a declaration that is built in to the compiler, e.g. the Prim
+ -- module. In this case we only need to store the module that the builtin
+ -- comes from (at the time of writing, this will only ever be "Prim").
+ | BuiltinModule P.ModuleName
+ deriving (Show, Eq, Ord)
+
+-- | Given a links context, a thing to link to (either a value or a type), and
+-- its containing module, attempt to create a DocLink.
+getLink :: LinksContext -> P.ModuleName -> Namespace -> Text -> ContainingModule -> Maybe DocLink
+getLink LinksContext{..} curMn namespace target containingMod = do
+ location <- getLinkLocation
+ return DocLink
+ { linkLocation = location
+ , linkTitle = target
+ , linkNamespace = namespace
+ }
+
+ where
+ getLinkLocation = normalLinkLocation <|> builtinLinkLocation
+
+ normalLinkLocation = do
+ case containingMod of
+ ThisModule ->
+ return SameModule
+ OtherModule destMn ->
+ case Map.lookup destMn ctxModuleMap of
+ Nothing ->
+ return $ LocalModule curMn destMn
+ Just pkgName -> do
+ pkgVersion <- lookup pkgName ctxResolvedDependencies
+ return $ DepsModule curMn pkgName pkgVersion destMn
+
+ builtinLinkLocation = do
+ let primMn = P.moduleNameFromString "Prim"
+ guard $ containingMod == OtherModule primMn
+ -- TODO: ensure the declaration exists in the builtin module too
+ return $ BuiltinModule primMn
+
+getLinksContext :: Package a -> LinksContext
+getLinksContext Package{..} =
+ LinksContext
+ { ctxGithub = pkgGithub
+ , ctxModuleMap = pkgModuleMap
+ , ctxResolvedDependencies = pkgResolvedDependencies
+ , ctxPackageName = bowerName pkgMeta
+ , ctxVersion = pkgVersion
+ , ctxVersionTag = pkgVersionTag
+ }
+
----------------------
-- Parsing
-parseUploadedPackage :: Version -> ByteString -> Either (ParseError PackageError) UploadedPackage
+parseUploadedPackage :: Version -> LByteString -> Either (ParseError PackageError) UploadedPackage
parseUploadedPackage minVersion = parse $ asUploadedPackage minVersion
-parseVerifiedPackage :: Version -> ByteString -> Either (ParseError PackageError) VerifiedPackage
+parseVerifiedPackage :: Version -> LByteString -> Either (ParseError PackageError) VerifiedPackage
parseVerifiedPackage minVersion = parse $ asVerifiedPackage minVersion
asPackage :: Version -> (forall e. Parse e a) -> Parse PackageError (Package a)
@@ -320,12 +461,21 @@ asPackage minimumVersion uploader = do
Package <$> key "packageMeta" asPackageMeta .! ErrorInPackageMeta
<*> key "version" asVersion
<*> key "versionTag" asText
+ <*> keyMay "tagTime" (withString parseTimeEither)
<*> key "modules" (eachInArray asModule)
- <*> key "bookmarks" asBookmarks .! ErrorInPackageMeta
+ <*> moduleMap
<*> key "resolvedDependencies" asResolvedDependencies
<*> key "github" asGithub
<*> key "uploader" uploader
<*> pure compilerVersion
+ where
+ moduleMap =
+ key "moduleMap" asModuleMap
+ `pOr` (key "bookmarks" bookmarksAsModuleMap .! ErrorInPackageMeta)
+
+parseTimeEither :: String -> Either PackageError UTCTime
+parseTimeEither =
+ maybe (Left InvalidTime) Right . parseTime
asUploadedPackage :: Version -> Parse PackageError UploadedPackage
asUploadedPackage minVersion = asPackage minVersion asNotYetKnown
@@ -359,6 +509,8 @@ displayPackageError e = case e of
"Invalid kind: \"" <> str <> "\""
InvalidDataDeclType str ->
"Invalid data declaration type: \"" <> str <> "\""
+ InvalidTime ->
+ "Invalid time"
instance A.FromJSON a => A.FromJSON (Package a) where
parseJSON = toAesonParser displayPackageError
@@ -406,9 +558,10 @@ asReExport =
asReExportModuleName :: Parse PackageError (InPackage P.ModuleName)
asReExportModuleName =
asInPackage fromAesonParser .! ErrorInPackageMeta
- <|> fmap Local fromAesonParser
+ `pOr` fmap Local fromAesonParser
- (<|>) p q = catchError p (const q)
+pOr :: Parse e a -> Parse e a -> Parse e a
+p `pOr` q = catchError p (const q)
asInPackage :: Parse BowerError a -> Parse BowerError (InPackage a)
asInPackage inner =
@@ -521,20 +674,38 @@ asQualifiedProperName = fromAesonParser
asQualifiedIdent :: Parse e (P.Qualified P.Ident)
asQualifiedIdent = fromAesonParser
-asBookmarks :: Parse BowerError [Bookmark]
-asBookmarks = eachInArray asBookmark
+asModuleMap :: Parse PackageError (Map P.ModuleName PackageName)
+asModuleMap =
+ Map.fromList <$>
+ eachInObjectWithKey (Right . P.moduleNameFromString)
+ (withText parsePackageName')
-asBookmark :: Parse BowerError Bookmark
-asBookmark =
- asInPackage ((,) <$> nth 0 (P.moduleNameFromString <$> asText)
- <*> nth 1 asText)
+-- This is here to preserve backwards compatibility with compilers which used
+-- to generate a 'bookmarks' field in the JSON (i.e. up to 0.10.5). We should
+-- remove this after the next breaking change to the JSON.
+bookmarksAsModuleMap :: Parse BowerError (Map P.ModuleName PackageName)
+bookmarksAsModuleMap =
+ convert <$>
+ eachInArray (asInPackage (nth 0 (P.moduleNameFromString <$> asText)))
+
+ where
+ convert :: [InPackage P.ModuleName] -> Map P.ModuleName PackageName
+ convert = Map.fromList . mapMaybe toTuple
+
+ toTuple (Local _) = Nothing
+ toTuple (FromDep pkgName mn) = Just (mn, pkgName)
asResolvedDependencies :: Parse PackageError [(PackageName, Version)]
asResolvedDependencies =
- eachInObjectWithKey (mapLeft ErrorInPackageMeta . parsePackageName) asVersion
- where
- mapLeft f (Left x) = Left (f x)
- mapLeft _ (Right x) = Right x
+ eachInObjectWithKey parsePackageName' asVersion
+
+parsePackageName' :: Text -> Either PackageError PackageName
+parsePackageName' =
+ mapLeft ErrorInPackageMeta . parsePackageName
+
+mapLeft :: (a -> a') -> Either a b -> Either a' b
+mapLeft f (Left x) = Left (f x)
+mapLeft _ (Right x) = Right x
asGithub :: Parse e (GithubUser, GithubRepo)
asGithub = (,) <$> nth 0 (GithubUser <$> asText)
@@ -550,19 +721,22 @@ asSourceSpan = P.SourceSpan <$> key "name" asString
instance A.ToJSON a => A.ToJSON (Package a) where
toJSON Package{..} =
- A.object
+ A.object $
[ "packageMeta" .= pkgMeta
, "version" .= showVersion pkgVersion
, "versionTag" .= pkgVersionTag
, "modules" .= pkgModules
- , "bookmarks" .= map (fmap (first P.runModuleName)) pkgBookmarks
+ , "moduleMap" .= assocListToJSON P.runModuleName
+ runPackageName
+ (Map.toList pkgModuleMap)
, "resolvedDependencies" .= assocListToJSON runPackageName
(T.pack . showVersion)
pkgResolvedDependencies
, "github" .= pkgGithub
, "uploader" .= pkgUploader
, "compilerVersion" .= showVersion P.version
- ]
+ ] ++
+ fmap (\t -> "tagTime" .= formatTime t) (maybeToList pkgTagTime)
instance A.ToJSON NotYetKnown where
toJSON _ = A.Null
diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs
index a62315f..86b3fec 100644
--- a/src/Language/PureScript/Environment.hs
+++ b/src/Language/PureScript/Environment.hs
@@ -347,7 +347,7 @@ primKinds =
-- |
-- The primitive types in the external javascript environment with their
--- associated kinds. There are also pseudo `Fail` and `Partial` types
+-- associated kinds. There are also pseudo `Fail`, `Warn`, and `Partial` types
-- that correspond to the classes with the same names.
--
primTypes :: M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind)
@@ -363,20 +363,23 @@ primTypes =
, (primName "Boolean", (kindType, ExternData))
, (primName "Partial", (kindType, ExternData))
, (primName "Fail", (FunKind kindSymbol kindType, ExternData))
+ , (primName "Warn", (FunKind kindSymbol kindType, ExternData))
, (primName "TypeString", (FunKind kindType kindSymbol, ExternData))
, (primName "TypeConcat", (FunKind kindSymbol (FunKind kindSymbol kindSymbol), ExternData))
]
-- |
--- The primitive class map. This just contains the `Fail` and `Partial`
+-- The primitive class map. This just contains the `Fail`, `Warn`, and `Partial`
-- classes. `Partial` is used as a kind of magic constraint for partial
--- functions. `Fail` is used for user-defined type errors.
+-- functions. `Fail` is used for user-defined type errors. `Warn` for
+-- user-defined warnings.
--
primClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData
primClasses =
M.fromList
[ (primName "Partial", (makeTypeClassData [] [] [] []))
, (primName "Fail", (makeTypeClassData [("message", Just kindSymbol)] [] [] []))
+ , (primName "Warn", (makeTypeClassData [("message", Just kindSymbol)] [] [] []))
]
-- |
diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs
index 50b8521..11b9507 100644
--- a/src/Language/PureScript/Errors.hs
+++ b/src/Language/PureScript/Errors.hs
@@ -6,44 +6,42 @@ module Language.PureScript.Errors
, module Language.PureScript.Errors
) where
-import Prelude.Compat
-
-import Control.Arrow ((&&&))
-import Control.Monad
-import Control.Monad.Error.Class (MonadError(..))
-import Control.Monad.Trans.State.Lazy
-import Control.Monad.Writer
-
-import Data.Char (isSpace)
-import Data.Either (lefts, rights)
-import Data.Foldable (fold)
-import Data.Functor.Identity (Identity(..))
-import Data.List (transpose, nub, nubBy, sortBy, partition)
-import Data.Maybe (maybeToList, fromMaybe, mapMaybe)
-import Data.Ord (comparing)
+import Prelude.Compat
+
+import Control.Arrow ((&&&))
+import Control.Monad
+import Control.Monad.Error.Class (MonadError(..))
+import Control.Monad.Trans.State.Lazy
+import Control.Monad.Writer
+import Data.Char (isSpace)
+import Data.Either (lefts, rights)
+import Data.Foldable (fold)
+import Data.Functor.Identity (Identity(..))
+import Data.List (transpose, nub, nubBy, sortBy, partition)
+import Data.Maybe (maybeToList, fromMaybe, mapMaybe)
+import Data.Ord (comparing)
+import Data.String (fromString)
import qualified Data.Map as M
import qualified Data.Text as T
-import Data.Text (Text)
-
-import Language.PureScript.AST
-import Language.PureScript.Crash
-import Language.PureScript.Environment
-import Language.PureScript.Names
-import Language.PureScript.Pretty
-import Language.PureScript.Traversals
-import Language.PureScript.Types
-import Language.PureScript.Label (Label(..))
-import Language.PureScript.Pretty.Common (before, endWith)
+import Data.Text (Text)
+import Language.PureScript.AST
import qualified Language.PureScript.Bundle as Bundle
import qualified Language.PureScript.Constants as C
-
+import Language.PureScript.Crash
+import Language.PureScript.Environment
+import Language.PureScript.Label (Label(..))
+import Language.PureScript.Names
+import Language.PureScript.Pretty
+import Language.PureScript.Pretty.Common (endWith)
+import Language.PureScript.PSString (PSString, decodeStringWithReplacement)
+import Language.PureScript.Traversals
+import Language.PureScript.Types
+import qualified Language.PureScript.Publish.BoxesHelpers as BoxHelpers
import qualified System.Console.ANSI as ANSI
-
import qualified Text.Parsec as P
import qualified Text.Parsec.Error as PE
+import Text.Parsec.Error (Message(..))
import qualified Text.PrettyPrint.Boxes as Box
-import qualified Language.PureScript.Publish.BoxesHelpers as BoxHelpers
-import Text.Parsec.Error (Message(..))
newtype ErrorSuggestion = ErrorSuggestion Text
@@ -72,11 +70,10 @@ stripModuleAndSpan (ErrorMessage hints e) = ErrorMessage (filter (not . shouldSt
shouldStrip (PositionedError _) = True
shouldStrip _ = False
--- |
--- Get the error code for a particular error type
---
+-- | Get the error code for a particular error type
errorCode :: ErrorMessage -> Text
errorCode em = case unwrapErrorMessage em of
+ ModuleNotFound{} -> "ModuleNotFound"
ErrorParsingFFIModule{} -> "ErrorParsingFFIModule"
ErrorParsingModule{} -> "ErrorParsingModule"
MissingFFIModule{} -> "MissingFFIModule"
@@ -168,30 +165,27 @@ errorCode em = case unwrapErrorMessage em of
CaseBinderLengthDiffers{} -> "CaseBinderLengthDiffers"
IncorrectAnonymousArgument -> "IncorrectAnonymousArgument"
InvalidOperatorInBinder{} -> "InvalidOperatorInBinder"
- DeprecatedRequirePath{} -> "DeprecatedRequirePath"
CannotGeneralizeRecursiveFunction{} -> "CannotGeneralizeRecursiveFunction"
CannotDeriveNewtypeForData{} -> "CannotDeriveNewtypeForData"
ExpectedWildcard{} -> "ExpectedWildcard"
+ CannotUseBindWithDo{} -> "CannotUseBindWithDo"
+ ClassInstanceArityMismatch{} -> "ClassInstanceArityMismatch"
+ UserDefinedWarning{} -> "UserDefinedWarning"
--- |
--- A stack trace for an error
---
+-- | A stack trace for an error
newtype MultipleErrors = MultipleErrors
- { runMultipleErrors :: [ErrorMessage] } deriving (Show, Monoid)
+ { runMultipleErrors :: [ErrorMessage]
+ } deriving (Show, Monoid)
-- | Check whether a collection of errors is empty or not.
nonEmpty :: MultipleErrors -> Bool
nonEmpty = not . null . runMultipleErrors
--- |
--- Create an error set from a single simple error message
---
+-- | Create an error set from a single simple error message
errorMessage :: SimpleErrorMessage -> MultipleErrors
errorMessage err = MultipleErrors [ErrorMessage [] err]
--- |
--- Create an error set from a single error message
---
+-- | Create an error set from a single error message
singleError :: ErrorMessage -> MultipleErrors
singleError = MultipleErrors . pure
@@ -224,15 +218,12 @@ defaultUnknownMap = TypeMap M.empty M.empty 0
-- | How critical the issue is
data Level = Error | Warning deriving Show
--- |
--- Extract nested error messages from wrapper errors
---
+-- | Extract nested error messages from wrapper errors
unwrapErrorMessage :: ErrorMessage -> SimpleErrorMessage
unwrapErrorMessage (ErrorMessage _ se) = se
replaceUnknowns :: Type -> State TypeMap Type
-replaceUnknowns = everywhereOnTypesM replaceTypes
- where
+replaceUnknowns = everywhereOnTypesM replaceTypes where
replaceTypes :: Type -> State TypeMap Type
replaceTypes (TUnknown u) = do
m <- get
@@ -385,10 +376,7 @@ defaultPPEOptions = PPEOptions
, ppeShowDocs = True
}
-
--- |
--- Pretty print a single error, simplifying if necessary
---
+-- | Pretty print a single error, simplifying if necessary
prettyPrintSingleError :: PPEOptions -> ErrorMessage -> Box.Box
prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalState defaultUnknownMap $ do
em <- onTypesInErrorMessageM replaceUnknowns (if full then e else simplifyErrorMessage e)
@@ -429,6 +417,10 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS
unknownInfo u = line $ markCode ("t" <> T.pack (show u)) <> " is an unknown type"
renderSimpleErrorMessage :: SimpleErrorMessage -> Box.Box
+ renderSimpleErrorMessage (ModuleNotFound mn) =
+ paras [ line $ "Module " <> markCode (runModuleName mn) <> " was not found."
+ , line "Make sure the source file exists, and that it has been provided as an input to psc."
+ ]
renderSimpleErrorMessage (CannotGetFileInfo path) =
paras [ line "Unable to read file info: "
, indent . lineS $ path
@@ -690,7 +682,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS
renderSimpleErrorMessage (ExtraneousClassMember ident className) =
line $ "" <> markCode (showIdent ident) <> " is not a member of type class " <> markCode (showQualified runProperName className)
renderSimpleErrorMessage (ExpectedType ty kind) =
- paras [ line $ "In a type-annotated expression " <> markCode "x :: t" <> ", the type " <> markCode "t" <> " must have kind " <> markCode "*" <> "."
+ paras [ line $ "In a type-annotated expression " <> markCode "x :: t" <> ", the type " <> markCode "t" <> " must have kind " <> markCode (prettyPrintKind kindType) <> "."
, line "The error arises from the type"
, markCodeBox $ indent $ typeAsBox ty
, line "having the kind"
@@ -862,9 +854,6 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS
, line "Only aliases for data constructors may be used in patterns."
]
- renderSimpleErrorMessage DeprecatedRequirePath =
- line "The require-path option is deprecated and will be removed in PureScript 0.9."
-
renderSimpleErrorMessage (CannotGeneralizeRecursiveFunction ident ty) =
paras [ line $ "Unable to generalize the type of the recursive function " <> markCode (showIdent ident) <> "."
, line $ "The inferred type of " <> markCode (showIdent ident) <> " was:"
@@ -880,6 +869,23 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS
paras [ line $ "Expected a type wildcard (_) when deriving an instance for " <> markCode (runProperName tyName) <> "."
]
+ renderSimpleErrorMessage CannotUseBindWithDo =
+ paras [ line $ "The name " <> markCode "bind" <> " cannot be brought into scope in a do notation block, since do notation uses the same name."
+ ]
+
+ renderSimpleErrorMessage (ClassInstanceArityMismatch dictName className expected actual) =
+ paras [ line $ "The type class " <> markCode (showQualified runProperName className) <>
+ " expects " <> T.pack (show expected) <> " argument(s)."
+ , line $ "But the instance " <> markCode (showIdent dictName) <> " only provided " <>
+ T.pack (show actual) <> "."
+ ]
+
+ renderSimpleErrorMessage (UserDefinedWarning msgTy) =
+ let msg = fromMaybe (typeAsBox msgTy) (toTypelevelString msgTy) in
+ paras [ line "A custom warning occurred while solving type class constraints:"
+ , indent msg
+ ]
+
renderHint :: ErrorMessageHint -> Box.Box -> Box.Box
renderHint (ErrorUnifyingTypes t1 t2) detail =
paras [ detail
@@ -1160,15 +1166,11 @@ prettyPrintRef (ReExportRef _ _) =
prettyPrintRef (PositionedDeclarationRef _ _ ref) =
prettyPrintRef ref
--- |
--- Pretty print multiple errors
---
+-- | Pretty print multiple errors
prettyPrintMultipleErrors :: PPEOptions -> MultipleErrors -> String
prettyPrintMultipleErrors ppeOptions = unlines . map renderBox . prettyPrintMultipleErrorsBox ppeOptions
--- |
--- Pretty print multiple warnings
---
+-- | Pretty print multiple warnings
prettyPrintMultipleWarnings :: PPEOptions -> MultipleErrors -> String
prettyPrintMultipleWarnings ppeOptions = unlines . map renderBox . prettyPrintMultipleWarningsBox ppeOptions
@@ -1199,11 +1201,10 @@ prettyPrintMultipleErrorsWith ppeOptions _ intro (MultipleErrors es) =
prettyPrintParseError :: P.ParseError -> Box.Box
prettyPrintParseError = prettyPrintParseErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" . PE.errorMessages
--- |
--- Pretty print ParseError detail messages.
---
--- Adapted from 'Text.Parsec.Error.showErrorMessages', see <https://github.com/aslatter/parsec/blob/v3.1.9/Text/Parsec/Error.hs#L173>.
+-- | Pretty print 'ParseError' detail messages.
--
+-- Adapted from 'Text.Parsec.Error.showErrorMessages'.
+-- See <https://github.com/aslatter/parsec/blob/v3.1.9/Text/Parsec/Error.hs#L173>.
prettyPrintParseErrorMessages :: String -> String -> String -> String -> String -> [Message] -> Box.Box
prettyPrintParseErrorMessages msgOr msgUnknown msgExpecting msgUnExpected msgEndOfInput msgs
| null msgs = Box.text msgUnknown
@@ -1265,16 +1266,17 @@ renderBox = unlines
whiteSpace = all isSpace
toTypelevelString :: Type -> Maybe Box.Box
-toTypelevelString (TypeLevelString s) = Just $ Box.text $ T.unpack $ prettyPrintString s
-toTypelevelString (TypeApp (TypeConstructor f) x)
- | f == primName "TypeString" = Just $ typeAsBox x
-toTypelevelString (TypeApp (TypeApp (TypeConstructor f) x) ret)
- | f == primName "TypeConcat" = before <$> (toTypelevelString x) <*> (toTypelevelString ret)
-toTypelevelString _ = Nothing
-
--- |
--- Rethrow an error with a more detailed error message in the case of failure
---
+toTypelevelString t = (Box.text . decodeStringWithReplacement) <$> toTypelevelString' t
+ where
+ toTypelevelString' :: Type -> Maybe PSString
+ toTypelevelString' (TypeLevelString s) = Just s
+ toTypelevelString' (TypeApp (TypeConstructor f) x)
+ | f == primName "TypeString" = Just $ fromString $ prettyPrintType x
+ toTypelevelString' (TypeApp (TypeApp (TypeConstructor f) x) ret)
+ | f == primName "TypeConcat" = toTypelevelString' x <> toTypelevelString' ret
+ toTypelevelString' _ = Nothing
+
+-- | Rethrow an error with a more detailed error message in the case of failure
rethrow :: (MonadError e m) => (e -> e) -> m a -> m a
rethrow f = flip catchError $ \e -> throwError (f e)
@@ -1287,9 +1289,7 @@ reflectErrors ma = ma >>= either throwError return
warnAndRethrow :: (MonadError e m, MonadWriter e m) => (e -> e) -> m a -> m a
warnAndRethrow f = rethrow f . censor f
--- |
--- Rethrow an error with source position information
---
+-- | Rethrow an error with source position information
rethrowWithPosition :: (MonadError MultipleErrors m) => SourceSpan -> m a -> m a
rethrowWithPosition pos = rethrow (onErrorMessages (withPosition pos))
@@ -1302,10 +1302,8 @@ warnAndRethrowWithPosition pos = rethrowWithPosition pos . warnWithPosition pos
withPosition :: SourceSpan -> ErrorMessage -> ErrorMessage
withPosition pos (ErrorMessage hints se) = ErrorMessage (PositionedError pos : hints) se
--- |
--- Runs a computation listening for warnings and then escalating any warnings
+-- | Runs a computation listening for warnings and then escalating any warnings
-- that match the predicate to error status.
---
escalateWarningWhen
:: (MonadWriter MultipleErrors m, MonadError MultipleErrors m)
=> (ErrorMessage -> Bool)
@@ -1318,16 +1316,20 @@ escalateWarningWhen isError ma = do
unless (null errors) $ throwError $ MultipleErrors errors
return a
--- |
--- Collect errors in in parallel
---
-parU :: (MonadError MultipleErrors m) => [a] -> (a -> m b) -> m [b]
-parU xs f = forM xs (withError . f) >>= collectErrors
+-- | Collect errors in in parallel
+parU
+ :: forall m a b
+ . MonadError MultipleErrors m
+ => [a]
+ -> (a -> m b)
+ -> m [b]
+parU xs f =
+ forM xs (withError . f) >>= collectErrors
where
- withError :: (MonadError MultipleErrors m) => m a -> m (Either MultipleErrors a)
- withError u = catchError (Right <$> u) (return . Left)
+ withError :: m b -> m (Either MultipleErrors b)
+ withError u = catchError (Right <$> u) (return . Left)
- collectErrors :: (MonadError MultipleErrors m) => [Either MultipleErrors a] -> m [a]
- collectErrors es = case lefts es of
- [] -> return $ rights es
- errs -> throwError $ fold errs
+ collectErrors :: [Either MultipleErrors b] -> m [b]
+ collectErrors es = case lefts es of
+ [] -> return $ rights es
+ errs -> throwError $ fold errs
diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs
index 77af155..aaaccbd 100644
--- a/src/Language/PureScript/Ide.hs
+++ b/src/Language/PureScript/Ide.hs
@@ -43,13 +43,17 @@ import System.FilePath.Glob (glob)
-- | Accepts a Commmand and runs it against psc-ide's State. This is the main
-- entry point for the server.
-handleCommand :: (Ide m, MonadLogger m, MonadError PscIdeError m) =>
+handleCommand :: (Ide m, MonadLogger m, MonadError IdeError m) =>
Command -> m Success
handleCommand c = case c of
Load [] ->
- findAvailableExterns >>= loadModules
+ findAvailableExterns >>= loadModulesAsync
Load modules ->
- loadModules modules
+ loadModulesAsync modules
+ LoadSync [] ->
+ findAvailableExterns >>= loadModulesSync
+ LoadSync modules ->
+ loadModulesSync modules
Type search filters currentModule ->
findType search filters currentModule
Complete filters matcher currentModule ->
@@ -78,7 +82,9 @@ handleCommand c = case c of
Left question ->
pure (CompletionResult (map (completionFromMatch . map withEmptyAnn) question))
Rebuild file ->
- rebuildFile file
+ rebuildFileAsync file
+ RebuildSync file ->
+ rebuildFileSync file
Cwd ->
TextResult . toS <$> liftIO getCurrentDirectory
Reset ->
@@ -125,7 +131,7 @@ listAvailableModules = do
let cleaned = filter (`notElem` [".", ".."]) contents
return (ModuleList (map toS cleaned))
-caseSplit :: (Ide m, MonadError PscIdeError m) =>
+caseSplit :: (Ide m, MonadError IdeError m) =>
Text -> Int -> Int -> CS.WildcardAnnotations -> Text -> m Success
caseSplit l b e csa t = do
patterns <- CS.makePattern l b e csa <$> CS.caseSplit t
@@ -133,7 +139,7 @@ caseSplit l b e csa t = do
-- | Finds all the externs.json files inside the output folder and returns the
-- corresponding Modulenames
-findAvailableExterns :: (Ide m, MonadError PscIdeError m) => m [P.ModuleName]
+findAvailableExterns :: (Ide m, MonadError IdeError m) => m [P.ModuleName]
findAvailableExterns = do
oDir <- outputDirectory
unlessM (liftIO (doesDirectoryExist oDir))
@@ -162,8 +168,33 @@ findAllSourceFiles = do
-- server state. Then proceeds to parse all the specified sourcefiles and
-- inserts their ASTs into the state. Finally kicks off an async worker, which
-- populates Stage 2 and 3 of the state.
+loadModulesAsync
+ :: (Ide m, MonadError IdeError m, MonadLogger m)
+ => [P.ModuleName]
+ -> m Success
+loadModulesAsync moduleNames = do
+ tr <- loadModules moduleNames
+
+ -- Finally we kick off the worker with @async@ and return the number of
+ -- successfully parsed modules.
+ env <- ask
+ let ll = confLogLevel (ideConfiguration env)
+ -- populateStage2 and 3 return Unit for now, so it's fine to discard this
+ -- result. We might want to block on this in a benchmarking situation.
+ _ <- liftIO (async (runLogger ll (runReaderT (populateStage2 *> populateStage3) env)))
+ pure tr
+
+loadModulesSync
+ :: (Ide m, MonadError IdeError m, MonadLogger m)
+ => [P.ModuleName]
+ -> m Success
+loadModulesSync moduleNames = do
+ tr <- loadModules moduleNames
+ populateStage2 *> populateStage3
+ pure tr
+
loadModules
- :: (Ide m, MonadError PscIdeError m, MonadLogger m)
+ :: (Ide m, MonadError IdeError m, MonadLogger m)
=> [P.ModuleName]
-> m Success
loadModules moduleNames = do
@@ -182,12 +213,5 @@ loadModules moduleNames = do
$(logWarn) ("Failed to parse: " <> show failures)
traverse_ insertModule allModules
- -- Finally we kick off the worker with @async@ and return the number of
- -- successfully parsed modules.
- env <- ask
- let ll = confLogLevel (ideConfiguration env)
- -- populateStage2 and 3 return Unit for now, so it's fine to discard this
- -- result. We might want to block on this in a benchmarking situation.
- _ <- liftIO (async (runLogger ll (runReaderT (populateStage2 *> populateStage3) env)))
pure (TextResult ("Loaded " <> show (length efiles) <> " modules and "
<> show (length allModules) <> " source files."))
diff --git a/src/Language/PureScript/Ide/CaseSplit.hs b/src/Language/PureScript/Ide/CaseSplit.hs
index c54380b..460ea91 100644
--- a/src/Language/PureScript/Ide/CaseSplit.hs
+++ b/src/Language/PureScript/Ide/CaseSplit.hs
@@ -45,7 +45,7 @@ explicitAnnotations = WildcardAnnotations True
noAnnotations :: WildcardAnnotations
noAnnotations = WildcardAnnotations False
-caseSplit :: (Ide m, MonadError PscIdeError m) =>
+caseSplit :: (Ide m, MonadError IdeError m) =>
Text -> m [Constructor]
caseSplit q = do
type' <- parseType' q
@@ -55,7 +55,7 @@ caseSplit q = do
let appliedCtors = map (second (map applyTypeVars)) ctors
pure appliedCtors
-findTypeDeclaration :: (Ide m, MonadError PscIdeError m) =>
+findTypeDeclaration :: (Ide m, MonadError IdeError m) =>
P.ProperName 'P.TypeName -> m ExternsDeclaration
findTypeDeclaration q = do
efs <- getExternFiles
@@ -73,7 +73,7 @@ findTypeDeclaration' t ExternsFile{..} =
EDType tn _ _ -> tn == t
_ -> False) efDeclarations
-splitTypeConstructor :: (MonadError PscIdeError m) =>
+splitTypeConstructor :: (MonadError IdeError m) =>
P.Type -> m (P.ProperName 'P.TypeName, [P.Type])
splitTypeConstructor = go []
where
@@ -105,7 +105,7 @@ makePattern t x y wsa = makePattern' (T.take x t) (T.drop y t)
where
makePattern' lhs rhs = map (\ctor -> lhs <> prettyCtor wsa ctor <> rhs)
-addClause :: (MonadError PscIdeError m) => Text -> WildcardAnnotations -> m [Text]
+addClause :: (MonadError IdeError m) => Text -> WildcardAnnotations -> m [Text]
addClause s wca = do
(fName, fType) <- parseTypeDeclaration' s
let args = splitFunctionType fType
@@ -114,7 +114,7 @@ addClause s wca = do
" = ?" <> (T.strip . P.runIdent $ fName)
pure [s, template]
-parseType' :: (MonadError PscIdeError m) =>
+parseType' :: (MonadError IdeError m) =>
Text -> m P.Type
parseType' s =
case P.lex "<psc-ide>" (toS s) >>= P.runTokenParser "<psc-ide>" (P.parseType <* Parsec.eof) of
@@ -123,7 +123,7 @@ parseType' s =
throwError (GeneralError ("Parsing the splittype failed with:"
<> show err))
-parseTypeDeclaration' :: (MonadError PscIdeError m) => Text -> m (P.Ident, P.Type)
+parseTypeDeclaration' :: (MonadError IdeError m) => Text -> m (P.Ident, P.Type)
parseTypeDeclaration' s =
let x = do
ts <- P.lex "" (toS s)
diff --git a/src/Language/PureScript/Ide/Command.hs b/src/Language/PureScript/Ide/Command.hs
index c51015f..e9999a8 100644
--- a/src/Language/PureScript/Ide/Command.hs
+++ b/src/Language/PureScript/Ide/Command.hs
@@ -25,6 +25,7 @@ import Language.PureScript.Ide.Types
data Command
= Load [P.ModuleName]
+ | LoadSync [P.ModuleName] -- used in tests
| Type
{ typeSearch :: Text
, typeFilters :: [Filter]
@@ -54,6 +55,7 @@ data Command
| Import FilePath (Maybe FilePath) [Filter] ImportCommand
| List { listType :: ListType }
| Rebuild FilePath -- ^ Rebuild the specified file using the loaded externs
+ | RebuildSync FilePath -- ^ Rebuild the specified file using the loaded externs
| Cwd
| Reset
| Quit
@@ -61,6 +63,7 @@ data Command
commandName :: Command -> Text
commandName c = case c of
Load{} -> "Load"
+ LoadSync{} -> "LoadSync"
Type{} -> "Type"
Complete{} -> "Complete"
Pursuit{} -> "Pursuit"
@@ -69,6 +72,7 @@ commandName c = case c of
Import{} -> "Import"
List{} -> "List"
Rebuild{} -> "Rebuild"
+ RebuildSync{} -> "RebuildSync"
Cwd{} -> "Cwd"
Reset{} -> "Reset"
Quit{} -> "Quit"
diff --git a/src/Language/PureScript/Ide/Completion.hs b/src/Language/PureScript/Ide/Completion.hs
index 181dbe0..81f68d7 100644
--- a/src/Language/PureScript/Ide/Completion.hs
+++ b/src/Language/PureScript/Ide/Completion.hs
@@ -8,6 +8,9 @@ import Protolude
import Language.PureScript.Ide.Filter
import Language.PureScript.Ide.Matcher
import Language.PureScript.Ide.Types
+import qualified Language.PureScript as P
+
+type Module = (P.ModuleName, [IdeDeclarationAnn])
-- | Applies the CompletionFilters and the Matcher to the given Modules
-- and sorts the found Completions according to the Matching Score
diff --git a/src/Language/PureScript/Ide/Conversions.hs b/src/Language/PureScript/Ide/Conversions.hs
deleted file mode 100644
index 1420c9d..0000000
--- a/src/Language/PureScript/Ide/Conversions.hs
+++ /dev/null
@@ -1,29 +0,0 @@
------------------------------------------------------------------------------
---
--- Module : Language.PureScript.Ide.Conversions
--- Description : Conversions to Text for PureScript types
--- Copyright : Christoph Hegemann 2016
--- License : MIT (http://opensource.org/licenses/MIT)
---
--- Maintainer : Christoph Hegemann <christoph.hegemann1337@gmail.com>
--- Stability : experimental
---
--- |
--- Conversions to Text for PureScript types
------------------------------------------------------------------------------
-
-module Language.PureScript.Ide.Conversions where
-
-import Control.Lens.Iso
-import Data.Text (lines, strip, unwords, pack)
-import qualified Language.PureScript as P
-import Protolude
-
-properNameT :: Iso' (P.ProperName a) Text
-properNameT = iso P.runProperName P.ProperName
-
-identT :: Iso' P.Ident Text
-identT = iso P.runIdent P.Ident
-
-prettyTypeT :: P.Type -> Text
-prettyTypeT = unwords . map strip . lines . pack . P.prettyPrintType
diff --git a/src/Language/PureScript/Ide/Error.hs b/src/Language/PureScript/Ide/Error.hs
index 44ee78e..1be0f89 100644
--- a/src/Language/PureScript/Ide/Error.hs
+++ b/src/Language/PureScript/Ide/Error.hs
@@ -13,7 +13,7 @@
-----------------------------------------------------------------------------
module Language.PureScript.Ide.Error
- ( PscIdeError(..)
+ ( IdeError(..)
) where
import Data.Aeson
@@ -22,15 +22,16 @@ import Language.PureScript.Ide.Types (ModuleIdent)
import Protolude
import qualified Text.Parsec.Error as P
-data PscIdeError
+data IdeError
= GeneralError Text
| NotFound Text
| ModuleNotFound ModuleIdent
| ModuleFileNotFound ModuleIdent
| ParseError P.ParseError Text
| RebuildError [JSONError]
+ deriving (Show, Eq)
-instance ToJSON PscIdeError where
+instance ToJSON IdeError where
toJSON (RebuildError errs) = object
[ "resultType" .= ("error" :: Text)
, "result" .= errs
@@ -40,7 +41,7 @@ instance ToJSON PscIdeError where
, "result" .= textError err
]
-textError :: PscIdeError -> Text
+textError :: IdeError -> Text
textError (GeneralError msg) = msg
textError (NotFound ident) = "Symbol '" <> ident <> "' not found."
textError (ModuleNotFound ident) = "Module '" <> ident <> "' not found."
diff --git a/src/Language/PureScript/Ide/Externs.hs b/src/Language/PureScript/Ide/Externs.hs
index e50fb12..1ffe761 100644
--- a/src/Language/PureScript/Ide/Externs.hs
+++ b/src/Language/PureScript/Ide/Externs.hs
@@ -28,13 +28,13 @@ import Data.Aeson (decodeStrict)
import qualified Data.ByteString as BS
import qualified Data.Map as Map
import Data.Version (showVersion)
-import Language.PureScript.Ide.Error (PscIdeError (..))
+import Language.PureScript.Ide.Error (IdeError (..))
import Language.PureScript.Ide.Types
import Language.PureScript.Ide.Util
import qualified Language.PureScript as P
-readExternFile :: (MonadIO m, MonadError PscIdeError m, MonadLogger m) =>
+readExternFile :: (MonadIO m, MonadError IdeError m, MonadLogger m) =>
FilePath -> m P.ExternsFile
readExternFile fp = do
parseResult <- liftIO (decodeStrict <$> BS.readFile fp)
@@ -54,9 +54,9 @@ readExternFile fp = do
where
version = toS (showVersion P.version)
-convertExterns :: P.ExternsFile -> (Module, [(P.ModuleName, P.DeclarationRef)])
+convertExterns :: P.ExternsFile -> ([IdeDeclarationAnn], [(P.ModuleName, P.DeclarationRef)])
convertExterns ef =
- ((P.efModuleName ef, decls), exportDecls)
+ (decls, exportDecls)
where
decls = map
(IdeDeclarationAnn emptyAnn)
@@ -71,8 +71,10 @@ convertExterns ef =
removeTypeDeclarationsForClass :: IdeDeclaration -> Endo [IdeDeclaration]
removeTypeDeclarationsForClass (IdeDeclTypeClass n) = Endo (filter notDuplicate)
- where notDuplicate (IdeDeclType t) = n ^. properNameT /= t ^. ideTypeName . properNameT
- notDuplicate (IdeDeclTypeSynonym s) = n ^. properNameT /= s ^. ideSynonymName . properNameT
+ where notDuplicate (IdeDeclType t) =
+ n ^. ideTCName . properNameT /= t ^. ideTypeName . properNameT
+ notDuplicate (IdeDeclTypeSynonym s) =
+ n ^. ideTCName . properNameT /= s ^. ideSynonymName . properNameT
notDuplicate _ = True
removeTypeDeclarationsForClass _ = mempty
@@ -88,12 +90,13 @@ convertDecl :: P.ExternsDeclaration -> Maybe IdeDeclaration
convertDecl P.EDType{..} = Just $ IdeDeclType $
IdeType edTypeName edTypeKind
convertDecl P.EDTypeSynonym{..} = Just $ IdeDeclTypeSynonym
- (IdeSynonym edTypeSynonymName edTypeSynonymType)
+ (IdeTypeSynonym edTypeSynonymName edTypeSynonymType)
convertDecl P.EDDataConstructor{..} = Just $ IdeDeclDataConstructor $
IdeDataConstructor edDataCtorName edDataCtorTypeCtor edDataCtorType
convertDecl P.EDValue{..} = Just $ IdeDeclValue $
IdeValue edValueName edValueType
-convertDecl P.EDClass{..} = Just (IdeDeclTypeClass edClassName)
+convertDecl P.EDClass{..} = Just $ IdeDeclTypeClass $
+ IdeTypeClass edClassName []
convertDecl P.EDKind{..} = Just (IdeDeclKind edKindName)
convertDecl P.EDInstance{} = Nothing
@@ -117,10 +120,10 @@ convertTypeOperator P.ExternsTypeFixity{..} =
annotateModule
:: (DefinitionSites P.SourceSpan, TypeAnnotations)
- -> Module
- -> Module
-annotateModule (defs, types) (moduleName, decls) =
- (moduleName, map convertDeclaration decls)
+ -> [IdeDeclarationAnn]
+ -> [IdeDeclarationAnn]
+annotateModule (defs, types) decls =
+ map convertDeclaration decls
where
convertDeclaration :: IdeDeclarationAnn -> IdeDeclarationAnn
convertDeclaration (IdeDeclarationAnn ann d) = case d of
@@ -132,12 +135,12 @@ annotateModule (defs, types) (moduleName, decls) =
annotateType (s ^. ideSynonymName . properNameT) (IdeDeclTypeSynonym s)
IdeDeclDataConstructor dtor ->
annotateValue (dtor ^. ideDtorName . properNameT) (IdeDeclDataConstructor dtor)
- IdeDeclTypeClass i ->
- annotateType (i ^. properNameT) (IdeDeclTypeClass i)
+ IdeDeclTypeClass tc ->
+ annotateType (tc ^. ideTCName . properNameT) (IdeDeclTypeClass tc)
IdeDeclValueOperator op ->
- annotateValue (op ^. ideValueOpAlias & valueOperatorAliasT) (IdeDeclValueOperator op)
+ annotateValue (op ^. ideValueOpName . opNameT) (IdeDeclValueOperator op)
IdeDeclTypeOperator op ->
- annotateType (op ^. ideTypeOpAlias & typeOperatorAliasT) (IdeDeclTypeOperator op)
+ annotateType (op ^. ideTypeOpName . opNameT) (IdeDeclTypeOperator op)
IdeDeclKind i ->
annotateKind (i ^. properNameT) (IdeDeclKind i)
where
diff --git a/src/Language/PureScript/Ide/Filter.hs b/src/Language/PureScript/Ide/Filter.hs
index 5648028..b15120c 100644
--- a/src/Language/PureScript/Ide/Filter.hs
+++ b/src/Language/PureScript/Ide/Filter.hs
@@ -32,6 +32,8 @@ import Language.PureScript.Ide.Util
newtype Filter = Filter (Endo [Module]) deriving(Monoid)
+type Module = (P.ModuleName, [IdeDeclarationAnn])
+
mkFilter :: ([Module] -> [Module]) -> Filter
mkFilter = Filter . Endo
diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs
index b8ad743..21158d8 100644
--- a/src/Language/PureScript/Ide/Imports.hs
+++ b/src/Language/PureScript/Ide/Imports.hs
@@ -39,7 +39,7 @@ import Language.PureScript.Ide.Filter
import Language.PureScript.Ide.State
import Language.PureScript.Ide.Types
import Language.PureScript.Ide.Util
-import System.IO.UTF8 (readUTF8FileT, writeUTF8FileT)
+import System.IO.UTF8 (writeUTF8FileT)
data Import = Import P.ModuleName P.ImportDeclarationType (Maybe P.ModuleName)
deriving (Eq, Show)
@@ -67,10 +67,10 @@ compImport (Import n i q) (Import n' i' q')
-- | Reads a file and returns the (lines before the imports, the imports, the
-- lines after the imports)
-parseImportsFromFile :: (MonadIO m, MonadError PscIdeError m) =>
+parseImportsFromFile :: (MonadIO m, MonadError IdeError m) =>
FilePath -> m (P.ModuleName, [Text], [Import], [Text])
parseImportsFromFile fp = do
- file <- liftIO (readUTF8FileT fp)
+ file <- ideReadFile fp
case sliceImportSection (T.lines file) of
Right res -> pure res
Left err -> throwError (GeneralError err)
@@ -147,7 +147,7 @@ moduleParse t = first show $ do
P.runTokenParser "<psc-ide>" P.parseModule tokens
-- | Adds an implicit import like @import Prelude@ to a Sourcefile.
-addImplicitImport :: (MonadIO m, MonadError PscIdeError m)
+addImplicitImport :: (MonadIO m, MonadError IdeError m)
=> FilePath -- ^ The Sourcefile read from
-> P.ModuleName -- ^ The module to import
-> m [Text]
@@ -170,7 +170,7 @@ addImplicitImport' imports mn =
-- So @addExplicitImport "/File.purs" "bind" "Prelude"@ with an already existing
-- @import Prelude (bind)@ in the file File.purs returns @["import Prelude
-- (bind, unit)"]@
-addExplicitImport :: (MonadIO m, MonadError PscIdeError m) =>
+addExplicitImport :: (MonadIO m, MonadError IdeError m) =>
FilePath -> IdeDeclaration -> P.ModuleName -> m [Text]
addExplicitImport fp decl moduleName = do
(mn, pre, imports, post) <- parseImportsFromFile fp
@@ -197,8 +197,8 @@ addExplicitImport' decl moduleName imports =
then imports
else updateAtFirstOrPrepend matches (insertDeclIntoImport decl) freshImport imports
where
- refFromDeclaration (IdeDeclTypeClass n) =
- P.TypeClassRef n
+ refFromDeclaration (IdeDeclTypeClass tc) =
+ P.TypeClassRef (tc ^. ideTCName)
refFromDeclaration (IdeDeclDataConstructor dtor) =
P.TypeRef (dtor ^. ideDtorTypeName) Nothing
refFromDeclaration (IdeDeclType t) =
@@ -249,7 +249,7 @@ updateAtFirstOrPrepend p t d l =
--
-- * If more than one possible imports are found, reports the possibilities as a
-- list of completions.
-addImportForIdentifier :: (Ide m, MonadError PscIdeError m)
+addImportForIdentifier :: (Ide m, MonadError IdeError m)
=> FilePath -- ^ The Sourcefile to read from
-> Text -- ^ The identifier to import
-> [Filter] -- ^ Filters to apply before searching for
diff --git a/src/Language/PureScript/Ide/Logging.hs b/src/Language/PureScript/Ide/Logging.hs
index 84f45d2..33fc3c2 100644
--- a/src/Language/PureScript/Ide/Logging.hs
+++ b/src/Language/PureScript/Ide/Logging.hs
@@ -4,6 +4,7 @@ module Language.PureScript.Ide.Logging
( runLogger
, logPerf
, displayTimeSpec
+ , labelTimespec
) where
import Protolude
@@ -24,6 +25,9 @@ runLogger logLevel' =
LogDebug -> not (logLevel == LevelOther "perf")
LogPerf -> logLevel == LevelOther "perf")
+labelTimespec :: Text -> TimeSpec -> Text
+labelTimespec label duration = label <> ": " <> displayTimeSpec duration
+
logPerf :: (MonadIO m, MonadLogger m) => (TimeSpec -> Text) -> m t -> m t
logPerf format f = do
start <- liftIO (getTime Monotonic)
diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs
index b1647ee..b0fa8dd 100644
--- a/src/Language/PureScript/Ide/Rebuild.hs
+++ b/src/Language/PureScript/Ide/Rebuild.hs
@@ -2,7 +2,9 @@
{-# LANGUAGE TemplateHaskell #-}
module Language.PureScript.Ide.Rebuild
- ( rebuildFile
+ ( rebuildFileSync
+ , rebuildFileAsync
+ , rebuildFile
) where
import Protolude
@@ -15,9 +17,10 @@ import qualified Data.Set as S
import qualified Language.PureScript as P
import Language.PureScript.Errors.JSON
import Language.PureScript.Ide.Error
+import Language.PureScript.Ide.Logging
import Language.PureScript.Ide.State
import Language.PureScript.Ide.Types
-import System.IO.UTF8 (readUTF8FileT)
+import Language.PureScript.Ide.Util
-- | Given a filepath performs the following steps:
--
@@ -35,12 +38,15 @@ import System.IO.UTF8 (readUTF8FileT)
-- warnings, and if rebuilding fails, returns a @RebuildError@ with the
-- generated errors.
rebuildFile
- :: (Ide m, MonadLogger m, MonadError PscIdeError m)
+ :: (Ide m, MonadLogger m, MonadError IdeError m)
=> FilePath
+ -- ^ The file to rebuild
+ -> (ReaderT IdeEnvironment (LoggingT IO) () -> m ())
+ -- ^ A runner for the second build with open exports
-> m Success
-rebuildFile path = do
+rebuildFile path runOpenBuild = do
- input <- liftIO (readUTF8FileT path)
+ input <- ideReadFile path
m <- case snd <$> P.parseModuleFromFile identity (path, input) of
Left parseError -> throwError
@@ -51,7 +57,7 @@ rebuildFile path = do
-- Externs files must be sorted ahead of time, so that they get applied
-- correctly to the 'Environment'.
- externs <- sortExterns m =<< getExternFiles
+ externs <- logPerf (labelTimespec "Sorting externs") (sortExterns m =<< getExternFiles)
outputDirectory <- confOutputPath . ideConfiguration <$> ask
@@ -62,25 +68,49 @@ rebuildFile path = do
let makeEnv = MakeActionsEnv outputDirectory filePathMap foreigns False
-- Rebuild the single module using the cached externs
- (result, warnings) <- liftIO
+ (result, warnings) <- logPerf (labelTimespec "Rebuilding Module") $
+ liftIO
. P.runMake P.defaultOptions
. P.rebuildModule (buildMakeActions
>>= shushProgress $ makeEnv) externs $ m
case result of
Left errors -> throwError (RebuildError (toJSONErrors False P.Error errors))
Right _ -> do
- rebuildModuleOpen makeEnv externs m
+ runOpenBuild (rebuildModuleOpen makeEnv externs m)
pure (RebuildSuccess (toJSONErrors False P.Warning warnings))
+rebuildFileAsync
+ :: forall m. (Ide m, MonadLogger m, MonadError IdeError m)
+ => FilePath -> m Success
+rebuildFileAsync fp = rebuildFile fp asyncRun
+ where
+ asyncRun :: ReaderT IdeEnvironment (LoggingT IO) () -> m ()
+ asyncRun action = do
+ env <- ask
+ let ll = confLogLevel (ideConfiguration env)
+ void (liftIO (async (runLogger ll (runReaderT action env))))
+
+rebuildFileSync
+ :: forall m. (Ide m, MonadLogger m, MonadError IdeError m)
+ => FilePath -> m Success
+rebuildFileSync fp = rebuildFile fp syncRun
+ where
+ syncRun :: ReaderT IdeEnvironment (LoggingT IO) () -> m ()
+ syncRun action = do
+ env <- ask
+ let ll = confLogLevel (ideConfiguration env)
+ void (liftIO (runLogger ll (runReaderT action env)))
+
+
-- | Rebuilds a module but opens up its export list first and stores the result
-- inside the rebuild cache
rebuildModuleOpen
- :: (Ide m, MonadLogger m, MonadError PscIdeError m)
+ :: (Ide m, MonadLogger m)
=> MakeActionsEnv
-> [P.ExternsFile]
-> P.Module
-> m ()
-rebuildModuleOpen makeEnv externs m = do
+rebuildModuleOpen makeEnv externs m = void $ runExceptT $ do
(openResult, _) <- liftIO
. P.runMake P.defaultOptions
. P.rebuildModule (buildMakeActions
@@ -99,8 +129,8 @@ rebuildModuleOpen makeEnv externs m = do
data MakeActionsEnv =
MakeActionsEnv
{ maeOutputDirectory :: FilePath
- , maeFilePathMap :: Map P.ModuleName (Either P.RebuildPolicy FilePath)
- , maeForeignPathMap :: Map P.ModuleName FilePath
+ , maeFilePathMap :: ModuleMap (Either P.RebuildPolicy FilePath)
+ , maeForeignPathMap :: ModuleMap FilePath
, maePrefixComment :: Bool
}
@@ -128,9 +158,9 @@ shushCodegen ma MakeActionsEnv{..} =
-- module. Throws an error if there is a cyclic dependency within the
-- ExternsFiles
sortExterns
- :: (Ide m, MonadError PscIdeError m)
+ :: (Ide m, MonadError IdeError m)
=> P.Module
- -> Map P.ModuleName P.ExternsFile
+ -> ModuleMap P.ExternsFile
-> m [P.ExternsFile]
sortExterns m ex = do
sorted' <- runExceptT
diff --git a/src/Language/PureScript/Ide/Reexports.hs b/src/Language/PureScript/Ide/Reexports.hs
index 47f1927..367fc0a 100644
--- a/src/Language/PureScript/Ide/Reexports.hs
+++ b/src/Language/PureScript/Ide/Reexports.hs
@@ -18,25 +18,26 @@ module Language.PureScript.Ide.Reexports
, prettyPrintReexportResult
, reexportHasFailures
, ReexportResult(..)
+ -- for tests
+ , resolveReexports'
) where
import Protolude
import Control.Lens hiding ((&))
-
import qualified Data.Map as Map
import qualified Language.PureScript as P
import Language.PureScript.Ide.Types
import Language.PureScript.Ide.Util
--- | Contains the module with resolved reexports, and eventual failures
+-- | Contains the module with resolved reexports, and possible failures
data ReexportResult a
= ReexportResult
{ reResolved :: a
, reFailed :: [(P.ModuleName, P.DeclarationRef)]
} deriving (Show, Eq, Functor)
--- | Uses the passed formatter to format the resolved module, and adds eventual
+-- | Uses the passed formatter to format the resolved module, and adds possible
-- failures
prettyPrintReexportResult
:: (a -> Text)
@@ -56,16 +57,27 @@ prettyPrintReexportResult f ReexportResult{..}
reexportHasFailures :: ReexportResult a -> Bool
reexportHasFailures = not . null . reFailed
--- | Resolves Reexports for a given Module, by looking up the reexported values
--- from the passed in Map
+-- | Resolves Reexports for the given Modules, by looking up the reexported
+-- values from the passed in DeclarationRefs
resolveReexports
- :: Map P.ModuleName [IdeDeclarationAnn]
+ :: ModuleMap [(P.ModuleName, P.DeclarationRef)]
+ -- ^ the references to resolve
+ -> ModuleMap [IdeDeclarationAnn]
-- ^ Modules to search for the reexported declarations
- -> (Module, [(P.ModuleName, P.DeclarationRef)])
- -- ^ The module to resolve reexports for, aswell as the references to resolve
- -> ReexportResult Module
-resolveReexports modules ((moduleName, decls), refs) =
- ReexportResult (moduleName, decls <> concat resolvedRefs) failedRefs
+ -> ModuleMap (ReexportResult [IdeDeclarationAnn])
+resolveReexports reexportRefs modules =
+ Map.mapWithKey (\moduleName decls ->
+ maybe (ReexportResult decls [])
+ (resolveReexports' modules decls)
+ (Map.lookup moduleName reexportRefs)) modules
+
+resolveReexports'
+ :: ModuleMap [IdeDeclarationAnn]
+ -> [IdeDeclarationAnn]
+ -> [(P.ModuleName, P.DeclarationRef)]
+ -> ReexportResult [IdeDeclarationAnn]
+resolveReexports' modules decls refs =
+ ReexportResult (decls <> concat resolvedRefs) failedRefs
where
(failedRefs, resolvedRefs) = partitionEithers (resolveRef' <$> refs)
resolveRef' x@(mn, r) = case Map.lookup mn modules of
@@ -78,7 +90,7 @@ resolveRef
-> Either P.DeclarationRef [IdeDeclarationAnn]
resolveRef decls ref = case ref of
P.TypeRef tn mdtors ->
- case findRef (\x -> x ^? _IdeDeclType . ideTypeName <&> (== tn) & fromMaybe False) of
+ case findRef (anyOf (_IdeDeclType . ideTypeName) (== tn)) of
Nothing -> Left ref
Just d -> Right $ d : case mdtors of
Nothing ->
@@ -88,13 +100,13 @@ resolveRef decls ref = case ref of
findDtors tn
Just dtors -> mapMaybe lookupDtor dtors
P.ValueRef i ->
- findWrapped (\x -> x ^? _IdeDeclValue . ideValueIdent <&> (== i) & fromMaybe False)
+ findWrapped (anyOf (_IdeDeclValue . ideValueIdent) (== i))
P.ValueOpRef name ->
- findWrapped (\x -> x ^? _IdeDeclValueOperator . ideValueOpName <&> (== name) & fromMaybe False)
+ findWrapped (anyOf (_IdeDeclValueOperator . ideValueOpName) (== name))
P.TypeOpRef name ->
- findWrapped (\x -> x ^? _IdeDeclTypeOperator . ideTypeOpName <&> (== name) & fromMaybe False)
+ findWrapped (anyOf (_IdeDeclTypeOperator . ideTypeOpName) (== name))
P.TypeClassRef name ->
- findWrapped (\case IdeDeclTypeClass n -> n == name; _ -> False)
+ findWrapped (anyOf (_IdeDeclTypeClass . ideTCName) (== name))
_ ->
Left ref
where
@@ -102,9 +114,9 @@ resolveRef decls ref = case ref of
findRef f = find (f . discardAnn) decls
lookupDtor name =
- findRef (\x -> x ^? _IdeDeclDataConstructor . ideDtorName <&> (== name) & fromMaybe False)
+ findRef (anyOf (_IdeDeclDataConstructor . ideDtorName) (== name))
- findDtors tn = filter (f . discardAnn) decls
- where
- f :: IdeDeclaration -> Bool
- f decl = decl ^? _IdeDeclDataConstructor . ideDtorTypeName <&> (== tn) & fromMaybe False
+ findDtors tn = filter (anyOf
+ (idaDeclaration
+ . _IdeDeclDataConstructor
+ . ideDtorTypeName) (== tn)) decls
diff --git a/src/Language/PureScript/Ide/SourceFile.hs b/src/Language/PureScript/Ide/SourceFile.hs
index 21f1e0c..e452236 100644
--- a/src/Language/PureScript/Ide/SourceFile.hs
+++ b/src/Language/PureScript/Ide/SourceFile.hs
@@ -28,14 +28,13 @@ import qualified Language.PureScript as P
import Language.PureScript.Ide.Error
import Language.PureScript.Ide.Types
import Language.PureScript.Ide.Util
-import System.IO.UTF8 (readUTF8FileT)
parseModule
- :: (MonadIO m)
+ :: (MonadIO m, MonadError IdeError m)
=> FilePath
-> m (Either FilePath (FilePath, P.Module))
parseModule path = do
- contents <- liftIO (readUTF8FileT path)
+ contents <- ideReadFile path
case P.parseModuleFromFile identity (path, contents) of
Left _ -> pure (Left path)
Right m -> pure (Right m)
@@ -47,7 +46,7 @@ getImports (P.Module _ _ _ declarations _) =
isImport (P.PositionedDeclaration _ _ (P.ImportDeclaration a b c)) = Just (a, b, c)
isImport _ = Nothing
-getImportsForFile :: (MonadIO m, MonadError PscIdeError m) =>
+getImportsForFile :: (MonadIO m, MonadError IdeError m) =>
FilePath -> m [ModuleImport]
getImportsForFile fp = do
moduleE <- parseModule fp
@@ -106,6 +105,10 @@ extractSpans ss d = case d of
P.DataDeclaration _ name _ ctors ->
(IdeNSType (P.runProperName name), ss)
: map (\(cname, _) -> (IdeNSValue (P.runProperName cname), ss)) ctors
+ P.FixityDeclaration (Left (P.ValueFixity _ _ opName)) ->
+ [(IdeNSValue (P.runOpName opName), ss)]
+ P.FixityDeclaration (Right (P.TypeFixity _ _ opName)) ->
+ [(IdeNSType (P.runOpName opName), ss)]
P.ExternDeclaration ident _ ->
[(IdeNSValue (P.runIdent ident), ss)]
P.ExternDataDeclaration name _ ->
diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs
index f24ad0c..8e58f3d 100644
--- a/src/Language/PureScript/Ide/State.hs
+++ b/src/Language/PureScript/Ide/State.hs
@@ -14,6 +14,7 @@
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE NamedFieldPuns #-}
module Language.PureScript.Ide.State
( getLoadedModulenames
@@ -29,10 +30,12 @@ module Language.PureScript.Ide.State
, populateStage3STM
-- for tests
, resolveOperatorsForModule
+ , resolveInstances
) where
import Protolude
+import Control.Arrow
import Control.Concurrent.STM
import Control.Lens hiding (op, (&))
import "monad-logger" Control.Monad.Logger
@@ -58,7 +61,7 @@ getLoadedModulenames :: Ide m => m [P.ModuleName]
getLoadedModulenames = Map.keys <$> getExternFiles
-- | Gets all loaded ExternFiles
-getExternFiles :: Ide m => m (Map P.ModuleName ExternsFile)
+getExternFiles :: Ide m => m (ModuleMap ExternsFile)
getExternFiles = s1Externs <$> getStage1
-- | Insert a Module into Stage1 of the State
@@ -121,7 +124,7 @@ setStage3STM ref s3 = do
-- | Checks if the given ModuleName matches the last rebuild cache and if it
-- does returns all loaded definitions + the definitions inside the rebuild
-- cache
-getAllModules :: Ide m => Maybe P.ModuleName -> m [Module]
+getAllModules :: Ide m => Maybe P.ModuleName -> m [(P.ModuleName, [IdeDeclarationAnn])]
getAllModules mmoduleName = do
declarations <- s3Declarations <$> getStage3
rebuild <- cachedRebuild
@@ -136,7 +139,7 @@ getAllModules mmoduleName = do
ast =
fromMaybe (Map.empty, Map.empty) (Map.lookup moduleName asts)
cachedModule =
- snd . annotateModule ast . fst . convertExterns $ ef
+ annotateModule ast (fst (convertExterns ef))
tmp =
Map.insert moduleName cachedModule declarations
resolved =
@@ -192,43 +195,84 @@ populateStage3 = do
st <- ideStateVar <$> ask
let message duration = "Finished populating Stage3 in " <> displayTimeSpec duration
results <- logPerf message (liftIO (atomically (populateStage3STM st)))
- traverse_
- (logWarnN . prettyPrintReexportResult (P.runModuleName . fst))
- (filter reexportHasFailures results)
+ void $ Map.traverseWithKey
+ (\mn -> logWarnN . prettyPrintReexportResult (const (P.runModuleName mn)))
+ (Map.filter reexportHasFailures results)
-- | STM version of populateStage3
-populateStage3STM :: TVar IdeState -> STM [ReexportResult Module]
+populateStage3STM
+ :: TVar IdeState
+ -> STM (ModuleMap (ReexportResult [IdeDeclarationAnn]))
populateStage3STM ref = do
externs <- s1Externs <$> getStage1STM ref
(AstData asts) <- s2AstData <$> getStage2STM ref
- let modules = Map.map convertExterns externs
- nModules :: Map P.ModuleName (Module, [(P.ModuleName, P.DeclarationRef)])
- nModules = Map.mapWithKey
- (\moduleName (m, refs) ->
- (fromMaybe m $ annotateModule <$> Map.lookup moduleName asts <*> pure m, refs)) modules
- -- resolves reexports and discards load failures for now
- result = resolveReexports (map (snd . fst) nModules) <$> Map.elems nModules
- resultP = resolveOperators (Map.fromList (reResolved <$> result))
- setStage3STM ref (Stage3 resultP Nothing)
- pure result
+ let (modules, reexportRefs) = (map fst &&& map snd) (Map.map convertExterns externs)
+ results =
+ resolveLocations asts modules
+ & resolveInstances externs
+ & resolveOperators
+ & resolveReexports reexportRefs
+ setStage3STM ref (Stage3 (map reResolved results) Nothing)
+ pure results
+
+
+resolveLocations
+ :: ModuleMap (DefinitionSites P.SourceSpan, TypeAnnotations)
+ -> ModuleMap [IdeDeclarationAnn]
+ -> ModuleMap [IdeDeclarationAnn]
+resolveLocations asts =
+ Map.mapWithKey (\mn decls ->
+ maybe decls (flip annotateModule decls) (Map.lookup mn asts))
+
+resolveInstances
+ :: ModuleMap P.ExternsFile
+ -> ModuleMap [IdeDeclarationAnn]
+ -> ModuleMap [IdeDeclarationAnn]
+resolveInstances externs declarations =
+ Map.foldr (flip (foldr go)) declarations
+ . Map.mapWithKey (\mn ef -> mapMaybe (extractInstances mn) (efDeclarations ef))
+ $ externs
+ where
+ extractInstances mn P.EDInstance{..} =
+ case edInstanceClassName of
+ P.Qualified (Just classModule) className ->
+ Just (IdeInstance mn
+ edInstanceName
+ edInstanceTypes
+ edInstanceConstraints, classModule, className)
+ _ -> Nothing
+ extractInstances _ _ = Nothing
+
+ go ::
+ (IdeInstance, P.ModuleName, P.ProperName 'P.ClassName)
+ -> ModuleMap [IdeDeclarationAnn]
+ -> ModuleMap [IdeDeclarationAnn]
+ go (ideInstance, classModule, className) acc' =
+ let
+ matchTC =
+ anyOf (idaDeclaration . _IdeDeclTypeClass . ideTCName) (== className)
+ updateDeclaration =
+ mapIf matchTC (idaDeclaration
+ . _IdeDeclTypeClass
+ . ideTCInstances
+ %~ cons ideInstance)
+ in
+ acc' & ix classModule %~ updateDeclaration
resolveOperators
- :: Map P.ModuleName [IdeDeclarationAnn]
- -> Map P.ModuleName [IdeDeclarationAnn]
+ :: ModuleMap [IdeDeclarationAnn]
+ -> ModuleMap [IdeDeclarationAnn]
resolveOperators modules =
map (resolveOperatorsForModule modules) modules
-- | Looks up the types and kinds for operators and assigns them to their
-- declarations
resolveOperatorsForModule
- :: Map P.ModuleName [IdeDeclarationAnn]
+ :: ModuleMap [IdeDeclarationAnn]
-> [IdeDeclarationAnn]
-> [IdeDeclarationAnn]
-resolveOperatorsForModule modules = map ((over idaDeclaration) resolveOperator)
+resolveOperatorsForModule modules = map (idaDeclaration %~ resolveOperator)
where
- hasName :: Eq b => Lens' a b -> b -> a -> Bool
- hasName l a x = x ^. l == a
-
getDeclarations :: P.ModuleName -> [IdeDeclaration]
getDeclarations moduleName =
Map.lookup moduleName modules
@@ -239,14 +283,14 @@ resolveOperatorsForModule modules = map ((over idaDeclaration) resolveOperator)
| (P.Qualified (Just mn) (Left ident)) <- op ^. ideValueOpAlias =
let t = getDeclarations mn
& mapMaybe (preview _IdeDeclValue)
- & filter (hasName ideValueIdent ident)
+ & filter (anyOf ideValueIdent (== ident))
& map (view ideValueType)
& listToMaybe
in IdeDeclValueOperator (op & ideValueOpType .~ t)
| (P.Qualified (Just mn) (Right dtor)) <- op ^. ideValueOpAlias =
let t = getDeclarations mn
& mapMaybe (preview _IdeDeclDataConstructor)
- & filter (hasName ideDtorName dtor)
+ & filter (anyOf ideDtorName (== dtor))
& map (view ideDtorType)
& listToMaybe
in IdeDeclValueOperator (op & ideValueOpType .~ t)
@@ -254,9 +298,12 @@ resolveOperatorsForModule modules = map ((over idaDeclaration) resolveOperator)
| P.Qualified (Just mn) properName <- op ^. ideTypeOpAlias =
let k = getDeclarations mn
& mapMaybe (preview _IdeDeclType)
- & filter (hasName ideTypeName properName)
+ & filter (anyOf ideTypeName (== properName))
& map (view ideTypeKind)
& listToMaybe
in IdeDeclTypeOperator (op & ideTypeOpKind .~ k)
resolveOperator x = x
+
+mapIf :: Functor f => (b -> Bool) -> (b -> b) -> f b -> f b
+mapIf p f = map (\x -> if p x then f x else x)
diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs
index 75e5d25..f8e75de 100644
--- a/src/Language/PureScript/Ide/Types.hs
+++ b/src/Language/PureScript/Ide/Types.hs
@@ -27,13 +27,14 @@ import qualified Language.PureScript as P
import qualified Language.PureScript.Errors.JSON as P
type ModuleIdent = Text
+type ModuleMap a = Map P.ModuleName a
data IdeDeclaration
= IdeDeclValue IdeValue
| IdeDeclType IdeType
- | IdeDeclTypeSynonym IdeSynonym
+ | IdeDeclTypeSynonym IdeTypeSynonym
| IdeDeclDataConstructor IdeDataConstructor
- | IdeDeclTypeClass (P.ProperName 'P.ClassName)
+ | IdeDeclTypeClass IdeTypeClass
| IdeDeclValueOperator IdeValueOperator
| IdeDeclTypeOperator IdeTypeOperator
| IdeDeclKind (P.ProperName 'P.KindName)
@@ -49,7 +50,7 @@ data IdeType = IdeType
, _ideTypeKind :: P.Kind
} deriving (Show, Eq, Ord)
-data IdeSynonym = IdeSynonym
+data IdeTypeSynonym = IdeTypeSynonym
{ _ideSynonymName :: P.ProperName 'P.TypeName
, _ideSynonymType :: P.Type
} deriving (Show, Eq, Ord)
@@ -60,6 +61,18 @@ data IdeDataConstructor = IdeDataConstructor
, _ideDtorType :: P.Type
} deriving (Show, Eq, Ord)
+data IdeTypeClass = IdeTypeClass
+ { _ideTCName :: P.ProperName 'P.ClassName
+ , _ideTCInstances :: [IdeInstance]
+ } deriving (Show, Eq, Ord)
+
+data IdeInstance = IdeInstance
+ { _ideInstanceModule :: P.ModuleName
+ , _ideInstanceName :: P.Ident
+ , _ideInstanceTypes :: [P.Type]
+ , _ideInstanceConstraints :: Maybe [P.Constraint]
+ } deriving (Show, Eq, Ord)
+
data IdeValueOperator = IdeValueOperator
{ _ideValueOpName :: P.OpName 'P.ValueOpName
, _ideValueOpAlias :: P.Qualified (Either P.Ident (P.ProperName 'P.ConstructorName))
@@ -79,8 +92,10 @@ data IdeTypeOperator = IdeTypeOperator
makePrisms ''IdeDeclaration
makeLenses ''IdeValue
makeLenses ''IdeType
-makeLenses ''IdeSynonym
+makeLenses ''IdeTypeSynonym
makeLenses ''IdeDataConstructor
+makeLenses ''IdeTypeClass
+makeLenses ''IdeInstance
makeLenses ''IdeValueOperator
makeLenses ''IdeTypeOperator
@@ -101,11 +116,9 @@ makeLenses ''IdeDeclarationAnn
emptyAnn :: Annotation
emptyAnn = Annotation Nothing Nothing Nothing
-type Module = (P.ModuleName, [IdeDeclarationAnn])
-
type DefinitionSites a = Map IdeDeclNamespace a
type TypeAnnotations = Map P.Ident P.Type
-newtype AstData a = AstData (Map P.ModuleName (DefinitionSites a, TypeAnnotations))
+newtype AstData a = AstData (ModuleMap (DefinitionSites a, TypeAnnotations))
-- ^ SourceSpans for the definition sites of Values and Types aswell as type
-- annotations found in a module
deriving (Show, Eq, Ord, Functor, Foldable)
@@ -132,7 +145,7 @@ data IdeState = IdeState
{ ideStage1 :: Stage1
, ideStage2 :: Stage2
, ideStage3 :: Stage3
- }
+ } deriving (Show)
emptyIdeState :: IdeState
emptyIdeState = IdeState emptyStage1 emptyStage2 emptyStage3
@@ -147,18 +160,18 @@ emptyStage3 :: Stage3
emptyStage3 = Stage3 M.empty Nothing
data Stage1 = Stage1
- { s1Externs :: M.Map P.ModuleName P.ExternsFile
- , s1Modules :: M.Map P.ModuleName (P.Module, FilePath)
- }
+ { s1Externs :: ModuleMap P.ExternsFile
+ , s1Modules :: ModuleMap (P.Module, FilePath)
+ } deriving (Show)
data Stage2 = Stage2
{ s2AstData :: AstData P.SourceSpan
- }
+ } deriving (Show, Eq)
data Stage3 = Stage3
- { s3Declarations :: M.Map P.ModuleName [IdeDeclarationAnn]
+ { s3Declarations :: ModuleMap [IdeDeclarationAnn]
, s3CachedRebuild :: Maybe (P.ModuleName, P.ExternsFile)
- }
+ } deriving (Show)
newtype Match a = Match (P.ModuleName, a)
deriving (Show, Eq, Functor)
@@ -216,6 +229,8 @@ 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 (P.ValueOpRef op) = P.showOp op
+identifierFromDeclarationRef (P.TypeOpRef op) = P.showOp op
identifierFromDeclarationRef _ = ""
data Success =
diff --git a/src/Language/PureScript/Ide/Util.hs b/src/Language/PureScript/Ide/Util.hs
index 3345b9b..d8e7706 100644
--- a/src/Language/PureScript/Ide/Util.hs
+++ b/src/Language/PureScript/Ide/Util.hs
@@ -24,21 +24,27 @@ module Language.PureScript.Ide.Util
, withEmptyAnn
, valueOperatorAliasT
, typeOperatorAliasT
- , module Language.PureScript.Ide.Conversions
+ , prettyTypeT
+ , properNameT
+ , identT
+ , opNameT
+ , ideReadFile
, module Language.PureScript.Ide.Logging
) where
import Protolude hiding (decodeUtf8,
encodeUtf8)
-import Control.Lens ((^.))
+import Control.Lens hiding ((&), op)
import Data.Aeson
import qualified Data.Text as T
+import qualified Data.Text.Lazy as TL
import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8)
import qualified Language.PureScript as P
-import Language.PureScript.Ide.Conversions
+import Language.PureScript.Ide.Error
import Language.PureScript.Ide.Logging
import Language.PureScript.Ide.Types
+import System.IO.UTF8 (readUTF8FileT)
identifierFromIdeDeclaration :: IdeDeclaration -> Text
identifierFromIdeDeclaration d = case d of
@@ -46,7 +52,7 @@ identifierFromIdeDeclaration d = case d of
IdeDeclType t -> t ^. ideTypeName . properNameT
IdeDeclTypeSynonym s -> s ^. ideSynonymName . properNameT
IdeDeclDataConstructor dtor -> dtor ^. ideDtorName . properNameT
- IdeDeclTypeClass name -> P.runProperName name
+ IdeDeclTypeClass tc -> tc ^. ideTCName . properNameT
IdeDeclValueOperator op -> op ^. ideValueOpName & P.runOpName
IdeDeclTypeOperator op -> op ^. ideTypeOpName & P.runOpName
IdeDeclKind name -> P.runProperName name
@@ -66,14 +72,14 @@ completionFromMatch (Match (m, IdeDeclarationAnn ann decl)) =
where
(complIdentifier, complExpandedType) = case decl of
IdeDeclValue v -> (v ^. ideValueIdent . identT, v ^. ideValueType & prettyTypeT)
- IdeDeclType t -> (t ^. ideTypeName . properNameT, t ^. ideTypeKind & P.prettyPrintKind & toS )
+ IdeDeclType t -> (t ^. ideTypeName . properNameT, t ^. ideTypeKind & P.prettyPrintKind)
IdeDeclTypeSynonym s -> (s ^. ideSynonymName . properNameT, s ^. ideSynonymType & prettyTypeT)
IdeDeclDataConstructor d -> (d ^. ideDtorName . properNameT, d ^. ideDtorType & prettyTypeT)
- IdeDeclTypeClass name -> (P.runProperName name, "class")
+ IdeDeclTypeClass d -> (d ^. ideTCName . properNameT, "type class")
IdeDeclValueOperator (IdeValueOperator op ref precedence associativity typeP) ->
(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)
+ (P.runOpName op, maybe (showFixity precedence associativity (typeOperatorAliasT ref) op) P.prettyPrintKind kind)
IdeDeclKind k -> (P.runProperName k, "kind")
complModule = P.runModuleName m
@@ -102,10 +108,10 @@ typeOperatorAliasT i =
P.showQualified P.runProperName i
encodeT :: (ToJSON a) => a -> Text
-encodeT = toS . decodeUtf8 . encode
+encodeT = TL.toStrict . decodeUtf8 . encode
decodeT :: (FromJSON a) => Text -> Maybe a
-decodeT = decode . encodeUtf8 . toS
+decodeT = decode . encodeUtf8 . TL.fromStrict
unwrapPositioned :: P.Declaration -> P.Declaration
unwrapPositioned (P.PositionedDeclaration _ _ x) = unwrapPositioned x
@@ -114,3 +120,28 @@ unwrapPositioned x = x
unwrapPositionedRef :: P.DeclarationRef -> P.DeclarationRef
unwrapPositionedRef (P.PositionedDeclarationRef _ _ x) = unwrapPositionedRef x
unwrapPositionedRef x = x
+
+properNameT :: Iso' (P.ProperName a) Text
+properNameT = iso P.runProperName P.ProperName
+
+identT :: Iso' P.Ident Text
+identT = iso P.runIdent P.Ident
+
+opNameT :: Iso' (P.OpName a) Text
+opNameT = iso P.runOpName P.OpName
+
+ideReadFile :: (MonadIO m, MonadError IdeError m) => FilePath -> m Text
+ideReadFile fp = do
+ contents :: Either IOException Text <- liftIO (try (readUTF8FileT fp))
+ either
+ (\_ -> throwError (GeneralError ("Couldn't find file at: " <> T.pack fp)))
+ pure
+ contents
+
+prettyTypeT :: P.Type -> Text
+prettyTypeT =
+ T.unwords
+ . map T.strip
+ . T.lines
+ . T.pack
+ . P.prettyPrintTypeWithUnicode
diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs
index 9f60e06..a61e6dc 100644
--- a/src/Language/PureScript/Make.hs
+++ b/src/Language/PureScript/Make.hs
@@ -20,53 +20,51 @@ module Language.PureScript.Make
, inferForeignModules
) where
-import Prelude.Compat
-
-import Control.Concurrent.Lifted as C
-import Control.Monad hiding (sequence)
-import Control.Monad.Base (MonadBase(..))
-import Control.Monad.Error.Class (MonadError(..))
-import Control.Monad.IO.Class
-import Control.Monad.Logger
-import Control.Monad.Reader (MonadReader(..), ReaderT(..), asks)
-import Control.Monad.Supply
-import Control.Monad.Trans.Class (MonadTrans(..))
-import Control.Monad.Trans.Control (MonadBaseControl(..))
-import Control.Monad.Trans.Except
-import Control.Monad.Writer.Class (MonadWriter(..))
-
-import Data.Aeson (encode, decode)
+import Prelude.Compat
+
+import Control.Concurrent.Lifted as C
+import Control.Monad hiding (sequence)
+import Control.Monad.Base (MonadBase(..))
+import Control.Monad.Error.Class (MonadError(..))
+import Control.Monad.IO.Class
+import Control.Monad.Logger
+import Control.Monad.Reader (MonadReader(..), ReaderT(..), asks)
+import Control.Monad.Supply
+import Control.Monad.Trans.Class (MonadTrans(..))
+import Control.Monad.Trans.Control (MonadBaseControl(..))
+import Control.Monad.Trans.Except
+import Control.Monad.Writer.Class (MonadWriter(..))
+import Data.Aeson (encode, decode)
import qualified Data.Aeson as Aeson
-import Data.Either (partitionEithers)
-import Data.Function (on)
-import Data.Foldable (for_)
-import Data.List (foldl', sortBy, groupBy)
-import Data.Maybe (fromMaybe, catMaybes)
-import Data.Monoid ((<>))
-import Data.Time.Clock
-import Data.Traversable (for)
-import Data.Version (showVersion)
+import Data.Either (partitionEithers)
+import Data.Function (on)
+import Data.Foldable (for_)
+import Data.List (foldl', sortBy, groupBy)
+import Data.Maybe (fromMaybe, catMaybes)
+import Data.Monoid ((<>))
+import Data.Time.Clock
+import Data.Traversable (for)
+import Data.Version (showVersion)
import qualified Data.ByteString.Lazy as B
import qualified Data.ByteString.UTF8 as BU8
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
-
-import Language.PureScript.AST
-import Language.PureScript.Crash
-import Language.PureScript.Environment
-import Language.PureScript.Errors
-import Language.PureScript.Externs
-import Language.PureScript.Linter
-import Language.PureScript.ModuleDependencies
-import Language.PureScript.Names
-import Language.PureScript.Options
-import Language.PureScript.Pretty
-import Language.PureScript.Pretty.Common(SMap(..))
-import Language.PureScript.Renamer
-import Language.PureScript.Sugar
-import Language.PureScript.TypeChecker
+import Language.PureScript.AST
+import Language.PureScript.Crash
+import Language.PureScript.Environment
+import Language.PureScript.Errors
+import Language.PureScript.Externs
+import Language.PureScript.Linter
+import Language.PureScript.ModuleDependencies
+import Language.PureScript.Names
+import Language.PureScript.Options
+import Language.PureScript.Pretty
+import Language.PureScript.Pretty.Common(SMap(..))
+import Language.PureScript.Renamer
+import Language.PureScript.Sugar
+import Language.PureScript.TypeChecker
import qualified Language.JavaScript.Parser as JS
import qualified Language.PureScript.Bundle as Bundle
import qualified Language.PureScript.CodeGen.JS as J
@@ -74,21 +72,18 @@ import qualified Language.PureScript.Constants as C
import qualified Language.PureScript.CoreFn as CF
import qualified Language.PureScript.CoreFn.ToJSON as CFJ
import qualified Language.PureScript.Parser as PSParser
-
import qualified Paths_purescript as Paths
-
-import SourceMap
-import SourceMap.Types
-
-import System.Directory (doesFileExist, getModificationTime, createDirectoryIfMissing, getCurrentDirectory)
-import System.FilePath ((</>), takeDirectory, makeRelative, splitPath, normalise, replaceExtension)
-import System.IO.Error (tryIOError)
-
+import SourceMap
+import SourceMap.Types
+import System.Directory (doesFileExist, getModificationTime, createDirectoryIfMissing, getCurrentDirectory)
+import System.FilePath ((</>), takeDirectory, makeRelative, splitPath, normalise, replaceExtension)
+import System.IO.Error (tryIOError)
import qualified Text.Parsec as Parsec
-- | Progress messages from the make process
data ProgressMessage
= CompilingModule ModuleName
+ -- ^ Compilation started for the specified module
deriving (Show, Eq, Ord)
-- | Render a progress message
@@ -102,7 +97,6 @@ renderProgressMessage (CompilingModule mn) = "Compiling " ++ T.unpack (runModule
-- * The particular backend being used (Javascript, C++11, etc.)
--
-- * The details of how files are read/written etc.
---
data MakeActions m = MakeActions
{ getInputTimestamp :: ModuleName -> m (Either RebuildPolicy (Maybe UTCTime))
-- ^ Get the timestamp for the input file(s) for a module. If there are multiple
@@ -121,26 +115,26 @@ data MakeActions m = MakeActions
-- ^ Respond to a progress update.
}
--- |
--- Generated code for an externs file.
---
+-- | Generated code for an externs file.
type Externs = B.ByteString
--- |
--- Determines when to rebuild a module
---
+-- | Determines when to rebuild a module
data RebuildPolicy
-- | Never rebuild this module
= RebuildNever
-- | Always rebuild this module
| RebuildAlways deriving (Show, Eq, Ord)
--- | Rebuild a single module
-rebuildModule :: forall m. (Monad m, MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
- => MakeActions m
- -> [ExternsFile]
- -> Module
- -> m ExternsFile
+-- | Rebuild a single module.
+--
+-- This function is used for fast-rebuild workflows (PSCi and psc-ide are examples).
+rebuildModule
+ :: forall m
+ . (Monad m, MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+ => MakeActions m
+ -> [ExternsFile]
+ -> Module
+ -> m ExternsFile
rebuildModule MakeActions{..} externs m@(Module _ _ moduleName _ _) = do
progress $ CompilingModule moduleName
let env = foldl' (flip applyExternsFileToEnvironment) initEnvironment externs
@@ -157,12 +151,10 @@ rebuildModule MakeActions{..} externs m@(Module _ _ moduleName _ _) = do
evalSupplyT nextVar . codegen renamed env' . encode $ exts
return exts
--- |
--- Compiles in "make" mode, compiling each module separately to a js files and an externs file
+-- | Compiles in "make" mode, compiling each module separately to a @.js@ file and an @externs.json@ file.
--
-- If timestamps have not changed, the externs file can be used to provide the module's types without
-- having to typecheck the module again.
---
make :: forall m. (Monad m, MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
=> MakeActions m
-> [Module]
@@ -244,7 +236,7 @@ make ma@MakeActions{..} ms = do
putMVar (fst $ fromMaybe (internalError "make: no barrier") $ lookup moduleName barriers) externs
putMVar (snd $ fromMaybe (internalError "make: no barrier") $ lookup moduleName barriers) errors
- maximumMaybe :: (Ord a) => [a] -> Maybe a
+ maximumMaybe :: Ord a => [a] -> Maybe a
maximumMaybe [] = Nothing
maximumMaybe xs = Just $ maximum xs
@@ -262,11 +254,10 @@ make ma@MakeActions{..} ms = do
importPrim :: Module -> Module
importPrim = addDefaultImport (ModuleName [ProperName C.prim])
--- |
--- A monad for running make actions
---
-newtype Make a = Make { unMake :: ReaderT Options (ExceptT MultipleErrors (Logger MultipleErrors)) a }
- deriving (Functor, Applicative, Monad, MonadIO, MonadError MultipleErrors, MonadWriter MultipleErrors, MonadReader Options)
+-- | A monad for running make actions
+newtype Make a = Make
+ { unMake :: ReaderT Options (ExceptT MultipleErrors (Logger MultipleErrors)) a
+ } deriving (Functor, Applicative, Monad, MonadIO, MonadError MultipleErrors, MonadWriter MultipleErrors, MonadReader Options)
instance MonadBase IO Make where
liftBase = liftIO
@@ -276,12 +267,12 @@ instance MonadBaseControl IO Make where
liftBaseWith f = Make $ liftBaseWith $ \q -> f (q . unMake)
restoreM = Make . restoreM
--- |
--- Execute a 'Make' monad, returning either errors, or the result of the compile plus any warnings.
---
+-- | Execute a 'Make' monad, returning either errors, or the result of the compile plus any warnings.
runMake :: Options -> Make a -> IO (Either MultipleErrors a, MultipleErrors)
runMake opts = runLogger' . runExceptT . flip runReaderT opts . unMake
+-- | Run an 'IO' action in the 'Make' monad, by specifying how IO errors should
+-- be rendered as 'ErrorMessage' values.
makeIO :: (IOError -> ErrorMessage) -> IO a -> Make a
makeIO f io = do
e <- liftIO $ tryIOError io
@@ -299,7 +290,8 @@ inferForeignModules
. MonadIO m
=> M.Map ModuleName (Either RebuildPolicy FilePath)
-> m (M.Map ModuleName FilePath)
-inferForeignModules = fmap (M.mapMaybe id) . traverse inferForeignModule
+inferForeignModules =
+ fmap (M.mapMaybe id) . traverse inferForeignModule
where
inferForeignModule :: Either RebuildPolicy FilePath -> m (Maybe FilePath)
inferForeignModule (Left _) = return Nothing
@@ -310,16 +302,19 @@ inferForeignModules = fmap (M.mapMaybe id) . traverse inferForeignModule
then return (Just jsFile)
else return Nothing
--- |
--- A set of make actions that read and write modules from the given directory.
---
-buildMakeActions :: FilePath -- ^ the output directory
- -> M.Map ModuleName (Either RebuildPolicy FilePath) -- ^ a map between module names and paths to the file containing the PureScript module
- -> M.Map ModuleName FilePath -- ^ a map between module name and the file containing the foreign javascript for the module
- -> Bool -- ^ Generate a prefix comment?
- -> MakeActions Make
+-- | A set of make actions that read and write modules from the given directory.
+buildMakeActions
+ :: FilePath
+ -- ^ the output directory
+ -> M.Map ModuleName (Either RebuildPolicy FilePath)
+ -- ^ a map between module names and paths to the file containing the PureScript module
+ -> M.Map ModuleName FilePath
+ -- ^ a map between module name and the file containing the foreign javascript for the module
+ -> Bool
+ -- ^ Generate a prefix comment?
+ -> MakeActions Make
buildMakeActions outputDir filePathMap foreigns usePrefix =
- MakeActions getInputTimestamp getOutputTimestamp readExterns codegen progress
+ MakeActions getInputTimestamp getOutputTimestamp readExterns codegen progress
where
getInputTimestamp :: ModuleName -> Make (Either RebuildPolicy (Maybe UTCTime))
@@ -331,10 +326,15 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
getOutputTimestamp :: ModuleName -> Make (Maybe UTCTime)
getOutputTimestamp mn = do
+ dumpCoreFn <- asks optionsDumpCoreFn
let filePath = T.unpack (runModuleName mn)
jsFile = outputDir </> filePath </> "index.js"
externsFile = outputDir </> filePath </> "externs.json"
- min <$> getTimestamp jsFile <*> getTimestamp externsFile
+ coreFnFile = outputDir </> filePath </> "corefn.json"
+ min3 js exts coreFn
+ | dumpCoreFn = min (min js exts) coreFn
+ | otherwise = min js exts
+ min3 <$> getTimestamp jsFile <*> getTimestamp externsFile <*> getTimestamp coreFnFile
readExterns :: ModuleName -> Make (FilePath, Externs)
readExterns mn = do
@@ -421,10 +421,8 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
progress :: ProgressMessage -> Make ()
progress = liftIO . putStrLn . renderProgressMessage
--- |
--- Check that the declarations in a given PureScript module match with those
+-- | Check that the declarations in a given PureScript module match with those
-- in its corresponding foreign module.
---
checkForeignDecls :: CF.Module ann -> FilePath -> SupplyT Make ()
checkForeignDecls m path = do
jsStr <- lift $ readTextFile path
diff --git a/src/Language/PureScript/ModuleDependencies.hs b/src/Language/PureScript/ModuleDependencies.hs
index a8e07f9..5766f0f 100644
--- a/src/Language/PureScript/ModuleDependencies.hs
+++ b/src/Language/PureScript/ModuleDependencies.hs
@@ -1,24 +1,18 @@
--- |
--- Provides the ability to sort modules based on module dependencies
---
+-- | Provides the ability to sort modules based on module dependencies
module Language.PureScript.ModuleDependencies
( sortModules
, ModuleGraph
) where
-import Prelude.Compat
-
-import Control.Monad.Error.Class (MonadError(..))
-
-import Data.Graph
-import Data.List (nub)
-import Data.Maybe (fromMaybe)
+import Protolude
-import Language.PureScript.AST
-import Language.PureScript.Crash
-import Language.PureScript.Errors
-import Language.PureScript.Names
-import Language.PureScript.Types
+import Data.Graph
+import qualified Data.Set as S
+import Language.PureScript.AST
+import qualified Language.PureScript.Constants as C
+import Language.PureScript.Crash
+import Language.PureScript.Errors
+import Language.PureScript.Names
-- | A list of modules with their transitive dependencies
type ModuleGraph = [(ModuleName, [ModuleName])]
@@ -26,75 +20,45 @@ type ModuleGraph = [(ModuleName, [ModuleName])]
-- | Sort a collection of modules based on module dependencies.
--
-- Reports an error if the module graph contains a cycle.
---
-sortModules :: (MonadError MultipleErrors m) => [Module] -> m ([Module], ModuleGraph)
+sortModules
+ :: forall m
+ . MonadError MultipleErrors m
+ => [Module]
+ -> m ([Module], ModuleGraph)
sortModules ms = do
- let verts = map goModule ms
- ms' <- mapM toModule $ stronglyConnComp verts
- let (graph, fromVertex, toVertex) = graphFromEdges verts
- moduleGraph = do (_, mn, _) <- verts
- let v = fromMaybe (internalError "sortModules: vertex not found") (toVertex mn)
- deps = reachable graph v
- toKey i = case fromVertex i of (_, key, _) -> key
- return (mn, filter (/= mn) (map toKey deps))
- return (ms', moduleGraph)
+ let mns = S.fromList $ map getModuleName ms
+ verts <- mapM (toGraphNode mns) ms
+ ms' <- mapM toModule $ stronglyConnComp verts
+ let (graph, fromVertex, toVertex) = graphFromEdges verts
+ moduleGraph = do (_, mn, _) <- verts
+ let v = fromMaybe (internalError "sortModules: vertex not found") (toVertex mn)
+ deps = reachable graph v
+ toKey i = case fromVertex i of (_, key, _) -> key
+ return (mn, filter (/= mn) (map toKey deps))
+ return (ms', moduleGraph)
where
- goModule :: Module -> (Module, ModuleName, [ModuleName])
- goModule m@(Module _ _ _ ds _) =
- let ams = concatMap extractQualAs ds
- in (m, getModuleName m, nub (concatMap (usedModules ams) ds))
+ toGraphNode :: S.Set ModuleName -> Module -> m (Module, ModuleName, [ModuleName])
+ toGraphNode mns m@(Module _ _ mn ds _) = do
+ let deps = ordNub (concatMap usedModules ds)
+ forM_ deps $ \dep ->
+ when (dep /= C.Prim && S.notMember dep mns) $
+ throwError . addHint (ErrorInModule mn) . errorMessage $ ModuleNotFound dep
+ pure (m, getModuleName m, deps)
- -- Extract module names that have been brought into scope by an `as` import.
- extractQualAs :: Declaration -> [ModuleName]
- extractQualAs (PositionedDeclaration _ _ d) = extractQualAs d
- extractQualAs (ImportDeclaration _ _ (Just am)) = [am]
- extractQualAs _ = []
-
--- |
--- Calculate a list of used modules based on explicit imports and qualified
--- names. `ams` is a list of `ModuleNames` that refer to names brought into
--- scope by importing with `as` - this ensures that when building the list we
--- don't inadvertantly assume a dependency on an actual module, if there is a
--- module that has the same name as the qualified import.
---
-usedModules :: [ModuleName] -> Declaration -> [ModuleName]
-usedModules ams d =
- let (f, _, _, _, _) = everythingOnValues (++) forDecls forValues (const []) (const []) (const [])
- (g, _, _, _, _) = accumTypes (everythingOnTypes (++) forTypes)
- in nub (f d ++ g d)
- where
+-- | Calculate a list of used modules based on explicit imports and qualified names.
+usedModules :: Declaration -> [ModuleName]
+usedModules d = f d where
+ f :: Declaration -> [ModuleName]
+ (f, _, _, _, _) = everythingOnValues (++) forDecls (const []) (const []) (const []) (const [])
forDecls :: Declaration -> [ModuleName]
- forDecls (ImportDeclaration mn _ _) =
- -- Regardless of whether an imported module is qualified we still need to
- -- take into account its import to build an accurate list of dependencies.
- [mn]
- forDecls (FixityDeclaration fd)
- | Just mn <- extractQualFixity fd, mn `notElem` ams = [mn]
- forDecls (TypeInstanceDeclaration _ _ (Qualified (Just mn) _) _ _)
- | mn `notElem` ams = [mn]
+ -- Regardless of whether an imported module is qualified we still need to
+ -- take into account its import to build an accurate list of dependencies.
+ forDecls (ImportDeclaration mn _ _) = [mn]
forDecls _ = []
- forValues :: Expr -> [ModuleName]
- forValues (Var (Qualified (Just mn) _))
- | mn `notElem` ams = [mn]
- forValues (Constructor (Qualified (Just mn) _))
- | mn `notElem` ams = [mn]
- forValues _ = []
-
- forTypes :: Type -> [ModuleName]
- forTypes (TypeConstructor (Qualified (Just mn) _))
- | mn `notElem` ams = [mn]
- forTypes _ = []
-
- extractQualFixity :: Either ValueFixity TypeFixity -> Maybe ModuleName
- extractQualFixity (Left (ValueFixity _ (Qualified mn _) _)) = mn
- extractQualFixity (Right (TypeFixity _ (Qualified mn _) _)) = mn
-
--- |
--- Convert a strongly connected component of the module graph to a module
---
-toModule :: (MonadError MultipleErrors m) => SCC Module -> m Module
+-- | Convert a strongly connected component of the module graph to a module
+toModule :: MonadError MultipleErrors m => SCC Module -> m Module
toModule (AcyclicSCC m) = return m
toModule (CyclicSCC [m]) = return m
toModule (CyclicSCC ms) = throwError . errorMessage $ CycleInModules (map getModuleName ms)
diff --git a/src/Language/PureScript/PSString.hs b/src/Language/PureScript/PSString.hs
index a841e43..0073f0f 100644
--- a/src/Language/PureScript/PSString.hs
+++ b/src/Language/PureScript/PSString.hs
@@ -5,6 +5,7 @@ module Language.PureScript.PSString
, toUTF16CodeUnits
, decodeString
, decodeStringEither
+ , decodeStringWithReplacement
, prettyPrintString
, prettyPrintStringJS
, mkString
@@ -52,16 +53,25 @@ newtype PSString = PSString { toUTF16CodeUnits :: [Word16] }
instance Show PSString where
show = show . codePoints
+-- |
-- Decode a PSString to a String, representing any lone surrogates as the
-- reserved code point with that index. Warning: if there are any lone
-- surrogates, converting the result to Text via Data.Text.pack will result in
-- loss of information as those lone surrogates will be replaced with U+FFFD
-- REPLACEMENT CHARACTER. Because this function requires care to use correctly,
-- we do not export it.
+--
codePoints :: PSString -> String
codePoints = map (either (chr . fromIntegral) id) . decodeStringEither
-- |
+-- Decode a PSString as UTF-16 text. Lone surrogates will be replaced with
+-- U+FFFD REPLACEMENT CHARACTER
+--
+decodeStringWithReplacement :: PSString -> String
+decodeStringWithReplacement = map (either (const '\xFFFD') id) . decodeStringEither
+
+-- |
-- Decode a PSString as UTF-16. Lone surrogates in the input are represented in
-- the output with the Left constructor; characters which were successfully
-- decoded are represented with the Right constructor.
diff --git a/src/Language/PureScript/Parser/Common.hs b/src/Language/PureScript/Parser/Common.hs
index 0048cd9..5030033 100644
--- a/src/Language/PureScript/Parser/Common.hs
+++ b/src/Language/PureScript/Parser/Common.hs
@@ -1,52 +1,39 @@
--- |
--- Constants and utility functions to be used when parsing
---
+-- | Useful common functions for building parsers
module Language.PureScript.Parser.Common where
-import Prelude.Compat
+import Prelude.Compat
-import Control.Applicative ((<|>))
-import Control.Monad (guard)
-import Data.Monoid ((<>))
-import Data.Text (Text)
+import Control.Applicative ((<|>))
+import Control.Monad (guard)
+import Data.Maybe (fromMaybe)
+import Data.Monoid ((<>))
+import Data.Text (Text)
import qualified Data.Text as T
-
-import Language.PureScript.AST.SourcePos
-import Language.PureScript.Comments
-import Language.PureScript.Names
-import Language.PureScript.Parser.Lexer
-import Language.PureScript.Parser.State
-import Language.PureScript.PSString (PSString, mkString)
-
+import Language.PureScript.AST.SourcePos
+import Language.PureScript.Comments
+import Language.PureScript.Names
+import Language.PureScript.Parser.Lexer
+import Language.PureScript.Parser.State
+import Language.PureScript.PSString (PSString, mkString)
import qualified Text.Parsec as P
--- |
--- Parse a general proper name.
---
+-- | Parse a general proper name.
properName :: TokenParser (ProperName a)
properName = ProperName <$> uname
--- |
--- Parse a proper name for a type.
---
+-- | Parse a proper name for a type.
typeName :: TokenParser (ProperName 'TypeName)
typeName = ProperName <$> tyname
--- |
--- Parse a proper name for a kind.
---
+-- | Parse a proper name for a kind.
kindName :: TokenParser (ProperName 'KindName)
kindName = ProperName <$> kiname
--- |
--- Parse a proper name for a data constructor.
---
+-- | Parse a proper name for a data constructor.
dataConstructorName :: TokenParser (ProperName 'ConstructorName)
dataConstructorName = ProperName <$> dconsname
--- |
--- Parse a module name
---
+-- | Parse a module name
moduleName :: TokenParser ModuleName
moduleName = part []
where
@@ -55,9 +42,7 @@ moduleName = part []
<|> (ModuleName . snoc path . ProperName <$> mname)
snoc path name = path ++ [name]
--- |
--- Parse a qualified name, i.e. M.name or just name
---
+-- | Parse a qualified name, i.e. M.name or just name
parseQualified :: TokenParser a -> TokenParser (Qualified a)
parseQualified parser = part []
where
@@ -67,42 +52,30 @@ parseQualified parser = part []
updatePath path name = path ++ [name]
qual path = if null path then Nothing else Just $ ModuleName path
--- |
--- Parse an identifier.
---
+-- | Parse an identifier.
parseIdent :: TokenParser Ident
parseIdent = Ident <$> identifier
--- |
--- Parse a label, which may look like an identifier or a string
---
+-- | Parse a label, which may look like an identifier or a string
parseLabel :: TokenParser PSString
parseLabel = (mkString <$> lname) <|> stringLiteral
--- |
--- Parse an operator.
---
+-- | Parse an operator.
parseOperator :: TokenParser (OpName a)
parseOperator = OpName <$> symbol
--- |
--- Run the first parser, then match the second if possible, applying the specified function on a successful match
---
+-- | Run the first parser, then match the second if possible, applying the specified function on a successful match
augment :: P.Stream s m t => P.ParsecT s u m a -> P.ParsecT s u m b -> (a -> b -> a) -> P.ParsecT s u m a
augment p q f = flip (maybe id $ flip f) <$> p <*> P.optionMaybe q
--- |
--- Run the first parser, then match the second zero or more times, applying the specified function for each match
---
+-- | Run the first parser, then match the second zero or more times, applying the specified function for each match
fold :: P.ParsecT s u m a -> P.ParsecT s u m b -> (a -> b -> a) -> P.ParsecT s u m a
fold first' more combine = do
a <- first'
bs <- P.many more
return $ foldl combine a bs
--- |
--- Build a parser from a smaller parser and a list of parsers for postfix operators
---
+-- | Build a parser from a smaller parser and a list of parsers for postfix operators
buildPostfixParser :: P.Stream s m t => [a -> P.ParsecT s u m a] -> P.ParsecT s u m a -> P.ParsecT s u m a
buildPostfixParser fs first' = do
a <- first'
@@ -114,9 +87,7 @@ buildPostfixParser fs first' = do
Nothing -> return a
Just a' -> go a'
--- |
--- Mark the current indentation level
---
+-- | Mark the current indentation level
mark :: P.Parsec s ParseState a -> P.Parsec s ParseState a
mark p = do
current <- indentationLevel <$> P.getState
@@ -126,9 +97,7 @@ mark p = do
P.modifyState $ \st -> st { indentationLevel = current }
return a
--- |
--- Check that the current identation level matches a predicate
---
+-- | Check that the current identation level matches a predicate
checkIndentation
:: (P.Column -> Text)
-> (P.Column -> P.Column -> Bool)
@@ -138,32 +107,39 @@ checkIndentation mkMsg rel = do
current <- indentationLevel <$> P.getState
guard (col `rel` current) P.<?> T.unpack (mkMsg current)
--- |
--- Check that the current indentation level is past the current mark
---
+-- | Check that the current indentation level is past the current mark
indented :: P.Parsec s ParseState ()
indented = checkIndentation (("indentation past column " <>) . (T.pack . show)) (>)
--- |
--- Check that the current indentation level is at the same indentation as the current mark
---
+-- | Check that the current indentation level is at the same indentation as the current mark
same :: P.Parsec s ParseState ()
same = checkIndentation (("indentation at column " <>) . (T.pack . show)) (==)
--- |
--- Read the comments from the the next token, without consuming it
---
+-- | Read the comments from the the next token, without consuming it
readComments :: P.Parsec [PositionedToken] u [Comment]
readComments = P.lookAhead $ ptComments <$> P.anyToken
--- |
--- Run a parser
---
+-- | Run a parser
runTokenParser :: FilePath -> TokenParser a -> [PositionedToken] -> Either P.ParseError a
runTokenParser filePath p = P.runParser p (ParseState 0) filePath
--- |
--- Convert from Parsec sourcepos
---
+-- | Convert from Parsec sourcepos
toSourcePos :: P.SourcePos -> SourcePos
toSourcePos pos = SourcePos (P.sourceLine pos) (P.sourceColumn pos)
+
+-- | Read source position information and comments
+withSourceSpan
+ :: (SourceSpan -> [Comment] -> a -> b)
+ -> P.Parsec [PositionedToken] u a
+ -> P.Parsec [PositionedToken] u b
+withSourceSpan f p = do
+ start <- P.getPosition
+ comments <- readComments
+ x <- p
+ end <- P.getPosition
+ input <- P.getInput
+ let end' = case input of
+ pt:_ -> ptPrevEndPos pt
+ _ -> Nothing
+ let sp = SourceSpan (P.sourceName start) (toSourcePos start) (toSourcePos $ fromMaybe end end')
+ return $ f sp comments x
diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs
index cd8d582..3ddd4fa 100644
--- a/src/Language/PureScript/Parser/Declarations.hs
+++ b/src/Language/PureScript/Parser/Declarations.hs
@@ -1,6 +1,4 @@
--- |
--- Parsers for module definitions and declarations
---
+-- | Parsers for module definitions and declarations
module Language.PureScript.Parser.Declarations
( parseDeclaration
, parseModule
@@ -15,53 +13,31 @@ module Language.PureScript.Parser.Declarations
, toPositionedError
) where
-import Prelude hiding (lex)
-
-import Data.Functor (($>))
-import Data.Maybe (fromMaybe)
-import Data.Text (Text)
-
-import Control.Applicative
-import Control.Arrow ((+++))
-import Control.Monad.Error.Class (MonadError(..))
-import Control.Parallel.Strategies (withStrategy, parList, rseq)
-
-import Language.PureScript.AST
-import Language.PureScript.Comments
-import Language.PureScript.Environment
-import Language.PureScript.Errors
-import Language.PureScript.Kinds
-import Language.PureScript.Names
-import Language.PureScript.Types
-import Language.PureScript.PSString (PSString, mkString)
-import Language.PureScript.Parser.Common
-import Language.PureScript.Parser.Kinds
-import Language.PureScript.Parser.Lexer
-import Language.PureScript.Parser.Types
-
-import qualified Language.PureScript.Parser.Common as C
+import Prelude hiding (lex)
+
+import Control.Applicative
+import Control.Arrow ((+++))
+import Control.Monad (foldM)
+import Control.Monad.Error.Class (MonadError(..))
+import Control.Parallel.Strategies (withStrategy, parList, rseq)
+import Data.Functor (($>))
+import Data.Maybe (fromMaybe)
+import qualified Data.Set as S
+import Data.Text (Text)
+import Language.PureScript.AST
+import Language.PureScript.Environment
+import Language.PureScript.Errors
+import Language.PureScript.Kinds
+import Language.PureScript.Names
+import Language.PureScript.Parser.Common
+import Language.PureScript.Parser.Kinds
+import Language.PureScript.Parser.Lexer
+import Language.PureScript.Parser.Types
+import Language.PureScript.PSString (PSString, mkString)
+import Language.PureScript.Types
import qualified Text.Parsec as P
import qualified Text.Parsec.Expr as P
--- |
--- Read source position information
---
-withSourceSpan
- :: (SourceSpan -> [Comment] -> a -> a)
- -> P.Parsec [PositionedToken] u a
- -> P.Parsec [PositionedToken] u a
-withSourceSpan f p = do
- start <- P.getPosition
- comments <- C.readComments
- x <- p
- end <- P.getPosition
- input <- P.getInput
- let end' = case input of
- pt:_ -> ptPrevEndPos pt
- _ -> Nothing
- let sp = SourceSpan (P.sourceName start) (C.toSourcePos start) (C.toSourcePos $ fromMaybe end end')
- return $ f sp comments x
-
kindedIdent :: TokenParser (Text, Maybe Kind)
kindedIdent = (, Nothing) <$> identifier
<|> parens ((,) <$> identifier <*> (Just <$> (indented *> doubleColon *> indented *> parseKind)))
@@ -91,7 +67,7 @@ parseValueDeclaration :: TokenParser Declaration
parseValueDeclaration = do
name <- parseIdent
binders <- P.many parseBinderNoParens
- value <- Left <$> (C.indented *>
+ value <- Left <$> (indented *>
P.many1 ((,) <$> parseGuard
<*> (indented *> equals *> parseValueWithWhereClause)
))
@@ -100,13 +76,13 @@ parseValueDeclaration = do
where
parseValueWithWhereClause :: TokenParser Expr
parseValueWithWhereClause = do
- C.indented
+ indented
value <- parseValue
whereClause <- P.optionMaybe $ do
- C.indented
+ indented
reserved "where"
- C.indented
- C.mark $ P.many1 (C.same *> parseLocalDeclaration)
+ indented
+ mark $ P.many1 (same *> parseLocalDeclaration)
return $ maybe value (`Let` value) whereClause
parseExternDeclaration :: TokenParser Declaration
@@ -237,9 +213,7 @@ parseDerivingInstanceDeclaration = do
positioned :: TokenParser Declaration -> TokenParser Declaration
positioned = withSourceSpan PositionedDeclaration
--- |
--- Parse a single declaration
---
+-- | Parse a single declaration
parseDeclaration :: TokenParser Declaration
parseDeclaration = positioned (P.choice
[ parseDataDeclaration
@@ -259,12 +233,10 @@ parseLocalDeclaration = positioned (P.choice
, parseValueDeclaration
] P.<?> "local declaration")
--- |
--- Parse a module header and a collection of declarations
---
+-- | Parse a module header and a collection of declarations
parseModule :: TokenParser Module
parseModule = do
- comments <- C.readComments
+ comments <- readComments
start <- P.getPosition
reserved "module"
indented
@@ -280,7 +252,7 @@ parseModule = do
return (imports ++ decls)
_ <- P.eof
end <- P.getPosition
- let ss = SourceSpan (P.sourceName start) (C.toSourcePos start) (C.toSourcePos end)
+ let ss = SourceSpan (P.sourceName start) (toSourcePos start) (toSourcePos end)
return $ Module ss comments name decls exports
-- | Parse a collection of modules in parallel
@@ -301,7 +273,6 @@ parseModulesFromFiles toFilePath input =
inParallel :: [Either P.ParseError (k, a)] -> [Either P.ParseError (k, a)]
inParallel = withStrategy (parList rseq)
-
-- | Parses a single module with FilePath for eventual parsing errors
parseModuleFromFile
:: (k -> FilePath)
@@ -313,12 +284,12 @@ parseModuleFromFile toFilePath (k, content) = do
m <- runTokenParser filename parseModule ts
pure (k, m)
--- | Converts a @ParseError@ into a @PositionedError@
+-- | Converts a 'ParseError' into a 'PositionedError'
toPositionedError :: P.ParseError -> ErrorMessage
toPositionedError perr = ErrorMessage [ PositionedError (SourceSpan name start end) ] (ErrorParsingModule perr)
where
name = (P.sourceName . P.errorPos) perr
- start = (C.toSourcePos . P.errorPos) perr
+ start = (toSourcePos . P.errorPos) perr
end = start
booleanLiteral :: TokenParser Bool
@@ -345,18 +316,18 @@ parseObjectLiteral p = ObjectLiteral <$> braces (commaSep p)
parseIdentifierAndValue :: TokenParser (PSString, Expr)
parseIdentifierAndValue =
do
- name <- C.indented *> lname
+ name <- indented *> lname
b <- P.option (Var $ Qualified Nothing (Ident name)) rest
return (mkString name, b)
- <|> (,) <$> (C.indented *> stringLiteral) <*> rest
+ <|> (,) <$> (indented *> stringLiteral) <*> rest
where
- rest = C.indented *> colon *> C.indented *> parseValue
+ rest = indented *> colon *> indented *> parseValue
parseAbs :: TokenParser Expr
parseAbs = do
symbol' "\\"
- args <- P.many1 (C.indented *> (Abs <$> (Left <$> C.parseIdent <|> Right <$> parseBinderNoParens)))
- C.indented *> rarrow
+ args <- P.many1 (indented *> (Abs <$> (Left <$> parseIdent <|> Right <$> parseBinderNoParens)))
+ indented *> rarrow
value <- parseValue
return $ toFunction args value
where
@@ -364,18 +335,18 @@ parseAbs = do
toFunction args value = foldr ($) value args
parseVar :: TokenParser Expr
-parseVar = Var <$> C.parseQualified C.parseIdent
+parseVar = Var <$> parseQualified parseIdent
parseConstructor :: TokenParser Expr
-parseConstructor = Constructor <$> C.parseQualified C.dataConstructorName
+parseConstructor = Constructor <$> parseQualified dataConstructorName
parseCase :: TokenParser Expr
-parseCase = Case <$> P.between (reserved "case") (C.indented *> reserved "of") (commaSep1 parseValue)
- <*> (C.indented *> C.mark (P.many1 (C.same *> C.mark parseCaseAlternative)))
+parseCase = Case <$> P.between (reserved "case") (indented *> reserved "of") (commaSep1 parseValue)
+ <*> (indented *> mark (P.many1 (same *> mark parseCaseAlternative)))
parseCaseAlternative :: TokenParser CaseAlternative
parseCaseAlternative = CaseAlternative <$> commaSep1 parseBinder
- <*> (Left <$> (C.indented *>
+ <*> (Left <$> (indented *>
P.many1 ((,) <$> parseGuard
<*> (indented *> rarrow *> parseValue)
))
@@ -383,16 +354,16 @@ parseCaseAlternative = CaseAlternative <$> commaSep1 parseBinder
P.<?> "case alternative"
parseIfThenElse :: TokenParser Expr
-parseIfThenElse = IfThenElse <$> (P.try (reserved "if") *> C.indented *> parseValue)
- <*> (C.indented *> reserved "then" *> C.indented *> parseValue)
- <*> (C.indented *> reserved "else" *> C.indented *> parseValue)
+parseIfThenElse = IfThenElse <$> (P.try (reserved "if") *> indented *> parseValue)
+ <*> (indented *> reserved "then" *> indented *> parseValue)
+ <*> (indented *> reserved "else" *> indented *> parseValue)
parseLet :: TokenParser Expr
parseLet = do
reserved "let"
- C.indented
- ds <- C.mark $ P.many1 (C.same *> parseLocalDeclaration)
- C.indented
+ indented
+ ds <- mark $ P.many1 (same *> parseLocalDeclaration)
+ indented
reserved "in"
result <- parseValue
return $ Let ds result
@@ -418,9 +389,7 @@ parseValueAtom = withSourceSpan PositionedValue $ P.choice
, parseHole
]
--- |
--- Parse an expression in backticks or an operator
---
+-- | Parse an expression in backticks or an operator
parseInfixExpr :: TokenParser Expr
parseInfixExpr
= P.between tick tick parseValue
@@ -429,28 +398,33 @@ parseInfixExpr
parseHole :: TokenParser Expr
parseHole = Hole <$> holeLit
-parsePropertyUpdate :: TokenParser (PSString, Expr)
+parsePropertyUpdate :: TokenParser (PSString, PathNode Expr)
parsePropertyUpdate = do
name <- parseLabel
- _ <- C.indented *> equals
- value <- C.indented *> parseValue
- return (name, value)
+ updates <- parseShallowUpdate <|> parseNestedUpdate
+ return (name, updates)
+ where
+ parseShallowUpdate :: TokenParser (PathNode Expr)
+ parseShallowUpdate = Leaf <$> (indented *> equals *> indented *> parseValue)
+
+ parseNestedUpdate :: TokenParser (PathNode Expr)
+ parseNestedUpdate = Branch <$> parseUpdaterBodyFields
parseAccessor :: Expr -> TokenParser Expr
parseAccessor (Constructor _) = P.unexpected "constructor"
-parseAccessor obj = P.try $ Accessor <$> (C.indented *> dot *> C.indented *> parseLabel) <*> pure obj
+parseAccessor obj = P.try $ Accessor <$> (indented *> dot *> indented *> parseLabel) <*> pure obj
parseDo :: TokenParser Expr
parseDo = do
reserved "do"
- C.indented
- Do <$> C.mark (P.many1 (C.same *> C.mark parseDoNotationElement))
+ indented
+ Do <$> mark (P.many1 (same *> mark parseDoNotationElement))
parseDoNotationLet :: TokenParser DoNotationElement
-parseDoNotationLet = DoNotationLet <$> (reserved "let" *> C.indented *> C.mark (P.many1 (C.same *> parseLocalDeclaration)))
+parseDoNotationLet = DoNotationLet <$> (reserved "let" *> indented *> mark (P.many1 (same *> parseLocalDeclaration)))
parseDoNotationBind :: TokenParser DoNotationElement
-parseDoNotationBind = DoNotationBind <$> P.try (parseBinder <* C.indented <* larrow) <*> parseValue
+parseDoNotationBind = DoNotationBind <$> P.try (parseBinder <* indented <* larrow) <*> parseValue
parseDoNotationElement :: TokenParser DoNotationElement
parseDoNotationElement = P.choice
@@ -461,33 +435,41 @@ parseDoNotationElement = P.choice
-- | Expressions including indexers and record updates
indexersAndAccessors :: TokenParser Expr
-indexersAndAccessors = C.buildPostfixParser postfixTable parseValueAtom
+indexersAndAccessors = buildPostfixParser postfixTable parseValueAtom
where
postfixTable = [ parseAccessor
, P.try . parseUpdaterBody
]
--- |
--- Parse a value
---
+-- | Parse an expression
parseValue :: TokenParser Expr
parseValue = withSourceSpan PositionedValue
(P.buildExpressionParser operators
- . C.buildPostfixParser postfixTable
+ . buildPostfixParser postfixTable
$ indexersAndAccessors) P.<?> "expression"
where
- postfixTable = [ \v -> P.try (flip App <$> (C.indented *> indexersAndAccessors)) <*> pure v
- , \v -> flip (TypedValue True) <$> (C.indented *> doubleColon *> parsePolyType) <*> pure v
+ postfixTable = [ \v -> P.try (flip App <$> (indented *> indexersAndAccessors)) <*> pure v
+ , \v -> flip (TypedValue True) <$> (indented *> doubleColon *> parsePolyType) <*> pure v
]
- operators = [ [ P.Prefix (C.indented *> symbol' "-" *> return UnaryMinus)
+ operators = [ [ P.Prefix (indented *> symbol' "-" *> return UnaryMinus)
]
- , [ P.Infix (P.try (C.indented *> parseInfixExpr P.<?> "infix expression") >>= \ident ->
+ , [ P.Infix (P.try (indented *> parseInfixExpr P.<?> "infix expression") >>= \ident ->
return (BinaryNoParens ident)) P.AssocRight
]
]
+parseUpdaterBodyFields :: TokenParser (PathTree Expr)
+parseUpdaterBodyFields = do
+ updates <- indented *> braces (commaSep1 (indented *> parsePropertyUpdate))
+ (_, tree) <- foldM insertUpdate (S.empty, []) updates
+ return (PathTree (AssocList (reverse tree)))
+ where
+ insertUpdate (seen, xs) (key, node)
+ | S.member key seen = P.unexpected ("Duplicate key in record update: " ++ show key)
+ | otherwise = return (S.insert key seen, (key, node) : xs)
+
parseUpdaterBody :: Expr -> TokenParser Expr
-parseUpdaterBody v = ObjectUpdate v <$> (C.indented *> braces (commaSep1 (C.indented *> parsePropertyUpdate)))
+parseUpdaterBody v = ObjectUpdateNested v <$> parseUpdaterBodyFields
parseAnonymousArgument :: TokenParser Expr
parseAnonymousArgument = underscore *> pure AnonymousArgument
@@ -501,21 +483,21 @@ parseNumberLiteral = LiteralBinder . NumericLiteral <$> (sign <*> number)
<|> return id
parseNullaryConstructorBinder :: TokenParser Binder
-parseNullaryConstructorBinder = ConstructorBinder <$> C.parseQualified C.dataConstructorName <*> pure []
+parseNullaryConstructorBinder = ConstructorBinder <$> parseQualified dataConstructorName <*> pure []
parseConstructorBinder :: TokenParser Binder
-parseConstructorBinder = ConstructorBinder <$> C.parseQualified C.dataConstructorName <*> many (C.indented *> parseBinderNoParens)
+parseConstructorBinder = ConstructorBinder <$> parseQualified dataConstructorName <*> many (indented *> parseBinderNoParens)
parseObjectBinder:: TokenParser Binder
-parseObjectBinder = LiteralBinder <$> parseObjectLiteral (C.indented *> parseIdentifierAndBinder)
+parseObjectBinder = LiteralBinder <$> parseObjectLiteral (indented *> parseIdentifierAndBinder)
parseArrayBinder :: TokenParser Binder
-parseArrayBinder = LiteralBinder <$> parseArrayLiteral (C.indented *> parseBinder)
+parseArrayBinder = LiteralBinder <$> parseArrayLiteral (indented *> parseBinder)
parseVarOrNamedBinder :: TokenParser Binder
parseVarOrNamedBinder = do
- name <- C.parseIdent
- let parseNamedBinder = NamedBinder name <$> (at *> C.indented *> parseBinderAtom)
+ name <- parseIdent
+ let parseNamedBinder = NamedBinder name <$> (at *> indented *> parseBinderAtom)
parseNamedBinder <|> return (VarBinder name)
parseNullBinder :: TokenParser Binder
@@ -528,11 +510,9 @@ parseIdentifierAndBinder =
return (mkString name, b)
<|> (,) <$> stringLiteral <*> rest
where
- rest = C.indented *> colon *> C.indented *> parseBinder
+ rest = indented *> colon *> indented *> parseBinder
--- |
--- Parse a binder
---
+-- | Parse a binder
parseBinder :: TokenParser Binder
parseBinder =
withSourceSpan
@@ -543,7 +523,7 @@ parseBinder =
)
where
operators =
- [ [ P.Infix (P.try (C.indented *> parseOpBinder P.<?> "binder operator") >>= \op ->
+ [ [ P.Infix (P.try (indented *> parseOpBinder P.<?> "binder operator") >>= \op ->
return (BinaryNoParensBinder op)) P.AssocRight
]
]
@@ -569,9 +549,7 @@ parseBinderAtom = P.choice
, ParensInBinder <$> parens parseBinder
] P.<?> "binder"
--- |
--- Parse a binder as it would appear in a top level declaration
---
+-- | Parse a binder as it would appear in a top level declaration
parseBinderNoParens :: TokenParser Binder
parseBinderNoParens = P.choice
[ parseNullBinder
@@ -586,8 +564,6 @@ parseBinderNoParens = P.choice
, ParensInBinder <$> parens parseBinder
] P.<?> "binder"
--- |
--- Parse a guard
---
+-- | Parse a guard
parseGuard :: TokenParser Guard
-parseGuard = pipe *> C.indented *> parseValue
+parseGuard = pipe *> indented *> parseValue
diff --git a/src/Language/PureScript/Pretty/Common.hs b/src/Language/PureScript/Pretty/Common.hs
index 9b7b6a1..32b5ea2 100644
--- a/src/Language/PureScript/Pretty/Common.hs
+++ b/src/Language/PureScript/Pretty/Common.hs
@@ -148,7 +148,7 @@ prettyPrintMany f xs = do
objectKeyRequiresQuoting :: Text -> Bool
objectKeyRequiresQuoting s =
- s `elem` reservedPsNames || isUnquotedKey s
+ s `elem` reservedPsNames || not (isUnquotedKey s)
-- | Place a box before another, vertically when the first box takes up multiple lines.
before :: Box -> Box -> Box
diff --git a/src/Language/PureScript/Pretty/JS.hs b/src/Language/PureScript/Pretty/JS.hs
index 0015933..92de636 100644
--- a/src/Language/PureScript/Pretty/JS.hs
+++ b/src/Language/PureScript/Pretty/JS.hs
@@ -122,22 +122,30 @@ literals = mkPattern' match'
[ return $ emit $ lbl <> ": "
, prettyPrintJS' js
]
- match (JSComment _ com js) = fmap mconcat $ sequence $
+ match (JSComment _ com js) = mconcat <$> sequence
+ [ mconcat <$> forM com comment
+ , prettyPrintJS' js
+ ]
+ match (JSRaw _ js) = return $ emit js
+ match _ = mzero
+
+ comment :: (Emit gen) => Comment -> StateT PrinterState Maybe gen
+ comment (LineComment com) = fmap mconcat $ sequence $
+ [ return $ emit "\n"
+ , currentIndent
+ , return $ emit "//" <> emit com <> emit "\n"
+ ]
+ comment (BlockComment com) = fmap mconcat $ sequence $
[ return $ emit "\n"
, currentIndent
, return $ emit "/**\n"
] ++
- map asLine (concatMap commentLines com) ++
+ map asLine (T.lines com) ++
[ currentIndent
, return $ emit " */\n"
, currentIndent
- , prettyPrintJS' js
]
where
- commentLines :: Comment -> [Text]
- commentLines (LineComment s) = [s]
- commentLines (BlockComment s) = T.lines s
-
asLine :: (Emit gen) => Text -> StateT PrinterState Maybe gen
asLine s = do
i <- currentIndent
@@ -150,8 +158,6 @@ literals = mkPattern' match'
Nothing -> case T.uncons t of
Just (x, xs) -> x `T.cons` removeComments xs
Nothing -> ""
- match (JSRaw _ js) = return $ emit js
- match _ = mzero
conditional :: Pattern PrinterState JS ((Maybe SourceSpan, JS, JS), JS)
conditional = mkPattern match
@@ -159,11 +165,13 @@ conditional = mkPattern match
match (JSConditional ss cond th el) = Just ((ss, th, el), cond)
match _ = Nothing
-accessor :: (Emit gen) => Pattern PrinterState JS (gen, JS)
+accessor :: Pattern PrinterState JS (Text, JS)
accessor = mkPattern match
where
- -- WARN: if `prop` does not match the `IdentifierName` grammar, this will generate invalid code; see #2513
- match (JSAccessor _ prop val) = Just (emit prop, val)
+ match (JSIndexer _ (JSStringLiteral _ prop) val) =
+ case decodeString prop of
+ Just s | not (identNeedsEscaping s) -> Just (s, val)
+ _ -> Nothing
match _ = Nothing
indexer :: (Emit gen) => Pattern PrinterState JS (gen, JS)
@@ -257,8 +265,8 @@ prettyPrintJS' = A.runKleisli $ runPattern matchValue
matchValue = buildPrettyPrinter operators (literals <+> fmap parensPos matchValue)
operators :: (Emit gen) => OperatorTable PrinterState JS gen
operators =
- OperatorTable [ [ Wrap accessor $ \prop val -> val <> emit "." <> prop ]
- , [ Wrap indexer $ \index val -> val <> emit "[" <> index <> emit "]" ]
+ OperatorTable [ [ Wrap indexer $ \index val -> val <> emit "[" <> index <> emit "]" ]
+ , [ Wrap accessor $ \prop val -> val <> emit "." <> emit prop ]
, [ Wrap app $ \args val -> val <> emit "(" <> args <> emit ")" ]
, [ unary JSNew "new " ]
, [ Wrap lam $ \(name, args, ss) ret -> addMapping' ss <>
diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs
index db92df6..a258199 100644
--- a/src/Language/PureScript/Pretty/Types.hs
+++ b/src/Language/PureScript/Pretty/Types.hs
@@ -5,10 +5,10 @@ module Language.PureScript.Pretty.Types
( typeAsBox
, suggestedTypeAsBox
, prettyPrintType
+ , prettyPrintTypeWithUnicode
, prettyPrintSuggestedType
, typeAtomAsBox
, prettyPrintTypeAtom
- , prettyPrintRowWith
, prettyPrintRow
, prettyPrintLabel
, prettyPrintObjectKey
@@ -37,9 +37,12 @@ import Text.PrettyPrint.Boxes hiding ((<+>))
-- TODO(Christoph): get rid of T.unpack s
-constraintsAsBox :: [Constraint] -> Box -> Box
-constraintsAsBox [con] ty = text "(" <> constraintAsBox con `before` (text ") => " <> ty)
-constraintsAsBox xs ty = vcat left (zipWith (\i con -> text (if i == 0 then "( " else ", ") <> constraintAsBox con) [0 :: Int ..] xs) `before` (text ") => " <> ty)
+constraintsAsBox :: TypeRenderOptions -> [Constraint] -> Box -> Box
+constraintsAsBox tro constraints ty = case constraints of
+ [con] -> text "(" <> constraintAsBox con `before` (") " <> text doubleRightArrow <> " " <> ty)
+ xs -> vcat left (zipWith (\i con -> text (if i == 0 then "( " else ", ") <> constraintAsBox con) [0 :: Int ..] xs) `before` (") " <> text doubleRightArrow <> " " <> ty)
+ where
+ doubleRightArrow = if troUnicode tro then "⇒" else "=>"
constraintAsBox :: Constraint -> Box
constraintAsBox (Constraint pn tys _) = typeAsBox (foldl TypeApp (TypeConstructor (fmap coerceProperName pn)) tys)
@@ -47,11 +50,13 @@ constraintAsBox (Constraint pn tys _) = typeAsBox (foldl TypeApp (TypeConstructo
-- |
-- Generate a pretty-printed string representing a Row
--
-prettyPrintRowWith :: Char -> Char -> Type -> Box
-prettyPrintRowWith open close = uncurry listToBox . toList []
+prettyPrintRowWith :: TypeRenderOptions -> Char -> Char -> Type -> Box
+prettyPrintRowWith tro open close = uncurry listToBox . toList []
where
nameAndTypeToPs :: Char -> Label -> Type -> Box
- nameAndTypeToPs start name ty = text (start : ' ' : T.unpack (prettyPrintLabel name) ++ " :: ") <> typeAsBox ty
+ nameAndTypeToPs start name ty = text (start : ' ' : T.unpack (prettyPrintLabel name) ++ " " ++ doubleColon ++ " ") <> typeAsBox ty
+
+ doubleColon = if troUnicode tro then "∷" else "::"
tailToPs :: Type -> Box
tailToPs REmpty = nullBox
@@ -63,13 +68,12 @@ prettyPrintRowWith open close = uncurry listToBox . toList []
listToBox ts rest = vcat left $
zipWith (\(nm, ty) i -> nameAndTypeToPs (if i == 0 then open else ',') nm ty) ts [0 :: Int ..] ++
[ tailToPs rest, text [close] ]
-
toList :: [(Label, Type)] -> Type -> ([(Label, Type)], Type)
toList tys (RCons name ty row) = toList ((name, ty):tys) row
toList tys r = (reverse tys, r)
prettyPrintRow :: Type -> String
-prettyPrintRow = render . prettyPrintRowWith '(' ')'
+prettyPrintRow = render . prettyPrintRowWith defaultOptions '(' ')'
typeApp :: Pattern () Type (Type, Type)
typeApp = mkPattern match
@@ -113,16 +117,16 @@ explicitParens = mkPattern match
match (ParensInType ty) = Just ((), ty)
match _ = Nothing
-matchTypeAtom :: Bool -> Pattern () Type Box
-matchTypeAtom suggesting =
- typeLiterals <+> fmap ((`before` (text ")")) . (text "(" <>)) (matchType suggesting)
+matchTypeAtom :: TypeRenderOptions -> Pattern () Type Box
+matchTypeAtom tro@TypeRenderOptions{troSuggesting = suggesting} =
+ typeLiterals <+> fmap ((`before` (text ")")) . (text "(" <>)) (matchType tro)
where
typeLiterals :: Pattern () Type Box
typeLiterals = mkPattern match where
match TypeWildcard{} = Just $ text "_"
match (TypeVar var) = Just $ text $ T.unpack var
match (TypeLevelString s) = Just $ text $ T.unpack $ prettyPrintString s
- match (PrettyPrintObject row) = Just $ prettyPrintRowWith '{' '}' row
+ match (PrettyPrintObject row) = Just $ prettyPrintRowWith tro '{' '}' row
match (TypeConstructor ctor) = Just $ text $ T.unpack $ runProperName $ disqualify ctor
match (TUnknown u)
| suggesting = Just $ text "_"
@@ -131,24 +135,28 @@ matchTypeAtom suggesting =
| suggesting = Just $ text $ T.unpack name
| otherwise = Just $ text $ T.unpack name ++ show s
match REmpty = Just $ text "()"
- match row@RCons{} = Just $ prettyPrintRowWith '(' ')' row
+ match row@RCons{} = Just $ prettyPrintRowWith tro '(' ')' row
match (BinaryNoParensType op l r) =
Just $ typeAsBox l <> text " " <> typeAsBox op <> text " " <> typeAsBox r
match (TypeOp op) = Just $ text $ T.unpack $ showQualified runOpName op
match _ = Nothing
-matchType :: Bool -> Pattern () Type Box
-matchType = buildPrettyPrinter operators . matchTypeAtom where
+matchType :: TypeRenderOptions -> Pattern () Type Box
+matchType tro = buildPrettyPrinter operators (matchTypeAtom tro) where
operators :: OperatorTable () Type Box
operators =
OperatorTable [ [ AssocL typeApp $ \f x -> keepSingleLinesOr (moveRight 2) f x ]
- , [ AssocR appliedFunction $ \arg ret -> keepSingleLinesOr id arg (text "-> " <> ret) ]
- , [ Wrap constrained $ \deps ty -> constraintsAsBox deps ty ]
- , [ Wrap forall_ $ \idents ty -> keepSingleLinesOr (moveRight 2) (text ("forall " ++ unwords idents ++ ".")) ty ]
- , [ Wrap kinded $ \k ty -> keepSingleLinesOr (moveRight 2) ty (text (":: " ++ T.unpack (prettyPrintKind k))) ]
+ , [ AssocR appliedFunction $ \arg ret -> keepSingleLinesOr id arg (text rightArrow <> " " <> ret) ]
+ , [ Wrap constrained $ \deps ty -> constraintsAsBox tro deps ty ]
+ , [ Wrap forall_ $ \idents ty -> keepSingleLinesOr (moveRight 2) (text (forall' ++ " " ++ unwords idents ++ ".")) ty ]
+ , [ Wrap kinded $ \k ty -> keepSingleLinesOr (moveRight 2) ty (text (doubleColon ++ " " ++ T.unpack (prettyPrintKind k))) ]
, [ Wrap explicitParens $ \_ ty -> ty ]
]
+ rightArrow = if troUnicode tro then "→" else "->"
+ forall' = if troUnicode tro then "∀" else "forall"
+ doubleColon = if troUnicode tro then "∷" else "::"
+
-- If both boxes span a single line, keep them on the same line, or else
-- use the specified function to modify the second box, then combine vertically.
keepSingleLinesOr :: (Box -> Box) -> Box -> Box -> Box
@@ -165,7 +173,7 @@ forall_ = mkPattern match
typeAtomAsBox :: Type -> Box
typeAtomAsBox
= fromMaybe (internalError "Incomplete pattern")
- . PA.pattern (matchTypeAtom False) ()
+ . PA.pattern (matchTypeAtom defaultOptions) ()
. insertPlaceholders
-- | Generate a pretty-printed string representing a Type, as it should appear inside parentheses
@@ -173,24 +181,46 @@ prettyPrintTypeAtom :: Type -> String
prettyPrintTypeAtom = render . typeAtomAsBox
typeAsBox :: Type -> Box
-typeAsBox = typeAsBoxImpl False
+typeAsBox = typeAsBoxImpl defaultOptions
suggestedTypeAsBox :: Type -> Box
-suggestedTypeAsBox = typeAsBoxImpl True
+suggestedTypeAsBox = typeAsBoxImpl suggestingOptions
+
+data TypeRenderOptions = TypeRenderOptions
+ { troSuggesting :: Bool
+ , troUnicode :: Bool
+ }
-typeAsBoxImpl :: Bool -> Type -> Box
-typeAsBoxImpl suggesting
+suggestingOptions :: TypeRenderOptions
+suggestingOptions = TypeRenderOptions True False
+
+defaultOptions :: TypeRenderOptions
+defaultOptions = TypeRenderOptions False False
+
+unicodeOptions :: TypeRenderOptions
+unicodeOptions = TypeRenderOptions False True
+
+typeAsBoxImpl :: TypeRenderOptions -> Type -> Box
+typeAsBoxImpl tro
= fromMaybe (internalError "Incomplete pattern")
- . PA.pattern (matchType suggesting) ()
+ . PA.pattern (matchType tro) ()
. insertPlaceholders
-- | Generate a pretty-printed string representing a 'Type'
prettyPrintType :: Type -> String
-prettyPrintType = render . typeAsBoxImpl False
+prettyPrintType = prettyPrintType' defaultOptions
+
+-- | Generate a pretty-printed string representing a 'Type' using unicode
+-- symbols where applicable
+prettyPrintTypeWithUnicode :: Type -> String
+prettyPrintTypeWithUnicode = prettyPrintType' unicodeOptions
-- | Generate a pretty-printed string representing a suggested 'Type'
prettyPrintSuggestedType :: Type -> String
-prettyPrintSuggestedType = render . typeAsBoxImpl True
+prettyPrintSuggestedType = prettyPrintType' suggestingOptions
+
+prettyPrintType' :: TypeRenderOptions -> Type -> String
+prettyPrintType' tro = render . typeAsBoxImpl tro
prettyPrintLabel :: Label -> Text
prettyPrintLabel (Label s) =
diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs
index 4b1c38e..4cff7ee 100644
--- a/src/Language/PureScript/Pretty/Values.hs
+++ b/src/Language/PureScript/Pretty/Values.hs
@@ -47,6 +47,9 @@ prettyPrintObject d = list '{' '}' prettyPrintObjectProperty
prettyPrintObjectProperty :: (PSString, Maybe Expr) -> Box
prettyPrintObjectProperty (key, value) = textT (prettyPrintObjectKey key Monoid.<> ": ") <> maybe (text "_") (prettyPrintValue (d - 1)) value
+prettyPrintUpdateEntry :: Int -> PSString -> Expr -> Box
+prettyPrintUpdateEntry d key val = textT (prettyPrintObjectKey key) <> text " = " <> prettyPrintValue (d - 1) val
+
-- | Pretty-print an expression
prettyPrintValue :: Int -> Expr -> Box
prettyPrintValue d _ | d < 0 = text "..."
@@ -56,7 +59,12 @@ prettyPrintValue d (IfThenElse cond th el) =
, text "else " <> prettyPrintValueAtom (d - 1) el
])
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 (prettyPrintObjectKey key Monoid.<> " = ") <> prettyPrintValue (d - 1) val) ps
+prettyPrintValue d (ObjectUpdate o ps) = prettyPrintValueAtom (d - 1) o `beforeWithSpace` list '{' '}' (uncurry (prettyPrintUpdateEntry d)) ps
+prettyPrintValue d (ObjectUpdateNested o ps) = prettyPrintValueAtom (d - 1) o `beforeWithSpace` prettyPrintUpdate ps
+ where
+ prettyPrintUpdate (PathTree tree) = list '{' '}' printNode (runAssocList tree)
+ printNode (key, Leaf val) = prettyPrintUpdateEntry d key val
+ printNode (key, Branch val) = textT (prettyPrintObjectKey key) `beforeWithSpace` prettyPrintUpdate val
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)
diff --git a/src/Language/PureScript/Publish.hs b/src/Language/PureScript/Publish.hs
index 8a862df..2af3f12 100644
--- a/src/Language/PureScript/Publish.hs
+++ b/src/Language/PureScript/Publish.hs
@@ -16,40 +16,31 @@ module Language.PureScript.Publish
, checkCleanWorkingTree
, getVersionFromGitTag
, getBowerRepositoryInfo
- , getModulesAndBookmarks
+ , getModules
, getResolvedDependencies
) where
-import Prelude ()
-import Prelude.Compat hiding (userError)
+import Protolude hiding (stdin)
-import Control.Arrow ((***), first)
+import Control.Arrow ((***))
import Control.Category ((>>>))
-import Control.Exception (catch, try)
-import Control.Monad.Error.Class (MonadError(..))
-import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
-import Control.Monad.Writer.Strict
+import Control.Monad.Writer.Strict (MonadWriter, WriterT, runWriterT, tell)
-import Data.Aeson.BetterErrors
+import Data.Aeson.BetterErrors (Parse, parse, keyMay, eachInObjectWithKey, eachInObject, key, keyOrDefault, asBool, asText)
import Data.Char (isSpace)
-import Data.Foldable (traverse_)
-import Data.Function (on)
+import Data.String (String, lines)
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
-
-import Safe (headMay)
+import Data.Time.Clock (UTCTime)
+import Data.Version
+import qualified Data.SPDX as SPDX
import System.Directory (doesFileExist, findExecutable)
-import System.Exit (exitFailure)
import System.FilePath (pathSeparator)
import System.Process (readProcess)
import qualified System.FilePath.Glob as Glob
@@ -60,13 +51,14 @@ import qualified Web.Bower.PackageMeta as Bower
import Language.PureScript.Publish.ErrorsWarnings
import Language.PureScript.Publish.Utils
-import qualified Language.PureScript as P (version)
+import qualified Language.PureScript as P (version, ModuleName)
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 (Text, Version)
+ , publishGetTagTime :: Text -> PrepareM UTCTime
, -- | What to do when the working tree is dirty
publishWorkingTreeDirty :: PrepareM ()
}
@@ -74,6 +66,7 @@ data PublishOptions = PublishOptions
defaultPublishOptions :: PublishOptions
defaultPublishOptions = PublishOptions
{ publishGetVersion = getVersionFromGitTag
+ , publishGetTagTime = getTagTime
, publishWorkingTreeDirty = userError DirtyWorkingTree
}
@@ -126,9 +119,6 @@ otherError = throwError . OtherError
catchLeft :: Applicative f => Either a b -> (a -> f b) -> f b
catchLeft a f = either f pure a
-unlessM :: Monad m => m Bool -> m () -> m ()
-unlessM cond act = cond >>= flip unless act
-
preparePackage' :: PublishOptions -> PrepareM D.UploadedPackage
preparePackage' opts = do
unlessM (liftIO (doesFileExist "bower.json")) (userError BowerJSONNotFound)
@@ -139,8 +129,9 @@ preparePackage' opts = do
checkLicense pkgMeta
(pkgVersionTag, pkgVersion) <- publishGetVersion opts
+ pkgTagTime <- Just <$> publishGetTagTime opts pkgVersionTag
pkgGithub <- getBowerRepositoryInfo pkgMeta
- (pkgBookmarks, pkgModules) <- getModulesAndBookmarks
+ (pkgModules, pkgModuleMap) <- getModules
let declaredDeps = map fst (bowerDependencies pkgMeta ++
bowerDevDependencies pkgMeta)
@@ -151,18 +142,18 @@ preparePackage' opts = do
return D.Package{..}
-getModulesAndBookmarks :: PrepareM ([D.Bookmark], [D.Module])
-getModulesAndBookmarks = do
+getModules :: PrepareM ([D.Module], Map P.ModuleName PackageName)
+getModules = do
(inputFiles, depsFiles) <- liftIO getInputAndDepsFiles
- (modules', bookmarks) <- parseAndBookmark inputFiles depsFiles
+ (modules', moduleMap) <- parseFilesInPackages inputFiles depsFiles
- case runExcept (D.convertModulesInPackage modules') of
- Right modules -> return (bookmarks, modules)
+ case runExcept (D.convertModulesInPackage modules' moduleMap) of
+ Right modules -> return (modules, moduleMap)
Left err -> userError (CompileError err)
where
- parseAndBookmark inputFiles depsFiles = do
- r <- liftIO . runExceptT $ D.parseAndBookmark inputFiles depsFiles
+ parseFilesInPackages inputFiles depsFiles = do
+ r <- liftIO . runExceptT $ D.parseFilesInPackages inputFiles depsFiles
case r of
Right r' ->
return r'
@@ -200,6 +191,14 @@ getVersionFromGitTag = do
digits <- stripPrefix "v" str
(str,) <$> D.parseVersion' digits
+-- | Given a git tag, get the time it was created.
+getTagTime :: Text -> PrepareM UTCTime
+getTagTime tag = do
+ out <- readProcess' "git" ["show", T.unpack tag, "--no-patch", "--format=%aI"] ""
+ case mapMaybe D.parseTime (lines out) of
+ [t] -> pure t
+ _ -> internalError (CouldntParseGitTagDate tag)
+
getBowerRepositoryInfo :: PackageMeta -> PrepareM (D.GithubUser, D.GithubRepo)
getBowerRepositoryInfo = either (userError . BadRepositoryField) return . tryExtract
where
diff --git a/src/Language/PureScript/Publish/ErrorsWarnings.hs b/src/Language/PureScript/Publish/ErrorsWarnings.hs
index 01935a1..c2f8225 100644
--- a/src/Language/PureScript/Publish/ErrorsWarnings.hs
+++ b/src/Language/PureScript/Publish/ErrorsWarnings.hs
@@ -17,7 +17,7 @@ import Prelude.Compat
import Control.Exception (IOException)
-import Data.Aeson.BetterErrors
+import Data.Aeson.BetterErrors (ParseError, displayError)
import Data.List (intersperse, intercalate)
import Data.List.NonEmpty (NonEmpty(..))
import Data.Maybe
@@ -73,6 +73,7 @@ data RepositoryFieldError
-- | An error that probably indicates a bug in this module.
data InternalError
= JSONError JSONSource (ParseError BowerError)
+ | CouldntParseGitTagDate Text
deriving (Show)
data JSONSource
@@ -289,6 +290,9 @@ displayInternalError e = case e of
[ "Error in JSON " ++ displayJSONSource src ++ ":"
, T.unpack (Bower.displayError r)
]
+ CouldntParseGitTagDate tag ->
+ [ "Unable to parse the date for a git tag: " ++ T.unpack tag
+ ]
displayJSONSource :: JSONSource -> String
displayJSONSource s = case s of
diff --git a/src/Language/PureScript/Sugar/DoNotation.hs b/src/Language/PureScript/Sugar/DoNotation.hs
index 452481e..b80b8e8 100644
--- a/src/Language/PureScript/Sugar/DoNotation.hs
+++ b/src/Language/PureScript/Sugar/DoNotation.hs
@@ -9,7 +9,6 @@ import Prelude.Compat
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.Supply.Class
-
import Language.PureScript.AST
import Language.PureScript.Crash
import Language.PureScript.Errors
@@ -49,6 +48,8 @@ desugarDo d =
return $ App (App bind val) (Abs (Left (Ident C.__unused)) rest')
go [DoNotationBind _ _] = throwError . errorMessage $ InvalidDoBind
go (DoNotationBind NullBinder val : rest) = go (DoNotationValue val : rest)
+ go (DoNotationBind b _ : _) | Ident C.bind `elem` binderNames b =
+ throwError . errorMessage $ CannotUseBindWithDo
go (DoNotationBind (VarBinder ident) val : rest) = do
rest' <- go rest
return $ App (App bind val) (Abs (Left ident) rest')
@@ -58,6 +59,12 @@ desugarDo d =
return $ App (App bind val) (Abs (Left ident) (Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] (Right rest')]))
go [DoNotationLet _] = throwError . errorMessage $ InvalidDoLet
go (DoNotationLet ds : rest) = do
+ let checkBind :: Declaration -> m ()
+ checkBind (ValueDeclaration (Ident name) _ _ _)
+ | name == C.bind = throwError . errorMessage $ CannotUseBindWithDo
+ checkBind (PositionedDeclaration pos _ decl) = rethrowWithPosition pos (checkBind decl)
+ checkBind _ = pure ()
+ mapM_ checkBind ds
rest' <- go rest
return $ Let ds rest'
go (PositionedDoNotationElement pos com el : rest) = rethrowWithPosition pos $ PositionedValue pos com <$> go (el : rest)
diff --git a/src/Language/PureScript/Sugar/ObjectWildcards.hs b/src/Language/PureScript/Sugar/ObjectWildcards.hs
index 3e306d0..149939a 100644
--- a/src/Language/PureScript/Sugar/ObjectWildcards.hs
+++ b/src/Language/PureScript/Sugar/ObjectWildcards.hs
@@ -3,19 +3,20 @@ module Language.PureScript.Sugar.ObjectWildcards
, desugarDecl
) where
-import Prelude.Compat
+import Prelude.Compat
-import Control.Monad (forM)
-import Control.Monad.Error.Class (MonadError(..))
-import Control.Monad.Supply.Class
+import Control.Monad (forM)
+import Control.Monad.Error.Class (MonadError(..))
+import Control.Monad.Supply.Class
+import Data.Foldable (toList)
+import Data.List (foldl')
+import Data.Maybe (catMaybes)
+import Language.PureScript.AST
+import Language.PureScript.Environment (NameKind(..))
+import Language.PureScript.Errors
+import Language.PureScript.Names
+import Language.PureScript.PSString (PSString)
-import Data.List (partition)
-import Data.Maybe (catMaybes)
-
-import Language.PureScript.AST
-import Language.PureScript.Errors
-import Language.PureScript.Names
-import Language.PureScript.PSString (PSString)
desugarObjectConstructors
:: forall m
@@ -41,11 +42,8 @@ desugarDecl other = fn other
, BinaryNoParens op u val <- b'
, isAnonymousArgument u = do arg <- freshIdent'
return $ Abs (Left arg) $ App (App op (Var (Qualified Nothing arg))) val
- desugarExpr (Literal (ObjectLiteral ps)) = wrapLambda (Literal . ObjectLiteral) ps
- desugarExpr (ObjectUpdate u ps) | isAnonymousArgument u = do
- obj <- freshIdent'
- Abs (Left obj) <$> wrapLambda (ObjectUpdate (argToExpr obj)) ps
- desugarExpr (ObjectUpdate obj ps) = wrapLambda (ObjectUpdate obj) ps
+ desugarExpr (Literal (ObjectLiteral ps)) = wrapLambdaAssoc (Literal . ObjectLiteral) ps
+ desugarExpr (ObjectUpdateNested obj ps) = transformNestedUpdate obj ps
desugarExpr (Accessor prop u)
| Just props <- peelAnonAccessorChain u = do
arg <- freshIdent'
@@ -62,14 +60,42 @@ desugarDecl other = fn other
return $ foldr (Abs . Left) if_ (catMaybes [u', t', f'])
desugarExpr e = return e
- wrapLambda :: ([(PSString, Expr)] -> Expr) -> [(PSString, Expr)] -> m Expr
- wrapLambda mkVal ps =
- let (args, props) = partition (isAnonymousArgument . snd) ps
- in if null args
- then return $ mkVal props
- else do
- (args', ps') <- unzip <$> mapM mkProp ps
- return $ foldr (Abs . Left) (mkVal ps') (catMaybes args')
+ transformNestedUpdate :: Expr -> PathTree Expr -> m Expr
+ transformNestedUpdate obj ps = do
+ -- If we don't have an anonymous argument then we need to generate a let wrapper
+ -- so that the object expression isn't re-evaluated for each nested update.
+ val <- freshIdent'
+ let valExpr = argToExpr val
+ if isAnonymousArgument obj
+ then Abs (Left val) <$> wrapLambda (buildUpdates valExpr) ps
+ else wrapLambda (buildLet val . buildUpdates valExpr) ps
+ where
+ buildLet val = Let [ValueDeclaration val Public [] (Right obj)]
+
+ -- recursively build up the nested `ObjectUpdate` expressions
+ buildUpdates :: Expr -> PathTree Expr -> Expr
+ buildUpdates val (PathTree vs) = ObjectUpdate val (goLayer [] <$> runAssocList vs) where
+ goLayer :: [PSString] -> (PSString, PathNode Expr) -> (PSString, Expr)
+ goLayer _ (key, Leaf expr) = (key, expr)
+ goLayer path (key, Branch (PathTree branch)) =
+ let path' = path ++ [key]
+ updates = goLayer path' <$> runAssocList branch
+ accessor = foldl' (flip Accessor) val path'
+ objectUpdate = ObjectUpdate accessor updates
+ in (key, objectUpdate)
+
+ wrapLambda :: forall t. Traversable t => (t Expr -> Expr) -> t Expr -> m Expr
+ wrapLambda mkVal ps = do
+ args <- traverse processExpr ps
+ return $ foldr (Abs . Left) (mkVal (snd <$> args)) (catMaybes $ toList (fst <$> args))
+ where
+ processExpr :: Expr -> m (Maybe Ident, Expr)
+ processExpr e = do
+ arg <- freshIfAnon e
+ return (arg, maybe e argToExpr arg)
+
+ wrapLambdaAssoc :: ([(PSString, Expr)] -> Expr) -> [(PSString, Expr)] -> m Expr
+ wrapLambdaAssoc mkVal = wrapLambda (mkVal . runAssocList) . AssocList
stripPositionInfo :: Expr -> Expr
stripPositionInfo (PositionedValue _ _ e) = stripPositionInfo e
@@ -86,11 +112,6 @@ desugarDecl other = fn other
isAnonymousArgument (PositionedValue _ _ e) = isAnonymousArgument e
isAnonymousArgument _ = False
- mkProp :: (PSString, Expr) -> m (Maybe Ident, (PSString, Expr))
- mkProp (name, e) = do
- arg <- freshIfAnon e
- return (arg, (name, maybe e argToExpr arg))
-
freshIfAnon :: Expr -> m (Maybe Ident)
freshIfAnon u
| isAnonymousArgument u = Just <$> freshIdent'
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
index c94e828..c63f5f6 100644
--- a/src/Language/PureScript/TypeChecker.hs
+++ b/src/Language/PureScript/TypeChecker.hs
@@ -297,6 +297,7 @@ typeCheckAll moduleName _ = traverse go
case M.lookup className (typeClasses env) of
Nothing -> internalError "typeCheckAll: Encountered unknown type class in instance declaration"
Just typeClass -> do
+ checkInstanceArity dictName className typeClass tys
sequence_ (zipWith (checkTypeClassInstance typeClass) [0..] tys)
checkOrphanInstance dictName className typeClass tys
_ <- traverseTypeInstanceBody checkInstanceMembers body
@@ -306,6 +307,13 @@ typeCheckAll moduleName _ = traverse go
go (PositionedDeclaration pos com d) =
warnAndRethrowWithPosition pos $ PositionedDeclaration pos com <$> go d
+ checkInstanceArity :: Ident -> Qualified (ProperName 'ClassName) -> TypeClassData -> [Type] -> m ()
+ checkInstanceArity dictName className typeClass tys = do
+ let typeClassArity = length (typeClassArguments typeClass)
+ instanceArity = length tys
+ when (typeClassArity /= instanceArity) $
+ throwError . errorMessage $ ClassInstanceArityMismatch dictName className typeClassArity instanceArity
+
checkInstanceMembers :: [Declaration] -> m [Declaration]
checkInstanceMembers instDecls = do
let idents = sort . map head . group . map memberName $ instDecls
diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs
index e5e33cb..8d5d177 100644
--- a/src/Language/PureScript/TypeChecker/Entailment.hs
+++ b/src/Language/PureScript/TypeChecker/Entailment.hs
@@ -45,6 +45,8 @@ import qualified Language.PureScript.Constants as C
data Evidence
= NamedInstance (Qualified Ident)
-- ^ An existing named instance
+ | WarnInstance Type
+ -- ^ Computed instance of the Warn type class with a user-defined warning message
| IsSymbolInstance PSString
-- ^ Computed instance of the IsSymbol type class for a given Symbol literal
| CompareSymbolInstance
@@ -144,6 +146,8 @@ entails SolverOptions{..} constraint context hints =
solve constraint
where
forClassName :: InstanceContext -> Qualified (ProperName 'ClassName) -> [Type] -> [TypeClassDict]
+ forClassName _ C.Warn [msg] =
+ [TypeClassDictionaryInScope (WarnInstance msg) [] C.Warn [msg] Nothing]
forClassName _ C.IsSymbol [TypeLevelString sym] =
[TypeClassDictionaryInScope (IsSymbolInstance sym) [] C.IsSymbol [TypeLevelString sym] Nothing]
forClassName _ C.CompareSymbol [arg0@(TypeLevelString lhs), arg1@(TypeLevelString rhs), _] =
@@ -216,8 +220,9 @@ entails SolverOptions{..} constraint context hints =
let subst'' = fmap (substituteType currentSubst') subst'
-- Solve any necessary subgoals
args <- solveSubgoals subst'' (tcdDependencies tcd)
+ initDict <- lift . lift $ mkDictionary (tcdValue tcd) args
let match = foldr (\(superclassName, index) dict -> subclassDictionaryValue dict superclassName index)
- (mkDictionary (tcdValue tcd) args)
+ initDict
(tcdPath tcd)
return match
Unsolved unsolved -> do
@@ -308,15 +313,18 @@ entails SolverOptions{..} constraint context hints =
Just <$> traverse (go (work + 1) . mapConstraintArgs (map (replaceAllTypeVars (M.toList subst)))) subgoals
-- 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 :: Evidence -> Maybe [Expr] -> m Expr
+ mkDictionary (NamedInstance n) args = return $ foldl App (Var n) (fold args)
+ mkDictionary (WarnInstance msg) _ = do
+ tell . errorMessage $ UserDefinedWarning msg
+ return $ TypeClassDictionaryConstructorApp C.Warn (Literal (ObjectLiteral []))
mkDictionary (IsSymbolInstance sym) _ =
let fields = [ ("reflectSymbol", Abs (Left (Ident C.__unused)) (Literal (StringLiteral sym))) ] in
- TypeClassDictionaryConstructorApp C.IsSymbol (Literal (ObjectLiteral fields))
+ return $ TypeClassDictionaryConstructorApp C.IsSymbol (Literal (ObjectLiteral fields))
mkDictionary CompareSymbolInstance _ =
- TypeClassDictionaryConstructorApp C.CompareSymbol (Literal (ObjectLiteral []))
+ return $ TypeClassDictionaryConstructorApp C.CompareSymbol (Literal (ObjectLiteral []))
mkDictionary AppendSymbolInstance _ =
- TypeClassDictionaryConstructorApp C.AppendSymbol (Literal (ObjectLiteral []))
+ return $ TypeClassDictionaryConstructorApp C.AppendSymbol (Literal (ObjectLiteral []))
-- Turn a DictionaryValue into a Expr
subclassDictionaryValue :: Expr -> Qualified (ProperName a) -> Integer -> Expr
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index b9c382d..5536253 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -77,11 +77,11 @@ typesOf
-> [(Ident, Expr)]
-> m [(Ident, (Expr, Type))]
typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do
- tys <- capturingSubstitution tidyUp $ do
- SplitBindingGroup untyped typed dict <- typeDictionaryForBindingGroup (Just moduleName) vals
+ (tys, wInfer) <- capturingSubstitution tidyUp $ do
+ (SplitBindingGroup untyped typed dict, w) <- withoutWarnings $ typeDictionaryForBindingGroup (Just moduleName) vals
ds1 <- parU typed $ \e -> withoutWarnings $ checkTypedBindingGroupElement moduleName e dict
ds2 <- forM untyped $ \e -> withoutWarnings $ typeForBindingGroupElement e dict
- return (map (False, ) ds1 ++ map (True, ) ds2)
+ return (map (False, ) ds1 ++ map (True, ) ds2, w)
inferred <- forM tys $ \(shouldGeneralize, ((ident, (val, ty)), _)) -> do
-- Replace type class dictionary placeholders with actual dictionaries
@@ -123,10 +123,13 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do
-- Show warnings here, since types in wildcards might have been solved during
-- instance resolution (by functional dependencies).
finalState <- get
+ let replaceTypes' = replaceTypes (checkSubstitution finalState)
+ runTypeSearch' gen = runTypeSearch (guard gen $> foldMap snd inferred) finalState
+ raisePreviousWarnings gen w = (escalateWarningWhen isHoleError . tell . onErrorMessages (runTypeSearch' gen . replaceTypes')) w
+
+ raisePreviousWarnings False wInfer
forM_ tys $ \(shouldGeneralize, ((_, (_, _)), w)) -> do
- let replaceTypes' = replaceTypes (checkSubstitution finalState)
- runTypeSearch' = runTypeSearch (guard shouldGeneralize $> foldMap snd inferred) finalState
- (escalateWarningWhen isHoleError . tell . onErrorMessages (runTypeSearch' . replaceTypes')) w
+ raisePreviousWarnings shouldGeneralize w
return (map fst inferred)
where
@@ -160,7 +163,7 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do
constrain cs = ConstrainedType (map (\(_, _, x) -> x) cs)
-- Apply the substitution that was returned from runUnify to both types and (type-annotated) values
- tidyUp ts sub = map (second (first (second (overTypes (substituteType sub) *** substituteType sub)))) ts
+ tidyUp ts sub = first (map (second (first (second (overTypes (substituteType sub) *** substituteType sub))))) ts
isHoleError :: ErrorMessage -> Bool
isHoleError (ErrorMessage _ HoleInferredType{}) = True
@@ -187,7 +190,7 @@ data SplitBindingGroup = SplitBindingGroup
-- This function also generates fresh unification variables for the types of
-- declarations without type annotations, returned in the 'UntypedData' structure.
typeDictionaryForBindingGroup
- :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+ :: (MonadState CheckState m, MonadWriter MultipleErrors m)
=> Maybe ModuleName
-> [(Ident, Expr)]
-> m SplitBindingGroup
@@ -197,7 +200,7 @@ typeDictionaryForBindingGroup moduleName vals = do
-- fully expanded types.
let (untyped, typed) = partitionEithers (map splitTypeAnnotation vals)
(typedDict, typed') <- fmap unzip . for typed $ \(ident, (expr, ty, checkType)) -> do
- ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty
+ ty' <- replaceTypeWildcards ty
return ((ident, ty'), (ident, (expr, ty', checkType)))
-- Create fresh unification variables for the types of untyped declarations
(untypedDict, untyped') <- fmap unzip . for untyped $ \(ident, expr) -> do
@@ -233,11 +236,14 @@ checkTypedBindingGroupElement mn (ident, (val, ty, checkType)) dict = do
-- Kind check
(kind, args) <- kindOfWithScopedVars ty
checkTypeKind ty kind
+ -- We replace type synonyms _after_ kind-checking, since we don't want type
+ -- synonym expansion to bring type variables into scope. See #2542.
+ ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty
-- Check the type with the new names in scope
val' <- if checkType
- then withScopedTypeVars mn args $ bindNames dict $ TypedValue True <$> check val ty <*> pure ty
- else return (TypedValue False val ty)
- return (ident, (val', ty))
+ then withScopedTypeVars mn args $ bindNames dict $ TypedValue True <$> check val ty' <*> pure ty'
+ else return (TypedValue False val ty')
+ return (ident, (val', ty'))
-- | Infer a type for a value in a binding group which lacks an annotation.
typeForBindingGroupElement
@@ -481,15 +487,12 @@ inferBinder val (NamedBinder name binder) = do
return $ M.insert name val m
inferBinder val (PositionedBinder pos _ binder) =
warnAndRethrowWithPositionTC pos $ inferBinder val binder
--- TODO: When adding support for polymorphic types, check subsumption here,
--- change the definition of `binderRequiresMonotype`,
--- and use `kindOfWithScopedVars`.
inferBinder val (TypedBinder ty binder) = do
kind <- kindOf ty
checkTypeKind ty kind
- ty1 <- replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty
+ ty1 <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty
unifyTypes val ty1
- inferBinder val binder
+ inferBinder ty1 binder
inferBinder _ OpBinder{} =
internalError "OpBinder should have been desugared before inferBinder"
inferBinder _ BinaryNoParensBinder{} =
@@ -504,6 +507,7 @@ binderRequiresMonotype NullBinder = False
binderRequiresMonotype (VarBinder _) = False
binderRequiresMonotype (NamedBinder _ b) = binderRequiresMonotype b
binderRequiresMonotype (PositionedBinder _ _ b) = binderRequiresMonotype b
+binderRequiresMonotype (TypedBinder ty b) = isMonoType ty || binderRequiresMonotype b
binderRequiresMonotype _ = True
-- | Instantiate polytypes only when necessitated by a binder.
diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs
index e345ad9..55aa8f2 100644
--- a/src/Language/PureScript/Types.hs
+++ b/src/Language/PureScript/Types.hs
@@ -127,6 +127,8 @@ rowFromList ((name, t):ts, r) = RCons name t (rowFromList (ts, r))
--
isMonoType :: Type -> Bool
isMonoType ForAll{} = False
+isMonoType (ParensInType t) = isMonoType t
+isMonoType (KindedType t _) = isMonoType t
isMonoType _ = True
-- |
diff --git a/stack.yaml b/stack.yaml
index 6d5f737..44b9670 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -2,4 +2,7 @@ resolver: lts-6.25
packages:
- '.'
extra-deps:
+- aeson-better-errors-0.9.1.0
- bower-json-1.0.0.1
+- optparse-applicative-0.13.0.0
+- turtle-1.3.1
diff --git a/tests/Language/PureScript/Ide/FilterSpec.hs b/tests/Language/PureScript/Ide/FilterSpec.hs
index 3b4cfc2..f129b18 100644
--- a/tests/Language/PureScript/Ide/FilterSpec.hs
+++ b/tests/Language/PureScript/Ide/FilterSpec.hs
@@ -8,6 +8,8 @@ import Language.PureScript.Ide.Types
import qualified Language.PureScript as P
import Test.Hspec
+type Module = (P.ModuleName, [IdeDeclarationAnn])
+
value :: Text -> IdeDeclarationAnn
value s = IdeDeclarationAnn emptyAnn (IdeDeclValue (IdeValue (P.Ident (toS s)) P.REmpty))
diff --git a/tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs b/tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs
deleted file mode 100644
index 01f474a..0000000
--- a/tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs
+++ /dev/null
@@ -1,83 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-module Language.PureScript.Ide.Imports.IntegrationSpec where
-
-
-import Protolude
-
-import qualified Data.Text as T
-import qualified Language.PureScript.Ide.Integration as Integration
-import Test.Hspec
-
-import System.Directory
-import System.FilePath
-import System.IO.UTF8 (readUTF8FileT)
-
-setup :: IO ()
-setup = void (Integration.reset *> Integration.loadAll)
-
-withSupportFiles :: (FilePath -> FilePath -> IO a) -> IO ()
-withSupportFiles test = do
- pdir <- Integration.projectDirectory
- let sourceFp = pdir </> "src" </> "ImportsSpec.purs"
- outFp = pdir </> "src" </> "ImportsSpecOut.tmp"
- Integration.deleteFileIfExists outFp
- void $ test sourceFp outFp
-
-outputFileShouldBe :: [Text] -> IO ()
-outputFileShouldBe expectation = do
- outFp <- (</> "src" </> "ImportsSpecOut.tmp") <$> Integration.projectDirectory
- outRes <- readUTF8FileT outFp
- shouldBe (T.strip <$> T.lines outRes) expectation
-
-spec :: Spec
-spec = beforeAll_ setup . describe "Adding imports" $ do
- let
- sourceFileSkeleton :: [Text] -> [Text]
- sourceFileSkeleton importSection =
- [ "module ImportsSpec where" , ""] ++ importSection ++ [ "" , "myId x = x"]
- it "adds an implicit import" $ do
- withSupportFiles (Integration.addImplicitImport "ImportsSpec1")
- outputFileShouldBe (sourceFileSkeleton
- [ "import ImportsSpec1"
- ])
- it "adds an explicit unqualified import" $ do
- withSupportFiles (Integration.addImport "exportedFunction")
- outputFileShouldBe (sourceFileSkeleton
- [ "import ImportsSpec1 (exportedFunction)"
- ])
- it "adds an explicit unqualified import (type)" $ do
- withSupportFiles (Integration.addImport "MyType")
- outputFileShouldBe (sourceFileSkeleton ["import ImportsSpec1 (MyType)"])
- it "adds an explicit unqualified import (parameterized type)" $ do
- withSupportFiles (Integration.addImport "MyParamType")
- outputFileShouldBe (sourceFileSkeleton ["import ImportsSpec1 (MyParamType)"])
- it "adds an explicit unqualified import (typeclass)" $ do
- withSupportFiles (Integration.addImport "ATypeClass")
- outputFileShouldBe (sourceFileSkeleton ["import ImportsSpec1 (class ATypeClass)"])
- it "adds an explicit unqualified import (dataconstructor)" $ do
- withSupportFiles (Integration.addImport "MyJust")
- outputFileShouldBe (sourceFileSkeleton ["import ImportsSpec1 (MyMaybe(..))"])
- it "adds an explicit unqualified import (newtype)" $ do
- withSupportFiles (Integration.addImport "MyNewtype")
- outputFileShouldBe (sourceFileSkeleton ["import ImportsSpec1 (MyNewtype(..))"])
- it "adds an explicit unqualified import (typeclass member function)" $ do
- withSupportFiles (Integration.addImport "typeClassFun")
- outputFileShouldBe (sourceFileSkeleton ["import ImportsSpec1 (typeClassFun)"])
- it "doesn't add a newtypes constructor if only the type is exported" $ do
- withSupportFiles (Integration.addImport "OnlyTypeExported")
- outputFileShouldBe (sourceFileSkeleton ["import ImportsSpec1 (OnlyTypeExported)"])
- it "doesn't add an import if the identifier is defined in the module itself" $ do
- withSupportFiles (Integration.addImport "myId")
- outputFileShouldBe (sourceFileSkeleton [])
- it "responds with an error if it's undecidable whether we want a type or constructor" $
- withSupportFiles (\sourceFp outFp -> do
- r <- Integration.addImport "SpecialCase" sourceFp outFp
- shouldBe False (Integration.resultIsSuccess r)
- shouldBe False =<< doesFileExist outFp)
- it "responds with an error if the identifier cannot be found and doesn't \
- \write to the output file" $
- withSupportFiles (\sourceFp outFp -> do
- r <- Integration.addImport "doesntExist" sourceFp outFp
- shouldBe False (Integration.resultIsSuccess r)
- shouldBe False =<< doesFileExist outFp)
diff --git a/tests/Language/PureScript/Ide/ImportsSpec.hs b/tests/Language/PureScript/Ide/ImportsSpec.hs
index e830ed0..ce90f93 100644
--- a/tests/Language/PureScript/Ide/ImportsSpec.hs
+++ b/tests/Language/PureScript/Ide/ImportsSpec.hs
@@ -6,8 +6,12 @@ import Protolude
import Data.Maybe (fromJust)
import qualified Language.PureScript as P
+import Language.PureScript.Ide.Command as Command
+import Language.PureScript.Ide.Error
import Language.PureScript.Ide.Imports
+import qualified Language.PureScript.Ide.Test as Test
import Language.PureScript.Ide.Types
+import System.FilePath
import Test.Hspec
simpleFile :: [Text]
@@ -22,6 +26,7 @@ splitSimpleFile :: (P.ModuleName, [Text], [Import], [Text])
splitSimpleFile = fromRight (sliceImportSection simpleFile)
where
fromRight = fromJust . rightToMaybe
+
withImports :: [Text] -> [Text]
withImports is =
take 2 simpleFile ++ is ++ drop 2 simpleFile
@@ -144,7 +149,7 @@ spec = do
addImport imports import' = addExplicitImport' import' moduleName imports
valueImport ident = (IdeDeclValue (IdeValue (P.Ident ident) wildcard))
typeImport name = (IdeDeclType (IdeType (P.ProperName name) P.kindType))
- classImport name = (IdeDeclTypeClass (P.ProperName name))
+ classImport name = (IdeDeclTypeClass (IdeTypeClass (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
expectSorted imports expected = shouldBe
@@ -171,3 +176,63 @@ spec = do
-- the imported names don't actually have to exist!
(map (uncurry dtorImport) [("Just", "Maybe"), ("Nothing", "Maybe"), ("SomeOtherConstructor", "SomeDataType")])
["import Prelude", "import Control.Monad (Maybe(..), SomeDataType(..), ap)"]
+ describe "importing from a loaded IdeState" importFromIdeState
+
+implImport :: Text -> Command
+implImport mn =
+ Command.Import ("src" </> "ImportsSpec.purs") Nothing [] (Command.AddImplicitImport (Test.mn mn))
+
+addExplicitImport :: Text -> Command
+addExplicitImport i =
+ Command.Import ("src" </> "ImportsSpec.purs") Nothing [] (Command.AddImportForIdentifier i)
+
+importShouldBe :: [Text] -> [Text] -> Expectation
+importShouldBe res importSection =
+ res `shouldBe` [ "module ImportsSpec where" , ""] ++ importSection ++ [ "" , "myId x = x"]
+
+runIdeLoaded :: Command -> IO (Either IdeError Success)
+runIdeLoaded c = do
+ ([_, result], _) <- Test.inProject $ Test.runIde [Command.LoadSync [] , c]
+ pure result
+
+importFromIdeState :: Spec
+importFromIdeState = do
+ it "adds an implicit import" $ do
+ Right (MultilineTextResult result) <-
+ runIdeLoaded (implImport "ImportsSpec1")
+ result `importShouldBe` [ "import ImportsSpec1" ]
+ it "adds an explicit unqualified import" $ do
+ Right (MultilineTextResult result) <- runIdeLoaded (addExplicitImport "exportedFunction")
+ result `importShouldBe` [ "import ImportsSpec1 (exportedFunction)" ]
+ it "adds an explicit unqualified import (type)" $ do
+ Right (MultilineTextResult result) <- runIdeLoaded (addExplicitImport "MyType")
+ result `importShouldBe` [ "import ImportsSpec1 (MyType)" ]
+ it "adds an explicit unqualified import (parameterized type)" $ do
+ Right (MultilineTextResult result) <- runIdeLoaded (addExplicitImport "MyParamType")
+ result `importShouldBe` [ "import ImportsSpec1 (MyParamType)" ]
+ it "adds an explicit unqualified import (typeclass)" $ do
+ Right (MultilineTextResult result) <- runIdeLoaded (addExplicitImport "ATypeClass")
+ result `importShouldBe` [ "import ImportsSpec1 (class ATypeClass)" ]
+ it "adds an explicit unqualified import (dataconstructor)" $ do
+ Right (MultilineTextResult result) <- runIdeLoaded (addExplicitImport "MyJust")
+ result `importShouldBe` [ "import ImportsSpec1 (MyMaybe(..))" ]
+ it "adds an explicit unqualified import (newtype)" $ do
+ Right (MultilineTextResult result) <- runIdeLoaded (addExplicitImport "MyNewtype")
+ result `importShouldBe` [ "import ImportsSpec1 (MyNewtype(..))" ]
+ it "adds an explicit unqualified import (typeclass member function)" $ do
+ Right (MultilineTextResult result) <- runIdeLoaded (addExplicitImport "typeClassFun")
+ result `importShouldBe` [ "import ImportsSpec1 (typeClassFun)" ]
+ it "doesn't add a newtypes constructor if only the type is exported" $ do
+ Right (MultilineTextResult result) <-
+ runIdeLoaded (addExplicitImport "OnlyTypeExported")
+ result `importShouldBe` [ "import ImportsSpec1 (OnlyTypeExported)" ]
+ it "doesn't add an import if the identifier is defined in the module itself" $ do
+ Right (MultilineTextResult result) <- runIdeLoaded (addExplicitImport "myId")
+ result `importShouldBe` []
+ it "responds with an error if it's undecidable whether we want a type or constructor" $ do
+ result <- runIdeLoaded (addExplicitImport "SpecialCase")
+ result `shouldSatisfy` isLeft
+ it "responds with an error if the identifier cannot be found and doesn't \
+ \write to the output file" $ do
+ result <- runIdeLoaded (addExplicitImport "doesnExist")
+ result `shouldSatisfy` isLeft
diff --git a/tests/Language/PureScript/Ide/Integration.hs b/tests/Language/PureScript/Ide/Integration.hs
deleted file mode 100644
index 92569d0..0000000
--- a/tests/Language/PureScript/Ide/Integration.hs
+++ /dev/null
@@ -1,273 +0,0 @@
------------------------------------------------------------------------------
---
--- Module : Language.PureScript.Ide.Integration
--- Description : A psc-ide client for use in integration tests
--- Copyright : Christoph Hegemann 2016
--- License : MIT (http://opensource.org/licenses/MIT)
---
--- Maintainer : Christoph Hegemann <christoph.hegemann1337@gmail.com>
--- Stability : experimental
---
--- |
--- A psc-ide client for use in integration tests
------------------------------------------------------------------------------
-
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-module Language.PureScript.Ide.Integration
- (
- -- managing the server process
- startServer
- , withServer
- , stopServer
- , quitServer
- -- util
- , compileTestProject
- , deleteOutputFolder
- , projectDirectory
- , deleteFileIfExists
- -- sending commands
- , addImport
- , addImplicitImport
- , loadAll
- , loadModule
- , loadModules
- , getCwd
- , getFlexCompletions
- , getFlexCompletionsInModule
- , getType
- , rebuildModule
- , reset
- -- checking results
- , resultIsSuccess
- , parseCompletions
- , parseTextResult
- ) where
-
-import Protolude
-import Data.Maybe (fromJust)
-
-import Data.Aeson
-import Data.Aeson.Types
-import qualified Data.Text as T
-import qualified Data.Vector as V
-import Language.PureScript.Ide.Util
-import qualified Language.PureScript as P
-import System.Directory
-import System.FilePath
-import System.IO.Error (mkIOError, userErrorType)
-import System.Process
-
-projectDirectory :: IO FilePath
-projectDirectory = do
- cd <- getCurrentDirectory
- return $ cd </> "tests" </> "support" </> "pscide"
-
-startServer :: IO ProcessHandle
-startServer = do
- pdir <- projectDirectory
- -- Turn off filewatching since it creates race condition in a testing environment
- (_, _, _, procHandle) <- createProcess $
- (shell "psc-ide-server --no-watch src/*.purs") {cwd = Just pdir}
- threadDelay 2000000 -- give the server 2s to start up
- return procHandle
-
-stopServer :: ProcessHandle -> IO ()
-stopServer = terminateProcess
-
-withServer :: IO a -> IO a
-withServer s = do
- _ <- startServer
- started <- tryNTimes 5 (rightToMaybe <$> (try getCwd :: IO (Either SomeException Text)))
- when (isNothing started) $
- throwIO (mkIOError userErrorType "psc-ide-server didn't start in time" Nothing Nothing)
- r <- s
- quitServer
- pure r
-
--- project management utils
-
-compileTestProject :: IO Bool
-compileTestProject = do
- pdir <- projectDirectory
- (_, _, _, procHandle) <- createProcess $
- (shell . toS $ "psc " <> fileGlob) { cwd = Just pdir }
- r <- tryNTimes 10 (getProcessExitCode procHandle)
- pure (fromMaybe False (isSuccess <$> r))
-
-tryNTimes :: Int -> IO (Maybe a) -> IO (Maybe a)
-tryNTimes 0 _ = pure Nothing
-tryNTimes n action = do
- r <- action
- case r of
- Nothing -> do
- threadDelay 500000
- tryNTimes (n - 1) action
- Just a -> pure (Just a)
-
-deleteOutputFolder :: IO ()
-deleteOutputFolder = do
- odir <- fmap (</> "output") projectDirectory
- whenM (doesDirectoryExist odir) (removeDirectoryRecursive odir)
-
-deleteFileIfExists :: FilePath -> IO ()
-deleteFileIfExists fp = whenM (doesFileExist fp) (removeFile fp)
-
-isSuccess :: ExitCode -> Bool
-isSuccess ExitSuccess = True
-isSuccess (ExitFailure _) = False
-
-fileGlob :: Text
-fileGlob = "\"src/**/*.purs\""
-
--- Integration Testing API
-
-sendCommand :: Value -> IO Text
-sendCommand v = toS <$> readCreateProcess
- ((shell "psc-ide-client") { std_out=CreatePipe
- , std_err=CreatePipe
- })
- (T.unpack (encodeT v))
-
-quitServer :: IO ()
-quitServer = do
- let quitCommand = object ["command" .= ("quit" :: Text)]
- _ <- try $ sendCommand quitCommand :: IO (Either SomeException Text)
- return ()
-
-reset :: IO ()
-reset = do
- let resetCommand = object ["command" .= ("reset" :: Text)]
- _ <- try $ sendCommand resetCommand :: IO (Either SomeException Text)
- return ()
-
-getCwd :: IO Text
-getCwd = do
- let cwdCommand = object ["command" .= ("cwd" :: Text)]
- sendCommand cwdCommand
-
-loadModule :: Text -> IO Text
-loadModule m = loadModules [m]
-
-loadModules :: [Text] -> IO Text
-loadModules = sendCommand . load
-
-loadAll :: IO Text
-loadAll = sendCommand (load [])
-
-getFlexCompletions :: Text -> IO [(Text, Text, Text, Maybe P.SourceSpan)]
-getFlexCompletions q = parseCompletions <$> sendCommand (completion [] (Just (flexMatcher q)) Nothing)
-
-getFlexCompletionsInModule :: Text -> Text -> IO [(Text, Text, Text, Maybe P.SourceSpan)]
-getFlexCompletionsInModule q m = parseCompletions <$> sendCommand (completion [] (Just (flexMatcher q)) (Just m))
-
-getType :: Text -> IO [(Text, Text, Text, Maybe P.SourceSpan)]
-getType q = parseCompletions <$> sendCommand (typeC q [])
-
-addImport :: Text -> FilePath -> FilePath -> IO Text
-addImport identifier fp outfp = sendCommand (addImportC identifier fp outfp)
-
-addImplicitImport :: Text -> FilePath -> FilePath -> IO Text
-addImplicitImport mn fp outfp = sendCommand (addImplicitImportC mn fp outfp)
-
-rebuildModule :: FilePath -> IO Text
-rebuildModule m = sendCommand (rebuildC m Nothing)
-
--- Command Encoding
-
-commandWrapper :: Text -> Value -> Value
-commandWrapper c p = object ["command" .= c, "params" .= p]
-
-load :: [Text] -> Value
-load ms = commandWrapper "load" (object ["modules" .= ms])
-
-typeC :: Text -> [Value] -> Value
-typeC q filters = commandWrapper "type" (object ["search" .= q, "filters" .= filters])
-
-addImportC :: Text -> FilePath -> FilePath -> Value
-addImportC identifier = addImportW $
- object [ "importCommand" .= ("addImport" :: Text)
- , "identifier" .= identifier
- ]
-
-addImplicitImportC :: Text -> FilePath -> FilePath -> Value
-addImplicitImportC mn = addImportW $
- object [ "importCommand" .= ("addImplicitImport" :: Text)
- , "module" .= mn
- ]
-
-rebuildC :: FilePath -> Maybe FilePath -> Value
-rebuildC file outFile =
- commandWrapper "rebuild" (object [ "file" .= file
- , "outfile" .= outFile
- ])
-
-addImportW :: Value -> FilePath -> FilePath -> Value
-addImportW importCommand fp outfp =
- commandWrapper "import" (object [ "file" .= fp
- , "outfile" .= outfp
- , "importCommand" .= importCommand
- ])
-
-
-completion :: [Value] -> Maybe Value -> Maybe Text -> Value
-completion filters matcher currentModule =
- let
- matcher' = case matcher of
- Nothing -> []
- Just m -> ["matcher" .= m]
- currentModule' = case currentModule of
- Nothing -> []
- Just cm -> ["currentModule" .= cm]
- in
- commandWrapper "complete" (object $ "filters" .= filters : matcher' ++ currentModule' )
-
-flexMatcher :: Text -> Value
-flexMatcher q = object [ "matcher" .= ("flex" :: Text)
- , "params" .= object ["search" .= q]
- ]
-
--- Result parsing
-
-unwrapResult :: Value -> Parser (Either Text Value)
-unwrapResult = withObject "result" $ \o -> do
- (rt :: Text) <- o .: "resultType"
- case rt of
- "error" -> do
- res <- o .: "result"
- pure (Left res)
- "success" -> do
- res <- o .: "result"
- pure (Right res)
- _ -> mzero
-
-withResult :: (Value -> Parser a) -> Value -> Parser (Either Text a)
-withResult p v = do
- r <- unwrapResult v
- case r of
- Left err -> pure (Left err)
- Right res -> Right <$> p res
-
-completionParser :: Value -> Parser [(Text, Text, Text, Maybe P.SourceSpan)]
-completionParser = withArray "res" $ \cs ->
- mapM (withObject "completion" $ \o -> do
- ident <- o .: "identifier"
- module' <- o .: "module"
- ty <- o .: "type"
- ss <- o .: "definedAt"
- pure (module', ident, ty, ss)) (V.toList cs)
-
-valueFromText :: Text -> Value
-valueFromText = fromJust . decode . toS
-
-resultIsSuccess :: Text -> Bool
-resultIsSuccess = isRight . join . first toS . parseEither unwrapResult . valueFromText
-
-parseCompletions :: Text -> [(Text, Text, Text, Maybe P.SourceSpan)]
-parseCompletions s =
- fromJust $ join (rightToMaybe <$> parseMaybe (withResult completionParser) (valueFromText s))
-
-parseTextResult :: Text -> Text
-parseTextResult s =
- fromJust $ join (rightToMaybe <$> parseMaybe (withResult (withText "tr" pure)) (valueFromText s))
diff --git a/tests/Language/PureScript/Ide/MatcherSpec.hs b/tests/Language/PureScript/Ide/MatcherSpec.hs
index f7a7f45..cfb7102 100644
--- a/tests/Language/PureScript/Ide/MatcherSpec.hs
+++ b/tests/Language/PureScript/Ide/MatcherSpec.hs
@@ -6,7 +6,6 @@ module Language.PureScript.Ide.MatcherSpec where
import Protolude
import qualified Language.PureScript as P
-import Language.PureScript.Ide.Integration
import Language.PureScript.Ide.Matcher
import Language.PureScript.Ide.Types
import Language.PureScript.Ide.Util
@@ -26,9 +25,6 @@ completions = [firstResult, secondResult, fiult]
runFlex :: Text -> [Match IdeDeclarationAnn]
runFlex s = runMatcher (flexMatcher s) completions
-setup :: IO ()
-setup = reset *> void loadAll
-
spec :: Spec
spec = do
describe "Flex Matcher" $ do
@@ -38,12 +34,3 @@ spec = do
runFlex "firstResult" `shouldBe` [firstResult]
it "scores short matches higher and sorts accordingly" $
runFlex "filt" `shouldBe` [fiult, firstResult]
-
- beforeAll_ setup . describe "Integration Tests: Flex Matcher" $ do
- it "doesn't match on an empty string" $ do
- cs <- getFlexCompletions ""
- cs `shouldBe` []
- it "matches on equality" $ do
- -- ignore any position information
- (m, i, t, _) : _ <- getFlexCompletions "const"
- (m, i, t) `shouldBe` ("MatcherSpec", "const", "forall a b. a -> b -> a")
diff --git a/tests/Language/PureScript/Ide/RebuildSpec.hs b/tests/Language/PureScript/Ide/RebuildSpec.hs
index f924190..801c3b6 100644
--- a/tests/Language/PureScript/Ide/RebuildSpec.hs
+++ b/tests/Language/PureScript/Ide/RebuildSpec.hs
@@ -4,54 +4,58 @@ module Language.PureScript.Ide.RebuildSpec where
import Protolude
-import qualified Language.PureScript.Ide.Integration as Integration
+import Language.PureScript.Ide.Command
+import Language.PureScript.Ide.Matcher
+import Language.PureScript.Ide.Types
+import qualified Language.PureScript.Ide.Test as Test
import System.FilePath
import Test.Hspec
-shouldBeSuccess :: Text -> IO ()
-shouldBeSuccess = shouldBe True . Integration.resultIsSuccess
+load :: [Text] -> Command
+load = LoadSync . map Test.mn
-shouldBeFailure :: Text -> IO ()
-shouldBeFailure = shouldBe False . Integration.resultIsSuccess
+rebuild :: FilePath -> Command
+rebuild fp = Rebuild ("src" </> fp)
+
+rebuildSync :: FilePath -> Command
+rebuildSync fp = RebuildSync ("src" </> fp)
spec :: Spec
-spec = before_ Integration.reset . describe "Rebuilding single modules" $ do
+spec = describe "Rebuilding single modules" $ do
it "rebuilds a correct module without dependencies successfully" $ do
- _ <- Integration.loadModule "RebuildSpecSingleModule"
- pdir <- Integration.projectDirectory
- let file = pdir </> "src" </> "RebuildSpecSingleModule.purs"
- Integration.rebuildModule file >>= shouldBeSuccess
+ ([_, result], _) <- Test.inProject $
+ Test.runIde [ load ["RebuildSpecSingleModule"]
+ , rebuild "RebuildSpecSingleModule.purs"
+ ]
+ result `shouldSatisfy` isRight
it "fails to rebuild an incorrect module without dependencies and returns the errors" $ do
- pdir <- Integration.projectDirectory
- let file = pdir </> "src" </> "RebuildSpecSingleModule.fail"
- Integration.rebuildModule file >>= shouldBeFailure
+ ([result], _) <- Test.inProject $
+ Test.runIde [ rebuild "RebuildSpecSingleModule.fail" ]
+ result `shouldSatisfy` isLeft
it "rebuilds a correct module with its dependencies successfully" $ do
- _ <- Integration.loadModules ["RebuildSpecWithDeps", "RebuildSpecDep"]
- pdir <- Integration.projectDirectory
- let file = pdir </> "src" </> "RebuildSpecWithDeps.purs"
- Integration.rebuildModule file >>= shouldBeSuccess
+ ([_, result], _) <- Test.inProject $
+ Test.runIde [ load ["RebuildSpecWithDeps", "RebuildSpecDep"]
+ , rebuild "RebuildSpecWithDeps.purs"
+ ]
+ result `shouldSatisfy` isRight
it "rebuilds a correct module that has reverse dependencies" $ do
- _ <- Integration.loadModule "RebuildSpecWithDeps"
- pdir <- Integration.projectDirectory
- let file = pdir </> "src" </> "RebuildSpecDep.purs"
- Integration.rebuildModule file >>= shouldBeSuccess
+ ([_, result], _) <- Test.inProject $
+ Test.runIde [ load ["RebuildSpecWithDeps"], rebuild "RebuildSpecDep.purs" ]
+ result `shouldSatisfy` isRight
it "fails to rebuild a module if its dependencies are not loaded" $ do
- _ <- Integration.loadModule "RebuildSpecWithDeps"
- pdir <- Integration.projectDirectory
- let file = pdir </> "src" </> "RebuildSpecWithDeps.purs"
- Integration.rebuildModule file >>= shouldBeFailure
+ ([_, result], _) <- Test.inProject $
+ Test.runIde [ load ["RebuildSpecWithDeps"], rebuild "RebuildSpecWithDeps.purs" ]
+ result `shouldSatisfy` isLeft
it "rebuilds a correct module with a foreign file" $ do
- _ <- Integration.loadModule "RebuildSpecWithForeign"
- pdir <- Integration.projectDirectory
- let file = pdir </> "src" </> "RebuildSpecWithForeign.purs"
- Integration.rebuildModule file >>= shouldBeSuccess
+ ([_, result], _) <- Test.inProject $
+ Test.runIde [ load ["RebuildSpecWithForeign"], rebuild "RebuildSpecWithForeign.purs" ]
+ result `shouldSatisfy` isRight
it "fails to rebuild a module with a foreign import but no file" $ do
- pdir <- Integration.projectDirectory
- let file = pdir </> "src" </> "RebuildSpecWithMissingForeign.fail"
- Integration.rebuildModule file >>= shouldBeFailure
+ ([result], _) <- Test.inProject $
+ Test.runIde [ rebuild "RebuildSpecWithMissingForeign.fail" ]
+ result `shouldSatisfy` isLeft
it "completes a hidden identifier after rebuilding" $ do
- pdir <- Integration.projectDirectory
- let file = pdir </> "src" </> "RebuildSpecWithHiddenIdent.purs"
- Integration.rebuildModule file >>= shouldBeSuccess
- res <- Integration.getFlexCompletionsInModule "hid" "RebuildSpecWithHiddenIdent"
- shouldBe False (null res)
+ ([_, (Right (CompletionResult [ result ]))], _) <- Test.inProject $
+ Test.runIde [ rebuildSync "RebuildSpecWithHiddenIdent.purs"
+ , Complete [] (flexMatcher "hid") (Just (Test.mn "RebuildSpecWithHiddenIdent"))]
+ complIdentifier result `shouldBe` "hidden"
diff --git a/tests/Language/PureScript/Ide/ReexportsSpec.hs b/tests/Language/PureScript/Ide/ReexportsSpec.hs
index adbdc74..c260c4e 100644
--- a/tests/Language/PureScript/Ide/ReexportsSpec.hs
+++ b/tests/Language/PureScript/Ide/ReexportsSpec.hs
@@ -10,6 +10,8 @@ import Language.PureScript.Ide.Types
import qualified Language.PureScript as P
import Test.Hspec
+type Module = (P.ModuleName, [IdeDeclarationAnn])
+
m :: Text -> P.ModuleName
m = P.moduleNameFromString
@@ -19,32 +21,32 @@ 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.kindType))
-classA = d (IdeDeclTypeClass (P.ProperName "ClassA"))
+classA = d (IdeDeclTypeClass (IdeTypeClass (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))
-env :: Map P.ModuleName [IdeDeclarationAnn]
+env :: ModuleMap [IdeDeclarationAnn]
env = Map.fromList
[ (m "A", [valueA, typeA, classA, dtorA1, dtorA2])
]
type Refs = [(P.ModuleName, P.DeclarationRef)]
-succTestCases :: [(Text, Module, Refs, Module)]
+succTestCases :: [(Text, [IdeDeclarationAnn], Refs, [IdeDeclarationAnn])]
succTestCases =
- [ ("resolves a value reexport", (m "C", []), [(m "A", P.ValueRef (P.Ident "valueA"))], (m "C", [valueA]))
+ [ ("resolves a value reexport", [], [(m "A", P.ValueRef (P.Ident "valueA"))], [valueA])
, ("resolves a type reexport with explicit data constructors"
- , (m "C", []), [(m "A", P.TypeRef (P.ProperName "TypeA") (Just [P.ProperName "DtorA1"]))], (m "C", [typeA, dtorA1]))
+ , [], [(m "A", P.TypeRef (P.ProperName "TypeA") (Just [P.ProperName "DtorA1"]))], [typeA, dtorA1])
, ("resolves a type reexport with implicit data constructors"
- , (m "C", []), [(m "A", P.TypeRef (P.ProperName "TypeA") Nothing)], (m "C", [typeA, dtorA1, dtorA2]))
- , ("resolves a class reexport", (m "C", []), [(m "A", P.TypeClassRef (P.ProperName "ClassA"))], (m "C", [classA]))
+ , [], [(m "A", P.TypeRef (P.ProperName "TypeA") Nothing)], [typeA, dtorA1, dtorA2])
+ , ("resolves a class reexport", [], [(m "A", P.TypeClassRef (P.ProperName "ClassA"))], [classA])
]
-failTestCases :: [(Text, Module, Refs)]
+failTestCases :: [(Text, [IdeDeclarationAnn], Refs)]
failTestCases =
- [ ("fails to resolve a non existing value", (m "C", []), [(m "A", P.ValueRef (P.Ident "valueB"))])
- , ("fails to resolve a non existing type reexport" , (m "C", []), [(m "A", P.TypeRef (P.ProperName "TypeB") Nothing)])
- , ("fails to resolve a non existing class reexport", (m "C", []), [(m "A", P.TypeClassRef (P.ProperName "ClassB"))])
+ [ ("fails to resolve a non existing value", [], [(m "A", P.ValueRef (P.Ident "valueB"))])
+ , ("fails to resolve a non existing type reexport" , [], [(m "A", P.TypeRef (P.ProperName "TypeB") Nothing)])
+ , ("fails to resolve a non existing class reexport", [], [(m "A", P.TypeClassRef (P.ProperName "ClassB"))])
]
spec :: Spec
@@ -52,12 +54,12 @@ spec = do
describe "Successful Reexports" $
for_ succTestCases $ \(desc, initial, refs, result) ->
it (toS desc) $ do
- let reResult = resolveReexports env (initial, refs)
+ let reResult = resolveReexports' env initial refs
reResolved reResult `shouldBe` result
reResult `shouldSatisfy` not . reexportHasFailures
describe "Failed Reexports" $
for_ failTestCases $ \(desc, initial, refs) ->
it (toS desc) $ do
- let reResult = resolveReexports env (initial, refs)
+ let reResult = resolveReexports' env initial refs
reFailed reResult `shouldBe` refs
reResult `shouldSatisfy` reexportHasFailures
diff --git a/tests/Language/PureScript/Ide/SourceFile/IntegrationSpec.hs b/tests/Language/PureScript/Ide/SourceFile/IntegrationSpec.hs
deleted file mode 100644
index 4fd6056..0000000
--- a/tests/Language/PureScript/Ide/SourceFile/IntegrationSpec.hs
+++ /dev/null
@@ -1,41 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-module Language.PureScript.Ide.SourceFile.IntegrationSpec where
-
-
-import Protolude
-
-import qualified Data.Text as T
-import qualified Language.PureScript.Ide.Integration as Integration
-import qualified Language.PureScript as P
-import Test.Hspec
-
-setup :: IO ()
-setup = void (Integration.reset *> Integration.loadAll)
-
-spec :: Spec
-spec = beforeAll_ setup $
- describe "Sourcefile Integration" $ do
- it "finds a value declaration" $
- testCase "sfValue" (3, 1)
- it "finds a type declaration" $
- testCase "SFType" (5, 1)
- it "finds a data declaration" $
- testCase "SFData" (7, 1)
- it "finds a data constructor" $
- testCase "SFOne" (7, 1)
- it "finds a typeclass" $
- testCase "SFClass" (9, 1)
- it "finds a typeclass member" $
- testCase "sfShow" (10, 3)
-
-testCase :: Text -> (Int, Int) -> IO ()
-testCase s (x, y) = do
- P.SourceSpan f (P.SourcePos l c) _ <- getLocation s
- toS f `shouldSatisfy` T.isSuffixOf "SourceFileSpec.purs"
- (l, c) `shouldBe` (x, y)
-
-getLocation :: Text -> IO P.SourceSpan
-getLocation s = do
- (_, _, _, Just location) : _ <- Integration.getType s
- pure location
diff --git a/tests/Language/PureScript/Ide/SourceFileSpec.hs b/tests/Language/PureScript/Ide/SourceFileSpec.hs
index eae3de7..e680c99 100644
--- a/tests/Language/PureScript/Ide/SourceFileSpec.hs
+++ b/tests/Language/PureScript/Ide/SourceFileSpec.hs
@@ -5,8 +5,10 @@ module Language.PureScript.Ide.SourceFileSpec where
import Protolude
import qualified Language.PureScript as P
+import Language.PureScript.Ide.Command
import Language.PureScript.Ide.SourceFile
import Language.PureScript.Ide.Types
+import Language.PureScript.Ide.Test
import Test.Hspec
span0, span1, span2 :: P.SourceSpan
@@ -14,7 +16,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, foreign3, member1 :: P.Declaration
+typeAnnotation1, value1, synonym1, class1, class2, data1, data2, valueFixity, typeFixity, 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,6 +25,16 @@ class2 = P.TypeClassDeclaration (P.ProperName "Class2") [] [] []
[P.PositionedDeclaration span2 [] member1]
data1 = P.DataDeclaration P.Newtype (P.ProperName "Data1") [] []
data2 = P.DataDeclaration P.Data (P.ProperName "Data2") [] [(P.ProperName "Cons1", [])]
+valueFixity =
+ P.ValueFixityDeclaration
+ (P.Fixity P.Infix 0)
+ (P.Qualified Nothing (Left (P.Ident "")))
+ (P.OpName "<$>")
+typeFixity =
+ P.TypeFixityDeclaration
+ (P.Fixity P.Infix 0)
+ (P.Qualified Nothing (P.ProperName ""))
+ (P.OpName "~>")
foreign1 = P.ExternDeclaration (P.Ident "foreign1") P.REmpty
foreign2 = P.ExternDataDeclaration (P.ProperName "Foreign2") P.kindType
foreign3 = P.ExternKindDeclaration (P.ProperName "Foreign3")
@@ -43,6 +55,10 @@ spec = do
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` [(IdeNSType "Data2", span1), (IdeNSValue "Cons1", span1)]
+ it "extracts a span for a value operator fixity declaration" $
+ extractSpans span0 (P.PositionedDeclaration span1 [] valueFixity) `shouldBe` [(IdeNSValue "<$>", span1)]
+ it "extracts a span for a type operator fixity declaration" $
+ extractSpans span0 (P.PositionedDeclaration span1 [] typeFixity) `shouldBe` [(IdeNSType "~>", span1)]
it "extracts a span for a foreign declaration" $
extractSpans span0 (P.PositionedDeclaration span1 [] foreign1) `shouldBe` [(IdeNSValue "foreign1", span1)]
it "extracts a span for a data foreign declaration" $
@@ -52,3 +68,55 @@ spec = do
describe "Type annotations" $ do
it "extracts a type annotation" $
extractTypeAnnotations [typeAnnotation1] `shouldBe` [(P.Ident "value1", P.REmpty)]
+ describe "Finding Source Spans for identifiers" $ do
+ it "finds a value declaration" $ do
+ Just r <- getLocation "sfValue"
+ r `shouldBe` valueSS
+ it "finds a synonym declaration" $ do
+ Just r <- getLocation "SFType"
+ r `shouldBe` synonymSS
+ it "finds a data declaration and its constructors" $ do
+ rs <- traverse getLocation ["SFData", "SFOne", "SFTwo", "SFThree"]
+ traverse_ (`shouldBe` (Just typeSS)) rs
+ it "finds a class declaration" $ do
+ Just r <- getLocation "SFClass"
+ r `shouldBe` classSS
+ it "finds a value operator declaration" $ do
+ Just r <- getLocation "<$>"
+ r `shouldBe` valueOpSS
+ it "finds a type operator declaration" $ do
+ Just r <- getLocation "~>"
+ r `shouldBe` typeOpSS
+
+getLocation :: Text -> IO (Maybe P.SourceSpan)
+getLocation s = do
+ ([Right (CompletionResult [c])], _) <-
+ runIde' defConfig ideState [Type s [] Nothing]
+ pure (complLocation c)
+ where
+ ideState = emptyIdeState `s3`
+ [ ("Test",
+ [ ideValue "sfValue" Nothing `annLoc` valueSS
+ , ideSynonym "SFType" P.tyString `annLoc` synonymSS
+ , ideType "SFData" Nothing `annLoc` typeSS
+ , ideDtor "SFOne" "SFData" Nothing `annLoc` typeSS
+ , ideDtor "SFTwo" "SFData" Nothing `annLoc` typeSS
+ , ideDtor "SFThree" "SFData" Nothing `annLoc` typeSS
+ , ideTypeClass "SFClass" [] `annLoc` classSS
+ , ideValueOp "<$>" (P.Qualified Nothing (Left "")) 0 Nothing Nothing
+ `annLoc` valueOpSS
+ , ideTypeOp "~>" (P.Qualified Nothing "") 0 Nothing Nothing
+ `annLoc` typeOpSS
+ ])
+ ]
+
+valueSS, synonymSS, typeSS, classSS, valueOpSS, typeOpSS :: P.SourceSpan
+valueSS = ss 3 1
+synonymSS = ss 5 1
+typeSS = ss 7 1
+classSS = ss 8 1
+valueOpSS = ss 12 1
+typeOpSS = ss 13 1
+
+ss :: Int -> Int -> P.SourceSpan
+ss x y = P.SourceSpan "Test.purs" (P.SourcePos x y) (P.SourcePos x y)
diff --git a/tests/Language/PureScript/Ide/StateSpec.hs b/tests/Language/PureScript/Ide/StateSpec.hs
index 5126fe2..a4a546a 100644
--- a/tests/Language/PureScript/Ide/StateSpec.hs
+++ b/tests/Language/PureScript/Ide/StateSpec.hs
@@ -3,6 +3,7 @@
module Language.PureScript.Ide.StateSpec where
import Protolude
+import Control.Lens hiding ((&))
import Language.PureScript.Ide.Types
import Language.PureScript.Ide.State
import qualified Language.PureScript as P
@@ -21,7 +22,7 @@ typeOperator :: Maybe P.Kind -> IdeDeclarationAnn
typeOperator =
d . IdeDeclTypeOperator . IdeTypeOperator (P.OpName ":") (P.Qualified (Just (mn "Test")) (P.ProperName "List")) 2 P.Infix
-testModule :: Module
+testModule :: (P.ModuleName, [IdeDeclarationAnn])
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.kindType))
@@ -34,18 +35,57 @@ d :: IdeDeclaration -> IdeDeclarationAnn
d = IdeDeclarationAnn emptyAnn
mn :: Text -> P.ModuleName
-mn = P.moduleNameFromString . toS
+mn = P.moduleNameFromString
-testState :: Map P.ModuleName [IdeDeclarationAnn]
-testState = Map.fromList
- [ testModule
- ]
+testState :: ModuleMap [IdeDeclarationAnn]
+testState = Map.fromList [testModule]
+
+-- The accessor fields for these data types are not exposed unfortunately
+ef :: P.ExternsFile
+ef = P.ExternsFile
+ -- { efVersion =
+ mempty
+ -- , efModuleName =
+ (mn "InstanceModule")
+ -- , efExports =
+ mempty
+ -- , efImports =
+ mempty
+ -- , efFixities =
+ mempty
+ -- , efTypeFixities =
+ mempty
+ --, efDeclarations =
+ [ P.EDInstance
+ -- { edInstanceClassName =
+ (P.Qualified (Just (mn "ClassModule")) (P.ProperName "MyClass"))
+ -- , edInstanceName =
+ (P.Ident "myClassInstance")
+ -- , edInstanceTypes =
+ mempty
+ -- , edInstanceConstraints =
+ mempty
+ -- }
+ ]
+ -- }
+
+moduleMap :: ModuleMap [IdeDeclarationAnn]
+moduleMap = Map.singleton (mn "ClassModule") [d (IdeDeclTypeClass (IdeTypeClass (P.ProperName "MyClass") []))]
+
+ideInstance :: IdeInstance
+ideInstance = IdeInstance (mn "InstanceModule") (P.Ident "myClassInstance") mempty mempty
spec :: Spec
-spec = describe "resolving operators" $ do
- it "resolves the type for a value operator" $
- resolveOperatorsForModule testState (snd testModule) `shouldSatisfy` elem (valueOperator (Just P.REmpty))
- it "resolves the type for a constructor operator" $
- resolveOperatorsForModule testState (snd testModule) `shouldSatisfy` elem (ctorOperator (Just P.REmpty))
- it "resolves the kind for a type operator" $
- resolveOperatorsForModule testState (snd testModule) `shouldSatisfy` elem (typeOperator (Just P.kindType))
+spec = do
+ describe "resolving operators" $ do
+ it "resolves the type for a value operator" $
+ resolveOperatorsForModule testState (snd testModule) `shouldSatisfy` elem (valueOperator (Just P.REmpty))
+ it "resolves the type for a constructor operator" $
+ resolveOperatorsForModule testState (snd testModule) `shouldSatisfy` elem (ctorOperator (Just P.REmpty))
+ it "resolves the kind for a type operator" $
+ resolveOperatorsForModule testState (snd testModule) `shouldSatisfy` elem (typeOperator (Just P.kindType))
+ describe "resolving instances for type classes" $ do
+ it "resolves an instance for an existing type class" $ do
+ resolveInstances (Map.singleton (mn "InstanceModule") ef) moduleMap
+ `shouldSatisfy`
+ elemOf (ix (mn "ClassModule") . ix 0 . idaDeclaration . _IdeDeclTypeClass . ideTCInstances . folded) ideInstance
diff --git a/tests/Language/PureScript/Ide/Test.hs b/tests/Language/PureScript/Ide/Test.hs
new file mode 100644
index 0000000..5d3841b
--- /dev/null
+++ b/tests/Language/PureScript/Ide/Test.hs
@@ -0,0 +1,135 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PackageImports #-}
+module Language.PureScript.Ide.Test where
+
+import Control.Concurrent.STM
+import "monad-logger" Control.Monad.Logger
+import qualified Data.Map as Map
+import Language.PureScript.Ide
+import Language.PureScript.Ide.Command
+import Language.PureScript.Ide.Error
+import Language.PureScript.Ide.Types
+import Protolude
+import System.Directory
+import System.FilePath
+import System.Process
+
+import qualified Language.PureScript as P
+
+defConfig :: Configuration
+defConfig =
+ Configuration { confLogLevel = LogNone
+ , confOutputPath = "output/"
+ , confGlobs = ["src/*.purs"]
+ }
+
+runIde' :: Configuration -> IdeState -> [Command] -> IO ([Either IdeError Success], IdeState)
+runIde' conf s cs = do
+ stateVar <- newTVarIO s
+ let env' = IdeEnvironment {ideStateVar = stateVar, ideConfiguration = conf}
+ r <- runNoLoggingT (runReaderT (traverse (runExceptT . handleCommand) cs) env')
+ newState <- readTVarIO stateVar
+ pure (r, newState)
+
+runIde :: [Command] -> IO ([Either IdeError Success], IdeState)
+runIde = runIde' defConfig emptyIdeState
+
+s3 :: IdeState -> [(Text, [IdeDeclarationAnn])] -> IdeState
+s3 s ds =
+ s {ideStage3 = stage3}
+ where
+ stage3 = Stage3 (Map.fromList decls) Nothing
+ decls = map (first P.moduleNameFromString) ds
+
+-- | Adding Annotations to IdeDeclarations
+ann :: IdeDeclarationAnn -> Annotation -> IdeDeclarationAnn
+ann (IdeDeclarationAnn _ d) a = IdeDeclarationAnn a d
+
+annLoc :: IdeDeclarationAnn -> P.SourceSpan -> IdeDeclarationAnn
+annLoc (IdeDeclarationAnn a d) loc = IdeDeclarationAnn a {annLocation = Just loc} d
+
+annExp :: IdeDeclarationAnn -> P.ModuleName -> IdeDeclarationAnn
+annExp (IdeDeclarationAnn a d) e = IdeDeclarationAnn a {annExportedFrom = Just e} d
+
+annTyp :: IdeDeclarationAnn -> P.Type -> IdeDeclarationAnn
+annTyp (IdeDeclarationAnn a d) ta = IdeDeclarationAnn a {annTypeAnnotation = Just ta} d
+
+
+ida :: IdeDeclaration -> IdeDeclarationAnn
+ida = IdeDeclarationAnn emptyAnn
+
+-- | Builders for Ide declarations
+ideValue :: Text -> Maybe P.Type -> IdeDeclarationAnn
+ideValue i ty = ida (IdeDeclValue (IdeValue (P.Ident i) (fromMaybe P.tyString ty)))
+
+ideType :: Text -> Maybe P.Kind -> IdeDeclarationAnn
+ideType pn ki = ida (IdeDeclType (IdeType (P.ProperName pn) (fromMaybe P.kindType ki)))
+
+ideSynonym :: Text -> P.Type -> IdeDeclarationAnn
+ideSynonym pn ty = ida (IdeDeclTypeSynonym (IdeTypeSynonym (P.ProperName pn) ty))
+
+ideTypeClass :: Text -> [IdeInstance] -> IdeDeclarationAnn
+ideTypeClass pn instances = ida (IdeDeclTypeClass (IdeTypeClass (P.ProperName pn) instances))
+
+ideDtor :: Text -> Text -> Maybe P.Type -> IdeDeclarationAnn
+ideDtor pn tn ty = ida (IdeDeclDataConstructor (IdeDataConstructor (P.ProperName pn) (P.ProperName tn) (fromMaybe P.tyString ty)))
+
+ideValueOp :: Text -> P.Qualified (Either Text Text) -> Integer -> Maybe P.Associativity -> Maybe P.Type -> IdeDeclarationAnn
+ideValueOp opName ident precedence assoc t =
+ ida (IdeDeclValueOperator
+ (IdeValueOperator
+ (P.OpName opName)
+ (bimap P.Ident P.ProperName <$> ident)
+ (precedence)
+ (fromMaybe P.Infix assoc)
+ t))
+
+ideTypeOp :: Text -> P.Qualified Text -> Integer -> Maybe P.Associativity -> Maybe P.Kind -> IdeDeclarationAnn
+ideTypeOp opName ident precedence assoc k =
+ ida (IdeDeclTypeOperator
+ (IdeTypeOperator
+ (P.OpName opName)
+ (P.ProperName <$> ident)
+ (precedence)
+ (fromMaybe P.Infix assoc)
+ k))
+
+ideKind :: Text -> IdeDeclarationAnn
+ideKind pn = ida (IdeDeclKind (P.ProperName pn))
+
+mn :: Text -> P.ModuleName
+mn = P.moduleNameFromString
+
+inProject :: IO a -> IO a
+inProject f = do
+ cwd' <- getCurrentDirectory
+ setCurrentDirectory ("." </> "tests" </> "support" </> "pscide")
+ a <- f
+ setCurrentDirectory cwd'
+ pure a
+
+compileTestProject :: IO Bool
+compileTestProject = inProject $ do
+ (_, _, _, procHandle) <-
+ createProcess $ (shell $ "psc \"src/**/*.purs\"")
+ r <- tryNTimes 10 (getProcessExitCode procHandle)
+ pure (fromMaybe False (isSuccess <$> r))
+
+isSuccess :: ExitCode -> Bool
+isSuccess ExitSuccess = True
+isSuccess (ExitFailure _) = False
+
+tryNTimes :: Int -> IO (Maybe a) -> IO (Maybe a)
+tryNTimes 0 _ = pure Nothing
+tryNTimes n action = do
+ r <- action
+ case r of
+ Nothing -> do
+ threadDelay 500000
+ tryNTimes (n - 1) action
+ Just a -> pure (Just a)
+
+deleteOutputFolder :: IO ()
+deleteOutputFolder = inProject $
+ whenM (doesDirectoryExist "output") (removeDirectoryRecursive "output")
diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs
index c995336..46ce23d 100644
--- a/tests/TestDocs.hs
+++ b/tests/TestDocs.hs
@@ -9,14 +9,16 @@ import Prelude ()
import Prelude.Compat
import Control.Arrow (first)
+import Control.Monad.IO.Class (liftIO)
-import Data.Version (Version(..))
-import Data.Monoid
-import Data.Maybe (fromMaybe)
-import Data.List ((\\))
import Data.Foldable
+import Data.List ((\\))
+import Data.Maybe (fromMaybe)
+import Data.Monoid
import Data.Text (Text)
import qualified Data.Text as T
+import Data.Time.Clock (getCurrentTime)
+import Data.Version (Version(..))
import System.Exit
import qualified Language.PureScript as P
@@ -32,6 +34,7 @@ import TestUtils
publishOpts :: Publish.PublishOptions
publishOpts = Publish.defaultPublishOptions
{ Publish.publishGetVersion = return testVersion
+ , Publish.publishGetTagTime = const (liftIO getCurrentTime)
, Publish.publishWorkingTreeDirty = return ()
}
where testVersion = ("v999.0.0", Version [999,0,0] [])
@@ -333,7 +336,6 @@ testCases =
[ ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "explicit" (ShowFn (hasTypeVar "something"))
, ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "anInt" (ShowFn (P.tyInt ==))
, ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "aNumber" (ShowFn (P.tyNumber ==))
- , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "nestedForAll" (renderedType "forall c. (forall a b. c)")
])
, ("ConstrainedArgument",
diff --git a/tests/TestPscIde.hs b/tests/TestPscIde.hs
index bf9e62c..97ff41f 100644
--- a/tests/TestPscIde.hs
+++ b/tests/TestPscIde.hs
@@ -1,15 +1,13 @@
module TestPscIde where
import Control.Monad (unless)
-import Language.PureScript.Ide.Integration
import qualified PscIdeSpec
+import Language.PureScript.Ide.Test
import Test.Hspec
main :: IO ()
main = do
deleteOutputFolder
s <- compileTestProject
- unless s $ fail "Failed to compile .purs sources"
-
- quitServer -- shuts down any left over server (primarily happens during development)
- withServer (hspec PscIdeSpec.spec)
+ unless s (fail "Failed to compile .purs sources")
+ hspec PscIdeSpec.spec
diff --git a/tests/TestPscPublish.hs b/tests/TestPscPublish.hs
index 14bd037..a97ca1f 100644
--- a/tests/TestPscPublish.hs
+++ b/tests/TestPscPublish.hs
@@ -4,8 +4,10 @@
module TestPscPublish where
+import Control.Monad.IO.Class (liftIO)
import System.Exit (exitFailure)
import Data.ByteString.Lazy (ByteString)
+import Data.Time.Clock (getCurrentTime)
import qualified Data.Aeson as A
import Data.Version
@@ -38,6 +40,7 @@ roundTrip pkg =
testRunOptions :: PublishOptions
testRunOptions = defaultPublishOptions
{ publishGetVersion = return testVersion
+ , publishGetTagTime = const (liftIO getCurrentTime)
, publishWorkingTreeDirty = return ()
}
where testVersion = ("v999.0.0", Version [999,0,0] [])
@@ -58,13 +61,4 @@ testPackage dir = pushd dir $ do
print other
exitFailure
where
- preparePackageError e@(UserError BowerJSONNotFound) = do
- Publish.printErrorToStdout e
- putStrLn ""
- putStrLn "=========================================="
- putStrLn "Did you forget to update the submodules?"
- putStrLn "$ git submodule sync; git submodule update"
- putStrLn "=========================================="
- putStrLn ""
- exitFailure
preparePackageError e = Publish.printErrorToStdout e >> exitFailure
diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs
index 783f0c7..ef9bbb5 100644
--- a/tests/TestUtils.hs
+++ b/tests/TestUtils.hs
@@ -78,6 +78,7 @@ supportModules =
, "Data.Array"
, "Data.Array.Partial"
, "Data.Array.ST"
+ , "Data.Array.ST.Iterator"
, "Data.Bifoldable"
, "Data.Bifunctor"
, "Data.Bifunctor.Clown"
diff --git a/tests/support/pscide/src/SourceFileSpec.purs b/tests/support/pscide/src/SourceFileSpec.purs
deleted file mode 100644
index e3484fa..0000000
--- a/tests/support/pscide/src/SourceFileSpec.purs
+++ /dev/null
@@ -1,10 +0,0 @@
-module SourceFileSpec where
-
-sfValue = "sfValue"
-
-type SFType = String
-
-data SFData = SFOne | SFTwo | SFThree
-
-class SFClass a where
- sfShow :: a -> String