summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2016-02-29 05:31:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2016-02-29 05:31:00 (GMT)
commitfd637969029015423133d358a637b35d9e3122cf (patch)
tree63c3ba451a1f9a17dd9b6eaed0f4a6734c72076b
parent43cd0c9c2258e12e695109d47d435ca0634cf3b0 (diff)
version 0.8.1.00.8.1.0
-rw-r--r--CONTRIBUTORS.md15
-rw-r--r--LICENSE34
-rw-r--r--examples/docs/src/ExplicitTypeSignatures.purs16
-rw-r--r--examples/failing/AnonArgument1.purs5
-rw-r--r--examples/failing/AnonArgument2.purs7
-rw-r--r--examples/failing/AnonArgument3.purs5
-rw-r--r--examples/failing/ConflictingExports2.purs13
-rw-r--r--examples/failing/ConflictingImports2.purs12
-rw-r--r--examples/failing/DctorOperatorAliasExport.purs6
-rw-r--r--examples/failing/InvalidOperatorInBinder.purs12
-rw-r--r--examples/passing/DctorOperatorAlias.purs35
-rw-r--r--examples/passing/Deriving.purs31
-rw-r--r--examples/passing/ExplicitOperatorSections.purs14
-rw-r--r--examples/passing/ResolvableScopeConflict.purs25
-rw-r--r--examples/passing/ResolvableScopeConflict2.purs22
-rw-r--r--examples/passing/ResolvableScopeConflict3.purs15
-rw-r--r--psc-docs/Main.hs12
-rw-r--r--psc-ide-client/Main.hs57
-rw-r--r--psc-ide-server/Main.hs135
-rw-r--r--psc/Main.hs6
-rw-r--r--psci/IO.hs21
-rw-r--r--psci/PSCi.hs576
-rw-r--r--psci/PSCi/Completion.hs (renamed from psci/Completion.hs)6
-rw-r--r--psci/PSCi/Directive.hs (renamed from psci/Directive.hs)8
-rw-r--r--psci/PSCi/IO.hs68
-rw-r--r--psci/PSCi/Message.hs53
-rw-r--r--psci/PSCi/Module.hs106
-rw-r--r--psci/PSCi/Option.hs57
-rw-r--r--psci/PSCi/Parser.hs (renamed from psci/Parser.hs)6
-rw-r--r--psci/PSCi/Printer.hs131
-rw-r--r--psci/PSCi/Types.hs (renamed from psci/Types.hs)5
-rw-r--r--purescript.cabal139
-rw-r--r--src/Language/PureScript/AST/Binders.hs20
-rw-r--r--src/Language/PureScript/AST/Declarations.hs19
-rw-r--r--src/Language/PureScript/AST/Traversals.hs34
-rw-r--r--src/Language/PureScript/CodeGen/JS.hs263
-rw-r--r--src/Language/PureScript/CodeGen/JS/AST.hs265
-rw-r--r--src/Language/PureScript/CodeGen/JS/Optimizer.hs10
-rw-r--r--src/Language/PureScript/CodeGen/JS/Optimizer/Blocks.hs8
-rw-r--r--src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs36
-rw-r--r--src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs100
-rw-r--r--src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs68
-rw-r--r--src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs64
-rw-r--r--src/Language/PureScript/CodeGen/JS/Optimizer/Unused.hs6
-rw-r--r--src/Language/PureScript/Constants.hs3
-rw-r--r--src/Language/PureScript/CoreFn/Binders.hs11
-rw-r--r--src/Language/PureScript/CoreFn/Desugar.hs71
-rw-r--r--src/Language/PureScript/CoreFn/Expr.hs8
-rw-r--r--src/Language/PureScript/CoreFn/Meta.hs6
-rw-r--r--src/Language/PureScript/CoreFn/Module.hs2
-rw-r--r--src/Language/PureScript/CoreFn/Traversals.hs4
-rw-r--r--src/Language/PureScript/Docs.hs2
-rw-r--r--src/Language/PureScript/Docs/AsMarkdown.hs16
-rw-r--r--src/Language/PureScript/Docs/Convert.hs169
-rw-r--r--src/Language/PureScript/Docs/Convert/ReExports.hs6
-rw-r--r--src/Language/PureScript/Docs/Convert/Single.hs10
-rw-r--r--src/Language/PureScript/Docs/ParseAndBookmark.hs (renamed from src/Language/PureScript/Docs/ParseAndDesugar.hs)69
-rw-r--r--src/Language/PureScript/Docs/Render.hs6
-rw-r--r--src/Language/PureScript/Docs/Types.hs13
-rw-r--r--src/Language/PureScript/Errors.hs95
-rw-r--r--src/Language/PureScript/Externs.hs5
-rw-r--r--src/Language/PureScript/Ide.hs199
-rw-r--r--src/Language/PureScript/Ide/CaseSplit.hs157
-rw-r--r--src/Language/PureScript/Ide/CodecJSON.hs13
-rw-r--r--src/Language/PureScript/Ide/Command.hs101
-rw-r--r--src/Language/PureScript/Ide/Completion.hs35
-rw-r--r--src/Language/PureScript/Ide/Error.hs43
-rw-r--r--src/Language/PureScript/Ide/Externs.hs102
-rw-r--r--src/Language/PureScript/Ide/Filter.hs110
-rw-r--r--src/Language/PureScript/Ide/Matcher.hs100
-rw-r--r--src/Language/PureScript/Ide/Pursuit.hs65
-rw-r--r--src/Language/PureScript/Ide/Reexports.hs73
-rw-r--r--src/Language/PureScript/Ide/SourceFile.hs106
-rw-r--r--src/Language/PureScript/Ide/State.hs80
-rw-r--r--src/Language/PureScript/Ide/Types.hs240
-rw-r--r--src/Language/PureScript/Ide/Watcher.hs40
-rw-r--r--src/Language/PureScript/Linter.hs1
-rw-r--r--src/Language/PureScript/Linter/Imports.hs19
-rw-r--r--src/Language/PureScript/Make.hs47
-rw-r--r--src/Language/PureScript/ModuleDependencies.hs3
-rw-r--r--src/Language/PureScript/Options.hs5
-rw-r--r--src/Language/PureScript/Parser/Declarations.hs57
-rw-r--r--src/Language/PureScript/Pretty.hs3
-rw-r--r--src/Language/PureScript/Pretty/Common.hs105
-rw-r--r--src/Language/PureScript/Pretty/JS.hs223
-rw-r--r--src/Language/PureScript/Pretty/Values.hs6
-rw-r--r--src/Language/PureScript/Publish.hs8
-rw-r--r--src/Language/PureScript/Renamer.hs18
-rw-r--r--src/Language/PureScript/Sugar/Names.hs16
-rw-r--r--src/Language/PureScript/Sugar/Names/Env.hs70
-rw-r--r--src/Language/PureScript/Sugar/Names/Exports.hs10
-rw-r--r--src/Language/PureScript/Sugar/Names/Imports.hs63
-rw-r--r--src/Language/PureScript/Sugar/ObjectWildcards.hs51
-rw-r--r--src/Language/PureScript/Sugar/Operators.hs175
-rw-r--r--src/Language/PureScript/Sugar/Operators/Binders.hs43
-rw-r--r--src/Language/PureScript/Sugar/Operators/Common.hs53
-rw-r--r--src/Language/PureScript/Sugar/Operators/Expr.hs52
-rw-r--r--src/Language/PureScript/Sugar/TypeClasses/Deriving.hs423
-rw-r--r--src/Language/PureScript/TypeChecker.hs67
-rw-r--r--src/Language/PureScript/TypeChecker/Types.hs15
-rw-r--r--stack-lts-2.yaml8
-rw-r--r--stack-lts-3.yaml5
-rw-r--r--stack-nightly.yaml4
-rw-r--r--stack.yaml6
-rw-r--r--tests/Main.hs215
-rw-r--r--tests/PscIdeSpec.hs1
-rw-r--r--tests/TestCompiler.hs194
-rw-r--r--tests/TestDocs.hs63
-rw-r--r--tests/TestPscIde.hs7
-rw-r--r--tests/TestPscPublish.hs17
-rw-r--r--tests/TestPsci.hs (renamed from psci/tests/Main.hs)15
-rw-r--r--tests/TestUtils.hs (renamed from tests/common/TestsSetup.hs)26
-rw-r--r--tests/support/flattened/Control-Monad-Eff-Class.purs24
-rw-r--r--tests/support/flattened/Control-Monad-Eff-Console.js18
-rw-r--r--tests/support/flattened/Control-Monad-Eff-Console.purs18
-rw-r--r--tests/support/flattened/Control-Monad-Eff-Unsafe.js8
-rw-r--r--tests/support/flattened/Control-Monad-Eff-Unsafe.purs10
-rw-r--r--tests/support/flattened/Control-Monad-Eff.js62
-rw-r--r--tests/support/flattened/Control-Monad-Eff.purs67
-rw-r--r--tests/support/flattened/Control-Monad-ST.js38
-rw-r--r--tests/support/flattened/Control-Monad-ST.purs42
-rw-r--r--tests/support/flattened/Data-Function.js233
-rw-r--r--tests/support/flattened/Data-Function.purs113
-rw-r--r--tests/support/flattened/Prelude.js228
-rw-r--r--tests/support/flattened/Prelude.purs872
-rw-r--r--tests/support/flattened/Test-Assert.js27
-rw-r--r--tests/support/flattened/Test-Assert.purs46
-rw-r--r--tests/support/prelude/LICENSE20
-rw-r--r--tests/support/prelude/bower.json23
-rw-r--r--tests/support/prelude/src/Prelude.js228
-rw-r--r--tests/support/prelude/src/Prelude.purs872
-rw-r--r--tests/support/psci/Sample.purs (renamed from psci/tests/data/Sample.purs)0
132 files changed, 7717 insertions, 1832 deletions
diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md
index b4c76eb..46867ac 100644
--- a/CONTRIBUTORS.md
+++ b/CONTRIBUTORS.md
@@ -13,7 +13,10 @@ This file lists the contributors to the PureScript compiler project, and the ter
- [@bergmark](https://github.com/bergmark) (Adam Bergmark) - My existing contributions and all future contributions until further notice are Copyright Adam Bergmark, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license.
- [@Bogdanp](https://github.com/Bogdanp) (Bogdan Paul Popa) My existing contributions and all future contributions until further notice are Copyright Bogdan Paul Popa, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
- [@cdepillabout](https://github.com/cdepillabout) (Dennis Gosnell) My existing contributions and all future contributions until further notice are Copyright Dennis Gosnell, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
+- [@chrissmoak](https://github.com/chrissmoak) (Chris Smoak) My existing contributions to the PureScript compiler and all future contributions to the PureScript compiler until further notice, are Copyright Chris Smoak, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
+- [@codedmart](https://github.com/codedmart) (Brandon Martin) My existing contributions and all future contributions until further notice are Copyright Brandon Martin, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
- [@davidchambers](https://github.com/davidchambers) (David Chambers) My existing contributions and all future contributions until further notice are Copyright David Chambers, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
+- [@DavidLindbom](https://github.com/DavidLindbom) (David Lindbom) My existing contributions and all future contributions until further notice are Copyright David Lindbom, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
- [@dckc](https://github.com/dckc) (Dan Connolly) My existing contributions and all future contributions until further notice are Copyright Dan Connolly, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
- [@dylex](https://github.com/dylex) (Dylan Simon) My existing and all future contributions to the PureScript compiler until further notice are Copyright Dylan Simon, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
- [@eamelink](https://github.com/eamelink) (Erik Bakker) - My existing contributions and all future contributions until further notice are Copyright Erik Bakker, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license.
@@ -22,6 +25,7 @@ This file lists the contributors to the PureScript compiler project, and the ter
- [@etrepum](https://github.com/etrepum) (Bob Ippolito) My existing contributions and all future contributions until further notice are Copyright Bob Ippolito, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
- [@garyb](https://github.com/garyb) (Gary Burgess) My existing contributions and all future contributions until further notice are Copyright Gary Burgess, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
- [@hdgarrood](https://github.com/hdgarrood) (Harry Garrood) My existing contributions and all future contributions until further notice are Copyright Harry Garrood, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
+- [@izgzhen](https://github.com/izgzhen) (Zhen Zhang) My existing contributions and all future contributions until further notice are Copyright Zhen Zhang, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
- [@jacereda](https://github.com/jacereda) (Jorge Acereda) My existing contributions and all future contributions until further notice are Copyright Jorge Acereda, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
- [@japesinator](https://github.com/japesinator) (JP Smith) My existing contributions and all future contributions until further notice are Copyright JP Smith, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
- [@joneshf](https://github.com/joneshf) (Hardy Jones) - My existing contributions and all future contributions until further notice are Copyright Hardy Jones, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license.
@@ -42,6 +46,7 @@ This file lists the contributors to the PureScript compiler project, and the ter
- [@nwolverson](https://github.com/nwolverson) (Nicholas Wolverson) My existing contributions and all future contributions until further notice are Copyright Nicholas Wolverson, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
- [@osa1](https://github.com/osa1) (Ömer Sinan Ağacan) - My existing contributions and all future contributions until further notice are Copyright Ömer Sinan Ağacan, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license.
- [@paf31](https://github.com/paf31) (Phil Freeman) My existing contributions and all future contributions until further notice are Copyright Phil Freeman, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
+- [@passy](https://github.com/passy) (Pascal Hartig) My existing contributions and all future contributions until further notice are Copyright Pascal Hartig, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
- [@paulyoung](https://github.com/paulyoung) (Paul Young) My existing contributions and all future contributions until further notice are Copyright Paul Young, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
- [@pelotom](https://github.com/pelotom) (Thomas Crockett) My existing contributions and all future contributions until further notice are Copyright Thomas Crockett, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
- [@phadej](https://github.com/phadej) (Oleg Grenrus) My existing contributions and all future contributions until further notice are Copyright Oleg Grenrus, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
@@ -51,20 +56,16 @@ This file lists the contributors to the PureScript compiler project, and the ter
- [@robdaemon](https://github.com/robdaemon) (Robert Roland) My existing contributions and all future contributions until further notice are Copyright Robert Roland, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
- [@RossMeikleham](https://github.com/RossMeikleham) (Ross Meikleham) My existing contributions and all future contributions until further notice are Copyright Ross Meikleham, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
- [@sebastiaanvisser](https://github.com/sebastiaanvisser) (Sebastiaan Visser) - My existing contributions and all future contributions until further notice are Copyright Sebastiaan Visser, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license.
+- [@senju](https://github.com/senju) - My existing contributions and all future contributions until further notice are Copyright senju, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
- [@sharkdp](https://github.com/sharkdp) (David Peter) My existing contributions and all future contributions until further notice are Copyright David Peter, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
+- [@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).
- [@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).
- [@trofi](https://github.com/trofi) (Sergei Trofimovich) My existing contributions and all future contributions until further notice are Copyright Sergei Trofimovich, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
- [@utkarshkukreti](https://github.com/utkarshkukreti) (Utkarsh Kukreti) My existing contributions and all future contributions until further notice are Copyright Utkarsh Kukreti, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
- [@vkorablin](https://github.com/vkorablin) (Vladimir Korablin) - My existing contributions and all future contributions until further notice are Copyright Vladimir Korablin, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license.
- [@zudov](https://github.com/zudov) (Konstantin Zudov) My existing contributions and all future contributions until further notice are Copyright Konstantin Zudov, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
-- [@senju](https://github.com/senju) - My existing contributions and all future contributions until further notice are Copyright senju, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
-<http://opensource.org/licenses/MIT>.
-- [@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).
-- [@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).
-- [@codedmart](https://github.com/codedmart) (Brandon Martin) My existing contributions and all future contributions until further notice are Copyright Brandon Martin, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
-- [@passy](https://github.com/passy) (Pascal Hartig) My existing contributions and all future contributions until further notice are Copyright Pascal Hartig, 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).
-- [@DavidLindbom](https://github.com/DavidLindbom) (David Lindbom) My existing contributions and all future contributions until further notice are Copyright David Lindbom, 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 00e252b..1c4fc06 100644
--- a/LICENSE
+++ b/LICENSE
@@ -63,6 +63,7 @@ PureScript uses the following Haskell library packages. Their license files foll
safe
scientific
semigroups
+ sourcemap
split
stm
syb
@@ -1589,6 +1590,39 @@ semigroups LICENSE file:
ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.
+sourcemap LICENSE file:
+
+ Copyright (c) 2012, Chris Done
+
+ 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 Chris Done 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.
+
split LICENSE file:
Copyright (c) 2008 Brent Yorgey, Louis Wasserman
diff --git a/examples/docs/src/ExplicitTypeSignatures.purs b/examples/docs/src/ExplicitTypeSignatures.purs
new file mode 100644
index 0000000..396ca14
--- /dev/null
+++ b/examples/docs/src/ExplicitTypeSignatures.purs
@@ -0,0 +1,16 @@
+
+module ExplicitTypeSignatures where
+
+-- This should use the explicit type signature so that the type variable name
+-- is preserved.
+explicit :: forall something. something -> something
+explicit x
+ | true = x
+ | false = x
+
+-- This should use the inferred type.
+anInt :: _
+anInt = 0
+
+-- This should infer a type.
+aNumber = 1.0
diff --git a/examples/failing/AnonArgument1.purs b/examples/failing/AnonArgument1.purs
new file mode 100644
index 0000000..74759b0
--- /dev/null
+++ b/examples/failing/AnonArgument1.purs
@@ -0,0 +1,5 @@
+-- @shouldFailWith IncorrectAnonymousArgument
+module Main where
+
+test :: Int -> Int
+test = _
diff --git a/examples/failing/AnonArgument2.purs b/examples/failing/AnonArgument2.purs
new file mode 100644
index 0000000..746a008
--- /dev/null
+++ b/examples/failing/AnonArgument2.purs
@@ -0,0 +1,7 @@
+-- @shouldFailWith IncorrectAnonymousArgument
+module Main where
+
+import Prelude
+
+test :: Int -> Int
+test = 1 + 2 * _
diff --git a/examples/failing/AnonArgument3.purs b/examples/failing/AnonArgument3.purs
new file mode 100644
index 0000000..34f9814
--- /dev/null
+++ b/examples/failing/AnonArgument3.purs
@@ -0,0 +1,5 @@
+-- @shouldFailWith IncorrectAnonymousArgument
+module Main where
+
+test :: Int -> Int
+test = 1 + _
diff --git a/examples/failing/ConflictingExports2.purs b/examples/failing/ConflictingExports2.purs
deleted file mode 100644
index 352548c..0000000
--- a/examples/failing/ConflictingExports2.purs
+++ /dev/null
@@ -1,13 +0,0 @@
--- @shouldFailWith ScopeConflict
-module A where
-
- thing :: Int
- thing = 1
-
--- Fails here because re-exporting forces any scope conflicts to be resolved
-module Main (thing, module A) where
-
- import A
-
- thing :: Int
- thing = 2
diff --git a/examples/failing/ConflictingImports2.purs b/examples/failing/ConflictingImports2.purs
index ef56fdd..02a21b6 100644
--- a/examples/failing/ConflictingImports2.purs
+++ b/examples/failing/ConflictingImports2.purs
@@ -4,13 +4,17 @@ module A where
thing :: Int
thing = 1
-module Main where
-
- import A
+module B where
thing :: Int
thing = 2
- -- Error due to referencing `thing` which is in scope as A.thing and Main.thing
+module Main where
+
+ import A (thing)
+ import B (thing)
+
+ -- Error due to referencing `thing` which is explicitly in scope as A.thing
+ -- and B.thing
what :: Int
what = thing
diff --git a/examples/failing/DctorOperatorAliasExport.purs b/examples/failing/DctorOperatorAliasExport.purs
new file mode 100644
index 0000000..0f46596
--- /dev/null
+++ b/examples/failing/DctorOperatorAliasExport.purs
@@ -0,0 +1,6 @@
+-- @shouldFailWith TransitiveDctorExportError
+module Data.List (List, (:)) where
+
+ data List a = Cons a (List a) | Nil
+
+ infixr 6 Cons as :
diff --git a/examples/failing/InvalidOperatorInBinder.purs b/examples/failing/InvalidOperatorInBinder.purs
new file mode 100644
index 0000000..5cf6fd8
--- /dev/null
+++ b/examples/failing/InvalidOperatorInBinder.purs
@@ -0,0 +1,12 @@
+-- @shouldFailWith InvalidOperatorInBinder
+module Main where
+
+data List a = Cons a (List a) | Nil
+
+cons ∷ ∀ a. a → List a → List a
+cons = Cons
+
+infixl 6 cons as :
+
+get ∷ ∀ a. List a → a
+get (_ : x : _) = x
diff --git a/examples/passing/DctorOperatorAlias.purs b/examples/passing/DctorOperatorAlias.purs
new file mode 100644
index 0000000..31b0027
--- /dev/null
+++ b/examples/passing/DctorOperatorAlias.purs
@@ -0,0 +1,35 @@
+module Data.List where
+
+ data List a = Cons a (List a) | Nil
+
+ infixr 6 Cons as :
+
+module Main where
+
+ import Prelude (Unit, bind, (==))
+ import Control.Monad.Eff (Eff)
+ import Control.Monad.Eff.Console (CONSOLE, log)
+ import Test.Assert (ASSERT, assert')
+ import Data.List (List(..), (:))
+
+ infixl 6 Cons as !
+
+ get1 ∷ ∀ a. a → List a → a
+ get1 y xs = case xs of
+ _ : x : _ → x
+ _ → y
+
+ get2 ∷ ∀ a. a → List a → a
+ get2 _ (_ : x : _) = x
+ get2 y _ = y
+
+ get3 ∷ ∀ a. a → List a → a
+ get3 _ (_ ! (x ! _)) = x
+ get3 y _ = y
+
+ main ∷ Eff (assert ∷ ASSERT, console ∷ CONSOLE) Unit
+ main = do
+ assert' "Incorrect result!" (get1 0 (1 : 2 : 3 : Nil) == 2)
+ assert' "Incorrect result!" (get2 0 (1 ! (2 ! (3 ! Nil))) == 2)
+ assert' "Incorrect result!" (get3 0.0 (1.0 : 2.0 : (3.0 ! Nil)) == 2.0)
+ log "Done"
diff --git a/examples/passing/Deriving.purs b/examples/passing/Deriving.purs
new file mode 100644
index 0000000..fb1b65e
--- /dev/null
+++ b/examples/passing/Deriving.purs
@@ -0,0 +1,31 @@
+module Main where
+
+import Prelude
+import Test.Assert
+
+data V
+
+derive instance eqV :: Eq V
+
+derive instance ordV :: Ord V
+
+data X = X Int | Y String
+
+derive instance eqX :: Eq X
+
+derive instance ordX :: Ord X
+
+newtype Z = Z { left :: X, right :: X }
+
+derive instance eqZ :: Eq Z
+
+main = do
+ assert $ X 0 == X 0
+ assert $ X 0 /= X 1
+ assert $ Y "Foo" == Y "Foo"
+ assert $ Y "Foo" /= Y "Bar"
+ assert $ X 0 < X 1
+ assert $ X 0 < Y "Foo"
+ assert $ Y "Bar" < Y "Baz"
+ assert $ z == z where
+ z = Z { left: X 0, right: Y "Foo" }
diff --git a/examples/passing/ExplicitOperatorSections.purs b/examples/passing/ExplicitOperatorSections.purs
new file mode 100644
index 0000000..b8e6fbf
--- /dev/null
+++ b/examples/passing/ExplicitOperatorSections.purs
@@ -0,0 +1,14 @@
+module Main where
+
+import Prelude
+
+subtractOne :: Int -> Int
+subtractOne = (_ - 1)
+
+addOne :: Int -> Int
+addOne = (1 + _)
+
+named :: Int -> Int
+named = (_ `sub` 1)
+
+main = Control.Monad.Eff.Console.log "Done"
diff --git a/examples/passing/ResolvableScopeConflict.purs b/examples/passing/ResolvableScopeConflict.purs
new file mode 100644
index 0000000..c187806
--- /dev/null
+++ b/examples/passing/ResolvableScopeConflict.purs
@@ -0,0 +1,25 @@
+module A where
+
+ thing :: Int
+ thing = 1
+
+module B where
+
+ thing :: Int
+ thing = 2
+
+ zing :: Int
+ zing = 3
+
+module Main where
+
+ import A (thing)
+ import B
+
+ -- Not an error as although we have `thing` in scope from both A and B, it is
+ -- imported explicitly from A, giving it a resolvable solution.
+ what :: Boolean -> Int
+ what true = thing
+ what false = zing
+
+ main = Control.Monad.Eff.Console.log "Done"
diff --git a/examples/passing/ResolvableScopeConflict2.purs b/examples/passing/ResolvableScopeConflict2.purs
new file mode 100644
index 0000000..971e51b
--- /dev/null
+++ b/examples/passing/ResolvableScopeConflict2.purs
@@ -0,0 +1,22 @@
+module A where
+
+ thing :: Int
+ thing = 2
+
+ zing :: Int
+ zing = 3
+
+module Main where
+
+ import A
+
+ thing :: Int
+ thing = 1
+
+ -- Not an error as although we have `thing` in scope from both Main and A,
+ -- as the local declaration takes precedence over the implicit import
+ what :: Boolean -> Int
+ what true = thing
+ what false = zing
+
+ main = Control.Monad.Eff.Console.log "Done"
diff --git a/examples/passing/ResolvableScopeConflict3.purs b/examples/passing/ResolvableScopeConflict3.purs
new file mode 100644
index 0000000..86a996b
--- /dev/null
+++ b/examples/passing/ResolvableScopeConflict3.purs
@@ -0,0 +1,15 @@
+module A where
+
+ thing :: Int
+ thing = 1
+
+module Main (thing, main, module A) where
+
+ import A
+
+ thing :: Int
+ thing = 2
+
+ main = Control.Monad.Eff.Console.log "Done"
+
+
diff --git a/psc-docs/Main.hs b/psc-docs/Main.hs
index f979587..6374dff 100644
--- a/psc-docs/Main.hs
+++ b/psc-docs/Main.hs
@@ -69,19 +69,19 @@ docgen (PSCDocsOptions fmt inputGlob output) = do
Etags -> dumpTags input dumpEtags
Ctags -> dumpTags input dumpCtags
Markdown -> do
- ms <- runExceptT (D.parseAndDesugar input []
- >>= ((\(ms, _, env) -> D.convertModulesInPackage env ms)))
+ ms <- runExceptT (D.parseAndBookmark input []
+ >>= (fst >>> D.convertModulesInPackage))
>>= successOrExit
case output of
EverythingToStdOut ->
putStrLn (D.runDocs (D.modulesAsMarkdown ms))
ToStdOut names -> do
- let (ms', missing) = takeByName ms (map P.runModuleName names)
+ let (ms', missing) = takeByName ms names
guardMissing missing
putStrLn (D.runDocs (D.modulesAsMarkdown ms'))
ToFiles names -> do
- let (ms', missing) = takeByName' ms (map (first P.runModuleName) names)
+ let (ms', missing) = takeByName' ms names
guardMissing missing
let ms'' = groupBy ((==) `on` fst) . sortBy (compare `on` fst) $ map swap ms'
@@ -93,12 +93,12 @@ docgen (PSCDocsOptions fmt inputGlob output) = do
where
guardMissing [] = return ()
guardMissing [mn] = do
- hPutStrLn stderr ("psc-docs: error: unknown module \"" ++ mn ++ "\"")
+ hPutStrLn stderr ("psc-docs: error: unknown module \"" ++ P.runModuleName mn ++ "\"")
exitFailure
guardMissing mns = do
hPutStrLn stderr "psc-docs: error: unknown modules:"
forM_ mns $ \mn ->
- hPutStrLn stderr (" * " ++ mn)
+ hPutStrLn stderr (" * " ++ P.runModuleName mn)
exitFailure
successOrExit :: Either P.MultipleErrors a -> IO a
diff --git a/psc-ide-client/Main.hs b/psc-ide-client/Main.hs
new file mode 100644
index 0000000..7007815
--- /dev/null
+++ b/psc-ide-client/Main.hs
@@ -0,0 +1,57 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Main where
+
+import Prelude ()
+import Prelude.Compat
+
+import Control.Exception
+import Data.Maybe (fromMaybe)
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.IO as T
+import Data.Version (showVersion)
+import Network
+import Options.Applicative
+import System.Exit
+import System.IO
+
+import qualified Paths_purescript as Paths
+
+data Options = Options
+ { optionsPort :: Maybe Int
+ }
+
+main :: IO ()
+main = do
+ Options port <- execParser opts
+ let port' = PortNumber . fromIntegral $ fromMaybe 4242 port
+ client port'
+ where
+ parser =
+ Options <$>
+ optional (option auto (long "port" <> short 'p'))
+ opts = info (version <*> parser) mempty
+ version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> help "Show the version number" <> hidden
+
+client :: PortID -> IO ()
+client port = do
+ h <-
+ connectTo "localhost" port `catch`
+ (\(SomeException e) ->
+ putStrLn
+ ("Couldn't connect to psc-ide-server on port: " ++
+ show port ++ " Error: " ++ show e) >>
+ exitFailure)
+ cmd <- T.getLine
+ -- Temporary fix for emacs windows bug
+ let cleanedCmd = removeSurroundingTicks cmd
+ --
+ T.hPutStrLn h cleanedCmd
+ res <- T.hGetLine h
+ putStrLn (T.unpack res)
+ hFlush stdout
+ hClose h
+
+-- TODO: Fix this in the emacs plugin by using a real process over shellcommands
+removeSurroundingTicks :: Text -> Text
+removeSurroundingTicks = T.dropWhile (== '\'') . T.dropWhileEnd (== '\'')
diff --git a/psc-ide-server/Main.hs b/psc-ide-server/Main.hs
new file mode 100644
index 0000000..6188c49
--- /dev/null
+++ b/psc-ide-server/Main.hs
@@ -0,0 +1,135 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PackageImports #-}
+{-# LANGUAGE TemplateHaskell #-}
+module Main where
+
+import Prelude ()
+import Prelude.Compat
+
+import Control.Concurrent (forkFinally)
+import Control.Concurrent.STM
+import Control.Exception (bracketOnError)
+import Control.Monad
+import "monad-logger" Control.Monad.Logger
+import Control.Monad.Reader
+import Control.Monad.Trans.Except
+import qualified Data.Text as T
+import qualified Data.Text.IO as T
+import Data.Version (showVersion)
+import Language.PureScript.Ide
+import Language.PureScript.Ide.CodecJSON
+import Language.PureScript.Ide.Error
+import Language.PureScript.Ide.Types
+import Language.PureScript.Ide.Watcher
+import Network hiding (socketPort)
+import Network.BSD (getProtocolNumber)
+import Network.Socket hiding (PortNumber, Type,
+ accept, sClose)
+import Options.Applicative
+import System.Directory
+import System.FilePath
+import System.IO
+
+import qualified Paths_purescript as Paths
+
+-- "Borrowed" from the Idris Compiler
+-- Copied from upstream impl of listenOn
+-- bound to localhost interface instead of iNADDR_ANY
+listenOnLocalhost :: PortID -> IO Socket
+listenOnLocalhost (PortNumber port) = do
+ proto <- getProtocolNumber "tcp"
+ localhost <- inet_addr "127.0.0.1"
+ bracketOnError
+ (socket AF_INET Stream proto)
+ sClose
+ (\sock -> do
+ setSocketOption sock ReuseAddr 1
+ bindSocket sock (SockAddrInet port localhost)
+ listen sock maxListenQueue
+ pure sock)
+listenOnLocalhost _ = error "Wrong Porttype"
+
+data Options = Options
+ { optionsDirectory :: Maybe FilePath
+ , optionsOutputPath :: FilePath
+ , optionsPort :: PortID
+ , optionsDebug :: Bool
+ }
+
+main :: IO ()
+main = do
+ Options dir outputPath port debug <- execParser opts
+ maybe (pure ()) setCurrentDirectory dir
+ serverState <- newTVarIO emptyPscIdeState
+ cwd <- getCurrentDirectory
+ _ <- forkFinally (watcher serverState (cwd </> outputPath)) print
+ let conf =
+ Configuration
+ {
+ confDebug = debug
+ , confOutputPath = outputPath
+ }
+ let env =
+ PscIdeEnvironment
+ {
+ envStateVar = serverState
+ , envConfiguration = conf
+ }
+ startServer port env
+ where
+ parser =
+ Options <$>
+ optional (strOption (long "directory" <> short 'd')) <*>
+ strOption (long "output-directory" <> value "output/") <*>
+ (PortNumber . fromIntegral <$>
+ option auto (long "port" <> short 'p' <> value (4242 :: Integer))) <*>
+ switch (long "debug")
+ opts = info (version <*> parser) mempty
+ version = abortOption
+ (InfoMsg (showVersion Paths.version))
+ (long "version" <> help "Show the version number")
+
+startServer :: PortID -> PscIdeEnvironment -> IO ()
+startServer port env = withSocketsDo $ do
+ sock <- listenOnLocalhost port
+ runLogger (runReaderT (forever (loop sock)) env)
+ where
+ runLogger = runStdoutLoggingT . filterLogger (\_ _ -> confDebug (envConfiguration env))
+
+ loop :: (PscIde m, MonadLogger m) => Socket -> m ()
+ loop sock = do
+ (cmd,h) <- acceptCommand sock
+ case decodeT cmd of
+ Just cmd' -> do
+ result <- runExceptT (handleCommand cmd')
+ $(logDebug) ("Answer was: " <> T.pack (show result))
+ liftIO (hFlush stdout)
+ case result of
+ -- What function can I use to clean this up?
+ Right r -> liftIO $ T.hPutStrLn h (encodeT r)
+ Left err -> liftIO $ T.hPutStrLn h (encodeT err)
+ Nothing -> do
+ $(logDebug) ("Parsing the command failed. Command: " <> cmd)
+ liftIO $ do
+ T.hPutStrLn h (encodeT (GeneralError "Error parsing Command."))
+ hFlush stdout
+ liftIO (hClose h)
+
+
+acceptCommand :: (Applicative m, MonadIO m, MonadLogger m)
+ => Socket -> m (T.Text, Handle)
+acceptCommand sock = do
+ h <- acceptConnection
+ $(logDebug) "Accepted a connection"
+ cmd <- liftIO (T.hGetLine h)
+ $(logDebug) cmd
+ pure (cmd, h)
+ where
+ acceptConnection = liftIO $ do
+ (h,_,_) <- accept sock
+ hSetEncoding h utf8
+ hSetBuffering h LineBuffering
+ pure h
diff --git a/psc/Main.hs b/psc/Main.hs
index 6f7d8d0..8639346 100644
--- a/psc/Main.hs
+++ b/psc/Main.hs
@@ -177,6 +177,11 @@ jsonErrors :: Parser Bool
jsonErrors = switch $
long "json-errors"
<> help "Print errors to stderr as JSON"
+sourceMaps :: Parser Bool
+sourceMaps = switch $
+ long "source-maps"
+ <> help "Generate source maps"
+
options :: Parser P.Options
options = P.Options <$> noTco
@@ -186,6 +191,7 @@ options = P.Options <$> noTco
<*> verboseErrors
<*> (not <$> comments)
<*> requirePath
+ <*> sourceMaps
pscMakeOptions :: Parser PSCMakeOptions
pscMakeOptions = PSCMakeOptions <$> many inputFile
diff --git a/psci/IO.hs b/psci/IO.hs
deleted file mode 100644
index 36a55d1..0000000
--- a/psci/IO.hs
+++ /dev/null
@@ -1,21 +0,0 @@
------------------------------------------------------------------------------
---
--- Module : IO
--- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
--- License : MIT
---
--- Maintainer : Phil Freeman <paf31@cantab.net>
--- Stability : experimental
--- Portability :
---
--- |
---
------------------------------------------------------------------------------
-
-module IO where
-
-import System.Directory (createDirectoryIfMissing)
-import System.FilePath (takeDirectory)
-
-mkdirp :: FilePath -> IO ()
-mkdirp = createDirectoryIfMissing True . takeDirectory
diff --git a/psci/PSCi.hs b/psci/PSCi.hs
index 4ea0342..ea119c5 100644
--- a/psci/PSCi.hs
+++ b/psci/PSCi.hs
@@ -7,16 +7,14 @@
-- |
-- PureScript Compiler Interactive.
--
-module PSCi where
+module PSCi (runPSCi) where
import Prelude ()
import Prelude.Compat
import Data.Foldable (traverse_)
-import Data.Maybe (mapMaybe)
-import Data.List (intersperse, intercalate, nub, sort, find)
+import Data.List (intercalate, nub, sort, find)
import Data.Tuple (swap)
-import Data.Version (showVersion)
import qualified Data.Map as M
import Control.Arrow (first)
@@ -24,102 +22,87 @@ import Control.Monad
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.Trans.Class
import Control.Monad.Trans.Except (ExceptT(), runExceptT)
-import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
import Control.Monad.Trans.State.Strict
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Writer.Strict (Writer(), runWriter)
-import Options.Applicative as Opts
-
import System.Console.Haskeline
-import System.Directory (doesFileExist, findExecutable, getHomeDirectory, getCurrentDirectory)
+import System.Directory (doesFileExist, getHomeDirectory, getCurrentDirectory)
import System.Exit
-import System.FilePath (pathSeparator, (</>), isPathSeparator)
+import System.FilePath ((</>))
import System.FilePath.Glob (glob)
import System.Process (readProcessWithExitCode)
import System.IO.Error (tryIOError)
-import qualified Text.PrettyPrint.Boxes as Box
import qualified Language.PureScript as P
import qualified Language.PureScript.Names as N
-import qualified Paths_purescript as Paths
-
-import qualified Directive as D
-import Completion (completion)
-import IO (mkdirp)
-import Parser (parseCommand)
-import Types
-
--- | The name of the PSCI support module
-supportModuleName :: P.ModuleName
-supportModuleName = P.ModuleName [P.ProperName "$PSCI", P.ProperName "Support"]
-
--- | Support module, contains code to evaluate terms
-supportModule :: P.Module
-supportModule =
- case P.parseModulesFromFiles id [("", code)] of
- Right [(_, P.Module ss cs _ ds exps)] -> P.Module ss cs supportModuleName ds exps
- _ -> P.internalError "Support module could not be parsed"
- where
- code :: String
- code = unlines
- [ "module S where"
- , ""
- , "import Prelude"
- , "import Control.Monad.Eff"
- , "import Control.Monad.Eff.Console"
- , "import Control.Monad.Eff.Unsafe"
- , ""
- , "class Eval a where"
- , " eval :: a -> Eff (console :: CONSOLE) Unit"
- , ""
- , "instance evalShow :: (Show a) => Eval a where"
- , " eval = print"
- , ""
- , "instance evalEff :: (Eval a) => Eval (Eff eff a) where"
- , " eval x = unsafeInterleaveEff x >>= eval"
- ]
-
--- File helpers
-
-onFirstFileMatching :: Monad m => (b -> m (Maybe a)) -> [b] -> m (Maybe a)
-onFirstFileMatching f pathVariants = runMaybeT . msum $ map (MaybeT . f) pathVariants
--- |
--- Locates the node executable.
--- Checks for either @nodejs@ or @node@.
---
-findNodeProcess :: IO (Maybe String)
-findNodeProcess = onFirstFileMatching findExecutable names
- where names = ["nodejs", "node"]
+import PSCi.Completion (completion)
+import PSCi.Parser (parseCommand)
+import PSCi.Option
+import PSCi.Types
+import PSCi.Message
+import PSCi.IO
+import PSCi.Printer
+import PSCi.Module
-- |
--- Grabs the filename where the history is stored.
+-- PSCI monad
--
-getHistoryFilename :: IO FilePath
-getHistoryFilename = do
- home <- getHomeDirectory
- let filename = home </> ".purescript" </> "psci_history"
- mkdirp filename
- return filename
+newtype PSCI a = PSCI { runPSCI :: InputT (StateT PSCiState IO) a } deriving (Functor, Applicative, Monad)
+
+psciIO :: IO a -> PSCI a
+psciIO io = PSCI . lift $ lift io
-- |
--- Loads a file for use with imports.
+-- The runner
--
-loadModule :: FilePath -> IO (Either String [P.Module])
-loadModule filename = do
- content <- readFile filename
- return $ either (Left . P.prettyPrintMultipleErrors False) (Right . map snd) $ P.parseModulesFromFiles id [(filename, content)]
+runPSCi :: IO ()
+runPSCi = getOpt >>= loop
-- |
--- Load all modules.
+-- The PSCI main loop.
--
-loadAllModules :: [FilePath] -> IO (Either P.MultipleErrors [(FilePath, P.Module)])
-loadAllModules files = do
- filesAndContent <- forM files $ \filename -> do
- content <- readFile filename
- return (filename, content)
- return $ P.parseModulesFromFiles id filesAndContent
+loop :: PSCiOptions -> IO ()
+loop PSCiOptions{..} = do
+ config <- loadUserConfig
+ inputFiles <- concat <$> traverse glob psciInputFile
+ foreignFiles <- concat <$> traverse glob psciForeignInputFiles
+ modulesOrFirstError <- loadAllModules inputFiles
+ case modulesOrFirstError of
+ Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> exitFailure
+ Right modules -> do
+ historyFilename <- getHistoryFilename
+ let settings = defaultSettings { historyFile = Just historyFilename }
+ foreignsOrError <- runMake $ do
+ foreignFilesContent <- forM foreignFiles (\inFile -> (inFile,) <$> makeIO (const (P.ErrorMessage [] $ P.CannotReadFile inFile)) (readFile inFile))
+ P.parseForeignModulesFromFiles foreignFilesContent
+ case foreignsOrError of
+ Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> exitFailure
+ Right foreigns ->
+ flip evalStateT (mkPSCiState [] modules foreigns [] psciInputNodeFlags) . runInputT (setComplete completion settings) $ do
+ outputStrLn prologueMessage
+ traverse_ (traverse_ (runPSCI . handleCommand)) config
+ modules' <- lift $ gets psciLoadedModules
+ unless (consoleIsDefined (map snd modules')) . outputStrLn $ unlines
+ [ "PSCi requires the purescript-console module to be installed."
+ , "For help getting started, visit http://wiki.purescript.org/PSCi"
+ ]
+ go
+ where
+ go :: InputT (StateT PSCiState IO) ()
+ go = do
+ c <- getCommand (not psciMultiLineMode)
+ case c of
+ Left err -> outputStrLn err >> go
+ Right Nothing -> go
+ Right (Just QuitPSCi) -> outputStrLn quitMessage
+ Right (Just c') -> do
+ handleInterrupt (outputStrLn "Interrupted.")
+ (withInterrupt (runPSCI (loadAllImportedModules >> handleCommand c')))
+ go
+
+-- Compile the module
-- |
-- Load all modules, updating the application state
@@ -129,116 +112,9 @@ loadAllImportedModules = do
files <- PSCI . lift $ fmap psciImportedFilenames get
modulesOrFirstError <- psciIO $ loadAllModules files
case modulesOrFirstError of
- Left errs -> printErrors errs
+ Left errs -> PSCI $ printErrors errs
Right modules -> PSCI . lift . modify $ updateModules modules
--- |
--- Expands tilde in path.
---
-expandTilde :: FilePath -> IO FilePath
-expandTilde ('~':p:rest) | isPathSeparator p = (</> rest) <$> getHomeDirectory
-expandTilde p = return p
-
--- Messages
-
--- |
--- The help message.
---
-helpMessage :: String
-helpMessage = "The following commands are available:\n\n " ++
- intercalate "\n " (map line D.help) ++
- "\n\n" ++ extraHelp
- where
- line :: (Directive, String, String) -> String
- line (dir, arg, desc) =
- let cmd = ':' : D.stringFor dir
- in unwords [ cmd
- , replicate (11 - length cmd) ' '
- , arg
- , replicate (11 - length arg) ' '
- , desc
- ]
-
- extraHelp =
- "Further information is available on the PureScript wiki:\n" ++
- " --> https://github.com/purescript/purescript/wiki/psci"
-
-
--- |
--- The welcome prologue.
---
-prologueMessage :: String
-prologueMessage = intercalate "\n"
- [ " ____ ____ _ _ "
- , "| _ \\ _ _ _ __ ___/ ___| ___ _ __(_)_ __ | |_ "
- , "| |_) | | | | '__/ _ \\___ \\ / __| '__| | '_ \\| __|"
- , "| __/| |_| | | | __/___) | (__| | | | |_) | |_ "
- , "|_| \\__,_|_| \\___|____/ \\___|_| |_| .__/ \\__|"
- , " |_| "
- , ""
- , ":? shows help"
- ]
-
--- |
--- The quit message.
---
-quitMessage :: String
-quitMessage = "See ya!"
-
--- |
--- PSCI monad
---
-newtype PSCI a = PSCI { runPSCI :: InputT (StateT PSCiState IO) a } deriving (Functor, Applicative, Monad)
-
-psciIO :: IO a -> PSCI a
-psciIO io = PSCI . lift $ lift io
-
--- |
--- Makes a volatile module to execute the current expression.
---
-createTemporaryModule :: Bool -> PSCiState -> P.Expr -> P.Module
-createTemporaryModule exec PSCiState{psciImportedModules = imports, psciLetBindings = lets} val =
- let
- moduleName = P.ModuleName [P.ProperName "$PSCI"]
- trace = P.Var (P.Qualified (Just supportModuleName) (P.Ident "eval"))
- mainValue = P.App trace (P.Var (P.Qualified Nothing (P.Ident "it")))
- itDecl = P.ValueDeclaration (P.Ident "it") P.Public [] $ Right val
- mainDecl = P.ValueDeclaration (P.Ident "$main") P.Public [] $ Right mainValue
- decls = if exec then [itDecl, mainDecl] else [itDecl]
- in
- P.Module (P.internalModuleSourceSpan "<internal>") [] moduleName ((importDecl `map` imports) ++ lets ++ decls) Nothing
-
-
--- |
--- Makes a volatile module to hold a non-qualified type synonym for a fully-qualified data type declaration.
---
-createTemporaryModuleForKind :: PSCiState -> P.Type -> P.Module
-createTemporaryModuleForKind PSCiState{psciImportedModules = imports, psciLetBindings = lets} typ =
- let
- moduleName = P.ModuleName [P.ProperName "$PSCI"]
- itDecl = P.TypeSynonymDeclaration (P.ProperName "IT") [] typ
- in
- P.Module (P.internalModuleSourceSpan "<internal>") [] moduleName ((importDecl `map` imports) ++ lets ++ [itDecl]) Nothing
-
--- |
--- Makes a volatile module to execute the current imports.
---
-createTemporaryModuleForImports :: PSCiState -> P.Module
-createTemporaryModuleForImports PSCiState{psciImportedModules = imports} =
- let
- moduleName = P.ModuleName [P.ProperName "$PSCI"]
- in
- P.Module (P.internalModuleSourceSpan "<internal>") [] moduleName (importDecl `map` imports) Nothing
-
-importDecl :: ImportedModule -> P.Declaration
-importDecl (mn, declType, asQ) = P.ImportDeclaration mn declType asQ False
-
-indexFile :: FilePath
-indexFile = ".psci_modules" ++ pathSeparator : "index.js"
-
-modulesDir :: FilePath
-modulesDir = ".psci_modules" ++ pathSeparator : "node_modules"
-
-- | This is different than the runMake in 'Language.PureScript.Make' in that it specifies the
-- options and ignores the warning messages.
runMake :: P.Make a -> IO (Either P.MultipleErrors a)
@@ -258,6 +134,58 @@ make st@PSCiState{..} ms = P.make actions' (map snd loadedModules ++ ms)
loadedModules = psciLoadedModules st
allModules = map (first Right) loadedModules ++ map (Left P.RebuildAlways,) ms
+
+-- Commands
+
+-- |
+-- Parses the input and returns either a Metacommand, or an error as a string.
+--
+getCommand :: Bool -> InputT (StateT PSCiState IO) (Either String (Maybe Command))
+getCommand singleLineMode = handleInterrupt (return (Right Nothing)) $ do
+ firstLine <- withInterrupt $ getInputLine "> "
+ case firstLine of
+ Nothing -> return (Right (Just QuitPSCi)) -- Ctrl-D when input is empty
+ Just "" -> return (Right Nothing)
+ Just s | singleLineMode || head s == ':' -> return .fmap Just $ parseCommand s
+ Just s -> fmap Just . parseCommand <$> go [s]
+ where
+ go :: [String] -> InputT (StateT PSCiState IO) String
+ go ls = maybe (return . unlines $ reverse ls) (go . (:ls)) =<< getInputLine " "
+
+-- |
+-- Performs an action for each meta-command given, and also for expressions.
+--
+handleCommand :: Command -> PSCI ()
+handleCommand (Expression val) = handleExpression val
+handleCommand ShowHelp = PSCI $ outputStrLn helpMessage
+handleCommand (Import im) = handleImport im
+handleCommand (Decls l) = handleDecls l
+handleCommand (LoadFile filePath) = PSCI $ whenFileExists filePath $ \absPath -> do
+ m <- lift . lift $ loadModule absPath
+ case m of
+ Left err -> outputStrLn err
+ Right mods -> lift $ modify (updateModules (map (absPath,) mods))
+handleCommand (LoadForeign filePath) = PSCI $ whenFileExists filePath $ \absPath -> do
+ foreignsOrError <- lift . lift . runMake $ do
+ foreignFile <- makeIO (const (P.ErrorMessage [] $ P.CannotReadFile absPath)) (readFile absPath)
+ P.parseForeignModulesFromFiles [(absPath, foreignFile)]
+ case foreignsOrError of
+ Left err -> outputStrLn $ P.prettyPrintMultipleErrors False err
+ Right foreigns -> lift $ modify (updateForeignFiles foreigns)
+handleCommand ResetState = do
+ PSCI . lift . modify $ \st ->
+ st { psciImportedModules = []
+ , psciLetBindings = []
+ }
+ loadAllImportedModules
+handleCommand (TypeOf val) = handleTypeOf val
+handleCommand (KindOf typ) = handleKindOf typ
+handleCommand (BrowseModule moduleName) = handleBrowse moduleName
+handleCommand (ShowInfo QueryLoaded) = handleShowLoadedModules
+handleCommand (ShowInfo QueryImport) = handleShowImportedModules
+handleCommand QuitPSCi = P.internalError "`handleCommand QuitPSCi` was called. This is a bug."
+
+
-- |
-- Takes a value expression and evaluates it with the current state.
--
@@ -268,7 +196,7 @@ handleExpression val = do
let nodeArgs = psciNodeFlags st ++ [indexFile]
e <- psciIO . runMake $ make st [supportModule, m]
case e of
- Left errs -> printErrors errs
+ Left errs -> PSCI $ printErrors errs
Right _ -> do
psciIO $ writeFile indexFile "require('$PSCI')['$main']();"
process <- psciIO findNodeProcess
@@ -289,7 +217,7 @@ handleDecls ds = do
let m = createTemporaryModule False st' (P.ObjectLiteral [])
e <- psciIO . runMake $ make st' [m]
case e of
- Left err -> printErrors err
+ Left err -> PSCI $ printErrors err
Right _ -> PSCI $ lift (put st')
-- |
@@ -344,7 +272,7 @@ handleImport im = do
let m = createTemporaryModuleForImports st
e <- psciIO . runMake $ make st [m]
case e of
- Left errs -> printErrors errs
+ Left errs -> PSCI $ printErrors errs
Right _ -> do
PSCI $ lift $ put st
return ()
@@ -358,125 +286,13 @@ handleTypeOf val = do
let m = createTemporaryModule False st val
e <- psciIO . runMake $ make st [m]
case e of
- Left errs -> printErrors errs
+ Left errs -> PSCI $ printErrors errs
Right env' ->
case M.lookup (P.ModuleName [P.ProperName "$PSCI"], P.Ident "it") (P.names env') of
Just (ty, _, _) -> PSCI . outputStrLn . P.prettyPrintType $ ty
Nothing -> PSCI $ outputStrLn "Could not find type"
-- |
--- Pretty print a module's signatures
---
-printModuleSignatures :: P.ModuleName -> P.Environment -> PSCI ()
-printModuleSignatures moduleName (P.Environment {..}) =
- PSCI $
- -- get relevant components of a module from environment
- let moduleNamesIdent = (filter ((== moduleName) . fst) . M.keys) names
- moduleTypeClasses = (filter (\(P.Qualified maybeName _) -> maybeName == Just moduleName) . M.keys) typeClasses
- moduleTypes = (filter (\(P.Qualified maybeName _) -> maybeName == Just moduleName) . M.keys) types
-
- in
- -- print each component
- (outputStr . unlines . map trimEnd . lines . Box.render . Box.vsep 1 Box.left)
- [ printModule's (mapMaybe (showTypeClass . findTypeClass typeClasses)) moduleTypeClasses -- typeClasses
- , printModule's (mapMaybe (showType typeClasses dataConstructors typeSynonyms . findType types)) moduleTypes -- types
- , printModule's (map (showNameType . findNameType names)) moduleNamesIdent -- functions
- ]
-
- where printModule's showF = Box.vsep 1 Box.left . showF
-
- findNameType :: M.Map (P.ModuleName, P.Ident) (P.Type, P.NameKind, P.NameVisibility) -> (P.ModuleName, P.Ident) -> (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility))
- findNameType envNames m@(_, mIdent) = (mIdent, M.lookup m envNames)
-
- showNameType :: (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility)) -> Box.Box
- showNameType (mIdent, Just (mType, _, _)) = Box.text (P.showIdent mIdent ++ " :: ") Box.<> P.typeAsBox mType
- showNameType _ = P.internalError "The impossible happened in printModuleSignatures."
-
- findTypeClass
- :: M.Map (P.Qualified (P.ProperName 'P.ClassName)) ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint])
- -> P.Qualified (P.ProperName 'P.ClassName)
- -> (P.Qualified (P.ProperName 'P.ClassName), Maybe ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint]))
- findTypeClass envTypeClasses name = (name, M.lookup name envTypeClasses)
-
- showTypeClass
- :: (P.Qualified (P.ProperName 'P.ClassName), Maybe ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint]))
- -> Maybe Box.Box
- showTypeClass (_, Nothing) = Nothing
- showTypeClass (P.Qualified _ name, Just (vars, body, constrs)) =
- let constraints =
- if null constrs
- then Box.text ""
- else Box.text "("
- Box.<> Box.hcat Box.left (intersperse (Box.text ", ") $ map (\(P.Qualified _ pn, lt) -> Box.text (P.runProperName pn) Box.<+> Box.hcat Box.left (map P.typeAtomAsBox lt)) constrs)
- Box.<> Box.text ") <= "
- className =
- Box.text (P.runProperName name)
- Box.<> Box.text (concatMap ((' ':) . fst) vars)
- classBody =
- Box.vcat Box.top (map (\(i, t) -> Box.text (P.showIdent i ++ " ::") Box.<+> P.typeAsBox t) body)
-
- in
- Just $
- (Box.text "class "
- Box.<> constraints
- Box.<> className
- Box.<+> if null body then Box.text "" else Box.text "where")
- Box.// Box.moveRight 2 classBody
-
-
- findType
- :: M.Map (P.Qualified (P.ProperName 'P.TypeName)) (P.Kind, P.TypeKind)
- -> P.Qualified (P.ProperName 'P.TypeName)
- -> (P.Qualified (P.ProperName 'P.TypeName), Maybe (P.Kind, P.TypeKind))
- findType envTypes name = (name, M.lookup name envTypes)
-
- showType
- :: M.Map (P.Qualified (P.ProperName 'P.ClassName)) ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint])
- -> M.Map (P.Qualified (P.ProperName 'P.ConstructorName)) (P.DataDeclType, P.ProperName 'P.TypeName, P.Type, [P.Ident])
- -> M.Map (P.Qualified (P.ProperName 'P.TypeName)) ([(String, Maybe P.Kind)], P.Type)
- -> (P.Qualified (P.ProperName 'P.TypeName), Maybe (P.Kind, P.TypeKind))
- -> Maybe Box.Box
- showType typeClassesEnv dataConstructorsEnv typeSynonymsEnv (n@(P.Qualified modul name), typ) =
- case (typ, M.lookup n typeSynonymsEnv) of
- (Just (_, P.TypeSynonym), Just (typevars, dtType)) ->
- if M.member (fmap P.coerceProperName n) typeClassesEnv
- then
- Nothing
- else
- Just $
- Box.text ("type " ++ P.runProperName name ++ concatMap ((' ':) . fst) typevars)
- Box.// Box.moveRight 2 (Box.text "=" Box.<+> P.typeAsBox dtType)
-
- (Just (_, P.DataType typevars pt), _) ->
- let prefix =
- case pt of
- [(dtProperName,_)] ->
- case M.lookup (P.Qualified modul dtProperName) dataConstructorsEnv of
- Just (dataDeclType, _, _, _) -> P.showDataDeclType dataDeclType
- _ -> "data"
- _ -> "data"
-
- in
- Just $ Box.text (prefix ++ " " ++ P.runProperName name ++ concatMap ((' ':) . fst) typevars) Box.// printCons pt
-
- _ ->
- Nothing
-
- where printCons pt =
- Box.moveRight 2 $
- Box.vcat Box.left $
- mapFirstRest (Box.text "=" Box.<+>) (Box.text "|" Box.<+>) $
- map (\(cons,idents) -> (Box.text (P.runProperName cons) Box.<> Box.hcat Box.left (map prettyPrintType idents))) pt
-
- prettyPrintType t = Box.text " " Box.<> P.typeAtomAsBox t
-
- mapFirstRest _ _ [] = []
- mapFirstRest f g (x:xs) = f x : map g xs
-
- trimEnd = reverse . dropWhile (== ' ') . reverse
-
-
--- |
-- Browse a module and displays its signature (if module exists).
--
handleBrowse :: P.ModuleName -> PSCI ()
@@ -484,14 +300,14 @@ handleBrowse moduleName = do
st <- PSCI $ lift get
env <- psciIO . runMake $ make st []
case env of
- Left errs -> printErrors errs
+ Left errs -> PSCI $ printErrors errs
Right env' ->
if isModInEnv moduleName st
- then printModuleSignatures moduleName env'
+ then PSCI $ printModuleSignatures moduleName env'
else case lookupUnQualifiedModName moduleName st of
Just unQualifiedName ->
if isModInEnv unQualifiedName st
- then printModuleSignatures unQualifiedName env'
+ then PSCI $ printModuleSignatures unQualifiedName env'
else failNotInEnv moduleName
Nothing ->
failNotInEnv moduleName
@@ -503,10 +319,6 @@ handleBrowse moduleName = do
lookupUnQualifiedModName quaModName st =
(\(modName,_,_) -> modName) <$> find ( \(_, _, mayQuaName) -> mayQuaName == Just quaModName) (psciImportedModules st)
--- | Pretty-print errors
-printErrors :: P.MultipleErrors -> PSCI ()
-printErrors = PSCI . outputStrLn . P.prettyPrintMultipleErrors False
-
-- |
-- Takes a value and prints its kind
--
@@ -517,7 +329,7 @@ handleKindOf typ = do
mName = P.ModuleName [P.ProperName "$PSCI"]
e <- psciIO . runMake $ make st [m]
case e of
- Left errs -> printErrors errs
+ Left errs -> PSCI $ printErrors errs
Right env' ->
case M.lookup (P.Qualified (Just mName) $ P.ProperName "IT") (P.typeSynonyms env') of
Just (_, typ') -> do
@@ -531,63 +343,7 @@ handleKindOf typ = do
Right (kind, _) -> PSCI . outputStrLn . P.prettyPrintKind $ kind
Nothing -> PSCI $ outputStrLn "Could not find kind"
--- Commands
-
--- |
--- Parses the input and returns either a Metacommand, or an error as a string.
---
-getCommand :: Bool -> InputT (StateT PSCiState IO) (Either String (Maybe Command))
-getCommand singleLineMode = handleInterrupt (return (Right Nothing)) $ do
- firstLine <- withInterrupt $ getInputLine "> "
- case firstLine of
- Nothing -> return (Right (Just QuitPSCi)) -- Ctrl-D when input is empty
- Just "" -> return (Right Nothing)
- Just s | singleLineMode || head s == ':' -> return .fmap Just $ parseCommand s
- Just s -> fmap Just . parseCommand <$> go [s]
- where
- go :: [String] -> InputT (StateT PSCiState IO) String
- go ls = maybe (return . unlines $ reverse ls) (go . (:ls)) =<< getInputLine " "
-
--- |
--- Performs an action for each meta-command given, and also for expressions.
---
-handleCommand :: Command -> PSCI ()
-handleCommand (Expression val) = handleExpression val
-handleCommand ShowHelp = PSCI $ outputStrLn helpMessage
-handleCommand (Import im) = handleImport im
-handleCommand (Decls l) = handleDecls l
-handleCommand (LoadFile filePath) = whenFileExists filePath $ \absPath -> do
- m <- psciIO $ loadModule absPath
- case m of
- Left err -> PSCI $ outputStrLn err
- Right mods -> PSCI . lift $ modify (updateModules (map (absPath,) mods))
-handleCommand (LoadForeign filePath) = whenFileExists filePath $ \absPath -> do
- foreignsOrError <- psciIO . runMake $ do
- foreignFile <- makeIO (const (P.ErrorMessage [] $ P.CannotReadFile absPath)) (readFile absPath)
- P.parseForeignModulesFromFiles [(absPath, foreignFile)]
- case foreignsOrError of
- Left err -> PSCI $ outputStrLn $ P.prettyPrintMultipleErrors False err
- Right foreigns -> PSCI . lift $ modify (updateForeignFiles foreigns)
-handleCommand ResetState = do
- PSCI . lift . modify $ \st ->
- st { psciImportedModules = []
- , psciLetBindings = []
- }
- loadAllImportedModules
-handleCommand (TypeOf val) = handleTypeOf val
-handleCommand (KindOf typ) = handleKindOf typ
-handleCommand (BrowseModule moduleName) = handleBrowse moduleName
-handleCommand (ShowInfo QueryLoaded) = handleShowLoadedModules
-handleCommand (ShowInfo QueryImport) = handleShowImportedModules
-handleCommand QuitPSCi = P.internalError "`handleCommand QuitPSCi` was called. This is a bug."
-
-whenFileExists :: FilePath -> (FilePath -> PSCI ()) -> PSCI ()
-whenFileExists filePath f = do
- absPath <- psciIO $ expandTilde filePath
- exists <- psciIO $ doesFileExist absPath
- if exists
- then f absPath
- else PSCI . outputStrLn $ "Couldn't locate: " ++ filePath
+-- Misc
-- |
-- Attempts to read initial commands from '.psci' in the present working
@@ -610,92 +366,6 @@ loadUserConfig = onFirstFileMatching readCommands pathGetters
else
return Nothing
-
-- | Checks if the Console module is defined
consoleIsDefined :: [P.Module] -> Bool
consoleIsDefined = any ((== P.ModuleName (map P.ProperName [ "Control", "Monad", "Eff", "Console" ])) . P.getModuleName)
-
--- |
--- The PSCI main loop.
---
-loop :: PSCiOptions -> IO ()
-loop PSCiOptions{..} = do
- config <- loadUserConfig
- inputFiles <- concat <$> traverse glob psciInputFile
- foreignFiles <- concat <$> traverse glob psciForeignInputFiles
- modulesOrFirstError <- loadAllModules inputFiles
- case modulesOrFirstError of
- Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> exitFailure
- Right modules -> do
- historyFilename <- getHistoryFilename
- let settings = defaultSettings { historyFile = Just historyFilename }
- foreignsOrError <- runMake $ do
- foreignFilesContent <- forM foreignFiles (\inFile -> (inFile,) <$> makeIO (const (P.ErrorMessage [] $ P.CannotReadFile inFile)) (readFile inFile))
- P.parseForeignModulesFromFiles foreignFilesContent
- case foreignsOrError of
- Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> exitFailure
- Right foreigns ->
- flip evalStateT (mkPSCiState [] modules foreigns [] psciInputNodeFlags) . runInputT (setComplete completion settings) $ do
- outputStrLn prologueMessage
- traverse_ (traverse_ (runPSCI . handleCommand)) config
- modules' <- lift $ gets psciLoadedModules
- unless (consoleIsDefined (map snd modules')) . outputStrLn $ unlines
- [ "PSCi requires the purescript-console module to be installed."
- , "For help getting started, visit http://wiki.purescript.org/PSCi"
- ]
- go
- where
- go :: InputT (StateT PSCiState IO) ()
- go = do
- c <- getCommand (not psciMultiLineMode)
- case c of
- Left err -> outputStrLn err >> go
- Right Nothing -> go
- Right (Just QuitPSCi) -> outputStrLn quitMessage
- Right (Just c') -> do
- handleInterrupt (outputStrLn "Interrupted.")
- (withInterrupt (runPSCI (loadAllImportedModules >> handleCommand c')))
- go
-
-multiLineMode :: Parser Bool
-multiLineMode = switch $
- long "multi-line-mode"
- <> short 'm'
- <> Opts.help "Run in multi-line mode (use ^D to terminate commands)"
-
-inputFile :: Parser FilePath
-inputFile = strArgument $
- metavar "FILE"
- <> Opts.help "Optional .purs files to load on start"
-
-inputForeignFile :: Parser FilePath
-inputForeignFile = strOption $
- short 'f'
- <> long "ffi"
- <> help "The input .js file(s) providing foreign import implementations"
-
-nodeFlagsFlag :: Parser [String]
-nodeFlagsFlag = option parser $
- long "node-opts"
- <> metavar "NODE_OPTS"
- <> value []
- <> Opts.help "Flags to pass to node, separated by spaces"
- where
- parser = words <$> str
-
-psciOptions :: Parser PSCiOptions
-psciOptions = PSCiOptions <$> multiLineMode
- <*> many inputFile
- <*> many inputForeignFile
- <*> nodeFlagsFlag
-
-runPSCi :: IO ()
-runPSCi = execParser opts >>= loop
- where
- opts = info (version <*> helper <*> psciOptions) infoModList
- infoModList = fullDesc <> headerInfo <> footerInfo
- headerInfo = header "psci - Interactive mode for PureScript"
- footerInfo = footer $ "psci " ++ showVersion Paths.version
-
- version :: Parser (a -> a)
- version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> Opts.help "Show the version number" <> hidden
diff --git a/psci/Completion.hs b/psci/PSCi/Completion.hs
index 564d904..26965e7 100644
--- a/psci/Completion.hs
+++ b/psci/PSCi/Completion.hs
@@ -1,6 +1,6 @@
{-# LANGUAGE DataKinds #-}
-module Completion where
+module PSCi.Completion where
import Prelude ()
import Prelude.Compat
@@ -19,8 +19,8 @@ import System.Console.Haskeline
import qualified Language.PureScript as P
import qualified Language.PureScript.Names as N
-import qualified Directive as D
-import Types
+import qualified PSCi.Directive as D
+import PSCi.Types
-- Completions may read the state, but not modify it.
type CompletionM = ReaderT PSCiState IO
diff --git a/psci/Directive.hs b/psci/PSCi/Directive.hs
index f2a3ca6..3d0cad5 100644
--- a/psci/Directive.hs
+++ b/psci/PSCi/Directive.hs
@@ -13,13 +13,17 @@
--
-----------------------------------------------------------------------------
-module Directive where
+module PSCi.Directive where
+
+import Prelude ()
+import Prelude.Compat
+
import Data.Maybe (fromJust, listToMaybe)
import Data.List (isPrefixOf)
import Data.Tuple (swap)
-import Types
+import PSCi.Types
-- |
-- List of all avaliable directives.
diff --git a/psci/PSCi/IO.hs b/psci/PSCi/IO.hs
new file mode 100644
index 0000000..fea644a
--- /dev/null
+++ b/psci/PSCi/IO.hs
@@ -0,0 +1,68 @@
+-----------------------------------------------------------------------------
+--
+-- Module : IO
+-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+--
+-----------------------------------------------------------------------------
+
+module PSCi.IO where
+
+import Prelude ()
+import Prelude.Compat
+
+import System.Directory (createDirectoryIfMissing, getHomeDirectory, findExecutable, doesFileExist)
+import System.FilePath (takeDirectory, (</>), isPathSeparator)
+import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
+import Control.Monad (msum)
+import Control.Monad.IO.Class (MonadIO, liftIO)
+import System.Console.Haskeline (outputStrLn, InputT)
+
+mkdirp :: FilePath -> IO ()
+mkdirp = createDirectoryIfMissing True . takeDirectory
+
+-- File helpers
+
+onFirstFileMatching :: Monad m => (b -> m (Maybe a)) -> [b] -> m (Maybe a)
+onFirstFileMatching f pathVariants = runMaybeT . msum $ map (MaybeT . f) pathVariants
+
+-- |
+-- Locates the node executable.
+-- Checks for either @nodejs@ or @node@.
+--
+findNodeProcess :: IO (Maybe String)
+findNodeProcess = onFirstFileMatching findExecutable names
+ where names = ["nodejs", "node"]
+
+-- |
+-- Grabs the filename where the history is stored.
+--
+getHistoryFilename :: IO FilePath
+getHistoryFilename = do
+ home <- getHomeDirectory
+ let filename = home </> ".purescript" </> "psci_history"
+ mkdirp filename
+ return filename
+
+
+-- |
+-- Expands tilde in path.
+--
+expandTilde :: FilePath -> IO FilePath
+expandTilde ('~':p:rest) | isPathSeparator p = (</> rest) <$> getHomeDirectory
+expandTilde p = return p
+
+
+whenFileExists :: MonadIO m => FilePath -> (FilePath -> InputT m ()) -> InputT m ()
+whenFileExists filePath f = do
+ absPath <- liftIO $ expandTilde filePath
+ exists <- liftIO $ doesFileExist absPath
+ if exists
+ then f absPath
+ else outputStrLn $ "Couldn't locate: " ++ filePath
diff --git a/psci/PSCi/Message.hs b/psci/PSCi/Message.hs
new file mode 100644
index 0000000..bd20b48
--- /dev/null
+++ b/psci/PSCi/Message.hs
@@ -0,0 +1,53 @@
+module PSCi.Message where
+
+
+import Data.List (intercalate)
+import qualified PSCi.Directive as D
+import PSCi.Types
+
+-- Messages
+
+-- |
+-- The help message.
+--
+helpMessage :: String
+helpMessage = "The following commands are available:\n\n " ++
+ intercalate "\n " (map line D.help) ++
+ "\n\n" ++ extraHelp
+ where
+ line :: (Directive, String, String) -> String
+ line (dir, arg, desc) =
+ let cmd = ':' : D.stringFor dir
+ in unwords [ cmd
+ , replicate (11 - length cmd) ' '
+ , arg
+ , replicate (11 - length arg) ' '
+ , desc
+ ]
+
+ extraHelp =
+ "Further information is available on the PureScript wiki:\n" ++
+ " --> https://github.com/purescript/purescript/wiki/psci"
+
+
+-- |
+-- The welcome prologue.
+--
+prologueMessage :: String
+prologueMessage = intercalate "\n"
+ [ " ____ ____ _ _ "
+ , "| _ \\ _ _ _ __ ___/ ___| ___ _ __(_)_ __ | |_ "
+ , "| |_) | | | | '__/ _ \\___ \\ / __| '__| | '_ \\| __|"
+ , "| __/| |_| | | | __/___) | (__| | | | |_) | |_ "
+ , "|_| \\__,_|_| \\___|____/ \\___|_| |_| .__/ \\__|"
+ , " |_| "
+ , ""
+ , ":? shows help"
+ ]
+
+-- |
+-- The quit message.
+--
+quitMessage :: String
+quitMessage = "See ya!"
+
diff --git a/psci/PSCi/Module.hs b/psci/PSCi/Module.hs
new file mode 100644
index 0000000..ead2c00
--- /dev/null
+++ b/psci/PSCi/Module.hs
@@ -0,0 +1,106 @@
+module PSCi.Module where
+
+import Prelude ()
+import Prelude.Compat
+
+import qualified Language.PureScript as P
+import PSCi.Types
+import System.FilePath (pathSeparator)
+import Control.Monad
+
+-- | The name of the PSCI support module
+supportModuleName :: P.ModuleName
+supportModuleName = P.ModuleName [P.ProperName "$PSCI", P.ProperName "Support"]
+
+-- | Support module, contains code to evaluate terms
+supportModule :: P.Module
+supportModule =
+ case P.parseModulesFromFiles id [("", code)] of
+ Right [(_, P.Module ss cs _ ds exps)] -> P.Module ss cs supportModuleName ds exps
+ _ -> P.internalError "Support module could not be parsed"
+ where
+ code :: String
+ code = unlines
+ [ "module S where"
+ , ""
+ , "import Prelude"
+ , "import Control.Monad.Eff"
+ , "import Control.Monad.Eff.Console"
+ , "import Control.Monad.Eff.Unsafe"
+ , ""
+ , "class Eval a where"
+ , " eval :: a -> Eff (console :: CONSOLE) Unit"
+ , ""
+ , "instance evalShow :: (Show a) => Eval a where"
+ , " eval = print"
+ , ""
+ , "instance evalEff :: (Eval a) => Eval (Eff eff a) where"
+ , " eval x = unsafeInterleaveEff x >>= eval"
+ ]
+
+-- Module Management
+
+-- |
+-- Loads a file for use with imports.
+--
+loadModule :: FilePath -> IO (Either String [P.Module])
+loadModule filename = do
+ content <- readFile filename
+ return $ either (Left . P.prettyPrintMultipleErrors False) (Right . map snd) $ P.parseModulesFromFiles id [(filename, content)]
+
+-- |
+-- Load all modules.
+--
+loadAllModules :: [FilePath] -> IO (Either P.MultipleErrors [(FilePath, P.Module)])
+loadAllModules files = do
+ filesAndContent <- forM files $ \filename -> do
+ content <- readFile filename
+ return (filename, content)
+ return $ P.parseModulesFromFiles id filesAndContent
+
+
+-- |
+-- Makes a volatile module to execute the current expression.
+--
+createTemporaryModule :: Bool -> PSCiState -> P.Expr -> P.Module
+createTemporaryModule exec PSCiState{psciImportedModules = imports, psciLetBindings = lets} val =
+ let
+ moduleName = P.ModuleName [P.ProperName "$PSCI"]
+ trace = P.Var (P.Qualified (Just supportModuleName) (P.Ident "eval"))
+ mainValue = P.App trace (P.Var (P.Qualified Nothing (P.Ident "it")))
+ itDecl = P.ValueDeclaration (P.Ident "it") P.Public [] $ Right val
+ mainDecl = P.ValueDeclaration (P.Ident "$main") P.Public [] $ Right mainValue
+ decls = if exec then [itDecl, mainDecl] else [itDecl]
+ in
+ P.Module (P.internalModuleSourceSpan "<internal>") [] moduleName ((importDecl `map` imports) ++ lets ++ decls) Nothing
+
+
+-- |
+-- Makes a volatile module to hold a non-qualified type synonym for a fully-qualified data type declaration.
+--
+createTemporaryModuleForKind :: PSCiState -> P.Type -> P.Module
+createTemporaryModuleForKind PSCiState{psciImportedModules = imports, psciLetBindings = lets} typ =
+ let
+ moduleName = P.ModuleName [P.ProperName "$PSCI"]
+ itDecl = P.TypeSynonymDeclaration (P.ProperName "IT") [] typ
+ in
+ P.Module (P.internalModuleSourceSpan "<internal>") [] moduleName ((importDecl `map` imports) ++ lets ++ [itDecl]) Nothing
+
+-- |
+-- Makes a volatile module to execute the current imports.
+--
+createTemporaryModuleForImports :: PSCiState -> P.Module
+createTemporaryModuleForImports PSCiState{psciImportedModules = imports} =
+ let
+ moduleName = P.ModuleName [P.ProperName "$PSCI"]
+ in
+ P.Module (P.internalModuleSourceSpan "<internal>") [] moduleName (importDecl `map` imports) Nothing
+
+importDecl :: ImportedModule -> P.Declaration
+importDecl (mn, declType, asQ) = P.ImportDeclaration mn declType asQ False
+
+indexFile :: FilePath
+indexFile = ".psci_modules" ++ pathSeparator : "index.js"
+
+modulesDir :: FilePath
+modulesDir = ".psci_modules" ++ pathSeparator : "node_modules"
diff --git a/psci/PSCi/Option.hs b/psci/PSCi/Option.hs
new file mode 100644
index 0000000..1b75001
--- /dev/null
+++ b/psci/PSCi/Option.hs
@@ -0,0 +1,57 @@
+module PSCi.Option (
+ getOpt
+) where
+
+import Prelude ()
+import Prelude.Compat
+
+import Options.Applicative as Opts
+import Data.Version (showVersion)
+
+import PSCi.Types
+import qualified Paths_purescript as Paths
+
+-- Parse Command line option
+
+multiLineMode :: Parser Bool
+multiLineMode = switch $
+ long "multi-line-mode"
+ <> short 'm'
+ <> Opts.help "Run in multi-line mode (use ^D to terminate commands)"
+
+inputFile :: Parser FilePath
+inputFile = strArgument $
+ metavar "FILE"
+ <> Opts.help "Optional .purs files to load on start"
+
+inputForeignFile :: Parser FilePath
+inputForeignFile = strOption $
+ short 'f'
+ <> long "ffi"
+ <> help "The input .js file(s) providing foreign import implementations"
+
+nodeFlagsFlag :: Parser [String]
+nodeFlagsFlag = option parser $
+ long "node-opts"
+ <> metavar "NODE_OPTS"
+ <> value []
+ <> Opts.help "Flags to pass to node, separated by spaces"
+ where
+ parser = words <$> str
+
+psciOptions :: Parser PSCiOptions
+psciOptions = PSCiOptions <$> multiLineMode
+ <*> many inputFile
+ <*> many inputForeignFile
+ <*> nodeFlagsFlag
+
+version :: Parser (a -> a)
+version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> Opts.help "Show the version number" <> hidden
+
+getOpt :: IO PSCiOptions
+getOpt = execParser opts
+ where
+ opts = info (version <*> helper <*> psciOptions) infoModList
+ infoModList = fullDesc <> headerInfo <> footerInfo
+ headerInfo = header "psci - Interactive mode for PureScript"
+ footerInfo = footer $ "psci " ++ showVersion Paths.version
diff --git a/psci/Parser.hs b/psci/PSCi/Parser.hs
index b8b0675..526f3d6 100644
--- a/psci/Parser.hs
+++ b/psci/PSCi/Parser.hs
@@ -13,7 +13,7 @@
--
-----------------------------------------------------------------------------
-module Parser
+module PSCi.Parser
( parseCommand
) where
@@ -28,8 +28,8 @@ import Text.Parsec hiding ((<|>))
import qualified Language.PureScript as P
import Language.PureScript.Parser.Common (mark, same)
-import qualified Directive as D
-import Types
+import qualified PSCi.Directive as D
+import PSCi.Types
-- |
-- Parses PSCI metacommands or expressions input from the user.
diff --git a/psci/PSCi/Printer.hs b/psci/PSCi/Printer.hs
new file mode 100644
index 0000000..1d128eb
--- /dev/null
+++ b/psci/PSCi/Printer.hs
@@ -0,0 +1,131 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE DataKinds #-}
+
+module PSCi.Printer where
+
+import Prelude ()
+import Prelude.Compat
+
+import qualified Language.PureScript as P
+import qualified Text.PrettyPrint.Boxes as Box
+import qualified Data.Map as M
+import System.Console.Haskeline
+import Data.Maybe (mapMaybe)
+import Data.List (intersperse)
+import Control.Monad.IO.Class (MonadIO)
+
+-- Printers
+
+-- |
+-- Pretty print a module's signatures
+--
+printModuleSignatures :: MonadIO m => P.ModuleName -> P.Environment -> InputT m ()
+printModuleSignatures moduleName (P.Environment {..}) =
+ -- get relevant components of a module from environment
+ let moduleNamesIdent = (filter ((== moduleName) . fst) . M.keys) names
+ moduleTypeClasses = (filter (\(P.Qualified maybeName _) -> maybeName == Just moduleName) . M.keys) typeClasses
+ moduleTypes = (filter (\(P.Qualified maybeName _) -> maybeName == Just moduleName) . M.keys) types
+
+ in
+ -- print each component
+ (outputStr . unlines . map trimEnd . lines . Box.render . Box.vsep 1 Box.left)
+ [ printModule's (mapMaybe (showTypeClass . findTypeClass typeClasses)) moduleTypeClasses -- typeClasses
+ , printModule's (mapMaybe (showType typeClasses dataConstructors typeSynonyms . findType types)) moduleTypes -- types
+ , printModule's (map (showNameType . findNameType names)) moduleNamesIdent -- functions
+ ]
+
+ where printModule's showF = Box.vsep 1 Box.left . showF
+
+ findNameType :: M.Map (P.ModuleName, P.Ident) (P.Type, P.NameKind, P.NameVisibility) -> (P.ModuleName, P.Ident) -> (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility))
+ findNameType envNames m@(_, mIdent) = (mIdent, M.lookup m envNames)
+
+ showNameType :: (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility)) -> Box.Box
+ showNameType (mIdent, Just (mType, _, _)) = Box.text (P.showIdent mIdent ++ " :: ") Box.<> P.typeAsBox mType
+ showNameType _ = P.internalError "The impossible happened in printModuleSignatures."
+
+ findTypeClass
+ :: M.Map (P.Qualified (P.ProperName 'P.ClassName)) ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint])
+ -> P.Qualified (P.ProperName 'P.ClassName)
+ -> (P.Qualified (P.ProperName 'P.ClassName), Maybe ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint]))
+ findTypeClass envTypeClasses name = (name, M.lookup name envTypeClasses)
+
+ showTypeClass
+ :: (P.Qualified (P.ProperName 'P.ClassName), Maybe ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint]))
+ -> Maybe Box.Box
+ showTypeClass (_, Nothing) = Nothing
+ showTypeClass (P.Qualified _ name, Just (vars, body, constrs)) =
+ let constraints =
+ if null constrs
+ then Box.text ""
+ else Box.text "("
+ Box.<> Box.hcat Box.left (intersperse (Box.text ", ") $ map (\(P.Qualified _ pn, lt) -> Box.text (P.runProperName pn) Box.<+> Box.hcat Box.left (map P.typeAtomAsBox lt)) constrs)
+ Box.<> Box.text ") <= "
+ className =
+ Box.text (P.runProperName name)
+ Box.<> Box.text (concatMap ((' ':) . fst) vars)
+ classBody =
+ Box.vcat Box.top (map (\(i, t) -> Box.text (P.showIdent i ++ " ::") Box.<+> P.typeAsBox t) body)
+
+ in
+ Just $
+ (Box.text "class "
+ Box.<> constraints
+ Box.<> className
+ Box.<+> if null body then Box.text "" else Box.text "where")
+ Box.// Box.moveRight 2 classBody
+
+
+ findType
+ :: M.Map (P.Qualified (P.ProperName 'P.TypeName)) (P.Kind, P.TypeKind)
+ -> P.Qualified (P.ProperName 'P.TypeName)
+ -> (P.Qualified (P.ProperName 'P.TypeName), Maybe (P.Kind, P.TypeKind))
+ findType envTypes name = (name, M.lookup name envTypes)
+
+ showType
+ :: M.Map (P.Qualified (P.ProperName 'P.ClassName)) ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint])
+ -> M.Map (P.Qualified (P.ProperName 'P.ConstructorName)) (P.DataDeclType, P.ProperName 'P.TypeName, P.Type, [P.Ident])
+ -> M.Map (P.Qualified (P.ProperName 'P.TypeName)) ([(String, Maybe P.Kind)], P.Type)
+ -> (P.Qualified (P.ProperName 'P.TypeName), Maybe (P.Kind, P.TypeKind))
+ -> Maybe Box.Box
+ showType typeClassesEnv dataConstructorsEnv typeSynonymsEnv (n@(P.Qualified modul name), typ) =
+ case (typ, M.lookup n typeSynonymsEnv) of
+ (Just (_, P.TypeSynonym), Just (typevars, dtType)) ->
+ if M.member (fmap P.coerceProperName n) typeClassesEnv
+ then
+ Nothing
+ else
+ Just $
+ Box.text ("type " ++ P.runProperName name ++ concatMap ((' ':) . fst) typevars)
+ Box.// Box.moveRight 2 (Box.text "=" Box.<+> P.typeAsBox dtType)
+
+ (Just (_, P.DataType typevars pt), _) ->
+ let prefix =
+ case pt of
+ [(dtProperName,_)] ->
+ case M.lookup (P.Qualified modul dtProperName) dataConstructorsEnv of
+ Just (dataDeclType, _, _, _) -> P.showDataDeclType dataDeclType
+ _ -> "data"
+ _ -> "data"
+
+ in
+ Just $ Box.text (prefix ++ " " ++ P.runProperName name ++ concatMap ((' ':) . fst) typevars) Box.// printCons pt
+
+ _ ->
+ Nothing
+
+ where printCons pt =
+ Box.moveRight 2 $
+ Box.vcat Box.left $
+ mapFirstRest (Box.text "=" Box.<+>) (Box.text "|" Box.<+>) $
+ map (\(cons,idents) -> (Box.text (P.runProperName cons) Box.<> Box.hcat Box.left (map prettyPrintType idents))) pt
+
+ prettyPrintType t = Box.text " " Box.<> P.typeAtomAsBox t
+
+ mapFirstRest _ _ [] = []
+ mapFirstRest f g (x:xs) = f x : map g xs
+
+ trimEnd = reverse . dropWhile (== ' ') . reverse
+
+-- | Pretty-print errors
+printErrors :: MonadIO m => P.MultipleErrors -> InputT m ()
+printErrors = outputStrLn . P.prettyPrintMultipleErrors False
diff --git a/psci/Types.hs b/psci/PSCi/Types.hs
index 7465cdf..3627d41 100644
--- a/psci/Types.hs
+++ b/psci/PSCi/Types.hs
@@ -13,7 +13,10 @@
--
-----------------------------------------------------------------------------
-module Types where
+module PSCi.Types where
+
+import Prelude ()
+import Prelude.Compat
import Control.Arrow (second)
import Data.Map (Map)
diff --git a/purescript.cabal b/purescript.cabal
index a1a21a8..dd4cf02 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,5 +1,5 @@
name: purescript
-version: 0.8.0.0
+version: 0.8.1.0
cabal-version: >=1.8
build-type: Simple
license: MIT
@@ -14,9 +14,10 @@ Homepage: http://www.purescript.org/
author: Phil Freeman <paf31@cantab.net>,
Gary Burgess <gary.burgess@gmail.com>,
Hardy Jones <jones3.hardy@gmail.com>,
- Harry Garrood <harry@garrood.me>
+ Harry Garrood <harry@garrood.me>,
+ Christoph Hegemann <christoph.hegemann1337@gmail.com>
-tested-with: GHC==7.8
+tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.1
extra-source-files: examples/passing/*.purs
, examples/failing/*.purs
@@ -25,9 +26,15 @@ extra-source-files: examples/passing/*.purs
, examples/docs/src/*.purs
, tests/support/setup.js
, tests/support/package.json
+ , tests/support/prelude/bower.json
+ , tests/support/prelude/src/*.purs
+ , tests/support/prelude/src/*.js
+ , tests/support/prelude/LICENSE
, tests/support/bower.json
, tests/support/setup-win.cmd
- , psci/tests/data/Sample.purs
+ , tests/support/flattened/*.purs
+ , tests/support/flattened/*.js
+ , tests/support/psci/*.purs
, stack.yaml
, stack-lts-2.yaml
, stack-lts-3.yaml
@@ -54,13 +61,13 @@ library
filepath -any,
mtl >= 2.1.0 && < 2.3.0,
parsec -any,
- transformers >= 0.3.0 && < 0.5,
+ transformers >= 0.3.0 && < 0.6,
transformers-compat >= 0.3.0,
utf8-string >= 1 && < 2,
pattern-arrows >= 0.0.2 && < 0.1,
time -any,
boxes >= 0.1.4 && < 0.2.0,
- aeson >= 0.8 && < 0.11,
+ aeson >= 0.8 && < 0.12,
vector -any,
bower-json >= 0.7,
aeson-better-errors >= 0.8,
@@ -70,10 +77,19 @@ library
language-javascript == 0.5.*,
syb -any,
Glob >= 0.7 && < 0.8,
- process >= 1.2.0 && < 1.4,
+ process >= 1.2.0 && < 1.5,
safe >= 0.3.9 && < 0.4,
semigroups >= 0.16.2 && < 0.19,
- parallel >= 3.2 && < 3.3
+ parallel >= 3.2 && < 3.3,
+ sourcemap >= 0.1.6,
+ stm >= 0.2.4.0,
+ regex-tdfa -any,
+ edit-distance -any,
+ fsnotify >= 0.2.1,
+ monad-logger >= 0.3 && < 0.4,
+ pipes >= 4.0.0 && < 4.2.0 ,
+ pipes-http -any,
+ http-types -any
exposed-modules: Language.PureScript
Language.PureScript.AST
@@ -143,6 +159,9 @@ library
Language.PureScript.Sugar.Names.Exports
Language.PureScript.Sugar.ObjectWildcards
Language.PureScript.Sugar.Operators
+ Language.PureScript.Sugar.Operators.Common
+ Language.PureScript.Sugar.Operators.Expr
+ Language.PureScript.Sugar.Operators.Binders
Language.PureScript.Sugar.TypeClasses
Language.PureScript.Sugar.TypeClasses.Deriving
Language.PureScript.Sugar.TypeDeclarations
@@ -170,7 +189,7 @@ library
Language.PureScript.Docs.RenderedCode.Types
Language.PureScript.Docs.RenderedCode.Render
Language.PureScript.Docs.AsMarkdown
- Language.PureScript.Docs.ParseAndDesugar
+ Language.PureScript.Docs.ParseAndBookmark
Language.PureScript.Docs.Utils.MonoidExtras
Language.PureScript.Publish
@@ -178,6 +197,22 @@ library
Language.PureScript.Publish.ErrorsWarnings
Language.PureScript.Publish.BoxesHelpers
+ Language.PureScript.Ide
+ Language.PureScript.Ide.Command
+ Language.PureScript.Ide.Externs
+ Language.PureScript.Ide.Error
+ Language.PureScript.Ide.CodecJSON
+ Language.PureScript.Ide.Pursuit
+ Language.PureScript.Ide.Completion
+ Language.PureScript.Ide.Matcher
+ Language.PureScript.Ide.Filter
+ Language.PureScript.Ide.Types
+ Language.PureScript.Ide.State
+ Language.PureScript.Ide.CaseSplit
+ Language.PureScript.Ide.SourceFile
+ Language.PureScript.Ide.Watcher
+ Language.PureScript.Ide.Reexports
+
Control.Monad.Logger
Control.Monad.Supply
Control.Monad.Supply.Class
@@ -196,11 +231,11 @@ executable psc
containers -any, directory -any, filepath -any,
mtl -any, optparse-applicative >= 0.10.0, parsec -any, purescript -any,
time -any, transformers -any, transformers-compat -any, Glob >= 0.7 && < 0.8,
- aeson >= 0.8 && < 0.11, bytestring -any, utf8-string >= 1 && < 2
+ aeson >= 0.8 && < 0.12, bytestring -any, utf8-string >= 1 && < 2
main-is: Main.hs
buildable: True
hs-source-dirs: psc
- other-modules: JSON
+ other-modules: JSON, Paths_purescript
ghc-options: -Wall -O2 -fno-warn-unused-do-bind -threaded -rtsopts "-with-rtsopts=-N"
executable psci
@@ -213,12 +248,17 @@ executable psci
main-is: Main.hs
buildable: True
hs-source-dirs: psci psci/main
- other-modules: Types
- Parser
- Directive
- Completion
- PSCi
- IO
+ other-modules: PSCi
+ PSCi.Types
+ PSCi.Parser
+ PSCi.Directive
+ PSCi.Completion
+ PSCi.IO
+ PSCi.Message
+ PSCi.Option
+ PSCi.Module
+ PSCi.Printer
+ Paths_purescript
ghc-options: -Wall -O2
executable psc-docs
@@ -228,6 +268,7 @@ executable psc-docs
filepath -any, Glob -any, transformers -any,
transformers-compat -any
main-is: Main.hs
+ other-modules: Paths_purescript
buildable: True
hs-source-dirs: psc-docs
other-modules: Ctags
@@ -238,6 +279,7 @@ executable psc-docs
executable psc-publish
build-depends: base >=4 && <5, purescript -any, bytestring -any, aeson -any, optparse-applicative -any
main-is: Main.hs
+ other-modules: Paths_purescript
buildable: True
hs-source-dirs: psc-publish
ghc-options: -Wall -O2
@@ -247,6 +289,7 @@ executable psc-hierarchy
process -any, mtl -any, parsec -any, filepath -any, directory -any,
Glob -any
main-is: Main.hs
+ other-modules: Paths_purescript
buildable: True
hs-source-dirs: hierarchy
other-modules:
@@ -254,7 +297,7 @@ executable psc-hierarchy
executable psc-bundle
main-is: Main.hs
- other-modules:
+ other-modules: Paths_purescript
other-extensions:
build-depends: base >=4 && <5,
purescript -any,
@@ -268,29 +311,55 @@ executable psc-bundle
ghc-options: -Wall -O2
hs-source-dirs: psc-bundle
+executable psc-ide-server
+ main-is: Main.hs
+ other-modules:
+ other-extensions:
+ build-depends: base >=4 && <5
+ , purescript -any
+ , directory -any
+ , filepath -any
+ , monad-logger -any
+ , mtl -any
+ , transformers -any
+ , transformers-compat -any
+ , network -any
+ , optparse-applicative >= 0.10.0
+ , stm -any
+ , text -any
+ , base-compat >=0.6.0
+ ghc-options: -Wall -O2 -threaded
+ hs-source-dirs: psc-ide-server
+
+executable psc-ide-client
+ main-is: Main.hs
+ other-modules:
+ other-extensions:
+ build-depends: base >=4 && <5
+ , mtl -any
+ , text -any
+ , optparse-applicative >= 0.10.0
+ , network -any
+ , base-compat >=0.6.0
+ ghc-options: -Wall -O2
+ hs-source-dirs: psc-ide-client
+
test-suite tests
build-depends: base >=4 && <5, containers -any, directory -any,
filepath -any, mtl -any, parsec -any, purescript -any,
transformers -any, process -any, transformers-compat -any, time -any,
Glob -any, aeson-better-errors -any, bytestring -any, aeson -any,
- base-compat -any
+ base-compat -any, haskeline >= 0.7.0.0, optparse-applicative -any,
+ boxes -any, HUnit -any, hspec -any, hspec-discover -any, stm -any, text -any
+ ghc-options: -Wall
type: exitcode-stdio-1.0
main-is: Main.hs
- other-modules: TestsSetup
- TestPscPublish
+ other-modules: TestUtils
+ TestCompiler
TestDocs
+ TestPscPublish
+ TestPsci
+ TestPscIde
+ PscIdeSpec
buildable: True
- hs-source-dirs: tests tests/common
-
-test-suite psci-tests
- build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,
- mtl -any, optparse-applicative >= 0.10.0, parsec -any,
- haskeline >= 0.7.0.0, purescript -any, transformers -any,
- transformers-compat -any, process -any, HUnit -any, time -any,
- Glob -any, base-compat >=0.6.0, boxes >= 0.1.4 && < 0.2.0
- type: exitcode-stdio-1.0
- main-is: Main.hs
- other-modules: TestsSetup
- buildable: True
- hs-source-dirs: psci psci/tests tests/common
- ghc-options: -Wall
+ hs-source-dirs: tests psci
diff --git a/src/Language/PureScript/AST/Binders.hs b/src/Language/PureScript/AST/Binders.hs
index d0b6b81..2ff3fe4 100644
--- a/src/Language/PureScript/AST/Binders.hs
+++ b/src/Language/PureScript/AST/Binders.hs
@@ -41,6 +41,24 @@ data Binder
--
| ConstructorBinder (Qualified (ProperName 'ConstructorName)) [Binder]
-- |
+ -- A operator alias binder. During the rebracketing phase of desugaring,
+ -- this data constructor will be removed.
+ --
+ | OpBinder (Qualified Ident)
+ -- |
+ -- Binary operator application. During the rebracketing phase of desugaring,
+ -- this data constructor will be removed.
+ --
+ | BinaryNoParensBinder Binder Binder Binder
+ -- |
+ -- Explicit parentheses. During the rebracketing phase of desugaring, this
+ -- data constructor will be removed.
+ --
+ -- Note: although it seems this constructor is not used, it _is_ useful,
+ -- since it prevents certain traversals from matching.
+ --
+ | ParensInBinder Binder
+ -- |
-- A binder which matches a record and binds its properties
--
| ObjectBinder [(String, Binder)]
@@ -70,6 +88,8 @@ binderNames = go []
where
go ns (VarBinder name) = name : ns
go ns (ConstructorBinder _ bs) = foldl go ns bs
+ go ns (BinaryNoParensBinder b1 b2 b3) = foldl go ns [b1, b2, b3]
+ go ns (ParensInBinder b) = go ns b
go ns (ObjectBinder bs) = foldl go ns (map snd bs)
go ns (ArrayBinder bs) = foldl go ns bs
go ns (NamedBinder name b) = go (name : ns) b
diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs
index 858df12..2b92a04 100644
--- a/src/Language/PureScript/AST/Declarations.hs
+++ b/src/Language/PureScript/AST/Declarations.hs
@@ -189,7 +189,7 @@ data Declaration
-- |
-- A fixity declaration (fixity data, operator name, value the operator is an alias for)
--
- | FixityDeclaration Fixity String (Maybe (Qualified Ident))
+ | FixityDeclaration Fixity String (Maybe (Either (Qualified Ident) (Qualified (ProperName 'ConstructorName))))
-- |
-- A module import (module name, qualified/unqualified/hiding, optional "qualified as" name)
-- TODO: also a boolean specifying whether the old `qualified` syntax was used, so a warning can be raised in desugaring (remove for 0.9)
@@ -337,6 +337,9 @@ data Expr
-- Explicit parentheses. During the rebracketing phase of desugaring, this data constructor
-- will be removed.
--
+ -- Note: although it seems this constructor is not used, it _is_ useful, since it prevents
+ -- certain traversals from matching.
+ --
| Parens Expr
-- |
-- Operator section. This will be removed during desugaring and replaced with a partially applied
@@ -352,11 +355,6 @@ data Expr
--
| ObjectLiteral [(String, Expr)]
-- |
- -- An object constructor (object literal with underscores). This will be removed during
- -- desugaring and expanded into a lambda that returns an object literal.
- --
- | ObjectConstructor [(String, Maybe Expr)]
- -- |
-- An object property getter (e.g. `_.x`). This will be removed during
-- desugaring and expanded into a lambda that reads a property from an object.
--
@@ -370,11 +368,6 @@ data Expr
--
| ObjectUpdate Expr [(String, Expr)]
-- |
- -- Partial record updater. This will be removed during desugaring and
- -- expanded into a lambda that returns an object update.
- --
- | ObjectUpdater (Maybe Expr) [(String, Maybe Expr)]
- -- |
-- Function introduction
--
| Abs (Either Ident Binder) Expr
@@ -433,6 +426,10 @@ data Expr
--
| SuperClassDictionary (Qualified (ProperName 'ClassName)) [Type]
-- |
+ -- A placeholder for an anonymous function argument
+ --
+ | AnonymousArgument
+ -- |
-- A value with source position information
--
| PositionedValue SourceSpan [Comment] Expr
diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs
index 0f7e62c..ce800a2 100644
--- a/src/Language/PureScript/AST/Traversals.hs
+++ b/src/Language/PureScript/AST/Traversals.hs
@@ -23,7 +23,7 @@ import Data.Foldable (fold)
import qualified Data.Set as S
import Control.Monad
-import Control.Arrow ((***), (+++), second)
+import Control.Arrow ((***), (+++))
import Language.PureScript.AST.Binders
import Language.PureScript.AST.Declarations
@@ -54,11 +54,9 @@ everywhereOnValues f g h = (f', g', h')
g' (OperatorSection op (Right v)) = g (OperatorSection (g' op) (Right $ g' v))
g' (ArrayLiteral vs) = g (ArrayLiteral (map g' vs))
g' (ObjectLiteral vs) = g (ObjectLiteral (map (fmap g') vs))
- g' (ObjectConstructor vs) = g (ObjectConstructor (map (second (fmap g')) vs))
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' (ObjectUpdater obj vs) = g (ObjectUpdater (fmap g' obj) (map (second (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))
@@ -71,6 +69,8 @@ everywhereOnValues f g h = (f', g', h')
h' :: Binder -> Binder
h' (ConstructorBinder ctor bs) = h (ConstructorBinder ctor (map h' bs))
+ h' (BinaryNoParensBinder b1 b2 b3) = h (BinaryNoParensBinder (h' b1) (h' b2) (h' b3))
+ h' (ParensInBinder b) = h (ParensInBinder (h' b))
h' (ObjectBinder bs) = h (ObjectBinder (map (fmap h') bs))
h' (ArrayBinder bs) = h (ArrayBinder (map h' bs))
h' (NamedBinder name b) = h (NamedBinder name (h' b))
@@ -112,11 +112,9 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)
g' (OperatorSection op (Right v)) = OperatorSection <$> (g op >>= g') <*> (Right <$> (g v >>= g'))
g' (ArrayLiteral vs) = ArrayLiteral <$> traverse (g' <=< g) vs
g' (ObjectLiteral vs) = ObjectLiteral <$> traverse (sndM (g' <=< g)) vs
- g' (ObjectConstructor vs) = ObjectConstructor <$> traverse (sndM $ maybeM (g' <=< g)) vs
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' (ObjectUpdater obj vs) = ObjectUpdater <$> (maybeM g obj >>= maybeM g') <*> traverse (sndM $ maybeM (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')
@@ -128,6 +126,8 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)
g' other = g other
h' (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> traverse (h' <=< h) bs
+ h' (BinaryNoParensBinder b1 b2 b3) = BinaryNoParensBinder <$> (h b1 >>= h') <*> (h b2 >>= h') <*> (h b3 >>= h')
+ h' (ParensInBinder b) = ParensInBinder <$> (h b >>= h')
h' (ObjectBinder bs) = ObjectBinder <$> traverse (sndM (h' <=< h)) bs
h' (ArrayBinder bs) = ArrayBinder <$> traverse (h' <=< h) bs
h' (NamedBinder name b) = NamedBinder name <$> (h b >>= h')
@@ -165,11 +165,9 @@ everywhereOnValuesM f g h = (f', g', h')
g' (OperatorSection op (Right v)) = (OperatorSection <$> g' op <*> (Right <$> g' v)) >>= g
g' (ArrayLiteral vs) = (ArrayLiteral <$> traverse g' vs) >>= g
g' (ObjectLiteral vs) = (ObjectLiteral <$> traverse (sndM g') vs) >>= g
- g' (ObjectConstructor vs) = (ObjectConstructor <$> traverse (sndM $ maybeM g') vs) >>= g
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' (ObjectUpdater obj vs) = (ObjectUpdater <$> maybeM g' obj <*> traverse (sndM $ maybeM 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
@@ -181,6 +179,8 @@ everywhereOnValuesM f g h = (f', g', h')
g' other = g other
h' (ConstructorBinder ctor bs) = (ConstructorBinder ctor <$> traverse h' bs) >>= h
+ h' (BinaryNoParensBinder b1 b2 b3) = (BinaryNoParensBinder <$> h' b1 <*> h' b2 <*> h' b3) >>= h
+ h' (ParensInBinder b) = (ParensInBinder <$> h' b) >>= h
h' (ObjectBinder bs) = (ObjectBinder <$> traverse (sndM h') bs) >>= h
h' (ArrayBinder bs) = (ArrayBinder <$> traverse h' bs) >>= h
h' (NamedBinder name b) = (NamedBinder name <$> h' b) >>= h
@@ -221,11 +221,9 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j')
g' v@(OperatorSection op (Right v1)) = g v <> g' op <> g' v1
g' v@(ArrayLiteral vs) = foldl (<>) (g v) (map g' vs)
g' v@(ObjectLiteral vs) = foldl (<>) (g v) (map (g' . snd) vs)
- g' v@(ObjectConstructor vs) = foldl (<>) (g v) (map g' (mapMaybe snd vs))
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@(ObjectUpdater obj vs) = foldl (<>) (maybe (g v) (\x -> g v <> g' x) obj) (map g' (mapMaybe snd 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
@@ -237,6 +235,8 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j')
g' v = g v
h' b@(ConstructorBinder _ bs) = foldl (<>) (h b) (map h' bs)
+ h' b@(BinaryNoParensBinder b1 b2 b3) = h b <> h' b1 <> h' b2 <> h' b3
+ h' b@(ParensInBinder b1) = h b <> h' b1
h' b@(ObjectBinder bs) = foldl (<>) (h b) (map (h' . snd) bs)
h' b@(ArrayBinder bs) = foldl (<>) (h b) (map h' bs)
h' b@(NamedBinder _ b1) = h b <> h' b1
@@ -288,11 +288,9 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'
g' s (OperatorSection op (Right v)) = g'' s op <> g'' s v
g' s (ArrayLiteral vs) = foldl (<>) r0 (map (g'' s) vs)
g' s (ObjectLiteral vs) = foldl (<>) r0 (map (g'' s . snd) vs)
- g' s (ObjectConstructor vs) = foldl (<>) r0 (map (g'' s) (mapMaybe snd vs))
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 (ObjectUpdater obj vs) = foldl (<>) (maybe r0 (g'' s) obj) (map (g'' s) (mapMaybe snd 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
@@ -306,6 +304,8 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'
h'' s b = let (s', r) = h s b in r <> h' s' b
h' s (ConstructorBinder _ bs) = foldl (<>) r0 (map (h'' s) bs)
+ h' s (BinaryNoParensBinder b1 b2 b3) = h'' s b1 <> h'' s b2 <> h'' s b3
+ h' s (ParensInBinder b) = h'' s b
h' s (ObjectBinder bs) = foldl (<>) r0 (map (h'' s . snd) bs)
h' s (ArrayBinder bs) = foldl (<>) r0 (map (h'' s) bs)
h' s (NamedBinder _ b1) = h'' s b1
@@ -358,11 +358,9 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j
g' s (OperatorSection op (Right v)) = OperatorSection <$> g'' s op <*> (Right <$> g'' s v)
g' s (ArrayLiteral vs) = ArrayLiteral <$> traverse (g'' s) vs
g' s (ObjectLiteral vs) = ObjectLiteral <$> traverse (sndM (g'' s)) vs
- g' s (ObjectConstructor vs) = ObjectConstructor <$> traverse (sndM $ maybeM (g'' s)) vs
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 (ObjectUpdater obj vs) = ObjectUpdater <$> maybeM (g'' s) obj <*> traverse (sndM $ maybeM (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
@@ -376,6 +374,8 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j
h'' s = uncurry h' <=< h s
h' s (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> traverse (h'' s) bs
+ h' s (BinaryNoParensBinder b1 b2 b3) = BinaryNoParensBinder <$> h'' s b1 <*> h'' s b2 <*> h'' s b3
+ h' s (ParensInBinder b) = ParensInBinder <$> h'' s b
h' s (ObjectBinder bs) = ObjectBinder <$> traverse (sndM (h'' s)) bs
h' s (ArrayBinder bs) = ArrayBinder <$> traverse (h'' s) bs
h' s (NamedBinder name b) = NamedBinder name <$> h'' s b
@@ -440,11 +440,9 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)
g' s (OperatorSection op (Right v)) = g'' s op <> g'' s v
g' s (ArrayLiteral vs) = foldMap (g'' s) vs
g' s (ObjectLiteral vs) = foldMap (g'' s . snd) vs
- g' s (ObjectConstructor vs) = foldMap (g'' s) (mapMaybe snd vs)
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 (ObjectUpdater obj vs) = foldMap (g'' s) obj <> foldMap (g'' s) (mapMaybe snd vs)
g' s (Abs (Left name) v1) =
let s' = S.insert name s
in g'' s' v1
@@ -465,11 +463,11 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)
h'' s a = h s a <> h' s a
h' s (ConstructorBinder _ bs) = foldMap (h'' s) bs
+ h' s (BinaryNoParensBinder b1 b2 b3) = foldMap (h'' s) [b1, b2, b3]
+ h' s (ParensInBinder b) = h'' s b
h' s (ObjectBinder bs) = foldMap (h'' s . snd) bs
h' s (ArrayBinder bs) = foldMap (h'' s) bs
- h' s (NamedBinder name b1) =
- let s' = S.insert name s
- in h'' s' b1
+ h' s (NamedBinder name b1) = h'' (S.insert name s) b1
h' s (PositionedBinder _ _ b1) = h'' s b1
h' s (TypedBinder _ b1) = h'' s b1
h' _ _ = mempty
diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index c77df0f..3b2de22 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -55,21 +55,21 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
rethrow (addHint (ErrorInModule mn)) $ do
let usedNames = concatMap getNames decls
let mnLookup = renameImports usedNames imps
- jsImports <- T.traverse (importToJs mnLookup) . delete (ModuleName [ProperName C.prim]) . (\\ [mn]) $ imps
+ jsImports <- T.traverse (importToJs mnLookup) . delete (ModuleName [ProperName C.prim]) . (\\ [mn]) $ map snd $ imps
let decls' = renameModules mnLookup decls
jsDecls <- mapM bindToJs decls'
optimized <- T.traverse (T.traverse optimize) jsDecls
F.traverse_ (F.traverse_ checkIntegers) optimized
comments <- not <$> asks optionsNoComments
- let strict = JSStringLiteral "use strict"
- let header = if comments && not (null coms) then JSComment coms strict else strict
- let foreign' = [JSVariableIntroduction "$foreign" foreign_ | not $ null foreigns || isNothing foreign_]
+ let strict = JSStringLiteral Nothing "use strict"
+ let header = if comments && not (null coms) then JSComment Nothing coms strict else strict
+ let foreign' = [JSVariableIntroduction Nothing "$foreign" foreign_ | not $ null foreigns || isNothing foreign_]
let moduleBody = header : foreign' ++ jsImports ++ concat optimized
let foreignExps = exps `intersect` (fst `map` foreigns)
let standardExps = exps \\ foreignExps
- let exps' = JSObjectLiteral $ map (runIdent &&& JSVar . identToJs) standardExps
+ let exps' = JSObjectLiteral Nothing $ map (runIdent &&& (JSVar Nothing) . identToJs) standardExps
++ map (runIdent &&& foreignIdent) foreignExps
- return $ moduleBody ++ [JSAssignment (JSAccessor "exports" (JSVar "module")) exps']
+ return $ moduleBody ++ [JSAssignment Nothing (JSAccessor Nothing "exports" (JSVar Nothing "module")) exps']
where
@@ -77,23 +77,23 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
-- Extracts all declaration names from a binding group.
--
getNames :: Bind Ann -> [Ident]
- getNames (NonRec ident _) = [ident]
- getNames (Rec vals) = map fst vals
+ getNames (NonRec _ ident _) = [ident]
+ getNames (Rec vals) = map (snd . fst) vals
-- |
-- Creates alternative names for each module to ensure they don't collide
-- with declaration names.
--
- renameImports :: [Ident] -> [ModuleName] -> M.Map ModuleName ModuleName
+ renameImports :: [Ident] -> [(Ann, ModuleName)] -> M.Map ModuleName (Ann, ModuleName)
renameImports ids mns = go M.empty ids mns
where
- go :: M.Map ModuleName ModuleName -> [Ident] -> [ModuleName] -> M.Map ModuleName ModuleName
- go acc used (mn' : mns') =
+ go :: M.Map ModuleName (Ann, ModuleName) -> [Ident] -> [(Ann, ModuleName)] -> M.Map ModuleName (Ann, ModuleName)
+ go acc used ((ann, mn') : mns') =
let mni = Ident $ runModuleName mn'
in if mn' /= mn && mni `elem` used
then let newName = freshModuleName 1 mn' used
- in go (M.insert mn' newName acc) (Ident (runModuleName newName) : used) mns'
- else go (M.insert mn' mn' acc) (mni : used) mns'
+ in go (M.insert mn' (ann, newName) acc) (Ident (runModuleName newName) : used) mns'
+ else go (M.insert mn' (ann, mn') acc) (mni : used) mns'
go acc _ [] = acc
freshModuleName :: Integer -> ModuleName -> [Ident] -> ModuleName
@@ -107,18 +107,18 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
-- Generates Javascript code for a module import, binding the required module
-- to the alternative
--
- importToJs :: M.Map ModuleName ModuleName -> ModuleName -> m JS
+ importToJs :: M.Map ModuleName (Ann, ModuleName) -> ModuleName -> m JS
importToJs mnLookup mn' = do
path <- asks optionsRequirePath
- let mnSafe = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup
- let moduleBody = JSApp (JSVar "require") [JSStringLiteral (maybe id (</>) path $ runModuleName mn')]
- return $ JSVariableIntroduction (moduleNameToJs mnSafe) (Just moduleBody)
+ let ((ss, _, _, _), mnSafe) = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup
+ let moduleBody = JSApp Nothing (JSVar Nothing "require") [JSStringLiteral Nothing (maybe id (</>) path $ runModuleName mn')]
+ withPos ss $ JSVariableIntroduction Nothing (moduleNameToJs mnSafe) (Just moduleBody)
-- |
-- Replaces the `ModuleName`s in the AST so that the generated code refers to
-- the collision-avoiding renamed module imports.
--
- renameModules :: M.Map ModuleName ModuleName -> [Bind Ann] -> [Bind Ann]
+ renameModules :: M.Map ModuleName (Ann, ModuleName) -> [Bind Ann] -> [Bind Ann]
renameModules mnLookup binds =
let (f, _, _) = everywhereOnValues id goExpr goBinder
in map f binds
@@ -131,7 +131,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
goBinder b = b
renameQual :: Qualified a -> Qualified a
renameQual (Qualified (Just mn') a) =
- let mnSafe = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup
+ let (_,mnSafe) = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup
in Qualified (Just mnSafe) a
renameQual q = q
@@ -139,8 +139,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 ident val) = return <$> nonRecToJS ident val
- bindToJs (Rec vals) = forM vals (uncurry nonRecToJS)
+ bindToJs (NonRec ann ident val) = return <$> nonRecToJS ann ident val
+ bindToJs (Rec vals) = forM vals (uncurry . uncurry $ nonRecToJS)
-- |
-- Generate code in the simplified Javascript intermediate representation for a single non-recursive
@@ -148,22 +148,30 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
--
-- The main purpose of this function is to handle code generation for comments.
--
- nonRecToJS :: Ident -> Expr Ann -> m JS
- nonRecToJS i e@(extractAnn -> (_, com, _, _)) | not (null com) = do
+ nonRecToJS :: Ann -> Ident -> Expr Ann -> m JS
+ nonRecToJS a i e@(extractAnn -> (_, com, _, _)) | not (null com) = do
withoutComment <- asks optionsNoComments
if withoutComment
- then nonRecToJS i (modifyAnn removeComments e)
- else JSComment com <$> nonRecToJS i (modifyAnn removeComments e)
- nonRecToJS ident val = do
+ then nonRecToJS a i (modifyAnn removeComments e)
+ else JSComment Nothing com <$> nonRecToJS a i (modifyAnn removeComments e)
+ nonRecToJS (ss, _, _, _) ident val = do
js <- valueToJs val
- return $ JSVariableIntroduction (identToJs ident) (Just js)
+ withPos ss $ JSVariableIntroduction Nothing (identToJs ident) (Just js)
+
+ withPos :: Maybe SourceSpan -> JS -> m JS
+ withPos (Just ss) js = do
+ withSM <- asks optionsSourceMaps
+ return $ if withSM
+ then withSourceSpan ss js
+ else js
+ withPos Nothing js = return js
-- |
-- Generate code in the simplified Javascript intermediate representation for a variable based on a
-- PureScript identifier.
--
var :: Ident -> JS
- var = JSVar . identToJs
+ var = JSVar Nothing . identToJs
-- |
-- Generate code in the simplified Javascript intermediate representation for an accessor based on
@@ -172,102 +180,106 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
--
accessor :: Ident -> JS -> JS
accessor (Ident prop) = accessorString prop
- accessor (Op op) = JSIndexer (JSStringLiteral op)
+ accessor (Op op) = JSIndexer Nothing (JSStringLiteral Nothing op)
accessor (GenIdent _ _) = internalError "GenIdent in accessor"
accessorString :: String -> JS -> JS
- accessorString prop | identNeedsEscaping prop = JSIndexer (JSStringLiteral prop)
- | otherwise = JSAccessor prop
+ accessorString prop | identNeedsEscaping prop = JSIndexer Nothing (JSStringLiteral Nothing prop)
+ | otherwise = JSAccessor Nothing prop
-- |
-- Generate code in the simplified Javascript intermediate representation for a value or expression.
--
valueToJs :: Expr Ann -> m JS
- valueToJs (Literal (pos, _, _, _) l) =
+ valueToJs e =
+ let (ss, _, _, _) = extractAnn e in
+ withPos ss =<< valueToJs' e
+
+ valueToJs' :: Expr Ann -> m JS
+ valueToJs' (Literal (pos, _, _, _) l) =
maybe id rethrowWithPosition pos $ literalToValueJS l
- valueToJs (Var (_, _, _, Just (IsConstructor _ [])) name) =
- return $ JSAccessor "value" $ qualifiedToJS id name
- valueToJs (Var (_, _, _, Just (IsConstructor _ _)) name) =
- return $ JSAccessor "create" $ qualifiedToJS id name
- valueToJs (Accessor _ prop val) =
+ valueToJs' (Var (_, _, _, Just (IsConstructor _ [])) name) =
+ return $ JSAccessor Nothing "value" $ qualifiedToJS id name
+ valueToJs' (Var (_, _, _, Just (IsConstructor _ _)) name) =
+ return $ JSAccessor Nothing "create" $ qualifiedToJS id name
+ valueToJs' (Accessor _ prop val) =
accessorString prop <$> valueToJs val
- valueToJs (ObjectUpdate _ o ps) = do
+ valueToJs' (ObjectUpdate _ o ps) = do
obj <- valueToJs o
sts <- mapM (sndM valueToJs) ps
extendObj obj sts
- valueToJs e@(Abs (_, _, _, Just IsTypeClassConstructor) _ _) =
+ valueToJs' e@(Abs (_, _, _, Just IsTypeClassConstructor) _ _) =
let args = unAbs e
- in return $ JSFunction Nothing (map identToJs args) (JSBlock $ map assign args)
+ in return $ JSFunction Nothing Nothing (map identToJs args) (JSBlock Nothing $ map assign args)
where
unAbs :: Expr Ann -> [Ident]
unAbs (Abs _ arg val) = arg : unAbs val
unAbs _ = []
assign :: Ident -> JS
- assign name = JSAssignment (accessorString (runIdent name) (JSVar "this"))
+ assign name = JSAssignment Nothing (accessorString (runIdent name) (JSVar Nothing "this"))
(var name)
- valueToJs (Abs _ arg val) = do
+ valueToJs' (Abs _ arg val) = do
ret <- valueToJs val
- return $ JSFunction Nothing [identToJs arg] (JSBlock [JSReturn ret])
- valueToJs e@App{} = do
+ return $ JSFunction Nothing Nothing [identToJs arg] (JSBlock Nothing [JSReturn Nothing ret])
+ valueToJs' e@App{} = do
let (f, args) = unApp e []
args' <- mapM valueToJs args
case f of
Var (_, _, _, Just IsNewtype) _ -> return (head args')
Var (_, _, _, Just (IsConstructor _ fields)) name | length args == length fields ->
- return $ JSUnary JSNew $ JSApp (qualifiedToJS id name) args'
+ return $ JSUnary Nothing JSNew $ JSApp Nothing (qualifiedToJS id name) args'
Var (_, _, _, Just IsTypeClassConstructor) name ->
- return $ JSUnary JSNew $ JSApp (qualifiedToJS id name) args'
- _ -> flip (foldl (\fn a -> JSApp fn [a])) args' <$> valueToJs f
+ return $ JSUnary Nothing JSNew $ JSApp Nothing (qualifiedToJS id name) args'
+ _ -> flip (foldl (\fn a -> JSApp Nothing fn [a])) args' <$> valueToJs f
where
unApp :: Expr Ann -> [Expr Ann] -> (Expr Ann, [Expr Ann])
unApp (App _ val arg) args = unApp val (arg : args)
unApp other args = (other, args)
- valueToJs (Var (_, _, _, Just IsForeign) qi@(Qualified (Just mn') ident)) =
+ valueToJs' (Var (_, _, _, Just IsForeign) qi@(Qualified (Just mn') ident)) =
return $ if mn' == mn
then foreignIdent ident
else varToJs qi
- valueToJs (Var (_, _, _, Just IsForeign) ident) =
+ valueToJs' (Var (_, _, _, Just IsForeign) ident) =
error $ "Encountered an unqualified reference to a foreign ident " ++ showQualified showIdent ident
- valueToJs (Var _ ident) =
- return $ varToJs ident
- valueToJs (Case (maybeSpan, _, _, _) values binders) = do
+ valueToJs' (Var _ ident) = return $ varToJs ident
+ valueToJs' (Case (maybeSpan, _, _, _) values binders) = do
vals <- mapM valueToJs values
bindersToJs maybeSpan binders vals
- valueToJs (Let _ ds val) = do
+ valueToJs' (Let _ ds val) = do
ds' <- concat <$> mapM bindToJs ds
ret <- valueToJs val
- return $ JSApp (JSFunction Nothing [] (JSBlock (ds' ++ [JSReturn ret]))) []
- valueToJs (Constructor (_, _, _, Just IsNewtype) _ (ProperName ctor) _) =
- return $ JSVariableIntroduction ctor (Just $
- JSObjectLiteral [("create",
- JSFunction Nothing ["value"]
- (JSBlock [JSReturn $ JSVar "value"]))])
- valueToJs (Constructor _ _ (ProperName ctor) []) =
- return $ iife ctor [ JSFunction (Just ctor) [] (JSBlock [])
- , JSAssignment (JSAccessor "value" (JSVar ctor))
- (JSUnary JSNew $ JSApp (JSVar ctor) []) ]
- valueToJs (Constructor _ _ (ProperName ctor) fields) =
+ return $ JSApp Nothing (JSFunction Nothing Nothing [] (JSBlock Nothing (ds' ++ [JSReturn Nothing ret]))) []
+ valueToJs' (Constructor (_, _, _, Just IsNewtype) _ (ProperName ctor) _) =
+ return $ JSVariableIntroduction Nothing ctor (Just $
+ JSObjectLiteral Nothing [("create",
+ JSFunction Nothing Nothing ["value"]
+ (JSBlock Nothing [JSReturn Nothing $ JSVar Nothing "value"]))])
+ valueToJs' (Constructor _ _ (ProperName ctor) []) =
+ return $ iife ctor [ JSFunction Nothing (Just ctor) [] (JSBlock Nothing [])
+ , JSAssignment Nothing (JSAccessor Nothing "value" (JSVar Nothing ctor))
+ (JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing ctor) []) ]
+ valueToJs' (Constructor _ _ (ProperName ctor) fields) =
let constructor =
- let body = [ JSAssignment (JSAccessor (identToJs f) (JSVar "this")) (var f) | f <- fields ]
- in JSFunction (Just ctor) (identToJs `map` fields) (JSBlock body)
+ let body = [ JSAssignment Nothing (JSAccessor Nothing (identToJs f) (JSVar Nothing "this")) (var f) | f <- fields ]
+ in JSFunction Nothing (Just ctor) (identToJs `map` fields) (JSBlock Nothing body)
createFn =
- let body = JSUnary JSNew $ JSApp (JSVar ctor) (var `map` fields)
- in foldr (\f inner -> JSFunction Nothing [identToJs f] (JSBlock [JSReturn inner])) body fields
+ let body = JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing ctor) (var `map` fields)
+ in foldr (\f inner -> JSFunction Nothing Nothing [identToJs f] (JSBlock Nothing [JSReturn Nothing inner])) body fields
in return $ iife ctor [ constructor
- , JSAssignment (JSAccessor "create" (JSVar ctor)) createFn
+ , JSAssignment Nothing (JSAccessor Nothing "create" (JSVar Nothing ctor)) createFn
]
iife :: String -> [JS] -> JS
- iife v exprs = JSApp (JSFunction Nothing [] (JSBlock $ exprs ++ [JSReturn $ JSVar v])) []
+ iife v exprs = JSApp Nothing (JSFunction Nothing Nothing [] (JSBlock Nothing $ exprs ++ [JSReturn Nothing $ JSVar Nothing v])) []
literalToValueJS :: Literal (Expr Ann) -> m JS
- literalToValueJS (NumericLiteral (Left i)) = return $ JSNumericLiteral (Left i)
- literalToValueJS (NumericLiteral (Right n)) = return $ JSNumericLiteral (Right n)
- literalToValueJS (StringLiteral s) = return $ JSStringLiteral s
- literalToValueJS (CharLiteral c) = return $ JSStringLiteral [c]
- literalToValueJS (BooleanLiteral b) = return $ JSBooleanLiteral b
- literalToValueJS (ArrayLiteral xs) = JSArrayLiteral <$> mapM valueToJs xs
- literalToValueJS (ObjectLiteral ps) = JSObjectLiteral <$> mapM (sndM valueToJs) ps
+ literalToValueJS (NumericLiteral (Left i)) = return $ JSNumericLiteral Nothing (Left i)
+ literalToValueJS (NumericLiteral (Right n)) = return $ JSNumericLiteral Nothing (Right n)
+ literalToValueJS (StringLiteral s) = return $ JSStringLiteral Nothing s
+ literalToValueJS (CharLiteral c) = return $ JSStringLiteral Nothing [c]
+ literalToValueJS (BooleanLiteral b) = return $ JSBooleanLiteral Nothing b
+ literalToValueJS (ArrayLiteral xs) = JSArrayLiteral Nothing <$> mapM valueToJs xs
+ literalToValueJS (ObjectLiteral ps) = JSObjectLiteral Nothing <$> mapM (sndM valueToJs) ps
-- |
-- Shallow copy an object.
@@ -277,16 +289,16 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
newObj <- freshName
key <- freshName
let
- jsKey = JSVar key
- jsNewObj = JSVar newObj
- block = JSBlock (objAssign:copy:extend ++ [JSReturn jsNewObj])
- objAssign = JSVariableIntroduction newObj (Just $ JSObjectLiteral [])
- copy = JSForIn key obj $ JSBlock [JSIfElse cond assign Nothing]
- cond = JSApp (JSAccessor "hasOwnProperty" obj) [jsKey]
- assign = JSBlock [JSAssignment (JSIndexer jsKey jsNewObj) (JSIndexer jsKey obj)]
- stToAssign (s, js) = JSAssignment (JSAccessor s jsNewObj) js
+ jsKey = JSVar Nothing key
+ jsNewObj = JSVar Nothing newObj
+ block = JSBlock Nothing (objAssign:copy:extend ++ [JSReturn Nothing jsNewObj])
+ objAssign = JSVariableIntroduction Nothing newObj (Just $ JSObjectLiteral Nothing [])
+ copy = JSForIn Nothing key obj $ JSBlock Nothing [JSIfElse Nothing cond assign Nothing]
+ cond = JSApp Nothing (JSAccessor Nothing "hasOwnProperty" obj) [jsKey]
+ assign = JSBlock Nothing [JSAssignment Nothing (JSIndexer Nothing jsKey jsNewObj) (JSIndexer Nothing jsKey obj)]
+ stToAssign (s, js) = JSAssignment Nothing (JSAccessor Nothing s jsNewObj) js
extend = map stToAssign sts
- return $ JSApp (JSFunction Nothing [] block) []
+ return $ JSApp Nothing (JSFunction Nothing Nothing [] block) []
-- |
-- Generate code in the simplified Javascript intermediate representation for a reference to a
@@ -301,12 +313,12 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
-- variable that may have a qualified name.
--
qualifiedToJS :: (a -> Ident) -> Qualified a -> JS
- qualifiedToJS f (Qualified (Just (ModuleName [ProperName mn'])) a) | mn' == C.prim = JSVar . runIdent $ f a
- qualifiedToJS f (Qualified (Just mn') a) | mn /= mn' = accessor (f a) (JSVar (moduleNameToJs mn'))
- qualifiedToJS f (Qualified _ a) = JSVar $ identToJs (f a)
+ qualifiedToJS f (Qualified (Just (ModuleName [ProperName mn'])) a) | mn' == C.prim = JSVar Nothing . runIdent $ f a
+ qualifiedToJS f (Qualified (Just mn') a) | mn /= mn' = accessor (f a) (JSVar Nothing (moduleNameToJs mn'))
+ qualifiedToJS f (Qualified _ a) = JSVar Nothing $ identToJs (f a)
foreignIdent :: Ident -> JS
- foreignIdent ident = accessorString (runIdent ident) (JSVar "$foreign")
+ foreignIdent ident = accessorString (runIdent ident) (JSVar Nothing "$foreign")
-- |
-- Generate code in the simplified Javascript intermediate representation for pattern match binders
@@ -315,11 +327,11 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
bindersToJs :: Maybe SourceSpan -> [CaseAlternative Ann] -> [JS] -> m JS
bindersToJs maybeSpan binders vals = do
valNames <- replicateM (length vals) freshName
- let assignments = zipWith JSVariableIntroduction valNames (map Just vals)
+ let assignments = zipWith (JSVariableIntroduction Nothing) valNames (map Just vals)
jss <- forM binders $ \(CaseAlternative bs result) -> do
ret <- guardsToJs result
go valNames ret bs
- return $ JSApp (JSFunction Nothing [] (JSBlock (assignments ++ concat jss ++ [JSThrow $ failedPatternError valNames])))
+ return $ JSApp Nothing (JSFunction Nothing Nothing [] (JSBlock Nothing (assignments ++ concat jss ++ [JSThrow Nothing $ failedPatternError valNames])))
[]
where
go :: [String] -> [JS] -> [Binder Ann] -> m [JS]
@@ -330,43 +342,48 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
go _ _ _ = internalError "Invalid arguments to bindersToJs"
failedPatternError :: [String] -> JS
- failedPatternError names = JSUnary JSNew $ JSApp (JSVar "Error") [JSBinary Add (JSStringLiteral failedPatternMessage) (JSArrayLiteral $ zipWith valueError names vals)]
+ failedPatternError names = JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing "Error") [JSBinary Nothing Add (JSStringLiteral Nothing failedPatternMessage) (JSArrayLiteral Nothing $ zipWith valueError names vals)]
failedPatternMessage :: String
failedPatternMessage = "Failed pattern match" ++ maybe "" (((" at " ++ runModuleName mn ++ " ") ++) . displayStartEndPos) maybeSpan ++ ": "
valueError :: String -> JS -> JS
- valueError _ l@(JSNumericLiteral _) = l
- valueError _ l@(JSStringLiteral _) = l
- valueError _ l@(JSBooleanLiteral _) = l
- valueError s _ = JSAccessor "name" . JSAccessor "constructor" $ JSVar s
+ valueError _ l@(JSNumericLiteral _ _) = l
+ valueError _ l@(JSStringLiteral _ _) = l
+ valueError _ l@(JSBooleanLiteral _ _) = l
+ valueError s _ = JSAccessor Nothing "name" . JSAccessor Nothing "constructor" $ JSVar Nothing s
guardsToJs :: Either [(Guard Ann, Expr Ann)] (Expr Ann) -> m [JS]
guardsToJs (Left gs) = forM gs $ \(cond, val) -> do
cond' <- valueToJs cond
done <- valueToJs val
- return $ JSIfElse cond' (JSBlock [JSReturn done]) Nothing
- guardsToJs (Right v) = return . JSReturn <$> valueToJs v
+ return $ JSIfElse Nothing cond' (JSBlock Nothing [JSReturn Nothing done]) Nothing
+ guardsToJs (Right v) = return . JSReturn Nothing <$> valueToJs v
+
+ binderToJs :: String -> [JS] -> Binder Ann -> m [JS]
+ binderToJs s done binder =
+ let (ss, _, _, _) = extractBinderAnn binder in
+ traverse (withPos ss) =<< binderToJs' s done binder
-- |
-- Generate code in the simplified Javascript intermediate representation for a pattern match
-- binder.
--
- binderToJs :: String -> [JS] -> Binder Ann -> m [JS]
- binderToJs _ done (NullBinder{}) = return done
- binderToJs varName done (LiteralBinder _ l) =
+ binderToJs' :: String -> [JS] -> Binder Ann -> m [JS]
+ binderToJs' _ done (NullBinder{}) = return done
+ binderToJs' varName done (LiteralBinder _ l) =
literalToBinderJS varName done l
- binderToJs varName done (VarBinder _ ident) =
- return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : done)
- binderToJs varName done (ConstructorBinder (_, _, _, Just IsNewtype) _ _ [b]) =
+ binderToJs' varName done (VarBinder _ ident) =
+ return (JSVariableIntroduction Nothing (identToJs ident) (Just (JSVar Nothing varName)) : done)
+ binderToJs' varName done (ConstructorBinder (_, _, _, Just IsNewtype) _ _ [b]) =
binderToJs varName done b
- binderToJs varName done (ConstructorBinder (_, _, _, Just (IsConstructor ctorType fields)) _ ctor bs) = do
+ binderToJs' varName done (ConstructorBinder (_, _, _, Just (IsConstructor ctorType fields)) _ ctor bs) = do
js <- go (zip fields bs) done
return $ case ctorType of
ProductType -> js
SumType ->
- [JSIfElse (JSInstanceOf (JSVar varName) (qualifiedToJS (Ident . runProperName) ctor))
- (JSBlock js)
+ [JSIfElse Nothing (JSInstanceOf Nothing (JSVar Nothing varName) (qualifiedToJS (Ident . runProperName) ctor))
+ (JSBlock Nothing js)
Nothing]
where
go :: [(Ident, Binder Ann)] -> [JS] -> m [JS]
@@ -375,24 +392,24 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
argVar <- freshName
done'' <- go remain done'
js <- binderToJs argVar done'' binder
- return (JSVariableIntroduction argVar (Just (JSAccessor (identToJs field) (JSVar varName))) : js)
- binderToJs _ _ ConstructorBinder{} =
+ return (JSVariableIntroduction Nothing argVar (Just (JSAccessor Nothing (identToJs field) (JSVar Nothing varName))) : js)
+ binderToJs' _ _ ConstructorBinder{} =
internalError "binderToJs: Invalid ConstructorBinder in binderToJs"
- binderToJs varName done (NamedBinder _ ident binder) = do
+ binderToJs' varName done (NamedBinder _ ident binder) = do
js <- binderToJs varName done binder
- return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : js)
+ return (JSVariableIntroduction Nothing (identToJs ident) (Just (JSVar Nothing varName)) : js)
literalToBinderJS :: String -> [JS] -> Literal (Binder Ann) -> m [JS]
literalToBinderJS varName done (NumericLiteral num) =
- return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSNumericLiteral num)) (JSBlock done) Nothing]
+ return [JSIfElse Nothing (JSBinary Nothing EqualTo (JSVar Nothing varName) (JSNumericLiteral Nothing num)) (JSBlock Nothing done) Nothing]
literalToBinderJS varName done (CharLiteral c) =
- return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSStringLiteral [c])) (JSBlock done) Nothing]
+ return [JSIfElse Nothing (JSBinary Nothing EqualTo (JSVar Nothing varName) (JSStringLiteral Nothing [c])) (JSBlock Nothing done) Nothing]
literalToBinderJS varName done (StringLiteral str) =
- return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSStringLiteral str)) (JSBlock done) Nothing]
+ return [JSIfElse Nothing (JSBinary Nothing EqualTo (JSVar Nothing varName) (JSStringLiteral Nothing str)) (JSBlock Nothing done) Nothing]
literalToBinderJS varName done (BooleanLiteral True) =
- return [JSIfElse (JSVar varName) (JSBlock done) Nothing]
+ return [JSIfElse Nothing (JSVar Nothing varName) (JSBlock Nothing done) Nothing]
literalToBinderJS varName done (BooleanLiteral False) =
- return [JSIfElse (JSUnary Not (JSVar varName)) (JSBlock done) Nothing]
+ return [JSIfElse Nothing (JSUnary Nothing Not (JSVar Nothing varName)) (JSBlock Nothing done) Nothing]
literalToBinderJS varName done (ObjectLiteral bs) = go done bs
where
go :: [JS] -> [(String, Binder Ann)] -> m [JS]
@@ -401,10 +418,10 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
propVar <- freshName
done'' <- go done' bs'
js <- binderToJs propVar done'' binder
- return (JSVariableIntroduction propVar (Just (accessorString prop (JSVar varName))) : js)
+ return (JSVariableIntroduction Nothing propVar (Just (accessorString prop (JSVar Nothing varName))) : js)
literalToBinderJS varName done (ArrayLiteral bs) = do
js <- go done 0 bs
- return [JSIfElse (JSBinary EqualTo (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (Left (fromIntegral $ length bs)))) (JSBlock js) Nothing]
+ return [JSIfElse Nothing (JSBinary Nothing EqualTo (JSAccessor Nothing "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'
@@ -412,21 +429,21 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
elVar <- freshName
done'' <- go done' (index + 1) bs'
js <- binderToJs elVar done'' binder
- return (JSVariableIntroduction elVar (Just (JSIndexer (JSNumericLiteral (Left index)) (JSVar varName))) : js)
+ return (JSVariableIntroduction Nothing elVar (Just (JSIndexer Nothing (JSNumericLiteral Nothing (Left index)) (JSVar Nothing varName))) : js)
-- Check that all integers fall within the valid int range for JavaScript.
checkIntegers :: JS -> m ()
checkIntegers = void . everywhereOnJSTopDownM go
where
go :: JS -> m JS
- go (JSUnary Negate (JSNumericLiteral (Left i))) =
+ go (JSUnary _ Negate (JSNumericLiteral ss (Left i))) =
-- Move the negation inside the literal; since this is a top-down
-- traversal doing this replacement will stop the next case from raising
-- the error when attempting to use -2147483648, as if left unrewritten
-- the value is `JSUnary Negate (JSNumericLiteral (Left 2147483648))`, and
-- 2147483648 is larger than the maximum allowed int.
- return $ JSNumericLiteral (Left (-i))
- go js@(JSNumericLiteral (Left i)) =
+ return $ JSNumericLiteral ss (Left (-i))
+ go js@(JSNumericLiteral _ (Left i)) =
let minInt = -2147483648
maxInt = 2147483647
in if i < minInt || i > maxInt
diff --git a/src/Language/PureScript/CodeGen/JS/AST.hs b/src/Language/PureScript/CodeGen/JS/AST.hs
index 3b8236d..59f7bc1 100644
--- a/src/Language/PureScript/CodeGen/JS/AST.hs
+++ b/src/Language/PureScript/CodeGen/JS/AST.hs
@@ -10,6 +10,7 @@ import Control.Monad.Identity
import Language.PureScript.Comments
import Language.PureScript.Traversals
+import Language.PureScript.AST (SourceSpan(..))
-- |
-- Built-in unary operators
@@ -126,120 +127,190 @@ data JS
-- |
-- A numeric literal
--
- = JSNumericLiteral (Either Integer Double)
+ = JSNumericLiteral (Maybe SourceSpan) (Either Integer Double)
-- |
-- A string literal
--
- | JSStringLiteral String
+ | JSStringLiteral (Maybe SourceSpan) String
-- |
-- A boolean literal
--
- | JSBooleanLiteral Bool
+ | JSBooleanLiteral (Maybe SourceSpan) Bool
-- |
-- A unary operator application
--
- | JSUnary UnaryOperator JS
+ | JSUnary (Maybe SourceSpan) UnaryOperator JS
-- |
-- A binary operator application
--
- | JSBinary BinaryOperator JS JS
+ | JSBinary (Maybe SourceSpan) BinaryOperator JS JS
-- |
-- An array literal
--
- | JSArrayLiteral [JS]
+ | JSArrayLiteral (Maybe SourceSpan) [JS]
-- |
-- An array indexer expression
--
- | JSIndexer JS JS
+ | JSIndexer (Maybe SourceSpan) JS JS
-- |
-- An object literal
--
- | JSObjectLiteral [(String, JS)]
+ | JSObjectLiteral (Maybe SourceSpan) [(String, JS)]
-- |
-- An object property accessor expression
--
- | JSAccessor String JS
+ | JSAccessor (Maybe SourceSpan) String JS
-- |
-- A function introduction (optional name, arguments, body)
--
- | JSFunction (Maybe String) [String] JS
+ | JSFunction (Maybe SourceSpan) (Maybe String) [String] JS
-- |
-- Function application
--
- | JSApp JS [JS]
+ | JSApp (Maybe SourceSpan) JS [JS]
-- |
-- Variable
--
- | JSVar String
+ | JSVar (Maybe SourceSpan) String
-- |
-- Conditional expression
--
- | JSConditional JS JS JS
+ | JSConditional (Maybe SourceSpan) JS JS JS
-- |
-- A block of expressions in braces
--
- | JSBlock [JS]
+ | JSBlock (Maybe SourceSpan) [JS]
-- |
-- A variable introduction and optional initialization
--
- | JSVariableIntroduction String (Maybe JS)
+ | JSVariableIntroduction (Maybe SourceSpan) String (Maybe JS)
-- |
-- A variable assignment
--
- | JSAssignment JS JS
+ | JSAssignment (Maybe SourceSpan) JS JS
-- |
-- While loop
--
- | JSWhile JS JS
+ | JSWhile (Maybe SourceSpan) JS JS
-- |
-- For loop
--
- | JSFor String JS JS JS
+ | JSFor (Maybe SourceSpan) String JS JS JS
-- |
-- ForIn loop
--
- | JSForIn String JS JS
+ | JSForIn (Maybe SourceSpan) String JS JS
-- |
-- If-then-else statement
--
- | JSIfElse JS JS (Maybe JS)
+ | JSIfElse (Maybe SourceSpan) JS JS (Maybe JS)
-- |
-- Return statement
--
- | JSReturn JS
+ | JSReturn (Maybe SourceSpan) JS
-- |
-- Throw statement
--
- | JSThrow JS
+ | JSThrow (Maybe SourceSpan) JS
-- |
-- Type-Of operator
--
- | JSTypeOf JS
+ | JSTypeOf (Maybe SourceSpan) JS
-- |
-- InstanceOf test
--
- | JSInstanceOf JS JS
+ | JSInstanceOf (Maybe SourceSpan) JS JS
-- |
-- Labelled statement
--
- | JSLabel String JS
+ | JSLabel (Maybe SourceSpan) String JS
-- |
-- Break statement
--
- | JSBreak String
+ | JSBreak (Maybe SourceSpan) String
-- |
-- Continue statement
--
- | JSContinue String
+ | JSContinue (Maybe SourceSpan) String
-- |
-- Raw Javascript (generated when parsing fails for an inline foreign import declaration)
--
- | JSRaw String
+ | JSRaw (Maybe SourceSpan) String
-- |
-- Commented Javascript
--
- | JSComment [Comment] JS
- deriving (Show, Read, Eq)
+ | JSComment (Maybe SourceSpan) [Comment] JS deriving (Show, Read, Eq)
+
+withSourceSpan :: SourceSpan -> JS -> JS
+withSourceSpan withSpan = go
+ where
+ ss :: Maybe SourceSpan
+ ss = Just withSpan
+
+ go :: JS -> JS
+ go (JSNumericLiteral _ n) = JSNumericLiteral ss n
+ go (JSStringLiteral _ s) = JSStringLiteral ss s
+ go (JSBooleanLiteral _ b) = JSBooleanLiteral ss b
+ go (JSUnary _ op j) = JSUnary ss op j
+ go (JSBinary _ op j1 j2) = JSBinary ss op j1 j2
+ 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
+ go (JSConditional _ j1 j2 j3) = JSConditional ss j1 j2 j3
+ go (JSBlock _ js) = JSBlock ss js
+ go (JSVariableIntroduction _ name j) = JSVariableIntroduction ss name j
+ go (JSAssignment _ j1 j2) = JSAssignment ss j1 j2
+ go (JSWhile _ j1 j2) = JSWhile ss j1 j2
+ go (JSFor _ name j1 j2 j3) = JSFor ss name j1 j2 j3
+ go (JSForIn _ name j1 j2) = JSForIn ss name j1 j2
+ go (JSIfElse _ j1 j2 j3) = JSIfElse ss j1 j2 j3
+ go (JSReturn _ js) = JSReturn ss js
+ go (JSThrow _ js) = JSThrow ss js
+ go (JSTypeOf _ js) = JSTypeOf ss js
+ go (JSInstanceOf _ j1 j2) = JSInstanceOf ss j1 j2
+ go (JSLabel _ name js) = JSLabel ss name js
+ go (JSBreak _ s) = JSBreak ss s
+ go (JSContinue _ s) = JSContinue ss s
+ go (JSRaw _ s) = JSRaw ss s
+ go (JSComment _ com j) = JSComment ss com j
+
+getSourceSpan :: JS -> Maybe SourceSpan
+getSourceSpan = go
+ where
+ go :: JS -> Maybe SourceSpan
+ go (JSNumericLiteral ss _) = ss
+ go (JSStringLiteral ss _) = ss
+ go (JSBooleanLiteral ss _) = ss
+ go (JSUnary ss _ _) = ss
+ go (JSBinary ss _ _ _) = ss
+ 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
+ go (JSConditional ss _ _ _) = ss
+ go (JSBlock ss _) = ss
+ go (JSVariableIntroduction ss _ _) = ss
+ go (JSAssignment ss _ _) = ss
+ go (JSWhile ss _ _) = ss
+ go (JSFor ss _ _ _ _) = ss
+ go (JSForIn ss _ _ _) = ss
+ go (JSIfElse ss _ _ _) = ss
+ go (JSReturn ss _) = ss
+ go (JSThrow ss _) = ss
+ go (JSTypeOf ss _) = ss
+ go (JSInstanceOf ss _ _) = ss
+ go (JSLabel ss _ _) = ss
+ go (JSBreak ss _) = ss
+ go (JSContinue ss _) = ss
+ go (JSRaw ss _) = ss
+ go (JSComment ss _ _) = ss
--
-- Traversals
@@ -249,28 +320,28 @@ everywhereOnJS :: (JS -> JS) -> JS -> JS
everywhereOnJS f = go
where
go :: JS -> JS
- go (JSUnary op j) = f (JSUnary op (go j))
- go (JSBinary op j1 j2) = f (JSBinary op (go j1) (go j2))
- go (JSArrayLiteral js) = f (JSArrayLiteral (map go js))
- go (JSIndexer j1 j2) = f (JSIndexer (go j1) (go j2))
- go (JSObjectLiteral js) = f (JSObjectLiteral (map (fmap go) js))
- go (JSAccessor prop j) = f (JSAccessor prop (go j))
- go (JSFunction name args j) = f (JSFunction name args (go j))
- go (JSApp j js) = f (JSApp (go j) (map go js))
- go (JSConditional j1 j2 j3) = f (JSConditional (go j1) (go j2) (go j3))
- go (JSBlock js) = f (JSBlock (map go js))
- go (JSVariableIntroduction name j) = f (JSVariableIntroduction name (fmap go j))
- go (JSAssignment j1 j2) = f (JSAssignment (go j1) (go j2))
- go (JSWhile j1 j2) = f (JSWhile (go j1) (go j2))
- go (JSFor name j1 j2 j3) = f (JSFor name (go j1) (go j2) (go j3))
- go (JSForIn name j1 j2) = f (JSForIn name (go j1) (go j2))
- go (JSIfElse j1 j2 j3) = f (JSIfElse (go j1) (go j2) (fmap go j3))
- go (JSReturn js) = f (JSReturn (go js))
- go (JSThrow js) = f (JSThrow (go js))
- go (JSTypeOf js) = f (JSTypeOf (go js))
- go (JSLabel name js) = f (JSLabel name (go js))
- go (JSInstanceOf j1 j2) = f (JSInstanceOf (go j1) (go j2))
- go (JSComment com j) = f (JSComment com (go j))
+ go (JSUnary ss op j) = f (JSUnary ss op (go j))
+ go (JSBinary ss op j1 j2) = f (JSBinary ss op (go j1) (go j2))
+ 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))
+ go (JSBlock ss js) = f (JSBlock ss (map go js))
+ go (JSVariableIntroduction ss name j) = f (JSVariableIntroduction ss name (fmap go j))
+ go (JSAssignment ss j1 j2) = f (JSAssignment ss (go j1) (go j2))
+ go (JSWhile ss j1 j2) = f (JSWhile ss (go j1) (go j2))
+ go (JSFor ss name j1 j2 j3) = f (JSFor ss name (go j1) (go j2) (go j3))
+ go (JSForIn ss name j1 j2) = f (JSForIn ss name (go j1) (go j2))
+ go (JSIfElse ss j1 j2 j3) = f (JSIfElse ss (go j1) (go j2) (fmap go j3))
+ go (JSReturn ss js) = f (JSReturn ss (go js))
+ go (JSThrow ss js) = f (JSThrow ss (go js))
+ go (JSTypeOf ss js) = f (JSTypeOf ss (go js))
+ go (JSLabel ss name js) = f (JSLabel ss name (go js))
+ go (JSInstanceOf ss j1 j2) = f (JSInstanceOf ss (go j1) (go j2))
+ go (JSComment ss com j) = f (JSComment ss com (go j))
go other = f other
everywhereOnJSTopDown :: (JS -> JS) -> JS -> JS
@@ -280,54 +351,54 @@ everywhereOnJSTopDownM :: (Applicative m, Monad m) => (JS -> m JS) -> JS -> m JS
everywhereOnJSTopDownM f = f >=> go
where
f' = f >=> go
- go (JSUnary op j) = JSUnary op <$> f' j
- go (JSBinary op j1 j2) = JSBinary op <$> f' j1 <*> f' j2
- go (JSArrayLiteral js) = JSArrayLiteral <$> traverse f' js
- go (JSIndexer j1 j2) = JSIndexer <$> f' j1 <*> f' j2
- go (JSObjectLiteral js) = JSObjectLiteral <$> traverse (sndM f') js
- go (JSAccessor prop j) = JSAccessor prop <$> f' j
- go (JSFunction name args j) = JSFunction name args <$> f' j
- go (JSApp j js) = JSApp <$> f' j <*> traverse f' js
- go (JSConditional j1 j2 j3) = JSConditional <$> f' j1 <*> f' j2 <*> f' j3
- go (JSBlock js) = JSBlock <$> traverse f' js
- go (JSVariableIntroduction name j) = JSVariableIntroduction name <$> traverse f' j
- go (JSAssignment j1 j2) = JSAssignment <$> f' j1 <*> f' j2
- go (JSWhile j1 j2) = JSWhile <$> f' j1 <*> f' j2
- go (JSFor name j1 j2 j3) = JSFor name <$> f' j1 <*> f' j2 <*> f' j3
- go (JSForIn name j1 j2) = JSForIn name <$> f' j1 <*> f' j2
- go (JSIfElse j1 j2 j3) = JSIfElse <$> f' j1 <*> f' j2 <*> traverse f' j3
- go (JSReturn j) = JSReturn <$> f' j
- go (JSThrow j) = JSThrow <$> f' j
- go (JSTypeOf j) = JSTypeOf <$> f' j
- go (JSLabel name j) = JSLabel name <$> f' j
- go (JSInstanceOf j1 j2) = JSInstanceOf <$> f' j1 <*> f' j2
- go (JSComment com j) = JSComment com <$> f' j
+ go (JSUnary ss op j) = JSUnary ss op <$> f' j
+ go (JSBinary ss op j1 j2) = JSBinary ss op <$> f' j1 <*> f' j2
+ 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
+ go (JSBlock ss js) = JSBlock ss <$> traverse f' js
+ go (JSVariableIntroduction ss name j) = JSVariableIntroduction ss name <$> traverse f' j
+ go (JSAssignment ss j1 j2) = JSAssignment ss <$> f' j1 <*> f' j2
+ go (JSWhile ss j1 j2) = JSWhile ss <$> f' j1 <*> f' j2
+ go (JSFor ss name j1 j2 j3) = JSFor ss name <$> f' j1 <*> f' j2 <*> f' j3
+ go (JSForIn ss name j1 j2) = JSForIn ss name <$> f' j1 <*> f' j2
+ go (JSIfElse ss j1 j2 j3) = JSIfElse ss <$> f' j1 <*> f' j2 <*> traverse f' j3
+ go (JSReturn ss j) = JSReturn ss <$> f' j
+ go (JSThrow ss j) = JSThrow ss <$> f' j
+ go (JSTypeOf ss j) = JSTypeOf ss <$> f' j
+ go (JSLabel ss name j) = JSLabel ss name <$> f' j
+ go (JSInstanceOf ss j1 j2) = JSInstanceOf ss <$> f' j1 <*> f' j2
+ go (JSComment ss com j) = JSComment ss com <$> f' j
go other = f other
everythingOnJS :: (r -> r -> r) -> (JS -> r) -> JS -> r
everythingOnJS (<>) f = go
where
- go j@(JSUnary _ j1) = f j <> go j1
- go j@(JSBinary _ j1 j2) = f j <> go j1 <> go j2
- 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
- go j@(JSBlock js) = foldl (<>) (f j) (map go js)
- go j@(JSVariableIntroduction _ (Just j1)) = f j <> go j1
- go j@(JSAssignment j1 j2) = f j <> go j1 <> go j2
- go j@(JSWhile j1 j2) = f j <> go j1 <> go j2
- go j@(JSFor _ j1 j2 j3) = f j <> go j1 <> go j2 <> go j3
- go j@(JSForIn _ j1 j2) = f j <> go j1 <> go j2
- go j@(JSIfElse j1 j2 Nothing) = f j <> go j1 <> go j2
- go j@(JSIfElse j1 j2 (Just j3)) = f j <> go j1 <> go j2 <> go j3
- go j@(JSReturn j1) = f j <> go j1
- go j@(JSThrow j1) = f j <> go j1
- go j@(JSTypeOf j1) = f j <> go j1
- go j@(JSLabel _ j1) = f j <> go j1
- go j@(JSInstanceOf j1 j2) = f j <> go j1 <> go j2
- go j@(JSComment _ j1) = f j <> go j1
+ go j@(JSUnary _ _ j1) = f j <> go j1
+ go j@(JSBinary _ _ j1 j2) = f j <> go j1 <> go j2
+ 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
+ go j@(JSBlock _ js) = foldl (<>) (f j) (map go js)
+ go j@(JSVariableIntroduction _ _ (Just j1)) = f j <> go j1
+ go j@(JSAssignment _ j1 j2) = f j <> go j1 <> go j2
+ go j@(JSWhile _ j1 j2) = f j <> go j1 <> go j2
+ go j@(JSFor _ _ j1 j2 j3) = f j <> go j1 <> go j2 <> go j3
+ go j@(JSForIn _ _ j1 j2) = f j <> go j1 <> go j2
+ go j@(JSIfElse _ j1 j2 Nothing) = f j <> go j1 <> go j2
+ go j@(JSIfElse _ j1 j2 (Just j3)) = f j <> go j1 <> go j2 <> go j3
+ go j@(JSReturn _ j1) = f j <> go j1
+ go j@(JSThrow _ j1) = f j <> go j1
+ go j@(JSTypeOf _ j1) = f j <> go j1
+ go j@(JSLabel _ _ j1) = f j <> go j1
+ go j@(JSInstanceOf _ j1 j2) = f j <> go j1 <> go j2
+ go j@(JSComment _ _ j1) = f j <> go j1
go other = f other
diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer.hs b/src/Language/PureScript/CodeGen/JS/Optimizer.hs
index 0b28e17..5836b46 100644
--- a/src/Language/PureScript/CodeGen/JS/Optimizer.hs
+++ b/src/Language/PureScript/CodeGen/JS/Optimizer.hs
@@ -53,11 +53,11 @@ optimize' js = do
opts <- ask
js' <- untilFixedPoint (inlineFnComposition . tidyUp . applyAll
[ inlineCommonValues
- , inlineOperator (C.prelude, (C.$)) $ \f x -> JSApp f [x]
- , inlineOperator (C.dataFunction, C.apply) $ \f x -> JSApp f [x]
- , inlineOperator (C.prelude, (C.#)) $ \x f -> JSApp f [x]
- , inlineOperator (C.dataFunction, C.applyFlipped) $ \x f -> JSApp f [x]
- , inlineOperator (C.dataArrayUnsafe, C.unsafeIndex) $ flip JSIndexer
+ , inlineOperator (C.prelude, (C.$)) $ \f x -> JSApp Nothing f [x]
+ , inlineOperator (C.dataFunction, C.apply) $ \f x -> JSApp Nothing f [x]
+ , inlineOperator (C.prelude, (C.#)) $ \x f -> JSApp Nothing f [x]
+ , inlineOperator (C.dataFunction, C.applyFlipped) $ \x f -> JSApp Nothing f [x]
+ , inlineOperator (C.dataArrayUnsafe, C.unsafeIndex) $ flip (JSIndexer Nothing)
, inlineCommonOperators
]) js
untilFixedPoint (return . tidyUp) . tco opts . magicDo opts $ js'
diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Blocks.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Blocks.hs
index 68c29c7..2abd781 100644
--- a/src/Language/PureScript/CodeGen/JS/Optimizer/Blocks.hs
+++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Blocks.hs
@@ -27,16 +27,16 @@ collapseNestedBlocks :: JS -> JS
collapseNestedBlocks = everywhereOnJS collapse
where
collapse :: JS -> JS
- collapse (JSBlock sts) = JSBlock (concatMap go sts)
+ collapse (JSBlock ss sts) = JSBlock ss (concatMap go sts)
collapse js = js
go :: JS -> [JS]
- go (JSBlock sts) = sts
+ go (JSBlock _ sts) = sts
go s = [s]
collapseNestedIfs :: JS -> JS
collapseNestedIfs = everywhereOnJS collapse
where
collapse :: JS -> JS
- collapse (JSIfElse cond1 (JSBlock [JSIfElse cond2 body Nothing]) Nothing) =
- JSIfElse (JSBinary And cond1 cond2) body Nothing
+ collapse (JSIfElse s1 cond1 (JSBlock _ [JSIfElse s2 cond2 body Nothing]) Nothing) =
+ JSIfElse s1 (JSBinary s2 And cond1 cond2) body Nothing
collapse js = js
diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs
index 2bbb99a..25cb331 100644
--- a/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs
+++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs
@@ -14,67 +14,67 @@ applyAll = foldl1 (.)
replaceIdent :: String -> JS -> JS -> JS
replaceIdent var1 js = everywhereOnJS replace
where
- replace (JSVar var2) | var1 == var2 = js
+ replace (JSVar _ var2) | var1 == var2 = js
replace other = other
replaceIdents :: [(String, JS)] -> JS -> JS
replaceIdents vars = everywhereOnJS replace
where
- replace v@(JSVar var) = fromMaybe v $ lookup var vars
+ replace v@(JSVar _ var) = fromMaybe v $ lookup var vars
replace other = other
isReassigned :: String -> JS -> Bool
isReassigned var1 = everythingOnJS (||) check
where
check :: JS -> Bool
- check (JSFunction _ args _) | var1 `elem` args = True
- check (JSVariableIntroduction arg _) | var1 == arg = True
- check (JSAssignment (JSVar arg) _) | var1 == arg = True
- check (JSFor arg _ _ _) | var1 == arg = True
- check (JSForIn arg _ _) | var1 == arg = True
+ check (JSFunction _ _ args _) | var1 `elem` args = True
+ check (JSVariableIntroduction _ arg _) | var1 == arg = True
+ check (JSAssignment _ (JSVar _ arg) _) | var1 == arg = True
+ check (JSFor _ arg _ _ _) | var1 == arg = True
+ check (JSForIn _ arg _ _) | var1 == arg = True
check _ = False
isRebound :: JS -> JS -> Bool
isRebound js d = any (\v -> isReassigned v d || isUpdated v d) (everythingOnJS (++) variablesOf js)
where
- variablesOf (JSVar var) = [var]
+ variablesOf (JSVar _ var) = [var]
variablesOf _ = []
isUsed :: String -> JS -> Bool
isUsed var1 = everythingOnJS (||) check
where
check :: JS -> Bool
- check (JSVar var2) | var1 == var2 = True
- check (JSAssignment target _) | var1 == targetVariable target = True
+ check (JSVar _ var2) | var1 == var2 = True
+ check (JSAssignment _ target _) | var1 == targetVariable target = True
check _ = False
targetVariable :: JS -> String
-targetVariable (JSVar var) = var
-targetVariable (JSAccessor _ tgt) = targetVariable tgt
-targetVariable (JSIndexer _ tgt) = targetVariable tgt
+targetVariable (JSVar _ var) = var
+targetVariable (JSAccessor _ _ tgt) = targetVariable tgt
+targetVariable (JSIndexer _ _ tgt) = targetVariable tgt
targetVariable _ = internalError "Invalid argument to targetVariable"
isUpdated :: String -> JS -> Bool
isUpdated var1 = everythingOnJS (||) check
where
check :: JS -> Bool
- check (JSAssignment target _) | var1 == targetVariable target = True
+ check (JSAssignment _ target _) | var1 == targetVariable target = True
check _ = False
removeFromBlock :: ([JS] -> [JS]) -> JS -> JS
-removeFromBlock go (JSBlock sts) = JSBlock (go sts)
+removeFromBlock go (JSBlock ss sts) = JSBlock ss (go sts)
removeFromBlock _ js = js
isFn :: (String, String) -> JS -> Bool
-isFn (moduleName, fnName) (JSAccessor x (JSVar y)) = x == fnName && y == moduleName
-isFn (moduleName, fnName) (JSIndexer (JSStringLiteral x) (JSVar y)) = x == fnName && y == moduleName
+isFn (moduleName, fnName) (JSAccessor _ x (JSVar _ y)) = x == fnName && y == moduleName
+isFn (moduleName, fnName) (JSIndexer _ (JSStringLiteral _ x) (JSVar _ y)) = x == fnName && y == moduleName
isFn _ _ = False
isFn' :: [(String, String)] -> JS -> Bool
isFn' xs js = any (`isFn` js) xs
isDict :: (String, String) -> JS -> Bool
-isDict (moduleName, dictName) (JSAccessor x (JSVar y)) = x == dictName && y == moduleName
+isDict (moduleName, dictName) (JSAccessor _ x (JSVar _ y)) = x == dictName && y == moduleName
isDict _ _ = False
isDict' :: [(String, String)] -> JS -> Bool
diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs
index 2b5cbd3..6b9f4e7 100644
--- a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs
+++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs
@@ -29,42 +29,42 @@ import qualified Language.PureScript.Constants as C
-- Needs to be: { 0..toFixed(10); }
-- Probably needs to be fixed in pretty-printer instead.
shouldInline :: JS -> Bool
-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 (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
etaConvert :: JS -> JS
etaConvert = everywhereOnJS convert
where
convert :: JS -> JS
- convert (JSBlock [JSReturn (JSApp (JSFunction Nothing idents block@(JSBlock body)) args)])
+ convert (JSBlock ss [JSReturn _ (JSApp _ (JSFunction _ Nothing idents block@(JSBlock _ body)) args)])
| all shouldInline args &&
- not (any (`isRebound` block) (map JSVar idents)) &&
+ not (any (`isRebound` block) (map (JSVar Nothing) idents)) &&
not (any (`isRebound` block) args)
- = JSBlock (map (replaceIdents (zip idents args)) body)
- convert (JSFunction Nothing [] (JSBlock [JSReturn (JSApp fn [])])) = fn
+ = JSBlock ss (map (replaceIdents (zip idents args)) body)
+ convert (JSFunction _ Nothing [] (JSBlock _ [JSReturn _ (JSApp _ fn [])])) = fn
convert js = js
unThunk :: JS -> JS
unThunk = everywhereOnJS convert
where
convert :: JS -> JS
- convert (JSBlock []) = JSBlock []
- convert (JSBlock jss) =
+ convert (JSBlock ss []) = JSBlock ss []
+ convert (JSBlock ss jss) =
case last jss of
- JSReturn (JSApp (JSFunction Nothing [] (JSBlock body)) []) -> JSBlock $ init jss ++ body
- _ -> JSBlock jss
+ JSReturn _ (JSApp _ (JSFunction _ Nothing [] (JSBlock _ body)) []) -> JSBlock ss $ init jss ++ body
+ _ -> JSBlock ss jss
convert js = js
evaluateIifes :: JS -> JS
evaluateIifes = everywhereOnJS convert
where
convert :: JS -> JS
- convert (JSApp (JSFunction Nothing [] (JSBlock [JSReturn ret])) []) = ret
+ convert (JSApp _ (JSFunction _ Nothing [] (JSBlock _ [JSReturn _ ret])) []) = ret
convert js = js
inlineVariables :: JS -> JS
@@ -72,7 +72,7 @@ inlineVariables = everywhereOnJS $ removeFromBlock go
where
go :: [JS] -> [JS]
go [] = []
- go (JSVariableIntroduction var (Just js) : sts)
+ go (JSVariableIntroduction _ var (Just js) : sts)
| shouldInline js && not (any (isReassigned var) sts) && not (any (isRebound js) sts) && not (any (isUpdated var) sts) =
go (map (replaceIdent var js) sts)
go (s:sts) = s : go sts
@@ -81,16 +81,16 @@ inlineCommonValues :: JS -> JS
inlineCommonValues = everywhereOnJS convert
where
convert :: JS -> JS
- convert (JSApp fn [dict])
- | isDict' (semiringNumber ++ semiringInt) dict && isFn' fnZero fn = JSNumericLiteral (Left 0)
- | isDict' (semiringNumber ++ semiringInt) dict && isFn' fnOne fn = JSNumericLiteral (Left 1)
- | isDict' boundedBoolean dict && isFn' fnBottom fn = JSBooleanLiteral False
- | isDict' boundedBoolean dict && isFn' fnTop fn = JSBooleanLiteral True
- convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y])
- | isDict' semiringInt dict && isFn' fnAdd fn = intOp Add x y
- | isDict' semiringInt dict && isFn' fnMultiply fn = intOp Multiply x y
- | isDict' moduloSemiringInt dict && isFn' fnDivide fn = intOp Divide x y
- | isDict' ringInt dict && isFn' fnSubtract fn = intOp Subtract x y
+ 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
+ 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' moduloSemiringInt dict && isFn' fnDivide fn = intOp ss Divide x y
+ | isDict' ringInt dict && isFn' fnSubtract fn = intOp ss Subtract x y
convert other = other
fnZero = [(C.prelude, C.zero), (C.dataSemiring, C.zero)]
fnOne = [(C.prelude, C.one), (C.dataSemiring, C.one)]
@@ -100,16 +100,16 @@ inlineCommonValues = everywhereOnJS convert
fnDivide = [(C.prelude, (C./)), (C.prelude, (C.div)), (C.dataModuloSemiring, C.div)]
fnMultiply = [(C.prelude, (C.*)), (C.prelude, (C.mul)), (C.dataSemiring, (C.*)), (C.dataSemiring, (C.mul))]
fnSubtract = [(C.prelude, (C.-)), (C.prelude, C.sub), (C.dataRing, C.sub)]
- intOp op x y = JSBinary BitwiseOr (JSBinary op x y) (JSNumericLiteral (Left 0))
+ intOp ss op x y = JSBinary ss BitwiseOr (JSBinary ss op x y) (JSNumericLiteral ss (Left 0))
inlineOperator :: (String, String) -> (JS -> JS -> JS) -> JS -> JS
inlineOperator (m, op) f = everywhereOnJS convert
where
convert :: JS -> JS
- convert (JSApp (JSApp op' [x]) [y]) | isOp op' = f x y
+ convert (JSApp _ (JSApp _ op' [x]) [y]) | isOp op' = f x y
convert other = other
- isOp (JSAccessor longForm (JSVar m')) = m == m' && longForm == identToJs (Op op)
- isOp (JSIndexer (JSStringLiteral op') (JSVar m')) = m == m' && op == op'
+ isOp (JSAccessor _ longForm (JSVar _ m')) = m == m' && longForm == identToJs (Op op)
+ isOp (JSIndexer _ (JSStringLiteral _ op') (JSVar _ m')) = m == m' && op == op'
isOp _ = False
inlineCommonOperators :: JS -> JS
@@ -177,49 +177,49 @@ inlineCommonOperators = applyAll $
binary dict fns op = everywhereOnJS convert
where
convert :: JS -> JS
- convert (JSApp (JSApp (JSApp fn [dict']) [x]) [y]) | isDict' dict dict' && isFn' fns fn = JSBinary op x y
+ convert (JSApp ss (JSApp _ (JSApp _ fn [dict']) [x]) [y]) | isDict' dict dict' && isFn' fns fn = JSBinary ss op x y
convert other = other
binary' :: String -> String -> BinaryOperator -> JS -> JS
binary' moduleName opString op = everywhereOnJS convert
where
convert :: JS -> JS
- convert (JSApp (JSApp fn [x]) [y]) | isFn (moduleName, opString) fn = JSBinary op x y
+ convert (JSApp ss (JSApp _ fn [x]) [y]) | isFn (moduleName, opString) fn = JSBinary ss op x y
convert other = other
unary :: [(String, String)] -> [(String, String)] -> UnaryOperator -> JS -> JS
unary dicts fns op = everywhereOnJS convert
where
convert :: JS -> JS
- convert (JSApp (JSApp fn [dict']) [x]) | isDict' dicts dict' && isFn' fns fn = JSUnary op x
+ convert (JSApp ss (JSApp _ fn [dict']) [x]) | isDict' dicts dict' && isFn' fns fn = JSUnary ss op x
convert other = other
unary' :: String -> String -> UnaryOperator -> JS -> JS
unary' moduleName fnName op = everywhereOnJS convert
where
convert :: JS -> JS
- convert (JSApp fn [x]) | isFn (moduleName, fnName) fn = JSUnary op x
+ convert (JSApp ss fn [x]) | isFn (moduleName, fnName) fn = JSUnary ss op x
convert other = other
mkFn :: Int -> JS -> JS
mkFn 0 = everywhereOnJS convert
where
convert :: JS -> JS
- convert (JSApp mkFnN [JSFunction Nothing [_] (JSBlock js)]) | isNFn C.mkFn 0 mkFnN =
- JSFunction Nothing [] (JSBlock 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
convert :: JS -> JS
- convert orig@(JSApp mkFnN [fn]) | isNFn C.mkFn n mkFnN =
+ convert orig@(JSApp ss mkFnN [fn]) | isNFn C.mkFn n mkFnN =
case collectArgs n [] fn of
- Just (args, js) -> JSFunction Nothing args (JSBlock js)
+ Just (args, js) -> JSFunction ss Nothing args (JSBlock ss js)
Nothing -> orig
convert other = other
collectArgs :: Int -> [String] -> JS -> Maybe ([String], [JS])
- collectArgs 1 acc (JSFunction Nothing [oneArg] (JSBlock js)) | length acc == n - 1 = Just (reverse (oneArg : acc), js)
- collectArgs m acc (JSFunction Nothing [oneArg] (JSBlock [JSReturn ret])) = collectArgs (m - 1) (oneArg : acc) ret
+ collectArgs 1 acc (JSFunction _ Nothing [oneArg] (JSBlock _ js)) | length acc == n - 1 = Just (reverse (oneArg : acc), js)
+ collectArgs m acc (JSFunction _ Nothing [oneArg] (JSBlock _ [JSReturn _ ret])) = collectArgs (m - 1) (oneArg : acc) ret
collectArgs _ _ _ = Nothing
isNFn :: String -> Int -> JS -> Bool
- isNFn prefix n (JSVar name) = name == (prefix ++ show n)
- isNFn prefix n (JSAccessor name (JSVar dataFunction)) | dataFunction == C.dataFunction = name == (prefix ++ show n)
+ isNFn prefix n (JSVar _ name) = name == (prefix ++ show n)
+ isNFn prefix n (JSAccessor _ name (JSVar _ dataFunction)) | dataFunction == C.dataFunction = name == (prefix ++ show n)
isNFn _ _ _ = False
runFn :: Int -> JS -> JS
@@ -229,8 +229,8 @@ inlineCommonOperators = applyAll $
convert js = fromMaybe js $ go n [] js
go :: Int -> [JS] -> JS -> Maybe JS
- go 0 acc (JSApp runFnN [fn]) | isNFn C.runFn n runFnN && length acc == n = Just (JSApp fn acc)
- go m acc (JSApp lhs [arg]) = go (m - 1) (arg : acc) lhs
+ go 0 acc (JSApp ss runFnN [fn]) | isNFn C.runFn n runFnN && length acc == n = Just (JSApp ss fn acc)
+ go m acc (JSApp _ lhs [arg]) = go (m - 1) (arg : acc) lhs
go _ _ _ = Nothing
-- (f <<< g $ x) = f (g x)
@@ -239,16 +239,16 @@ inlineFnComposition :: (Applicative m, MonadSupply m) => JS -> m JS
inlineFnComposition = everywhereOnJSTopDownM convert
where
convert :: (MonadSupply m) => JS -> m JS
- convert (JSApp (JSApp (JSApp (JSApp fn [dict']) [x]) [y]) [z])
- | isFnCompose dict' fn = return $ JSApp x [JSApp y [z]]
- | isFnComposeFlipped dict' fn = return $ JSApp y [JSApp x [z]]
- convert (JSApp (JSApp (JSApp fn [dict']) [x]) [y])
+ 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]]
+ convert (JSApp ss (JSApp _ (JSApp _ fn [dict']) [x]) [y])
| isFnCompose dict' fn = do
arg <- freshName
- return $ JSFunction Nothing [arg] (JSBlock [JSReturn $ JSApp x [JSApp y [JSVar arg]]])
+ return $ JSFunction ss Nothing [arg] (JSBlock ss [JSReturn Nothing $ JSApp Nothing x [JSApp Nothing y [JSVar Nothing arg]]])
| isFnComposeFlipped dict' fn = do
arg <- freshName
- return $ JSFunction Nothing [arg] (JSBlock [JSReturn $ JSApp y [JSApp x [JSVar arg]]])
+ 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
diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs
index fb5eda8..30edbf0 100644
--- a/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs
+++ b/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs
@@ -40,46 +40,46 @@ magicDo' = everywhereOnJS undo . everywhereOnJSTopDown convert
-- Desugar monomorphic calls to >>= and return for the Eff monad
convert :: JS -> JS
-- Desugar pure & return
- convert (JSApp (JSApp pure' [val]) []) | isPure pure' = val
+ convert (JSApp _ (JSApp _ pure' [val]) []) | isPure pure' = val
-- Desugar >>
- convert (JSApp (JSApp bind [m]) [JSFunction Nothing [] (JSBlock js)]) | isBind bind =
- JSFunction (Just fnName) [] $ JSBlock (JSApp m [] : map applyReturns js )
+ convert (JSApp _ (JSApp _ bind [m]) [JSFunction s1 Nothing [] (JSBlock s2 js)]) | isBind bind =
+ JSFunction s1 (Just fnName) [] $ JSBlock s2 (JSApp s2 m [] : map applyReturns js )
-- Desugar >>=
- convert (JSApp (JSApp bind [m]) [JSFunction Nothing [arg] (JSBlock js)]) | isBind bind =
- JSFunction (Just fnName) [] $ JSBlock (JSVariableIntroduction arg (Just (JSApp m [])) : map applyReturns js)
+ convert (JSApp _ (JSApp _ bind [m]) [JSFunction s1 Nothing [arg] (JSBlock s2 js)]) | isBind bind =
+ JSFunction s1 (Just fnName) [] $ JSBlock s2 (JSVariableIntroduction s2 arg (Just (JSApp s2 m [])) : map applyReturns js)
-- Desugar untilE
- convert (JSApp (JSApp f [arg]) []) | isEffFunc C.untilE f =
- JSApp (JSFunction Nothing [] (JSBlock [ JSWhile (JSUnary Not (JSApp arg [])) (JSBlock []), JSReturn $ JSObjectLiteral []])) []
+ convert (JSApp s1 (JSApp _ f [arg]) []) | isEffFunc C.untilE f =
+ JSApp s1 (JSFunction s1 Nothing [] (JSBlock s1 [ JSWhile s1 (JSUnary s1 Not (JSApp s1 arg [])) (JSBlock s1 []), JSReturn s1 $ JSObjectLiteral s1 []])) []
-- Desugar whileE
- convert (JSApp (JSApp (JSApp f [arg1]) [arg2]) []) | isEffFunc C.whileE f =
- JSApp (JSFunction Nothing [] (JSBlock [ JSWhile (JSApp arg1 []) (JSBlock [ JSApp arg2 [] ]), JSReturn $ JSObjectLiteral []])) []
+ convert (JSApp _ (JSApp _ (JSApp s1 f [arg1]) [arg2]) []) | isEffFunc C.whileE f =
+ JSApp s1 (JSFunction s1 Nothing [] (JSBlock s1 [ JSWhile s1 (JSApp s1 arg1 []) (JSBlock s1 [ JSApp s1 arg2 [] ]), JSReturn s1 $ JSObjectLiteral s1 []])) []
convert other = other
-- Check if an expression represents a monomorphic call to >>= for the Eff monad
- isBind (JSApp fn [dict]) | isDict (C.eff, C.bindEffDictionary) dict && isBindPoly fn = True
+ isBind (JSApp _ fn [dict]) | isDict (C.eff, C.bindEffDictionary) dict && isBindPoly fn = True
isBind _ = False
-- Check if an expression represents a monomorphic call to pure or return for the Eff applicative
- isPure (JSApp fn [dict]) | isDict (C.eff, C.applicativeEffDictionary) dict && isPurePoly fn = True
+ 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.prelude, C.bind), (C.prelude, (C.>>=)), (C.controlBind, C.bind)]
-- Check if an expression represents the polymorphic pure or return function
isPurePoly = isFn' [(C.prelude, C.pure'), (C.prelude, C.return), (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 (JSAccessor _ name' (JSVar _ eff)) = eff == C.eff && name == name'
isEffFunc _ _ = False
-- Remove __do function applications which remain after desugaring
undo :: JS -> JS
- undo (JSReturn (JSApp (JSFunction (Just ident) [] body) [])) | ident == fnName = body
+ undo (JSReturn _ (JSApp _ (JSFunction _ (Just ident) [] body) [])) | ident == fnName = body
undo other = other
applyReturns :: JS -> JS
- applyReturns (JSReturn ret) = JSReturn (JSApp ret [])
- applyReturns (JSBlock jss) = JSBlock (map applyReturns jss)
- applyReturns (JSWhile cond js) = JSWhile cond (applyReturns js)
- applyReturns (JSFor v lo hi js) = JSFor v lo hi (applyReturns js)
- applyReturns (JSForIn v xs js) = JSForIn v xs (applyReturns js)
- applyReturns (JSIfElse cond t f) = JSIfElse cond (applyReturns t) (applyReturns `fmap` f)
+ applyReturns (JSReturn ss ret) = JSReturn ss (JSApp ss ret [])
+ applyReturns (JSBlock ss jss) = JSBlock ss (map applyReturns jss)
+ applyReturns (JSWhile ss cond js) = JSWhile ss cond (applyReturns js)
+ applyReturns (JSFor ss v lo hi js) = JSFor ss v lo hi (applyReturns js)
+ applyReturns (JSForIn ss v xs js) = JSForIn ss v xs (applyReturns js)
+ applyReturns (JSIfElse ss cond t f) = JSIfElse ss cond (applyReturns t) (applyReturns `fmap` f)
applyReturns other = other
-- |
@@ -91,7 +91,7 @@ inlineST = everywhereOnJS convertBlock
-- Look for runST blocks and inline the STRefs there.
-- If all STRefs are used in the scope of the same runST, only using { read, write, modify }STRef then
-- we can be more aggressive about inlining, and actually turn STRefs into local variables.
- convertBlock (JSApp f [arg]) | isSTFunc C.runST f =
+ convertBlock (JSApp _ f [arg]) | isSTFunc C.runST f =
let refs = nub . findSTRefsIn $ arg
usages = findAllSTUsagesIn arg
allUsagesAreLocalVars = all (\u -> let v = toVar u in isJust v && fromJust v `elem` refs) usages
@@ -101,34 +101,34 @@ inlineST = everywhereOnJS convertBlock
-- Convert a block in a safe way, preserving object wrappers of references,
-- or in a more aggressive way, turning wrappers into local variables depending on the
-- agg(ressive) parameter.
- convert agg (JSApp f [arg]) | isSTFunc C.newSTRef f =
- JSFunction Nothing [] (JSBlock [JSReturn $ if agg then arg else JSObjectLiteral [(C.stRefValue, arg)]])
- convert agg (JSApp (JSApp f [ref]) []) | isSTFunc C.readSTRef f =
- if agg then ref else JSAccessor C.stRefValue ref
- convert agg (JSApp (JSApp (JSApp f [ref]) [arg]) []) | isSTFunc C.writeSTRef f =
- if agg then JSAssignment ref arg else JSAssignment (JSAccessor C.stRefValue ref) arg
- convert agg (JSApp (JSApp (JSApp f [ref]) [func]) []) | isSTFunc C.modifySTRef f =
- if agg then JSAssignment ref (JSApp func [ref]) else JSAssignment (JSAccessor C.stRefValue ref) (JSApp func [JSAccessor C.stRefValue ref])
+ convert agg (JSApp s1 f [arg]) | isSTFunc C.newSTRef f =
+ JSFunction s1 Nothing [] (JSBlock s1 [JSReturn s1 $ if agg then arg else JSObjectLiteral s1 [(C.stRefValue, arg)]])
+ convert agg (JSApp _ (JSApp s1 f [ref]) []) | isSTFunc C.readSTRef f =
+ if agg then ref else JSAccessor 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
+ 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])
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 (JSAccessor _ name' (JSVar _ st)) = st == C.st && name == name'
isSTFunc _ _ = False
-- Find all ST Refs initialized in this block
findSTRefsIn = everythingOnJS (++) isSTRef
where
- isSTRef (JSVariableIntroduction ident (Just (JSApp (JSApp f [_]) []))) | isSTFunc C.newSTRef f = [ident]
+ isSTRef (JSVariableIntroduction _ ident (Just (JSApp _ (JSApp _ f [_]) []))) | isSTFunc C.newSTRef f = [ident]
isSTRef _ = []
-- Find all STRefs used as arguments to readSTRef, writeSTRef, modifySTRef
findAllSTUsagesIn = everythingOnJS (++) isSTUsage
where
- isSTUsage (JSApp (JSApp f [ref]) []) | isSTFunc C.readSTRef f = [ref]
- isSTUsage (JSApp (JSApp (JSApp f [ref]) [_]) []) | isSTFunc C.writeSTRef f || isSTFunc C.modifySTRef f = [ref]
+ isSTUsage (JSApp _ (JSApp _ f [ref]) []) | isSTFunc C.readSTRef f = [ref]
+ isSTUsage (JSApp _ (JSApp _ (JSApp _ f [ref]) [_]) []) | isSTFunc C.writeSTRef f || isSTFunc C.modifySTRef f = [ref]
isSTUsage _ = []
-- Find all uses of a variable
appearingIn ref = everythingOnJS (++) isVar
where
- isVar e@(JSVar v) | v == ref = [e]
+ isVar e@(JSVar _ v) | v == ref = [e]
isVar _ = []
-- Convert a JS value to a String if it is a JSVar
- toVar (JSVar v) = Just v
+ toVar (JSVar _ v) = Just v
toVar _ = Nothing
diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs
index 3908e5f..8cff910 100644
--- a/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs
+++ b/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs
@@ -40,7 +40,7 @@ tco' = everywhereOnJS convert
copyVar arg = "__copy_" ++ arg
convert :: JS -> JS
- convert js@(JSVariableIntroduction name (Just fn@JSFunction {})) =
+ convert js@(JSVariableIntroduction ss name (Just fn@JSFunction {})) =
let
(argss, body', replace) = collectAllFunctionArgs [] id fn
in case () of
@@ -48,19 +48,19 @@ tco' = everywhereOnJS convert
let
allArgs = concat $ reverse argss
in
- JSVariableIntroduction name (Just (replace (toLoop name allArgs body')))
+ JSVariableIntroduction ss name (Just (replace (toLoop name allArgs body')))
| otherwise -> js
convert js = js
collectAllFunctionArgs :: [[String]] -> (JS -> JS) -> JS -> ([[String]], JS, JS -> JS)
- collectAllFunctionArgs allArgs f (JSFunction ident args (JSBlock (body@(JSReturn _):_))) =
- collectAllFunctionArgs (args : allArgs) (\b -> f (JSFunction ident (map copyVar args) (JSBlock [b]))) body
- collectAllFunctionArgs allArgs f (JSFunction ident args body@(JSBlock _)) =
- (args : allArgs, body, f . JSFunction ident (map copyVar args))
- collectAllFunctionArgs allArgs f (JSReturn (JSFunction ident args (JSBlock [body]))) =
- collectAllFunctionArgs (args : allArgs) (\b -> f (JSReturn (JSFunction ident (map copyVar args) (JSBlock [b])))) body
- collectAllFunctionArgs allArgs f (JSReturn (JSFunction ident args body@(JSBlock _))) =
- (args : allArgs, body, f . JSReturn . JSFunction ident (map copyVar args))
+ collectAllFunctionArgs allArgs f (JSFunction s1 ident args (JSBlock s2 (body@(JSReturn _ _):_))) =
+ collectAllFunctionArgs (args : allArgs) (\b -> f (JSFunction s1 ident (map copyVar args) (JSBlock s2 [b]))) body
+ collectAllFunctionArgs allArgs f (JSFunction ss ident args body@(JSBlock _ _)) =
+ (args : allArgs, body, f . JSFunction ss ident (map copyVar args))
+ collectAllFunctionArgs allArgs f (JSReturn s1 (JSFunction s2 ident args (JSBlock s3 [body]))) =
+ collectAllFunctionArgs (args : allArgs) (\b -> f (JSReturn s1 (JSFunction s2 ident (map copyVar args) (JSBlock s3 [b])))) body
+ collectAllFunctionArgs allArgs f (JSReturn s1 (JSFunction s2 ident args body@(JSBlock _ _))) =
+ (args : allArgs, body, f . JSReturn s1 . JSFunction s2 ident (map copyVar args))
collectAllFunctionArgs allArgs f body = (allArgs, body, f)
isTailCall :: String -> JS -> Bool
@@ -77,51 +77,53 @@ tco' = everywhereOnJS convert
&& numSelfCallWithFnArgs == 0
where
countSelfCalls :: JS -> Int
- countSelfCalls (JSApp (JSVar ident') _) | ident == ident' = 1
+ countSelfCalls (JSApp _ (JSVar _ ident') _) | ident == ident' = 1
countSelfCalls _ = 0
-
+
countSelfCallsInTailPosition :: JS -> Int
- countSelfCallsInTailPosition (JSReturn ret) | isSelfCall ident ret = 1
+ countSelfCallsInTailPosition (JSReturn _ ret) | isSelfCall ident ret = 1
countSelfCallsInTailPosition _ = 0
-
+
countSelfCallsUnderFunctions :: JS -> Int
- countSelfCallsUnderFunctions (JSFunction _ _ js') = everythingOnJS (+) countSelfCalls js'
+ countSelfCallsUnderFunctions (JSFunction _ _ _ js') = everythingOnJS (+) countSelfCalls js'
countSelfCallsUnderFunctions _ = 0
-
+
countSelfCallsWithFnArgs :: JS -> Int
countSelfCallsWithFnArgs ret = if isSelfCallWithFnArgs ident ret [] then 1 else 0
toLoop :: String -> [String] -> JS -> JS
- toLoop ident allArgs js = JSBlock $
- map (\arg -> JSVariableIntroduction arg (Just (JSVar (copyVar arg)))) allArgs ++
- [ JSLabel tcoLabel $ JSWhile (JSBooleanLiteral True) (JSBlock [ everywhereOnJS loopify js ]) ]
+ toLoop ident allArgs js = JSBlock rootSS $
+ map (\arg -> JSVariableIntroduction rootSS arg (Just (JSVar rootSS (copyVar arg)))) allArgs ++
+ [ JSLabel rootSS tcoLabel $ JSWhile rootSS (JSBooleanLiteral rootSS True) (JSBlock rootSS [ everywhereOnJS loopify js ]) ]
where
+ rootSS = Nothing
+
loopify :: JS -> JS
- loopify (JSReturn ret) | isSelfCall ident ret =
+ loopify (JSReturn ss ret) | isSelfCall ident ret =
let
allArgumentValues = concat $ collectSelfCallArgs [] ret
in
- JSBlock $ zipWith (\val arg ->
- JSVariableIntroduction (tcoVar arg) (Just val)) allArgumentValues allArgs
+ JSBlock ss $ zipWith (\val arg ->
+ JSVariableIntroduction ss (tcoVar arg) (Just val)) allArgumentValues allArgs
++ map (\arg ->
- JSAssignment (JSVar arg) (JSVar (tcoVar arg))) allArgs
- ++ [ JSContinue tcoLabel ]
+ JSAssignment ss (JSVar ss arg) (JSVar ss (tcoVar arg))) allArgs
+ ++ [ JSContinue ss tcoLabel ]
loopify other = other
collectSelfCallArgs :: [[JS]] -> JS -> [[JS]]
- collectSelfCallArgs allArgumentValues (JSApp fn args') = collectSelfCallArgs (args' : allArgumentValues) fn
+ collectSelfCallArgs allArgumentValues (JSApp _ fn args') = collectSelfCallArgs (args' : allArgumentValues) fn
collectSelfCallArgs allArgumentValues _ = allArgumentValues
isSelfCall :: String -> JS -> Bool
- isSelfCall ident (JSApp (JSVar ident') _) = ident == ident'
- isSelfCall ident (JSApp fn _) = isSelfCall ident fn
+ isSelfCall ident (JSApp _ (JSVar _ ident') _) = ident == ident'
+ isSelfCall ident (JSApp _ fn _) = isSelfCall ident fn
isSelfCall _ _ = False
isSelfCallWithFnArgs :: String -> 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 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 :: JS -> Bool
hasFunction = getAny . everythingOnJS mappend (Any . isFunction)
where
isFunction JSFunction{} = True
diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Unused.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Unused.hs
index 7a3b6d3..0f3d851 100644
--- a/src/Language/PureScript/CodeGen/JS/Optimizer/Unused.hs
+++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Unused.hs
@@ -30,17 +30,17 @@ removeCodeAfterReturnStatements = everywhereOnJS (removeFromBlock go)
go :: [JS] -> [JS]
go jss | not (any isJSReturn jss) = jss
| otherwise = let (body, ret : _) = break isJSReturn jss in body ++ [ret]
- isJSReturn (JSReturn _) = True
+ isJSReturn (JSReturn _ _) = True
isJSReturn _ = False
removeUnusedArg :: JS -> JS
removeUnusedArg = everywhereOnJS convert
where
- convert (JSFunction name [arg] body) | arg == C.__unused = JSFunction name [] body
+ convert (JSFunction ss name [arg] body) | arg == C.__unused = JSFunction ss name [] body
convert js = js
removeUndefinedApp :: JS -> JS
removeUndefinedApp = everywhereOnJS convert
where
- convert (JSApp fn [JSVar arg]) | arg == C.undefined = JSApp fn []
+ convert (JSApp ss fn [JSVar _ arg]) | arg == C.undefined = JSApp ss fn []
convert js = js
diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs
index 573654a..6a57d3f 100644
--- a/src/Language/PureScript/Constants.hs
+++ b/src/Language/PureScript/Constants.hs
@@ -98,6 +98,9 @@ eq = "eq"
notEq :: String
notEq = "notEq"
+compare :: String
+compare = "compare"
+
(&&) :: String
(&&) = "&&"
diff --git a/src/Language/PureScript/CoreFn/Binders.hs b/src/Language/PureScript/CoreFn/Binders.hs
index 15b833d..ae8a014 100644
--- a/src/Language/PureScript/CoreFn/Binders.hs
+++ b/src/Language/PureScript/CoreFn/Binders.hs
@@ -31,5 +31,12 @@ data Binder a
-- |
-- A binder which binds its input to an identifier
--
- | NamedBinder a Ident (Binder a)
- deriving (Show, Read, Functor)
+ | NamedBinder a Ident (Binder a) deriving (Show, Read, Functor)
+
+
+extractBinderAnn :: Binder a -> a
+extractBinderAnn (NullBinder a) = a
+extractBinderAnn (LiteralBinder a _) = a
+extractBinderAnn (VarBinder a _) = a
+extractBinderAnn (ConstructorBinder a _ _ _) = a
+extractBinderAnn (NamedBinder a _ _) = a
diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs
index dbc9717..9816bc0 100644
--- a/src/Language/PureScript/CoreFn/Desugar.hs
+++ b/src/Language/PureScript/CoreFn/Desugar.hs
@@ -1,5 +1,9 @@
module Language.PureScript.CoreFn.Desugar (moduleToCoreFn) where
+import Prelude ()
+import Prelude.Compat
+
+
import Data.Function (on)
import Data.List (sort, sortBy, nub)
import Data.Maybe (mapMaybe)
@@ -30,36 +34,52 @@ moduleToCoreFn :: Environment -> A.Module -> Module Ann
moduleToCoreFn _ (A.Module _ _ _ _ Nothing) =
internalError "Module exports were not elaborated before moduleToCoreFn"
moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =
- let imports = nub $ mapMaybe importToCoreFn decls ++ findQualModules decls
+ let imports = mapMaybe importToCoreFn decls ++ findQualModules decls
+ imports' = nub $ filter (keepImp imports) imports-- TODO could be more efficient
exps' = nub $ concatMap exportToCoreFn exps
externs = nub $ mapMaybe externToCoreFn decls
decls' = concatMap (declToCoreFn Nothing []) decls
- in Module coms mn imports exps' externs decls'
+ in Module coms mn imports' exps' externs decls'
where
+ -- Remove duplicate imports favoring the one containing sourcespan info
+ keepImp :: [(Ann, ModuleName)] -> (Ann, ModuleName) -> Bool
+ keepImp imps (a, i) = hasSS a || not (any hasDup imps)
+ where
+ hasDup (a', i') = i == i' && hasSS a'
+
+ hasSS :: Ann -> Bool
+ hasSS (Just _, _, _, _) = True
+ hasSS _ = False
+
+ ssA :: Maybe SourceSpan -> Ann
+ ssA ss = (ss, [], Nothing, Nothing)
+
-- |
-- Desugars member declarations from AST to CoreFn representation.
--
declToCoreFn :: Maybe SourceSpan -> [Comment] -> A.Declaration -> [Bind Ann]
declToCoreFn ss com (A.DataDeclaration Newtype _ _ [(ctor, _)]) =
- [NonRec (properToIdent ctor) $
+ [NonRec (ssA ss) (properToIdent ctor) $
Abs (ss, com, Nothing, Just IsNewtype) (Ident "x") (Var nullAnn $ Qualified Nothing (Ident "x"))]
declToCoreFn _ _ d@(A.DataDeclaration Newtype _ _ _) =
error $ "Found newtype with multiple constructors: " ++ show d
declToCoreFn ss com (A.DataDeclaration Data tyName _ ctors) =
flip map ctors $ \(ctor, _) ->
let (_, _, _, fields) = lookupConstructor env (Qualified (Just mn) ctor)
- in NonRec (properToIdent ctor) $ Constructor (ss, com, Nothing, Nothing) tyName ctor fields
+ in NonRec (ssA ss) (properToIdent ctor) $ Constructor (ss, com, Nothing, Nothing) tyName ctor fields
declToCoreFn ss _ (A.DataBindingGroupDeclaration ds) = concatMap (declToCoreFn ss []) ds
declToCoreFn ss com (A.ValueDeclaration name _ _ (Right e)) =
- [NonRec name (exprToCoreFn ss com Nothing e)]
+ [NonRec (ssA ss) name (exprToCoreFn ss com Nothing e)]
declToCoreFn ss com (A.FixityDeclaration _ name (Just alias)) =
- [NonRec (Op name) (Var (ss, com, Nothing, getValueMeta alias) alias)]
+ let meta = either getValueMeta (Just . getConstructorMeta) alias
+ alias' = either id (fmap properToIdent) alias
+ in [NonRec (ssA ss) (Op name) (Var (ss, com, Nothing, meta) alias')]
declToCoreFn ss _ (A.BindingGroupDeclaration ds) =
- [Rec $ map (\(name, _, e) -> (name, exprToCoreFn ss [] Nothing e)) ds]
+ [Rec $ map (\(name, _, e) -> ((ssA ss, name), exprToCoreFn ss [] Nothing e)) ds]
declToCoreFn ss com (A.TypeClassDeclaration name _ supers members) =
- [NonRec (properToIdent name) $ mkTypeClassConstructor ss com supers members]
+ [NonRec (ssA ss) (properToIdent name) $ mkTypeClassConstructor ss com supers members]
declToCoreFn _ com (A.PositionedDeclaration ss com1 d) =
declToCoreFn (Just ss) (com ++ com1) d
declToCoreFn _ _ _ = []
@@ -157,6 +177,12 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =
binderToCoreFn (Just ss) (com ++ com1) b
binderToCoreFn ss com (A.TypedBinder _ b) =
binderToCoreFn ss com b
+ binderToCoreFn _ _ A.OpBinder{} =
+ internalError "OpBinder should have been desugared before binderToCoreFn"
+ binderToCoreFn _ _ A.BinaryNoParensBinder{} =
+ internalError "BinaryNoParensBinder should have been desugared before binderToCoreFn"
+ binderToCoreFn _ _ A.ParensInBinder{} =
+ internalError "ParensInBinder should have been desugared before binderToCoreFn"
-- |
-- Gets metadata for values.
@@ -195,31 +221,36 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =
-- ensure instances are imported from any module that is referenced by the
-- current module, not just from those that are imported explicitly (#667).
--
-findQualModules :: [A.Declaration] -> [ModuleName]
+findQualModules :: [A.Declaration] -> [(Ann, ModuleName)]
findQualModules decls =
let (f, _, _, _, _) = everythingOnValues (++) fqDecls fqValues fqBinders (const []) (const [])
in f `concatMap` decls
where
- fqDecls :: A.Declaration -> [ModuleName]
- fqDecls (A.TypeInstanceDeclaration _ _ (Qualified (Just mn) _) _ _) = [mn]
- fqDecls (A.FixityDeclaration _ _ (Just (Qualified (Just mn) _))) = [mn]
+ fqDecls :: A.Declaration -> [(Ann, ModuleName)]
+ fqDecls (A.TypeInstanceDeclaration _ _ q _ _) = getQual q
+ fqDecls (A.FixityDeclaration _ _ (Just eq)) = either getQual getQual eq
fqDecls _ = []
- fqValues :: A.Expr -> [ModuleName]
- fqValues (A.Var (Qualified (Just mn) _)) = [mn]
- fqValues (A.Constructor (Qualified (Just mn) _)) = [mn]
+ fqValues :: A.Expr -> [(Ann, ModuleName)]
+ fqValues (A.Var q) = getQual q
+ fqValues (A.Constructor q) = getQual q
fqValues _ = []
- fqBinders :: A.Binder -> [ModuleName]
- fqBinders (A.ConstructorBinder (Qualified (Just mn) _) _) = [mn]
+ fqBinders :: A.Binder -> [(Ann, ModuleName)]
+ fqBinders (A.ConstructorBinder q _) = getQual q
fqBinders _ = []
+ getQual :: Qualified a -> [(Ann, ModuleName)]
+ getQual (Qualified (Just mn) _) = [(nullAnn, mn)]
+ getQual _ = []
+
-- |
-- Desugars import declarations from AST to CoreFn representation.
--
-importToCoreFn :: A.Declaration -> Maybe ModuleName
-importToCoreFn (A.ImportDeclaration name _ _ _) = Just name
-importToCoreFn (A.PositionedDeclaration _ _ d) = importToCoreFn d
+importToCoreFn :: A.Declaration -> Maybe (Ann, ModuleName)
+importToCoreFn (A.ImportDeclaration name _ _ _) = Just (nullAnn, name)
+importToCoreFn (A.PositionedDeclaration ss _ d) =
+ ((,) (Just ss, [], Nothing, Nothing) . snd) <$> importToCoreFn d
importToCoreFn _ = Nothing
-- |
diff --git a/src/Language/PureScript/CoreFn/Expr.hs b/src/Language/PureScript/CoreFn/Expr.hs
index 2445556..c4117d7 100644
--- a/src/Language/PureScript/CoreFn/Expr.hs
+++ b/src/Language/PureScript/CoreFn/Expr.hs
@@ -60,12 +60,11 @@ data Bind a
-- |
-- Non-recursive binding for a single value
--
- = NonRec Ident (Expr a)
+ = NonRec a Ident (Expr a)
-- |
-- Mutually recursive binding group for several values
--
- | Rec [(Ident, Expr a)]
- deriving (Show, Read, Functor)
+ | Rec [((a, Ident), Expr a)] deriving (Show, Read, Functor)
-- |
-- A guard is just a boolean-valued expression that appears alongside a set of binders
@@ -84,8 +83,7 @@ data CaseAlternative a = CaseAlternative
-- The result expression or a collect of guarded expressions
--
, caseAlternativeResult :: Either [(Guard a, Expr a)] (Expr a)
- }
- deriving (Show, Read)
+ } deriving (Show, Read)
instance Functor CaseAlternative where
diff --git a/src/Language/PureScript/CoreFn/Meta.hs b/src/Language/PureScript/CoreFn/Meta.hs
index 91d77a0..da583ae 100644
--- a/src/Language/PureScript/CoreFn/Meta.hs
+++ b/src/Language/PureScript/CoreFn/Meta.hs
@@ -24,8 +24,7 @@ data Meta
-- |
-- The contained reference is for a foreign member
--
- | IsForeign
- deriving (Show, Read)
+ | IsForeign deriving (Show, Read, Eq)
-- |
-- Data constructor metadata
@@ -38,5 +37,4 @@ data ConstructorType
-- |
-- The constructor is for a type with multiple construcors
--
- | SumType
- deriving (Show, Read)
+ | SumType deriving (Show, Read, Eq)
diff --git a/src/Language/PureScript/CoreFn/Module.hs b/src/Language/PureScript/CoreFn/Module.hs
index c9ceeb1..383c9ca 100644
--- a/src/Language/PureScript/CoreFn/Module.hs
+++ b/src/Language/PureScript/CoreFn/Module.hs
@@ -22,7 +22,7 @@ import Language.PureScript.Types
data Module a = Module
{ moduleComments :: [Comment]
, moduleName :: ModuleName
- , moduleImports :: [ModuleName]
+ , moduleImports :: [(a, ModuleName)]
, moduleExports :: [Ident]
, moduleForeign :: [ForeignDecl]
, moduleDecls :: [Bind a]
diff --git a/src/Language/PureScript/CoreFn/Traversals.hs b/src/Language/PureScript/CoreFn/Traversals.hs
index 8b10f67..91a077e 100644
--- a/src/Language/PureScript/CoreFn/Traversals.hs
+++ b/src/Language/PureScript/CoreFn/Traversals.hs
@@ -26,7 +26,7 @@ everywhereOnValues :: (Bind a -> Bind a) ->
(Bind a -> Bind a, Expr a -> Expr a, Binder a -> Binder a)
everywhereOnValues f g h = (f', g', h')
where
- f' (NonRec name e) = f (NonRec name (g' e))
+ f' (NonRec a name e) = f (NonRec a name (g' e))
f' (Rec es) = f (Rec (map (second g') es))
g' (Literal ann e) = g (Literal ann (handleLiteral g' e))
@@ -61,7 +61,7 @@ everythingOnValues :: (r -> r -> r) ->
(Bind a -> r, Expr a -> r, Binder a -> r, CaseAlternative a -> r)
everythingOnValues (<>) f g h i = (f', g', h', i')
where
- f' b@(NonRec _ e) = f b <> g' e
+ f' b@(NonRec _ _ e) = f b <> g' e
f' b@(Rec es) = foldl (<>) (f b) (map (g' . snd) es)
g' v@(Literal _ l) = foldl (<>) (g v) (map g' (extractLiteral l))
diff --git a/src/Language/PureScript/Docs.hs b/src/Language/PureScript/Docs.hs
index 837403f..bd84e8b 100644
--- a/src/Language/PureScript/Docs.hs
+++ b/src/Language/PureScript/Docs.hs
@@ -11,4 +11,4 @@ import Language.PureScript.Docs.RenderedCode.Types as Docs
import Language.PureScript.Docs.RenderedCode.Render as Docs
import Language.PureScript.Docs.Convert as Docs
import Language.PureScript.Docs.Render as Docs
-import Language.PureScript.Docs.ParseAndDesugar as Docs
+import Language.PureScript.Docs.ParseAndBookmark as Docs
diff --git a/src/Language/PureScript/Docs/AsMarkdown.hs b/src/Language/PureScript/Docs/AsMarkdown.hs
index e0b6e4b..9d1f0a6 100644
--- a/src/Language/PureScript/Docs/AsMarkdown.hs
+++ b/src/Language/PureScript/Docs/AsMarkdown.hs
@@ -31,31 +31,29 @@ import qualified Language.PureScript.Docs.Render as Render
renderModulesAsMarkdown ::
(Functor m, Applicative m,
MonadError P.MultipleErrors m) =>
- P.Env ->
[P.Module] ->
m String
-renderModulesAsMarkdown env =
- fmap (runDocs . modulesAsMarkdown) . Convert.convertModules env
+renderModulesAsMarkdown =
+ fmap (runDocs . modulesAsMarkdown) . Convert.convertModules
modulesAsMarkdown :: [Module] -> Docs
modulesAsMarkdown = mapM_ moduleAsMarkdown
moduleAsMarkdown :: Module -> Docs
moduleAsMarkdown Module{..} = do
- headerLevel 2 $ "Module " ++ modName
+ headerLevel 2 $ "Module " ++ P.runModuleName modName
spacer
for_ modComments tell'
mapM_ (declAsMarkdown modName) modDeclarations
spacer
for_ modReExports $ \(mn, decls) -> do
- let modName' = P.runModuleName mn
- headerLevel 3 $ "Re-exported from " ++ modName' ++ ":"
+ headerLevel 3 $ "Re-exported from " ++ P.runModuleName mn ++ ":"
spacer
- mapM_ (declAsMarkdown modName') decls
+ mapM_ (declAsMarkdown mn) decls
-declAsMarkdown :: String -> Declaration -> Docs
+declAsMarkdown :: P.ModuleName -> Declaration -> Docs
declAsMarkdown mn decl@Declaration{..} = do
- let options = defaultRenderTypeOptions { currentModule = Just (P.moduleNameFromString mn) }
+ let options = defaultRenderTypeOptions { currentModule = Just mn }
headerLevel 4 (ticks declTitle)
spacer
diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs
index 9d34a45..3b98889 100644
--- a/src/Language/PureScript/Docs/Convert.hs
+++ b/src/Language/PureScript/Docs/Convert.hs
@@ -16,12 +16,17 @@ module Language.PureScript.Docs.Convert
import Prelude ()
import Prelude.Compat
-import Control.Monad.Error.Class (MonadError)
-import Control.Arrow ((&&&))
+import Control.Arrow ((&&&), second)
import Control.Category ((>>>))
+import Control.Monad
+import Control.Monad.State (runStateT)
+import Control.Monad.Writer.Strict (runWriterT)
+import Control.Monad.Error.Class (MonadError)
import qualified Data.Map as Map
+import Text.Parsec (eof)
import qualified Language.PureScript as P
+import qualified Language.PureScript.Constants as C
import Language.PureScript.Docs.Types
import Language.PureScript.Docs.Convert.Single (convertSingleModule, collectBookmarks)
@@ -33,18 +38,17 @@ import Language.PureScript.Docs.Convert.ReExports (updateReExports)
-- documentation.
--
convertModulesInPackage ::
- (Functor m, MonadError P.MultipleErrors m) =>
- P.Env ->
+ (Functor m, Applicative m, MonadError P.MultipleErrors m) =>
[InPackage P.Module] ->
m [Module]
-convertModulesInPackage env modules =
+convertModulesInPackage modules =
go modules
where
localNames =
- map (P.runModuleName . P.getModuleName) (takeLocals modules)
+ map P.getModuleName (takeLocals modules)
go =
map ignorePackage
- >>> convertModules env
+ >>> convertModules
>>> fmap (filter ((`elem` localNames) . modName))
-- |
@@ -53,35 +57,140 @@ convertModulesInPackage env modules =
-- imports/exports information about the list of modules, which is needed for
-- documenting re-exports.
--
--- Preconditions:
+-- 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
+-- be included.
--
--- * If any module in the list re-exports documentation from other
--- modules, those modules must also be included in the list.
--- * The modules passed must have had names desugared and re-exports
--- elaborated first.
---
--- If either of these are not satisfied, an internal error will be thrown. To
--- avoid this, it is recommended to use
--- Language.PureScript.Docs.ParseAndDesugar to construct the inputs to this
--- function.
+-- For value declarations, if explicit type signatures are omitted, or a
+-- wildcard type is used, then we typecheck the modules and use the inferred
+-- types.
--
convertModules ::
- (Functor m, MonadError P.MultipleErrors m) =>
- P.Env ->
+ (Functor m, Applicative m, MonadError P.MultipleErrors m) =>
[P.Module] ->
m [Module]
-convertModules env =
- P.sortModules >>> fmap (convertSorted env . fst)
+convertModules =
+ P.sortModules
+ >>> fmap (fst >>> map importPrim)
+ >=> convertSorted
+
+importPrim :: P.Module -> P.Module
+importPrim = P.addDefaultImport (P.ModuleName [P.ProperName C.prim])
-- |
-- Convert a sorted list of modules.
--
-convertSorted :: P.Env -> [P.Module] -> [Module]
-convertSorted env modules =
- let
- traversalOrder =
- map P.getModuleName modules
- moduleMap =
- Map.fromList $ map (P.getModuleName &&& convertSingleModule) modules
- in
- Map.elems (updateReExports env traversalOrder moduleMap)
+convertSorted ::
+ (Functor m, Applicative m, MonadError P.MultipleErrors m) =>
+ [P.Module] ->
+ m [Module]
+convertSorted modules = do
+ (env, convertedModules) <- second (map convertSingleModule) <$> partiallyDesugar modules
+
+ modulesWithTypes <- typeCheckIfNecessary modules convertedModules
+ let moduleMap = Map.fromList (map (modName &&& id) modulesWithTypes)
+
+ let traversalOrder = map P.getModuleName modules
+ pure (Map.elems (updateReExports env traversalOrder moduleMap))
+
+-- |
+-- If any exported value declarations have either wildcard type signatures, or
+-- none at all, then typecheck in order to fill them in with the inferred
+-- types.
+--
+typeCheckIfNecessary ::
+ (Functor m, Applicative m, MonadError P.MultipleErrors m) =>
+ [P.Module] ->
+ [Module] ->
+ m [Module]
+typeCheckIfNecessary modules convertedModules =
+ if any hasWildcards convertedModules
+ then go
+ else pure convertedModules
+
+ where
+ hasWildcards =
+ any ((==) (ValueDeclaration P.TypeWildcard) . declInfo) . modDeclarations
+
+ go = do
+ checkEnv <- snd <$> typeCheck modules
+ pure (map (insertValueTypes checkEnv) convertedModules)
+
+-- |
+-- Typechecks all the modules together. Also returns the final 'P.Environment',
+-- which is useful for adding in inferred types where explicit declarations
+-- were not provided.
+--
+typeCheck ::
+ (Functor m, MonadError P.MultipleErrors m) =>
+ [P.Module] ->
+ m ([P.Module], P.Environment)
+typeCheck =
+ (P.desugar [] >=> check)
+ >>> fmap (second P.checkEnv)
+ >>> P.evalSupplyT 0
+ >>> ignoreWarnings
+
+ where
+ check ms =
+ runStateT
+ (traverse P.typeCheckModule ms)
+ (P.emptyCheckState P.initEnvironment)
+
+ ignoreWarnings =
+ fmap fst . runWriterT
+
+-- |
+-- Updates all the types of the ValueDeclarations inside the module based on
+-- their types inside the given Environment.
+--
+insertValueTypes ::
+ P.Environment -> Module -> Module
+insertValueTypes env m =
+ m { modDeclarations = map go (modDeclarations m) }
+ where
+ go (d@Declaration { declInfo = ValueDeclaration P.TypeWildcard }) =
+ let
+ ident = parseIdent (declTitle d)
+ ty = lookupName ident
+ in
+ d { declInfo = ValueDeclaration ty }
+ go other =
+ other
+
+ parseIdent =
+ either (err . ("failed to parse Ident: " ++)) id . runParser P.parseIdent
+
+ lookupName name =
+ let key = (modName m, name)
+ in case Map.lookup key (P.names env) of
+ Just (ty, _, _) ->
+ ty
+ Nothing ->
+ err ("name not found: " ++ show key)
+
+ err msg =
+ P.internalError ("Docs.Convert.insertValueTypes: " ++ msg)
+
+runParser :: P.TokenParser a -> String -> Either String a
+runParser p s = either (Left . show) Right $ do
+ ts <- P.lex "" s
+ P.runTokenParser "" (p <* eof) ts
+
+-- |
+-- Partially desugar modules so that they are suitable for extracting
+-- documentation information from.
+--
+partiallyDesugar ::
+ (Functor m, Applicative m, MonadError P.MultipleErrors m) =>
+ [P.Module]
+ -> m (P.Env, [P.Module])
+partiallyDesugar = P.evalSupplyT 0 . desugar'
+ where
+ desugar' =
+ traverse P.desugarDoModule
+ >=> P.desugarCasesModule
+ >=> P.desugarTypeDeclarationsModule
+ >=> ignoreWarnings . P.desugarImportsWithEnv []
+
+ ignoreWarnings = fmap fst . runWriterT
diff --git a/src/Language/PureScript/Docs/Convert/ReExports.hs b/src/Language/PureScript/Docs/Convert/ReExports.hs
index a42d0e6..a9330f9 100644
--- a/src/Language/PureScript/Docs/Convert/ReExports.hs
+++ b/src/Language/PureScript/Docs/Convert/ReExports.hs
@@ -155,16 +155,16 @@ collectDeclarations imports exports = do
--
findImport ::
(Show name, Eq name, Applicative m, MonadReader P.ModuleName m) =>
- [(P.Qualified name, P.ModuleName)] ->
+ [P.ImportRecord name] ->
(name, P.ModuleName) ->
m (P.ModuleName, name)
findImport imps (name, orig) =
let
- matches (qual, mn) = P.disqualify qual == name && mn == orig
+ matches (P.ImportRecord qual mn _) = P.disqualify qual == name && mn == orig
matching = filter matches imps
getQualified (P.Qualified mname _) = mname
in
- case mapMaybe (getQualified . fst) matching of
+ case mapMaybe (getQualified . P.importName) matching of
-- A value can occur more than once if it is imported twice (eg, if it is
-- exported by A, re-exported from A by B, and C imports it from both A
-- and B). In this case, we just take its first appearance.
diff --git a/src/Language/PureScript/Docs/Convert/Single.hs b/src/Language/PureScript/Docs/Convert/Single.hs
index ceec9b3..cade0ec 100644
--- a/src/Language/PureScript/Docs/Convert/Single.hs
+++ b/src/Language/PureScript/Docs/Convert/Single.hs
@@ -29,7 +29,7 @@ import Language.PureScript.Docs.Types
--
convertSingleModule :: P.Module -> Module
convertSingleModule m@(P.Module _ coms moduleName _ _) =
- Module (P.runModuleName moduleName) comments (declarations m) []
+ Module moduleName comments (declarations m) []
where
comments = convertComments coms
declarations =
@@ -109,7 +109,7 @@ addDefaultFixity decl@Declaration{..}
defaultFixity = P.Fixity P.Infixl (-1)
getDeclarationTitle :: P.Declaration -> Maybe String
-getDeclarationTitle (P.TypeDeclaration name _) = Just (P.showIdent name)
+getDeclarationTitle (P.ValueDeclaration name _ _ _) = Just (P.showIdent name)
getDeclarationTitle (P.ExternDeclaration name _) = Just (P.showIdent name)
getDeclarationTitle (P.DataDeclaration _ name _ _) = Just (P.runProperName name)
getDeclarationTitle (P.ExternDataDeclaration name _) = Just (P.runProperName name)
@@ -135,8 +135,12 @@ basicDeclaration :: String -> DeclarationInfo -> Maybe IntermediateDeclaration
basicDeclaration title info = Just $ Right $ mkDeclaration title info
convertDeclaration :: P.Declaration -> String -> Maybe IntermediateDeclaration
-convertDeclaration (P.TypeDeclaration _ ty) title =
+convertDeclaration (P.ValueDeclaration _ _ _ (Right (P.TypedValue _ _ ty))) title =
basicDeclaration title (ValueDeclaration ty)
+convertDeclaration (P.ValueDeclaration _ _ _ _) title =
+ -- If no explicit type declaration was provided, insert a wildcard, so that
+ -- the actual type will be added during type checking.
+ basicDeclaration title (ValueDeclaration P.TypeWildcard)
convertDeclaration (P.ExternDeclaration _ ty) title =
basicDeclaration title (ValueDeclaration ty)
convertDeclaration (P.DataDeclaration dtype _ args ctors) title =
diff --git a/src/Language/PureScript/Docs/ParseAndDesugar.hs b/src/Language/PureScript/Docs/ParseAndBookmark.hs
index 2f0302a..ed94820 100644
--- a/src/Language/PureScript/Docs/ParseAndDesugar.hs
+++ b/src/Language/PureScript/Docs/ParseAndBookmark.hs
@@ -1,8 +1,8 @@
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE FlexibleContexts #-}
-module Language.PureScript.Docs.ParseAndDesugar
- ( parseAndDesugar
+module Language.PureScript.Docs.ParseAndBookmark
+ ( parseAndBookmark
) where
import Prelude ()
@@ -10,16 +10,13 @@ import Prelude.Compat
import qualified Data.Map as M
import Control.Arrow (first)
-import Control.Monad
-import Control.Monad.Writer.Strict (runWriterT)
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.IO.Class (MonadIO(..))
import Web.Bower.PackageMeta (PackageName)
import qualified Language.PureScript as P
-import qualified Language.PureScript.Constants as C
import Language.PureScript.Docs.Types
import Language.PureScript.Docs.Convert (collectBookmarks)
@@ -35,23 +32,18 @@ import Language.PureScript.Docs.Convert (collectBookmarks)
-- * Parse all of the input and dependency source files
-- * Associate each dependency module with its package name, thereby
-- distinguishing these from local modules
--- * Partially desugar all of the resulting modules (just enough for
--- producing documentation from them)
-- * Collect a list of bookmarks from the whole set of source files
--- * Return the desugared modules, the bookmarks, and the imports/exports
--- Env (which is needed for producing documentation).
-parseAndDesugar ::
+-- * Return the parsed modules and the bookmarks
+parseAndBookmark ::
(Functor m, Applicative m, MonadError P.MultipleErrors m, MonadIO m) =>
[FilePath]
-> [(PackageName, FilePath)]
- -> m ([InPackage P.Module], [Bookmark], P.Env)
-parseAndDesugar inputFiles depsFiles = do
+ -> m ([InPackage P.Module], [Bookmark])
+parseAndBookmark inputFiles depsFiles = do
inputFiles' <- traverse (parseAs Local) inputFiles
depsFiles' <- traverse (\(pkgName, f) -> parseAs (FromDep pkgName) f) depsFiles
- ms <- parseFiles (inputFiles' ++ depsFiles')
- ms' <- sortModules (map snd ms)
- desugarWithBookmarks ms ms'
+ addBookmarks <$> parseFiles (inputFiles' ++ depsFiles')
parseFiles ::
(MonadError P.MultipleErrors m, MonadIO m) =>
@@ -60,29 +52,16 @@ parseFiles ::
parseFiles =
throwLeft . P.parseModulesFromFiles fileInfoToString
-sortModules ::
- (Functor m, MonadError P.MultipleErrors m, MonadIO m) =>
- [P.Module]
- -> m [P.Module]
-sortModules =
- fmap fst . throwLeft . sortModules' . map importPrim
- where
- sortModules' :: [P.Module] -> Either P.MultipleErrors ([P.Module], P.ModuleGraph)
- sortModules' = P.sortModules
-
-desugarWithBookmarks ::
- (MonadError P.MultipleErrors m, MonadIO m) =>
+addBookmarks ::
[(FileInfo, P.Module)]
- -> [P.Module]
- -> m ([InPackage P.Module], [Bookmark], P.Env)
-desugarWithBookmarks msInfo msSorted = do
- (env, msDesugared) <- throwLeft (desugar msSorted)
-
- let msDeps = getDepsModuleNames (map (\(fp, m) -> (,m) <$> fp) msInfo)
- msPackages = map (addPackage msDeps) msDesugared
- bookmarks = concatMap collectBookmarks msPackages
-
- return (msPackages, bookmarks, env)
+ -> ([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
@@ -100,22 +79,6 @@ fileInfoToString :: FileInfo -> FilePath
fileInfoToString (Local fn) = fn
fileInfoToString (FromDep _ fn) = fn
-importPrim :: P.Module -> P.Module
-importPrim = P.addDefaultImport (P.ModuleName [P.ProperName C.prim])
-
-desugar ::
- (Functor m, Applicative m, MonadError P.MultipleErrors m) =>
- [P.Module]
- -> m (P.Env, [P.Module])
-desugar = P.evalSupplyT 0 . desugar'
- where
- desugar' =
- traverse P.desugarDoModule
- >=> P.desugarCasesModule
- >=> ignoreWarnings . P.desugarImportsWithEnv []
-
- ignoreWarnings m = liftM fst (runWriterT m)
-
parseFile :: FilePath -> IO (FilePath, String)
parseFile input' = (,) input' <$> readFile input'
diff --git a/src/Language/PureScript/Docs/Render.hs b/src/Language/PureScript/Docs/Render.hs
index d954fcc..ca53c91 100644
--- a/src/Language/PureScript/Docs/Render.hs
+++ b/src/Language/PureScript/Docs/Render.hs
@@ -61,7 +61,11 @@ renderDeclarationWithOptions opts Declaration{..} =
AliasDeclaration for (P.Fixity associativity precedence) ->
[ keywordFixity associativity
, syntax $ show precedence
- , ident $ P.showQualified P.runIdent $ dequalifyCurrentModule for
+ , ident $
+ either
+ (P.showQualified P.runIdent . dequalifyCurrentModule)
+ (P.showQualified P.runProperName . dequalifyCurrentModule)
+ for
, keyword "as"
, ident . tail . init $ declTitle
]
diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs
index 8d19cfb..28bbad4 100644
--- a/src/Language/PureScript/Docs/Types.hs
+++ b/src/Language/PureScript/Docs/Types.hs
@@ -73,7 +73,7 @@ packageName :: Package a -> PackageName
packageName = bowerName . pkgMeta
data Module = Module
- { modName :: String
+ { modName :: P.ModuleName
, modComments :: Maybe String
, modDeclarations :: [Declaration]
-- Re-exported values from other modules
@@ -133,7 +133,7 @@ data DeclarationInfo
-- An operator alias declaration, with the member the alias is for and the
-- operator's fixity.
--
- | AliasDeclaration (P.Qualified P.Ident) P.Fixity
+ | AliasDeclaration (Either (P.Qualified P.Ident) (P.Qualified (P.ProperName 'P.ConstructorName))) P.Fixity
deriving (Show, Eq, Ord)
declInfoToString :: DeclarationInfo -> String
@@ -346,7 +346,7 @@ parseVersion' str =
asModule :: Parse PackageError Module
asModule =
- Module <$> key "name" asString
+ Module <$> key "name" (P.moduleNameFromString <$> asString)
<*> key "comments" (perhaps asString)
<*> key "declarations" (eachInArray asDeclaration)
<*> key "reExports" (eachInArray asReExport)
@@ -406,11 +406,14 @@ asDeclarationInfo = do
TypeClassDeclaration <$> key "arguments" asTypeArguments
<*> key "superclasses" (eachInArray asConstraint)
"alias" ->
- AliasDeclaration <$> key "for" asQualifiedIdent
+ AliasDeclaration <$> key "for" asAliasFor
<*> key "fixity" asFixity
other ->
throwCustomError (InvalidDeclarationType other)
+asAliasFor :: Parse e (Either (P.Qualified P.Ident) (P.Qualified (P.ProperName 'P.ConstructorName)))
+asAliasFor = fromAesonParser
+
asTypeArguments :: Parse PackageError [(String, Maybe P.Kind)]
asTypeArguments = eachInArray asTypeArgument
where
@@ -512,7 +515,7 @@ instance A.ToJSON NotYetKnown where
instance A.ToJSON Module where
toJSON Module{..} =
- A.object [ "name" .= modName
+ A.object [ "name" .= P.runModuleName modName
, "comments" .= modComments
, "declarations" .= modDeclarations
, "reExports" .= map toObj modReExports
diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs
index 6487057..9c5d2d6 100644
--- a/src/Language/PureScript/Errors.hs
+++ b/src/Language/PureScript/Errors.hs
@@ -24,6 +24,7 @@ import Control.Arrow ((&&&))
import Language.PureScript.Crash
import Language.PureScript.AST
import Language.PureScript.Pretty
+import Language.PureScript.Pretty.Common (before)
import Language.PureScript.Types
import Language.PureScript.Names
import Language.PureScript.Kinds
@@ -68,6 +69,7 @@ data SimpleErrorMessage
| UnknownImportDataConstructor ModuleName (ProperName 'TypeName) (ProperName 'ConstructorName)
| UnknownExportDataConstructor (ProperName 'TypeName) (ProperName 'ConstructorName)
| ScopeConflict String [ModuleName]
+ | ScopeShadowing String (Maybe ModuleName) [ModuleName]
| ConflictingTypeDecls (ProperName 'TypeName)
| ConflictingCtorDecls (ProperName 'ConstructorName)
| TypeConflictsWithClass (ProperName 'TypeName)
@@ -112,6 +114,7 @@ data SimpleErrorMessage
| InvalidNewtype (ProperName 'TypeName)
| InvalidInstanceHead Type
| TransitiveExportError DeclarationRef [DeclarationRef]
+ | TransitiveDctorExportError DeclarationRef (ProperName 'ConstructorName)
| ShadowedName Ident
| ShadowedTypeVar String
| UnusedTypeVar String
@@ -128,6 +131,7 @@ data SimpleErrorMessage
| UnusedDctorImport (ProperName 'TypeName)
| UnusedDctorExplicitImport (ProperName 'TypeName) [ProperName 'ConstructorName]
| DeprecatedOperatorDecl String
+ | DeprecatedOperatorSection Expr (Either Expr Expr)
| DeprecatedQualifiedSyntax ModuleName ModuleName
| DeprecatedClassImport ModuleName (ProperName 'ClassName)
| DeprecatedClassExport (ProperName 'ClassName)
@@ -142,6 +146,8 @@ data SimpleErrorMessage
| ImplicitImport ModuleName [DeclarationRef]
| HidingImport ModuleName [DeclarationRef]
| CaseBinderLengthDiffers Int [Binder]
+ | IncorrectAnonymousArgument
+ | InvalidOperatorInBinder Ident Ident
deriving (Show)
-- | Error message hints, providing more detailed information about failure.
@@ -243,6 +249,7 @@ errorCode em = case unwrapErrorMessage em of
UnknownImportDataConstructor{} -> "UnknownImportDataConstructor"
UnknownExportDataConstructor{} -> "UnknownExportDataConstructor"
ScopeConflict{} -> "ScopeConflict"
+ ScopeShadowing{} -> "ScopeShadowing"
ConflictingTypeDecls{} -> "ConflictingTypeDecls"
ConflictingCtorDecls{} -> "ConflictingCtorDecls"
TypeConflictsWithClass{} -> "TypeConflictsWithClass"
@@ -287,6 +294,7 @@ errorCode em = case unwrapErrorMessage em of
InvalidNewtype{} -> "InvalidNewtype"
InvalidInstanceHead{} -> "InvalidInstanceHead"
TransitiveExportError{} -> "TransitiveExportError"
+ TransitiveDctorExportError{} -> "TransitiveDctorExportError"
ShadowedName{} -> "ShadowedName"
ShadowedTypeVar{} -> "ShadowedTypeVar"
UnusedTypeVar{} -> "UnusedTypeVar"
@@ -303,6 +311,7 @@ errorCode em = case unwrapErrorMessage em of
UnusedDctorImport{} -> "UnusedDctorImport"
UnusedDctorExplicitImport{} -> "UnusedDctorExplicitImport"
DeprecatedOperatorDecl{} -> "DeprecatedOperatorDecl"
+ DeprecatedOperatorSection{} -> "DeprecatedOperatorSection"
DeprecatedQualifiedSyntax{} -> "DeprecatedQualifiedSyntax"
DeprecatedClassImport{} -> "DeprecatedClassImport"
DeprecatedClassExport{} -> "DeprecatedClassExport"
@@ -317,6 +326,8 @@ errorCode em = case unwrapErrorMessage em of
ImplicitImport{} -> "ImplicitImport"
HidingImport{} -> "HidingImport"
CaseBinderLengthDiffers{} -> "CaseBinderLengthDiffers"
+ IncorrectAnonymousArgument -> "IncorrectAnonymousArgument"
+ InvalidOperatorInBinder{} -> "InvalidOperatorInBinder"
-- |
-- A stack trace for an error
@@ -424,7 +435,7 @@ wikiUri e = "https://github.com/purescript/purescript/wiki/Error-Code-" ++ error
-- TODO Other possible suggestions:
-- WildcardInferredType - source span not small enough
-- DuplicateSelectiveImport - would require 2 ranges to remove and 1 insert
--- DeprecatedClassExport, DeprecatedClassImport, would want to replace smaller span?
+-- DeprecatedClassExport, DeprecatedClassImport, DeprecatedOperatorSection, would want to replace smaller span?
errorSuggestion :: SimpleErrorMessage -> Maybe ErrorSuggestion
errorSuggestion err = case err of
UnusedImport{} -> emptySuggestion
@@ -595,6 +606,13 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap
paras [ line $ "Conflicting definitions are in scope for " ++ nm ++ " from the following modules:"
, indent $ paras $ map (line . runModuleName) ms
]
+ renderSimpleErrorMessage (ScopeShadowing nm exmn ms) =
+ paras [ line $ "Shadowed definitions are in scope for " ++ nm ++ " from the following open imports:"
+ , indent $ paras $ map (line . ("import " ++) . runModuleName) ms
+ , line $ "These will be ignored and the " ++ case exmn of
+ Just exmn' -> "declaration from " ++ runModuleName exmn' ++ " will be used."
+ Nothing -> "local declaration will be used."
+ ]
renderSimpleErrorMessage (ConflictingTypeDecls nm) =
line $ "Conflicting type declarations for " ++ runProperName nm
renderSimpleErrorMessage (ConflictingCtorDecls nm) =
@@ -784,6 +802,10 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap
paras [ line $ "An export for " ++ prettyPrintExport x ++ " requires the following to also be exported: "
, indent $ paras $ map (line . prettyPrintExport) ys
]
+ renderSimpleErrorMessage (TransitiveDctorExportError x ctor) =
+ paras [ line $ "An export for " ++ prettyPrintExport x ++ " requires the following data constructor to also be exported: "
+ , indent $ line $ runProperName ctor
+ ]
renderSimpleErrorMessage (ShadowedName nm) =
line $ "Name '" ++ showIdent nm ++ "' was shadowed."
renderSimpleErrorMessage (ShadowedTypeVar tv) =
@@ -798,7 +820,7 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap
renderSimpleErrorMessage (MisleadingEmptyTypeImport mn name) =
line $ "Importing type " ++ runProperName name ++ "(..) from " ++ runModuleName mn ++ " is misleading as it has no exported data constructors."
renderSimpleErrorMessage (ImportHidingModule name) =
- paras [ line $ "'hiding' imports cannot be used to hide modules."
+ paras [ line "'hiding' imports cannot be used to hide modules."
, line $ "An attempt was made to hide the import of " ++ runModuleName name
]
renderSimpleErrorMessage (WildcardInferredType ty) =
@@ -812,14 +834,14 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap
, indent $ typeAsBox ty
]
renderSimpleErrorMessage (NotExhaustivePattern bs b) =
- paras $ [ line "A case expression could not be determined to cover all inputs."
- , line "The following additional cases are required to cover all inputs:\n"
- , indent $ paras $
- [ Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs)) ]
- ++ [ line "..." | not b ]
- , line "Or alternatively, add a Partial constraint to the type of the enclosing value."
- , line "Non-exhaustive patterns for values without a `Partial` constraint will be disallowed in PureScript 0.9."
- ]
+ paras [ line "A case expression could not be determined to cover all inputs."
+ , line "The following additional cases are required to cover all inputs:\n"
+ , indent $ paras $
+ [ Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs)) ]
+ ++ [ line "..." | not b ]
+ , line "Or alternatively, add a Partial constraint to the type of the enclosing value."
+ , line "Non-exhaustive patterns for values without a `Partial` constraint will be disallowed in PureScript 0.9."
+ ]
renderSimpleErrorMessage (OverlappingPattern bs b) =
paras $ [ line "A case expression contains unreachable cases:\n"
, Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs))
@@ -835,7 +857,7 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap
renderSimpleErrorMessage msg@(UnusedExplicitImport mn names _ _) =
paras [ line $ "The import of module " ++ runModuleName mn ++ " contains the following unused references:"
, indent $ paras $ map line names
- , line $ "It could be replaced with:"
+ , line "It could be replaced with:"
, indent $ line $ showSuggestion msg ]
renderSimpleErrorMessage (UnusedDctorImport name) =
@@ -849,15 +871,39 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap
paras [ line $ "The operator (" ++ name ++ ") was declared as a value rather than an alias for a named function."
, line "Operator aliases are declared by using a fixity declaration, for example:"
, indent $ line $ "infixl 9 someFunction as " ++ name
- , line $ "Support for value-declared operators will be removed in PureScript 0.9."
+ , line "Support for value-declared operators will be removed in PureScript 0.9."
]
+ renderSimpleErrorMessage (DeprecatedOperatorSection op val) =
+ paras [ line "An operator section uses legacy syntax. Operator sections are now written using anonymous function syntax:"
+ , indent $ foldr1 before $
+ case val of
+ Left l ->
+ [ line "("
+ , prettyPrintValue valueDepth l
+ , line " "
+ , renderOperator op
+ , line " _)"
+ ]
+ Right r ->
+ [ line "(_ "
+ , renderOperator op
+ , line " "
+ , prettyPrintValue valueDepth r
+ , line ")"
+ ]
+ , line "Support for legacy operator sections will be removed in PureScript 0.9."
+ ]
+ where
+ renderOperator (PositionedValue _ _ ex) = renderOperator ex
+ renderOperator (Var (Qualified _ (Op ident))) = line ident
+ renderOperator other = Box.hcat Box.top [ line "`", prettyPrintValue valueDepth other, line "`" ]
renderSimpleErrorMessage (DeprecatedQualifiedSyntax name qualName) =
- paras [ line $ "Import uses the deprecated 'qualified' syntax:"
+ paras [ line "Import uses the deprecated 'qualified' syntax:"
, indent $ line $ "import qualified " ++ runModuleName name ++ " as " ++ runModuleName qualName
, line "Should instead use the form:"
, indent $ line $ "import " ++ runModuleName name ++ " as " ++ runModuleName qualName
- , line $ "The deprecated syntax will be removed in PureScript 0.9."
+ , line "The deprecated syntax will be removed in PureScript 0.9."
]
renderSimpleErrorMessage (DeprecatedClassImport mn name) =
@@ -865,15 +911,15 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap
, indent $ line $ runProperName name
, line "Should instead use the form:"
, indent $ line $ "class " ++ runProperName name
- , line $ "The deprecated syntax will be removed in PureScript 0.9."
+ , line "The deprecated syntax will be removed in PureScript 0.9."
]
renderSimpleErrorMessage (DeprecatedClassExport name) =
- paras [ line $ "Class export uses deprecated syntax that omits the 'class' keyword:"
+ paras [ line "Class export uses deprecated syntax that omits the 'class' keyword:"
, indent $ line $ runProperName name
, line "Should instead use the form:"
, indent $ line $ "class " ++ runProperName name
- , line $ "The deprecated syntax will be removed in PureScript 0.9."
+ , line "The deprecated syntax will be removed in PureScript 0.9."
]
renderSimpleErrorMessage (RedundantUnqualifiedImport name imp) =
@@ -915,9 +961,18 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap
]
renderSimpleErrorMessage (CaseBinderLengthDiffers l bs) =
- paras $ [ line $ "Binder list length differs in case alternative:"
- , indent $ line $ intercalate ", " $ fmap prettyPrintBinderAtom bs
- , line $ "Expecting " ++ show l ++ " binder" ++ (if l == 1 then "" else "s") ++ "." ]
+ paras [ line "Binder list length differs in case alternative:"
+ , indent $ line $ intercalate ", " $ fmap prettyPrintBinderAtom bs
+ , line $ "Expecting " ++ show l ++ " binder" ++ (if l == 1 then "" else "s") ++ "."
+ ]
+
+ renderSimpleErrorMessage IncorrectAnonymousArgument =
+ line "An anonymous function argument appears in an invalid context."
+
+ renderSimpleErrorMessage (InvalidOperatorInBinder op fn) =
+ paras $ [ line $ "Operator " ++ showIdent op ++ " cannot be used in a pattern as it is an alias for function " ++ showIdent fn ++ "."
+ , line "Only aliases for data constructors may be used in patterns."
+ ]
renderHint :: ErrorMessageHint -> Box.Box -> Box.Box
renderHint (ErrorUnifyingTypes t1 t2) detail =
diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs
index 5bdc304..b334a8b 100644
--- a/src/Language/PureScript/Externs.hs
+++ b/src/Language/PureScript/Externs.hs
@@ -73,7 +73,7 @@ data ExternsFixity = ExternsFixity
-- | The operator symbol
, efOperator :: String
-- | The value the operator is an alias for
- , efAlias :: Maybe (Qualified Ident)
+ , efAlias :: Maybe (Either (Qualified Ident) (Qualified (ProperName 'ConstructorName)))
} deriving (Show, Read)
-- | A type or value declaration appearing in an externs file
@@ -153,7 +153,8 @@ moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..}
efDeclarations = concatMap toExternsDeclaration efExports
fixityDecl :: Declaration -> Maybe ExternsFixity
- fixityDecl (FixityDeclaration (Fixity assoc prec) op alias) = fmap (const (ExternsFixity assoc prec op alias)) (find exportsOp exps)
+ fixityDecl (FixityDeclaration (Fixity assoc prec) op alias) =
+ fmap (const (ExternsFixity assoc prec op alias)) (find exportsOp exps)
where
exportsOp :: DeclarationRef -> Bool
exportsOp (PositionedDeclarationRef _ _ r) = exportsOp r
diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs
new file mode 100644
index 0000000..3d9a45a
--- /dev/null
+++ b/src/Language/PureScript/Ide.hs
@@ -0,0 +1,199 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PackageImports #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TupleSections #-}
+
+module Language.PureScript.Ide where
+
+import Prelude ()
+import Prelude.Compat
+
+import Control.Monad.Error.Class
+import Control.Monad.IO.Class
+import "monad-logger" Control.Monad.Logger
+import Control.Monad.Reader.Class
+import Data.Foldable
+import qualified Data.Map.Lazy as M
+import Data.Maybe (catMaybes, mapMaybe)
+import Data.Monoid
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Language.PureScript.Ide.CaseSplit as CS
+import Language.PureScript.Ide.Command
+import Language.PureScript.Ide.Completion
+import Language.PureScript.Ide.Error
+import Language.PureScript.Ide.Externs
+import Language.PureScript.Ide.Filter
+import Language.PureScript.Ide.Matcher
+import Language.PureScript.Ide.Pursuit
+import Language.PureScript.Ide.Reexports
+import Language.PureScript.Ide.SourceFile
+import Language.PureScript.Ide.State
+import Language.PureScript.Ide.Types
+import System.Directory
+import System.FilePath
+import System.Exit
+
+
+handleCommand :: (PscIde m, MonadLogger m, MonadError PscIdeError m) =>
+ Command -> m Success
+handleCommand (Load modules deps) =
+ loadModulesAndDeps modules deps
+handleCommand (Type search filters) =
+ findType search filters
+handleCommand (Complete filters matcher) =
+ findCompletions filters matcher
+handleCommand (Pursuit query Package) =
+ findPursuitPackages query
+handleCommand (Pursuit query Identifier) =
+ findPursuitCompletions query
+handleCommand (List LoadedModules) =
+ printModules
+handleCommand (List AvailableModules) =
+ listAvailableModules
+handleCommand (List (Imports fp)) =
+ importsForFile fp
+handleCommand (CaseSplit l b e wca t) =
+ caseSplit l b e wca t
+handleCommand (AddClause l wca) =
+ pure $ addClause l wca
+handleCommand Cwd =
+ TextResult . T.pack <$> liftIO getCurrentDirectory
+handleCommand Quit = liftIO exitSuccess
+
+findCompletions :: (PscIde m, MonadLogger m) =>
+ [Filter] -> Matcher -> m Success
+findCompletions filters matcher =
+ CompletionResult . getCompletions filters matcher <$> getAllModulesWithReexports
+
+findType :: (PscIde m, MonadLogger m) =>
+ DeclIdent -> [Filter] -> m Success
+findType search filters =
+ CompletionResult . getExactMatches search filters <$> getAllModulesWithReexports
+
+findPursuitCompletions :: (Applicative m, MonadIO m, MonadLogger m) =>
+ PursuitQuery -> m Success
+findPursuitCompletions (PursuitQuery q) =
+ PursuitResult <$> liftIO (searchPursuitForDeclarations q)
+
+findPursuitPackages :: (Applicative m, MonadIO m, MonadLogger m) =>
+ PursuitQuery -> m Success
+findPursuitPackages (PursuitQuery q) =
+ PursuitResult <$> liftIO (findPackagesForModuleIdent q)
+
+loadExtern ::(PscIde m, MonadLogger m, MonadError PscIdeError m) =>
+ FilePath -> m ()
+loadExtern fp = do
+ m <- readExternFile fp
+ insertModule m
+
+printModules :: (PscIde m) => m Success
+printModules = printModules' <$> getPscIdeState
+
+printModules' :: M.Map ModuleIdent [ExternDecl] -> Success
+printModules' = ModuleList . M.keys
+
+listAvailableModules :: PscIde m => m Success
+listAvailableModules = do
+ outputPath <- confOutputPath . envConfiguration <$> ask
+ liftIO $ do
+ cwd <- getCurrentDirectory
+ dirs <- getDirectoryContents (cwd </> outputPath)
+ return (ModuleList (listAvailableModules' dirs))
+
+listAvailableModules' :: [FilePath] -> [Text]
+listAvailableModules' dirs =
+ let cleanedModules = filter (`notElem` [".", ".."]) dirs
+ in map T.pack cleanedModules
+
+caseSplit :: (PscIde m, MonadLogger m, MonadError PscIdeError 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
+ pure (MultilineTextResult patterns)
+
+addClause :: Text -> CS.WildcardAnnotations -> Success
+addClause t wca = MultilineTextResult (CS.addClause t wca)
+
+importsForFile :: (Applicative m, MonadIO m, MonadLogger m, MonadError PscIdeError m) =>
+ FilePath -> m Success
+importsForFile fp = do
+ imports <- getImportsForFile fp
+ pure (ImportList imports)
+
+-- | The first argument is a set of modules to load. The second argument
+-- denotes modules for which to load dependencies
+loadModulesAndDeps :: (PscIde m, MonadLogger m, MonadError PscIdeError m) =>
+ [ModuleIdent] -> [ModuleIdent] -> m Success
+loadModulesAndDeps mods deps = do
+ r1 <- mapM loadModule (mods ++ deps)
+ r2 <- mapM loadModuleDependencies deps
+ let moduleResults = T.concat r1
+ let dependencyResults = T.concat r2
+ pure (TextResult (moduleResults <> ", " <> dependencyResults))
+
+loadModuleDependencies ::(PscIde m, MonadLogger m, MonadError PscIdeError m) =>
+ ModuleIdent -> m Text
+loadModuleDependencies moduleName = do
+ m <- getModule moduleName
+ case getDependenciesForModule <$> m of
+ Just deps -> do
+ mapM_ loadModule deps
+ -- We need to load the modules, that get reexported from the dependencies
+ depModules <- catMaybes <$> mapM getModule deps
+ -- What to do with errors here? This basically means a reexported dependency
+ -- doesn't exist in the output/ folder
+ traverse_ loadReexports depModules
+ pure ("Dependencies for " <> moduleName <> " loaded.")
+ Nothing -> throwError (ModuleNotFound moduleName)
+
+loadReexports :: (PscIde m, MonadLogger m, MonadError PscIdeError m) =>
+ Module -> m [ModuleIdent]
+loadReexports m = case getReexports m of
+ [] -> pure []
+ exportDeps -> do
+ -- I'm fine with this crashing on a failed pattern match.
+ -- If this ever fails I'll need to look at GADTs
+ let reexports = map (\(Export mn) -> mn) exportDeps
+ $(logDebug) ("Loading reexports for module: " <> fst m <>
+ " reexports: " <> T.intercalate ", " reexports)
+ traverse_ loadModule reexports
+ exportDepsModules <- catMaybes <$> traverse getModule reexports
+ exportDepDeps <- traverse loadReexports exportDepsModules
+ return $ concat exportDepDeps
+
+getDependenciesForModule :: Module -> [ModuleIdent]
+getDependenciesForModule (_, decls) = mapMaybe getDependencyName decls
+ where getDependencyName (Dependency dependencyName _ _) = Just dependencyName
+ getDependencyName _ = Nothing
+
+loadModule :: (PscIde m, MonadLogger m, MonadError PscIdeError m) =>
+ ModuleIdent -> m Text
+loadModule "Prim" = pure "Prim won't be loaded"
+loadModule mn = do
+ path <- filePathFromModule mn
+ loadExtern path
+ $(logDebug) ("Loaded extern file at: " <> T.pack path)
+ pure ("Loaded extern file at: " <> T.pack path)
+
+filePathFromModule :: (PscIde m, MonadError PscIdeError m) =>
+ ModuleIdent -> m FilePath
+filePathFromModule moduleName = do
+ outputPath <- confOutputPath . envConfiguration <$> ask
+ cwd <- liftIO getCurrentDirectory
+ let path = cwd </> outputPath </> T.unpack moduleName </> "externs.json"
+ ex <- liftIO $ doesFileExist path
+ if ex
+ then pure path
+ else throwError (ModuleFileNotFound moduleName)
+
+-- | Taken from Data.Either.Utils
+maybeToEither :: MonadError e m =>
+ e -- ^ (Left e) will be returned if the Maybe value is Nothing
+ -> Maybe a -- ^ (Right a) will be returned if this is (Just a)
+ -> m a
+maybeToEither errorval Nothing = throwError errorval
+maybeToEither _ (Just normalval) = return normalval
diff --git a/src/Language/PureScript/Ide/CaseSplit.hs b/src/Language/PureScript/Ide/CaseSplit.hs
new file mode 100644
index 0000000..83dbeab
--- /dev/null
+++ b/src/Language/PureScript/Ide/CaseSplit.hs
@@ -0,0 +1,157 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PackageImports #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Language.PureScript.Ide.CaseSplit
+ ( WildcardAnnotations()
+ , explicitAnnotations
+ , noAnnotations
+ , makePattern
+ , addClause
+ , caseSplit
+ ) where
+
+import Prelude ()
+import Prelude.Compat hiding (lex)
+
+import Control.Monad.Error.Class
+import "monad-logger" Control.Monad.Logger
+import Data.List (find)
+import Data.Monoid
+import Data.Text (Text)
+import qualified Data.Text as T
+import Language.PureScript.AST
+import Language.PureScript.Environment
+import Language.PureScript.Externs
+import Language.PureScript.Ide.Error
+import Language.PureScript.Ide.Externs (unwrapPositioned)
+import Language.PureScript.Ide.State
+import Language.PureScript.Ide.Types hiding (Type)
+import Language.PureScript.Names
+import Language.PureScript.Parser.Common (runTokenParser)
+import Language.PureScript.Parser.Declarations
+import Language.PureScript.Parser.Lexer (lex)
+import Language.PureScript.Parser.Types
+import Language.PureScript.Pretty
+import Language.PureScript.Types
+import Text.Parsec as P
+
+type Constructor = (ProperName 'ConstructorName, [Type])
+
+newtype WildcardAnnotations = WildcardAnnotations Bool
+
+explicitAnnotations :: WildcardAnnotations
+explicitAnnotations = WildcardAnnotations True
+
+noAnnotations :: WildcardAnnotations
+noAnnotations = WildcardAnnotations False
+
+caseSplit :: (PscIde m, MonadLogger m, MonadError PscIdeError m) =>
+ Text -> m [Constructor]
+caseSplit q = do
+ (tc, args) <- splitTypeConstructor (parseType' (T.unpack q))
+ (EDType _ _ (DataType typeVars ctors)) <- findTypeDeclaration tc
+ let applyTypeVars = everywhereOnTypes (replaceAllTypeVars (zip (map fst typeVars) args))
+ let appliedCtors = map (\(n, ts) -> (n, map applyTypeVars ts)) ctors
+ pure appliedCtors
+
+{- ["EDType {
+ edTypeName = ProperName {runProperName = \"Either\"}
+ , edTypeKind = FunKind Star (FunKind Star Star)
+ , edTypeDeclarationKind =
+ DataType [(\"a\",Just Star),(\"b\",Just Star)]
+ [(ProperName {runProperName = \"Left\"},[TypeVar \"a\"])
+ ,(ProperName {runProperName = \"Right\"},[TypeVar \"b\"])]}"]
+-}
+
+findTypeDeclaration :: (PscIde m, MonadLogger m, MonadError PscIdeError m) =>
+ ProperName 'TypeName -> m ExternsDeclaration
+findTypeDeclaration q = do
+ efs <- getExternFiles
+ let m = getFirst $ foldMap (findTypeDeclaration' q) efs
+ case m of
+ Just mn -> pure mn
+ Nothing -> throwError (GeneralError "Not Found")
+
+findTypeDeclaration' ::
+ ProperName 'TypeName
+ -> ExternsFile
+ -> First ExternsDeclaration
+findTypeDeclaration' t ExternsFile{..} =
+ First $ find (\case
+ EDType tn _ _ -> tn == t
+ _ -> False) efDeclarations
+
+splitTypeConstructor :: (Applicative m, MonadError PscIdeError m) =>
+ Type -> m (ProperName 'TypeName, [Type])
+splitTypeConstructor = go []
+ where
+ go acc (TypeApp ty arg) = go (arg : acc) ty
+ go acc (TypeConstructor tc) = pure (disqualify tc, acc)
+ go _ _ = throwError (GeneralError "Failed to read TypeConstructor")
+
+prettyCtor :: WildcardAnnotations -> Constructor -> Text
+prettyCtor _ (ctorName, []) = T.pack (runProperName ctorName)
+prettyCtor wsa (ctorName, ctorArgs) =
+ "("<> T.pack (runProperName ctorName) <> " "
+ <> T.unwords (map (prettyPrintWildcard wsa) ctorArgs) <>")"
+
+prettyPrintWildcard :: WildcardAnnotations -> Type -> Text
+prettyPrintWildcard (WildcardAnnotations True) = prettyWildcard
+prettyPrintWildcard (WildcardAnnotations False) = const "_"
+
+prettyWildcard :: Type -> Text
+prettyWildcard t = "( _ :: " <> T.strip (T.pack (prettyPrintTypeAtom t)) <> ")"
+
+-- | Constructs Patterns to insert into a sourcefile
+makePattern :: Text -- ^ Current line
+ -> Int -- ^ Begin of the split
+ -> Int -- ^ End of the split
+ -> WildcardAnnotations -- ^ Whether to explicitly type the splits
+ -> [Constructor] -- ^ Constructors to split
+ -> [Text]
+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 :: Text -> WildcardAnnotations -> [Text]
+addClause s wca =
+ let (fName, fType) = parseTypeDeclaration' (T.unpack s)
+ (args, _) = splitFunctionType fType
+ template = T.pack (runIdent fName) <> " " <>
+ T.unwords (map (prettyPrintWildcard wca) args) <>
+ " = ?" <> (T.strip . T.pack . runIdent $ fName)
+ in [s, template]
+
+parseType' :: String -> Type
+parseType' s = let (Right t) = do
+ ts <- lex "" s
+ runTokenParser "" (parseType <* P.eof) ts
+ in t
+
+parseTypeDeclaration' :: String -> (Ident, Type)
+parseTypeDeclaration' s =
+ let x = do
+ ts <- lex "" s
+ runTokenParser "" (parseDeclaration <* P.eof) ts
+ in
+ case unwrapPositioned <$> x of
+ Right (TypeDeclaration i t) -> (i, t)
+ y -> error (show y)
+
+splitFunctionType :: Type -> ([Type], Type)
+splitFunctionType t = (arguments, returns)
+ where
+ returns = last splitted
+ arguments = init splitted
+ splitted = splitType' t
+ splitType' (ForAll _ t' _) = splitType' t'
+ splitType' (ConstrainedType _ t') = splitType' t'
+ splitType' (TypeApp (TypeApp t' lhs) rhs)
+ | t' == tyFunction = lhs : splitType' rhs
+ splitType' t' = [t']
diff --git a/src/Language/PureScript/Ide/CodecJSON.hs b/src/Language/PureScript/Ide/CodecJSON.hs
new file mode 100644
index 0000000..8a264c0
--- /dev/null
+++ b/src/Language/PureScript/Ide/CodecJSON.hs
@@ -0,0 +1,13 @@
+module Language.PureScript.Ide.CodecJSON where
+
+import Data.Aeson
+import Data.Text (Text())
+import Data.Text.Lazy (toStrict, fromStrict)
+import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8)
+
+encodeT :: (ToJSON a) => a -> Text
+encodeT = toStrict . decodeUtf8 . encode
+
+decodeT :: (FromJSON a) => Text -> Maybe a
+decodeT = decode . encodeUtf8 . fromStrict
+
diff --git a/src/Language/PureScript/Ide/Command.hs b/src/Language/PureScript/Ide/Command.hs
new file mode 100644
index 0000000..d7387d4
--- /dev/null
+++ b/src/Language/PureScript/Ide/Command.hs
@@ -0,0 +1,101 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Language.PureScript.Ide.Command where
+
+import Prelude ()
+import Prelude.Compat
+
+import Control.Monad
+import Data.Aeson
+import Data.Maybe
+import Data.Text (Text)
+import Language.PureScript.Ide.CaseSplit
+import Language.PureScript.Ide.Filter
+import Language.PureScript.Ide.Matcher
+import Language.PureScript.Ide.Types
+
+data Command
+ = Load { loadModules :: [ModuleIdent]
+ , loadDependencies :: [ModuleIdent]}
+ | Type { typeSearch :: DeclIdent
+ , typeFilters :: [Filter]}
+ | Complete { completeFilters :: [Filter]
+ , completeMatcher :: Matcher}
+ | Pursuit { pursuitQuery :: PursuitQuery
+ , pursuitSearchType :: PursuitSearchType}
+ | List {listType :: ListType}
+ | CaseSplit {
+ caseSplitLine :: Text
+ , caseSplitBegin :: Int
+ , caseSplitEnd :: Int
+ , caseSplitAnnotations :: WildcardAnnotations
+ , caseSplitType :: Type}
+ | AddClause {
+ addClauseLine :: Text
+ , addClauseAnnotations :: WildcardAnnotations}
+ | Cwd
+ | Quit
+
+data ListType = LoadedModules | Imports FilePath | AvailableModules
+
+instance FromJSON ListType where
+ parseJSON = withObject "ListType" $ \o -> do
+ (listType' :: String) <- o .: "type"
+ case listType' of
+ "import" -> do
+ fp <- o .: "file"
+ return (Imports fp)
+ "loadedModules" -> return LoadedModules
+ "availableModules" -> return AvailableModules
+ _ -> mzero
+
+instance FromJSON Command where
+ parseJSON = withObject "command" $ \o -> do
+ (command :: String) <- o .: "command"
+ case command of
+ "list" -> do
+ listType' <- o .:? "params"
+ return $ List (fromMaybe LoadedModules listType')
+ "cwd" -> return Cwd
+ "quit" -> return Quit
+ "load" -> do
+ params <- o .: "params"
+ mods <- params .:? "modules"
+ deps <- params .:? "dependencies"
+ return $ Load (fromMaybe [] mods) (fromMaybe [] deps)
+ "type" -> do
+ params <- o .: "params"
+ search <- params .: "search"
+ filters <- params .: "filters"
+ return $ Type search filters
+ "complete" -> do
+ params <- o .: "params"
+ filters <- params .:? "filters"
+ matcher <- params .:? "matcher"
+ return $ Complete (fromMaybe [] filters) (fromMaybe mempty matcher)
+ "pursuit" -> do
+ params <- o .: "params"
+ query <- params .: "query"
+ queryType <- params .: "type"
+ return $ Pursuit query queryType
+ "caseSplit" -> do
+ params <- o .: "params"
+ line <- params .: "line"
+ begin <- params .: "begin"
+ end <- params .: "end"
+ annotations <- params .: "annotations"
+ type' <- params .: "type"
+ return $ CaseSplit line begin end (if annotations
+ then explicitAnnotations
+ else noAnnotations) type'
+ "addClause" -> do
+ params <- o .: "params"
+ line <- params .: "line"
+ annotations <- params .: "annotations"
+ return $ AddClause line (if annotations
+ then explicitAnnotations
+ else noAnnotations)
+ _ -> mzero
+
diff --git a/src/Language/PureScript/Ide/Completion.hs b/src/Language/PureScript/Ide/Completion.hs
new file mode 100644
index 0000000..d0430ad
--- /dev/null
+++ b/src/Language/PureScript/Ide/Completion.hs
@@ -0,0 +1,35 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Language.PureScript.Ide.Completion
+ (getCompletions, getExactMatches)
+ where
+
+import Prelude ()
+import Prelude.Compat
+
+import Data.Maybe (mapMaybe)
+import Language.PureScript.Ide.Filter
+import Language.PureScript.Ide.Matcher
+import Language.PureScript.Ide.Types
+
+-- | Applies the CompletionFilters and the Matcher to the given Modules
+-- and sorts the found Completions according to the Matching Score
+getCompletions :: [Filter] -> Matcher -> [Module] -> [Completion]
+getCompletions filters matcher modules =
+ runMatcher matcher $ completionsFromModules (applyFilters filters modules)
+
+getExactMatches :: DeclIdent -> [Filter] -> [Module] -> [Completion]
+getExactMatches search filters modules =
+ completionsFromModules $
+ applyFilters (equalityFilter search : filters) modules
+
+completionsFromModules :: [Module] -> [Completion]
+completionsFromModules = foldMap completionFromModule
+ where
+ completionFromModule :: Module -> [Completion]
+ completionFromModule (moduleIdent, decls) = mapMaybe (completionFromDecl moduleIdent) decls
+
+completionFromDecl :: ModuleIdent -> ExternDecl -> Maybe Completion
+completionFromDecl mi (FunctionDecl name type') = Just (Completion (mi, name, type'))
+completionFromDecl mi (DataDecl name kind) = Just (Completion (mi, name, kind))
+completionFromDecl _ (ModuleDecl name _) = Just (Completion ("module", name, "module"))
+completionFromDecl _ _ = Nothing
diff --git a/src/Language/PureScript/Ide/Error.hs b/src/Language/PureScript/Ide/Error.hs
new file mode 100644
index 0000000..9b5d1fb
--- /dev/null
+++ b/src/Language/PureScript/Ide/Error.hs
@@ -0,0 +1,43 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Language.PureScript.Ide.Error
+ (ErrorMsg, PscIdeError(..), textError, first)
+ where
+
+import Data.Aeson
+import Data.Monoid
+import Data.Text (Text, pack)
+import Language.PureScript.Ide.Types (ModuleIdent)
+import qualified Text.Parsec.Error as P
+
+type ErrorMsg = String
+
+data PscIdeError
+ = GeneralError ErrorMsg
+ | NotFound Text
+ | ModuleNotFound ModuleIdent
+ | ModuleFileNotFound ModuleIdent
+ | ParseError P.ParseError ErrorMsg
+ deriving (Show, Eq)
+
+instance ToJSON PscIdeError where
+ toJSON err = object
+ [
+ "resultType" .= ("error" :: Text),
+ "result" .= textError err
+ ]
+
+textError :: PscIdeError -> Text
+textError (GeneralError msg) = pack msg
+textError (NotFound ident) = "Symbol '" <> ident <> "' not found."
+textError (ModuleNotFound ident) = "Module '" <> ident <> "' not found."
+textError (ModuleFileNotFound ident) = "Extern file for module " <> ident <>" could not be found"
+textError (ParseError parseError msg) = pack $ msg <> ": " <> show (escape parseError)
+ where
+ -- escape newlines and other special chars so we can send the error over the socket as a single line
+ escape :: P.ParseError -> String
+ escape = show
+
+-- | Specialized version of `first` from `Data.Bifunctors`
+first :: (a -> b) -> Either a r -> Either b r
+first f (Left x) = Left (f x)
+first _ (Right r2) = Right r2
diff --git a/src/Language/PureScript/Ide/Externs.hs b/src/Language/PureScript/Ide/Externs.hs
new file mode 100644
index 0000000..67e9cd7
--- /dev/null
+++ b/src/Language/PureScript/Ide/Externs.hs
@@ -0,0 +1,102 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Language.PureScript.Ide.Externs
+ (
+ ExternDecl(..),
+ ModuleIdent,
+ DeclIdent,
+ Type,
+ Fixity(..),
+ readExternFile,
+ convertExterns,
+ unwrapPositioned,
+ unwrapPositionedRef
+ ) where
+
+import Prelude ()
+import Prelude.Compat
+
+import Control.Monad.Error.Class
+import Control.Monad.IO.Class
+import Data.Maybe (mapMaybe)
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.IO as T
+import qualified Language.PureScript.AST.Declarations as D
+import qualified Language.PureScript.Externs as PE
+import Language.PureScript.Ide.CodecJSON
+import Language.PureScript.Ide.Error (PscIdeError (..))
+import Language.PureScript.Ide.Types
+import qualified Language.PureScript.Names as N
+import qualified Language.PureScript.Pretty as PP
+
+readExternFile :: (Applicative m, MonadIO m, MonadError PscIdeError m) =>
+ FilePath -> m PE.ExternsFile
+readExternFile fp = do
+ parseResult <- liftIO (decodeT <$> T.readFile fp)
+ case parseResult of
+ Nothing -> throwError . GeneralError $ "Parsing the extern at: " ++ fp ++ " failed"
+ Just externs -> pure externs
+
+moduleNameToText :: N.ModuleName -> Text
+moduleNameToText = T.pack . N.runModuleName
+
+properNameToText :: N.ProperName a -> Text
+properNameToText = T.pack . N.runProperName
+
+identToText :: N.Ident -> Text
+identToText = T.pack . N.runIdent
+
+convertExterns :: PE.ExternsFile -> Module
+convertExterns ef = (moduleName, exportDecls ++ importDecls ++ otherDecls)
+ where
+ moduleName = moduleNameToText (PE.efModuleName ef)
+ importDecls = convertImport <$> PE.efImports ef
+ exportDecls = mapMaybe (convertExport . unwrapPositionedRef) (PE.efExports ef)
+ -- Ignoring operator fixities for now since we're not using them
+ -- operatorDecls = convertOperator <$> PE.efFixities ef
+ otherDecls = mapMaybe convertDecl (PE.efDeclarations ef)
+
+convertImport :: PE.ExternsImport -> ExternDecl
+convertImport ei = Dependency
+ (moduleNameToText (PE.eiModule ei))
+ []
+ (moduleNameToText <$> PE.eiImportedAs ei)
+
+convertExport :: D.DeclarationRef -> Maybe ExternDecl
+convertExport (D.ModuleRef mn) = Just (Export (moduleNameToText mn))
+convertExport _ = Nothing
+
+convertDecl :: PE.ExternsDeclaration -> Maybe ExternDecl
+convertDecl PE.EDType{..} = Just $
+ DataDecl
+ (properNameToText edTypeName)
+ (packAndStrip (PP.prettyPrintKind edTypeKind))
+convertDecl PE.EDTypeSynonym{..} = Just $
+ DataDecl
+ (properNameToText edTypeSynonymName)
+ (packAndStrip (PP.prettyPrintType edTypeSynonymType))
+convertDecl PE.EDDataConstructor{..} = Just $
+ DataDecl
+ (properNameToText edDataCtorName)
+ (packAndStrip (PP.prettyPrintType edDataCtorType))
+convertDecl PE.EDValue{..} = Just $
+ FunctionDecl
+ (identToText edValueName)
+ (packAndStrip (PP.prettyPrintType edValueType))
+convertDecl _ = Nothing
+
+packAndStrip :: String -> Text
+packAndStrip = T.unwords . fmap T.strip . T.lines . T.pack
+
+unwrapPositioned :: D.Declaration -> D.Declaration
+unwrapPositioned (D.PositionedDeclaration _ _ x) = x
+unwrapPositioned x = x
+
+unwrapPositionedRef :: D.DeclarationRef -> D.DeclarationRef
+unwrapPositionedRef (D.PositionedDeclarationRef _ _ x) = x
+unwrapPositionedRef x = x
diff --git a/src/Language/PureScript/Ide/Filter.hs b/src/Language/PureScript/Ide/Filter.hs
new file mode 100644
index 0000000..47deed9
--- /dev/null
+++ b/src/Language/PureScript/Ide/Filter.hs
@@ -0,0 +1,110 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module Language.PureScript.Ide.Filter
+ (Filter, moduleFilter, prefixFilter, equalityFilter, dependencyFilter,
+ runFilter, applyFilters)
+ where
+
+import Prelude ()
+import Prelude.Compat
+
+import Control.Monad
+import Data.Aeson
+import Data.Foldable
+import Data.Maybe (listToMaybe, mapMaybe)
+import Data.Monoid
+import Data.Text (Text, isPrefixOf)
+import Language.PureScript.Ide.Types
+
+newtype Filter = Filter (Endo [Module]) deriving(Monoid)
+
+mkFilter :: ([Module] -> [Module]) -> Filter
+mkFilter = Filter . Endo
+
+-- | Only keeps the given Modules
+moduleFilter :: [ModuleIdent] -> Filter
+moduleFilter =
+ mkFilter . moduleFilter'
+
+moduleFilter' :: [ModuleIdent] -> [Module] -> [Module]
+moduleFilter' moduleIdents = filter (flip elem moduleIdents . fst)
+
+-- | Only keeps the given Modules and all of their dependencies
+dependencyFilter :: [ModuleIdent] -> Filter
+dependencyFilter = mkFilter . dependencyFilter'
+
+dependencyFilter' :: [ModuleIdent] -> [Module] -> [Module]
+dependencyFilter' moduleIdents mods =
+ moduleFilter' (concatMap (getDepForModule mods) moduleIdents) mods
+ where
+ getDepForModule :: [Module] -> ModuleIdent -> [ModuleIdent]
+ getDepForModule ms moduleIdent =
+ moduleIdent : maybe [] extractDeps (findModule moduleIdent ms)
+
+ findModule :: ModuleIdent -> [Module] -> Maybe Module
+ findModule i ms = listToMaybe $ filter go ms
+ where go (mn, _) = i == mn
+
+ extractDeps :: Module -> [ModuleIdent]
+ extractDeps = mapMaybe extractDep . snd
+ where extractDep (Dependency n _ _) = Just n
+ extractDep _ = Nothing
+
+-- | Only keeps Identifiers that start with the given prefix
+prefixFilter :: Text -> Filter
+prefixFilter "" = mkFilter id
+prefixFilter t = mkFilter $ identFilter prefix t
+ where
+ prefix :: ExternDecl -> Text -> Bool
+ prefix (FunctionDecl name _) search = search `isPrefixOf` name
+ prefix (DataDecl name _) search = search `isPrefixOf` name
+ prefix (ModuleDecl name _) search = search `isPrefixOf` name
+ prefix _ _ = False
+
+
+-- | Only keeps Identifiers that are equal to the search string
+equalityFilter :: Text -> Filter
+equalityFilter = mkFilter . identFilter equality
+ where
+ equality :: ExternDecl -> Text -> Bool
+ equality (FunctionDecl name _) prefix = prefix == name
+ equality (DataDecl name _) prefix = prefix == name
+ equality _ _ = False
+
+
+identFilter :: (ExternDecl -> Text -> Bool ) -> Text -> [Module] -> [Module]
+identFilter predicate search =
+ filter (not . null . snd) . fmap filterModuleDecls
+ where
+ filterModuleDecls :: Module -> Module
+ filterModuleDecls (moduleIdent,decls) =
+ (moduleIdent, filter (`predicate` search) decls)
+
+runFilter :: Filter -> [Module] -> [Module]
+runFilter (Filter f)= appEndo f
+
+applyFilters :: [Filter] -> [Module] -> [Module]
+applyFilters = runFilter . fold
+
+instance FromJSON Filter where
+ parseJSON = withObject "filter" $ \o -> do
+ (filter' :: String) <- o .: "filter"
+ case filter' of
+ "exact" -> do
+ params <- o .: "params"
+ search <- params .: "search"
+ return $ equalityFilter search
+ "prefix" -> do
+ params <- o.: "params"
+ search <- params .: "search"
+ return $ prefixFilter search
+ "modules" -> do
+ params <- o .: "params"
+ modules <- params .: "modules"
+ return $ moduleFilter modules
+ "dependencies" -> do
+ params <- o .: "params"
+ deps <- params .: "modules"
+ return $ dependencyFilter deps
+ _ -> mzero
diff --git a/src/Language/PureScript/Ide/Matcher.hs b/src/Language/PureScript/Ide/Matcher.hs
new file mode 100644
index 0000000..cb92cc3
--- /dev/null
+++ b/src/Language/PureScript/Ide/Matcher.hs
@@ -0,0 +1,100 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module Language.PureScript.Ide.Matcher (Matcher, flexMatcher, runMatcher) where
+
+import Prelude ()
+import Prelude.Compat
+
+import Control.Monad
+import Data.Aeson
+import Data.Function (on)
+import Data.List (sortBy)
+import Data.Maybe (mapMaybe)
+import Data.Monoid
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
+import Language.PureScript.Ide.Types
+import Text.EditDistance
+import Text.Regex.TDFA ((=~))
+
+
+type ScoredCompletion = (Completion, Double)
+
+newtype Matcher = Matcher (Endo [Completion]) deriving(Monoid)
+
+instance FromJSON Matcher where
+ parseJSON = withObject "matcher" $ \o -> do
+ (matcher :: Maybe String) <- o .:? "matcher"
+ case matcher of
+ Just "flex" -> do
+ params <- o .: "params"
+ search <- params .: "search"
+ pure $ flexMatcher search
+ Just "distance" -> do
+ params <- o .: "params"
+ search <- params .: "search"
+ maxDist <- params .: "maximumDistance"
+ pure $ distanceMatcher search maxDist
+ Just _ -> mzero
+ Nothing -> return mempty
+
+-- | Matches any occurence of the search string with intersections
+-- |
+-- | The scoring measures how far the matches span the string where
+-- | closer is better.
+-- | Examples:
+-- | flMa matches flexMatcher. Score: 14.28
+-- | sons matches sortCompletions. Score: 6.25
+flexMatcher :: Text -> Matcher
+flexMatcher pattern = mkMatcher (flexMatch pattern)
+
+distanceMatcher :: Text -> Int -> Matcher
+distanceMatcher q maxDist = mkMatcher (distanceMatcher' q maxDist)
+
+distanceMatcher' :: Text -> Int -> [Completion] -> [ScoredCompletion]
+distanceMatcher' q maxDist = mapMaybe go
+ where
+ go c@(Completion (_, y, _)) = let d = dist (T.unpack y)
+ in if d <= maxDist
+ then Just (c, 1 / fromIntegral d)
+ else Nothing
+ dist = levenshteinDistance defaultEditCosts (T.unpack q)
+
+mkMatcher :: ([Completion] -> [ScoredCompletion]) -> Matcher
+mkMatcher matcher = Matcher . Endo $ fmap fst . sortCompletions . matcher
+
+runMatcher :: Matcher -> [Completion] -> [Completion]
+runMatcher (Matcher m)= appEndo m
+
+sortCompletions :: [ScoredCompletion] -> [ScoredCompletion]
+sortCompletions = sortBy (flip compare `on` snd)
+
+flexMatch :: Text -> [Completion] -> [ScoredCompletion]
+flexMatch pattern = mapMaybe (flexRate pattern)
+
+flexRate :: Text -> Completion -> Maybe ScoredCompletion
+flexRate pattern c@(Completion (_,ident,_)) = do
+ score <- flexScore pattern ident
+ return (c, score)
+
+-- FlexMatching ala Sublime.
+-- Borrowed from: http://cdewaka.com/2013/06/fuzzy-pattern-matching-in-haskell/
+--
+-- By string =~ pattern we'll get the start of the match and the length of
+-- the matchas a (start, length) tuple if there's a match.
+-- If match fails then it would be (-1,0)
+flexScore :: Text -> DeclIdent -> Maybe Double
+flexScore "" _ = Nothing
+flexScore pat str =
+ case TE.encodeUtf8 str =~ TE.encodeUtf8 pat' :: (Int, Int) of
+ (-1,0) -> Nothing
+ (start,len) -> Just $ calcScore start (start + len)
+ where
+ Just (first,pattern) = T.uncons pat
+ -- This just interleaves the search string with .*
+ -- abcd -> a.*b.*c.*d
+ pat' = first `T.cons` T.concatMap (T.snoc ".*") pattern
+ calcScore start end =
+ 100.0 / fromIntegral ((1 + start) * (end - start + 1))
diff --git a/src/Language/PureScript/Ide/Pursuit.hs b/src/Language/PureScript/Ide/Pursuit.hs
new file mode 100644
index 0000000..8a6987d
--- /dev/null
+++ b/src/Language/PureScript/Ide/Pursuit.hs
@@ -0,0 +1,65 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Language.PureScript.Ide.Pursuit where
+
+import Prelude ()
+import Prelude.Compat
+
+import qualified Control.Exception as E
+import Data.Aeson
+import Data.ByteString (ByteString)
+import Data.ByteString.Lazy (fromStrict)
+import Data.Foldable (toList)
+import Data.Monoid ((<>))
+import Data.Maybe (mapMaybe)
+import Data.String
+import Data.Text (Text)
+import qualified Data.Text as T
+import Language.PureScript.Ide.Types
+import Network.HTTP.Types.Header (hAccept)
+import Pipes.HTTP
+import qualified Pipes.Prelude as P
+
+-- We need to remove trailing dots because Pursuit will return a 400 otherwise
+-- TODO: remove this when the issue is fixed at Pursuit
+queryPursuit :: Text -> IO ByteString
+queryPursuit q = do
+ let qClean = T.dropWhileEnd (== '.') q
+ req' <- parseUrl "http://pursuit.purescript.org/search"
+ let req = req'
+ { queryString=("q=" <> (fromString . T.unpack) qClean)
+ , requestHeaders=[(hAccept, "application/json")]
+ }
+ m <- newManager tlsManagerSettings
+ withHTTP req m $ \resp ->
+ P.fold (\x a -> x <> a) "" id $ responseBody resp
+
+
+handler :: HttpException -> IO [a]
+handler StatusCodeException{} = return []
+handler _ = return []
+
+searchPursuitForDeclarations :: Text -> IO [PursuitResponse]
+searchPursuitForDeclarations query =
+ (do r <- queryPursuit query
+ let results' = decode (fromStrict r) :: Maybe Array
+ case results' of
+ Nothing -> pure []
+ Just results -> pure (mapMaybe isDeclarationResponse (map fromJSON (toList results)))) `E.catch`
+ handler
+ where
+ isDeclarationResponse (Success a@DeclarationResponse{}) = Just a
+ isDeclarationResponse _ = Nothing
+
+findPackagesForModuleIdent :: Text -> IO [PursuitResponse]
+findPackagesForModuleIdent query =
+ (do r <- queryPursuit query
+ let results' = decode (fromStrict r) :: Maybe Array
+ case results' of
+ Nothing -> pure []
+ Just results -> pure (mapMaybe isModuleResponse (map fromJSON (toList results)))) `E.catch`
+ handler
+ where
+ isModuleResponse (Success a@ModuleResponse{}) = Just a
+ isModuleResponse _ = Nothing
diff --git a/src/Language/PureScript/Ide/Reexports.hs b/src/Language/PureScript/Ide/Reexports.hs
new file mode 100644
index 0000000..8831e77
--- /dev/null
+++ b/src/Language/PureScript/Ide/Reexports.hs
@@ -0,0 +1,73 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE TupleSections #-}
+module Language.PureScript.Ide.Reexports where
+
+
+import Prelude ()
+import Prelude.Compat
+
+import Data.List (union)
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Maybe
+import Language.PureScript.Ide.Types
+
+getReexports :: Module -> [ExternDecl]
+getReexports (mn, decls)= concatMap getExport decls
+ where getExport d
+ | (Export mn') <- d
+ , mn /= mn' = replaceExportWithAliases decls mn'
+ | otherwise = []
+
+dependencyToExport :: ExternDecl -> ExternDecl
+dependencyToExport (Dependency m _ _) = Export m
+dependencyToExport decl = decl
+
+replaceExportWithAliases :: [ExternDecl] -> ModuleIdent -> [ExternDecl]
+replaceExportWithAliases decls ident =
+ case filter isMatch decls of
+ [] -> [Export ident]
+ aliases -> map dependencyToExport aliases
+ where isMatch d
+ | Dependency _ _ (Just alias) <- d
+ , alias == ident = True
+ | otherwise = False
+
+replaceReexport :: ExternDecl -> Module -> Module -> Module
+replaceReexport e@(Export _) (m, decls) (_, newDecls) =
+ (m, filter (/= e) decls `union` newDecls)
+replaceReexport _ _ _ = error "Should only get Exports here."
+
+emptyModule :: Module
+emptyModule = ("Empty", [])
+
+isExport :: ExternDecl -> Bool
+isExport (Export _) = True
+isExport _ = False
+
+removeExportDecls :: Module -> Module
+removeExportDecls = fmap (filter (not . isExport))
+
+replaceReexports :: Module -> Map ModuleIdent [ExternDecl] -> Module
+replaceReexports m db = result
+ where reexports = getReexports m
+ result = foldl go (removeExportDecls m) reexports
+
+ go :: Module -> ExternDecl -> Module
+ go m' re@(Export name) = replaceReexport re m' (getModule name)
+ go _ _ = error "partiality! woohoo"
+
+ getModule :: ModuleIdent -> Module
+ getModule name = clean res
+ where res = fromMaybe emptyModule $ (name , ) <$> Map.lookup name db
+ -- we have to do this because keeping self exports in will result in
+ -- infinite loops
+ clean (mn, decls) = (mn,) (filter (/= Export mn) decls)
+
+resolveReexports :: Map ModuleIdent [ExternDecl] -> Module -> Module
+resolveReexports modules m = do
+ let replaced = replaceReexports m modules
+ if null . getReexports $ replaced
+ then replaced
+ else resolveReexports modules replaced
diff --git a/src/Language/PureScript/Ide/SourceFile.hs b/src/Language/PureScript/Ide/SourceFile.hs
new file mode 100644
index 0000000..ab22ba2
--- /dev/null
+++ b/src/Language/PureScript/Ide/SourceFile.hs
@@ -0,0 +1,106 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Language.PureScript.Ide.SourceFile where
+
+import Prelude ()
+import Prelude.Compat
+
+import Control.Monad.Error.Class
+import Control.Monad.IO.Class
+import Control.Monad.Trans.Except
+import Data.Maybe (mapMaybe)
+import Data.Monoid
+import qualified Data.Text as T
+import qualified Language.PureScript.AST.Declarations as D
+import qualified Language.PureScript.AST.SourcePos as SP
+import Language.PureScript.Ide.Error
+import Language.PureScript.Ide.Externs (unwrapPositioned,
+ unwrapPositionedRef)
+import Language.PureScript.Ide.Types
+import qualified Language.PureScript.Names as N
+import qualified Language.PureScript.Parser as P
+import System.Directory
+
+parseModuleFromFile :: (Applicative m, MonadIO m, MonadError PscIdeError m) =>
+ FilePath -> m D.Module
+parseModuleFromFile fp = do
+ exists <- liftIO (doesFileExist fp)
+ if exists
+ then do
+ content <- liftIO (readFile fp)
+ let m = do tokens <- P.lex fp content
+ P.runTokenParser "" P.parseModule tokens
+ either (throwError . (`ParseError` "File could not be parsed.")) pure m
+ else throwError (NotFound "File does not exist.")
+
+-- data Module = Module SourceSpan [Comment] ModuleName [Declaration] (Maybe [DeclarationRef])
+
+getDeclarations :: D.Module -> [D.Declaration]
+getDeclarations (D.Module _ _ _ declarations _) = declarations
+
+getImports :: D.Module -> [D.Declaration]
+getImports (D.Module _ _ _ declarations _) =
+ mapMaybe isImport declarations
+ where
+ isImport (D.PositionedDeclaration _ _ (i@D.ImportDeclaration{})) = Just i
+ isImport _ = Nothing
+
+getImportsForFile :: (Applicative m, MonadIO m, MonadError PscIdeError m) =>
+ FilePath -> m [ModuleImport]
+getImportsForFile fp = do
+ module' <- parseModuleFromFile fp
+ let imports = getImports module'
+ pure (mkModuleImport . unwrapPositionedImport <$> imports)
+ where mkModuleImport (D.ImportDeclaration mn importType' qualifier _) =
+ ModuleImport
+ (T.pack (N.runModuleName mn))
+ importType'
+ (T.pack . N.runModuleName <$> qualifier)
+ mkModuleImport _ = error "Shouldn't have gotten anything but Imports here"
+ unwrapPositionedImport (D.ImportDeclaration mn importType' qualifier b) =
+ D.ImportDeclaration mn (unwrapImportType importType') qualifier b
+ unwrapPositionedImport x = x
+ unwrapImportType (D.Explicit decls) = D.Explicit (map unwrapPositionedRef decls)
+ unwrapImportType (D.Hiding decls) = D.Hiding (map unwrapPositionedRef decls)
+ unwrapImportType D.Implicit = D.Implicit
+
+getPositionedImports :: D.Module -> [D.Declaration]
+getPositionedImports (D.Module _ _ _ declarations _) =
+ mapMaybe isImport declarations
+ where
+ isImport i@(D.PositionedDeclaration _ _ (D.ImportDeclaration{})) = Just i
+ isImport _ = Nothing
+
+getDeclPosition :: D.Module -> String -> Maybe SP.SourceSpan
+getDeclPosition m ident =
+ let decls = getDeclarations m
+ in getFirst (foldMap (match ident) decls)
+ where match q (D.PositionedDeclaration ss _ decl) = First (if go q decl
+ then Just ss
+ else Nothing)
+ match _ _ = First Nothing
+
+ go q (D.DataDeclaration _ name _ constructors) =
+ properEqual name q || any (\(x,_) -> properEqual x q) constructors
+ go q (D.DataBindingGroupDeclaration decls) = any (go q) decls
+ go q (D.TypeSynonymDeclaration name _ _) = properEqual name q
+ go q (D.TypeDeclaration ident' _) = identEqual ident' q
+ go q (D.ValueDeclaration ident' _ _ _) = identEqual ident' q
+ go q (D.ExternDeclaration ident' _) = identEqual ident' q
+ go q (D.ExternDataDeclaration name _) = properEqual name q
+ go q (D.TypeClassDeclaration name _ _ members) =
+ properEqual name q || any (go q . unwrapPositioned) members
+ go q (D.TypeInstanceDeclaration ident' _ _ _ _) =
+ identEqual ident' q
+ go _ _ = False
+
+ properEqual x q = N.runProperName x == q
+ identEqual x q = N.runIdent x == q
+
+goToDefinition :: String -> FilePath -> IO (Maybe SP.SourceSpan)
+goToDefinition q fp = do
+ m <- runExceptT (parseModuleFromFile fp)
+ case m of
+ Right module' -> return $ getDeclPosition module' q
+ Left _ -> return Nothing
diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs
new file mode 100644
index 0000000..dc015cb
--- /dev/null
+++ b/src/Language/PureScript/Ide/State.hs
@@ -0,0 +1,80 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PackageImports #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TupleSections #-}
+
+module Language.PureScript.Ide.State where
+
+import Prelude ()
+import Prelude.Compat
+
+import Control.Concurrent.STM
+import Control.Monad.IO.Class
+import "monad-logger" Control.Monad.Logger
+import Control.Monad.Reader.Class
+import qualified Data.Map.Lazy as M
+import Data.Maybe (catMaybes)
+import Data.Monoid
+import qualified Data.Text as T
+import Language.PureScript.Externs
+import Language.PureScript.Ide.Externs
+import Language.PureScript.Ide.Reexports
+import Language.PureScript.Ide.Types
+import Language.PureScript.Names
+
+getPscIdeState :: (PscIde m, Functor m) =>
+ m (M.Map ModuleIdent [ExternDecl])
+getPscIdeState = do
+ stateVar <- envStateVar <$> ask
+ liftIO $ pscStateModules <$> readTVarIO stateVar
+
+getExternFiles :: (PscIde m, Functor m) =>
+ m (M.Map ModuleName ExternsFile)
+getExternFiles = do
+ stateVar <- envStateVar <$> ask
+ liftIO (externsFiles <$> readTVarIO stateVar)
+
+getAllDecls :: (PscIde m, Functor m) => m [ExternDecl]
+getAllDecls = concat <$> getPscIdeState
+
+getAllModules :: (PscIde m, Functor m) => m [Module]
+getAllModules = M.toList <$> getPscIdeState
+
+getAllModulesWithReexports :: (PscIde m, MonadLogger m, Applicative m) =>
+ m [Module]
+getAllModulesWithReexports = do
+ mis <- M.keys <$> getPscIdeState
+ ms <- traverse getModuleWithReexports mis
+ pure (catMaybes ms)
+
+getModule :: (PscIde m, MonadLogger m, Applicative m) =>
+ ModuleIdent -> m (Maybe Module)
+getModule m = do
+ modules <- getPscIdeState
+ pure ((m,) <$> M.lookup m modules)
+
+getModuleWithReexports :: (PscIde m, MonadLogger m, Applicative m) =>
+ ModuleIdent -> m (Maybe Module)
+getModuleWithReexports mi = do
+ m <- getModule mi
+ modules <- getPscIdeState
+ pure $ resolveReexports modules <$> m
+
+insertModule ::(PscIde m, MonadLogger m) =>
+ ExternsFile -> m ()
+insertModule externsFile = do
+ env <- ask
+ let moduleName = efModuleName externsFile
+ $(logDebug) $ "Inserting Module: " <> (T.pack (runModuleName moduleName))
+ liftIO . atomically $ insertModule' (envStateVar env) externsFile
+
+insertModule' :: TVar PscIdeState -> ExternsFile -> STM ()
+insertModule' st ef = do
+ modifyTVar (st) $ \x ->
+ x { externsFiles = M.insert (efModuleName ef) ef (externsFiles x)
+ , pscStateModules = let (mn, decls ) = convertExterns ef
+ in M.insert mn decls (pscStateModules x)
+ }
diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs
new file mode 100644
index 0000000..0d8d429
--- /dev/null
+++ b/src/Language/PureScript/Ide/Types.hs
@@ -0,0 +1,240 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Language.PureScript.Ide.Types where
+
+import Prelude ()
+import Prelude.Compat
+
+import Control.Concurrent.STM
+import Control.Monad
+import Control.Monad.Reader.Class
+import Control.Monad.Trans
+import Data.Aeson
+import Data.Map.Lazy as M
+import Data.Maybe (maybeToList)
+import Data.Text (Text (), pack, unpack)
+import qualified Language.PureScript.AST.Declarations as D
+import Language.PureScript.Externs
+import Language.PureScript.Names
+import qualified Language.PureScript.Names as N
+
+import Text.Parsec
+import Text.Parsec.Text
+
+type ModuleIdent = Text
+type DeclIdent = Text
+type Type = Text
+
+data Fixity = Infix | Infixl | Infixr deriving(Show, Eq, Ord)
+
+data ExternDecl
+ = FunctionDecl { functionName :: DeclIdent
+ , functionType :: Type
+ }
+ | FixityDeclaration Fixity
+ Int
+ DeclIdent
+ | Dependency { dependencyModule :: ModuleIdent
+ , dependencyNames :: [Text]
+ , dependencyAlias :: Maybe Text
+ }
+ | ModuleDecl ModuleIdent
+ [DeclIdent]
+ | DataDecl DeclIdent
+ Text
+ | Export ModuleIdent
+ deriving (Show,Eq,Ord)
+
+instance ToJSON ExternDecl where
+ toJSON (FunctionDecl n t) = object ["name" .= n, "type" .= t]
+ toJSON (ModuleDecl n t) = object ["name" .= n, "type" .= t]
+ toJSON (DataDecl n t) = object ["name" .= n, "type" .= t]
+ toJSON (Dependency n names _) = object ["module" .= n, "names" .= names]
+ toJSON (FixityDeclaration f p n) = object ["name" .= n
+ , "fixity" .= show f
+ , "precedence" .= p]
+ toJSON (Export _) = object []
+
+type Module = (ModuleIdent, [ExternDecl])
+
+data Configuration =
+ Configuration {
+ confOutputPath :: FilePath
+ , confDebug :: Bool
+ }
+
+data PscIdeEnvironment =
+ PscIdeEnvironment {
+ envStateVar :: TVar PscIdeState
+ , envConfiguration :: Configuration
+ }
+
+type PscIde m = (Applicative m, MonadIO m, MonadReader PscIdeEnvironment m)
+
+data PscIdeState =
+ PscIdeState {
+ pscStateModules :: M.Map Text [ExternDecl]
+ , externsFiles :: M.Map ModuleName ExternsFile
+ } deriving Show
+
+emptyPscIdeState :: PscIdeState
+emptyPscIdeState = PscIdeState M.empty M.empty
+
+newtype Completion =
+ Completion (ModuleIdent, DeclIdent, Type)
+ deriving (Show,Eq)
+
+data ModuleImport =
+ ModuleImport {
+ importModuleName :: ModuleIdent
+ , importType :: D.ImportDeclarationType
+ , importQualifier :: Maybe Text
+ } deriving(Show)
+
+instance Eq ModuleImport where
+ mi1 == mi2 = importModuleName mi1 == importModuleName mi2
+ && importQualifier mi1 == importQualifier mi2
+
+instance ToJSON ModuleImport where
+ toJSON (ModuleImport mn D.Implicit qualifier) =
+ object $ ["module" .= mn
+ , "importType" .= ("implicit" :: Text)
+ ] ++ fmap (\x -> "qualifier" .= x) (maybeToList qualifier)
+ toJSON (ModuleImport mn (D.Explicit refs) _) =
+ object ["module" .= mn
+ , "importType" .= ("explicit" :: Text)
+ , "identifiers" .= (identifierFromDeclarationRef <$> refs)]
+ toJSON (ModuleImport mn (D.Hiding refs) _) =
+ object ["module" .= mn
+ , "importType" .= ("hiding" :: Text)
+ , "identifiers" .= (identifierFromDeclarationRef <$> refs)]
+
+identifierFromDeclarationRef :: D.DeclarationRef -> String
+identifierFromDeclarationRef (D.TypeRef name _) = N.runProperName name
+identifierFromDeclarationRef (D.ValueRef ident) = N.runIdent ident
+identifierFromDeclarationRef (D.TypeClassRef name) = N.runProperName name
+identifierFromDeclarationRef _ = ""
+
+instance FromJSON Completion where
+ parseJSON (Object o) = do
+ m <- o .: "module"
+ d <- o .: "identifier"
+ t <- o .: "type"
+ return $ Completion (m, d, t)
+ parseJSON _ = mzero
+
+instance ToJSON Completion where
+ toJSON (Completion (m,d,t)) =
+ object ["module" .= m, "identifier" .= d, "type" .= t]
+
+data Success =
+ CompletionResult [Completion]
+ | TextResult Text
+ | MultilineTextResult [Text]
+ | PursuitResult [PursuitResponse]
+ | ImportList [ModuleImport]
+ | ModuleList [ModuleIdent]
+ deriving(Show, Eq)
+
+encodeSuccess :: (ToJSON a) => a -> Value
+encodeSuccess res =
+ object ["resultType" .= ("success" :: Text), "result" .= res]
+
+instance ToJSON Success where
+ toJSON (CompletionResult cs) = encodeSuccess cs
+ toJSON (TextResult t) = encodeSuccess t
+ toJSON (MultilineTextResult ts) = encodeSuccess ts
+ toJSON (PursuitResult resp) = encodeSuccess resp
+ toJSON (ImportList decls) = encodeSuccess decls
+ toJSON (ModuleList modules) = encodeSuccess modules
+
+newtype PursuitQuery = PursuitQuery Text
+ deriving (Show, Eq)
+
+data PursuitSearchType = Package | Identifier
+ deriving (Show, Eq)
+
+instance FromJSON PursuitSearchType where
+ parseJSON (String t) = case t of
+ "package" -> return Package
+ "completion" -> return Identifier
+ _ -> mzero
+ parseJSON _ = mzero
+
+instance FromJSON PursuitQuery where
+ parseJSON o = fmap PursuitQuery (parseJSON o)
+
+data PursuitResponse
+ = ModuleResponse { moduleResponseName :: Text
+ , moduleResponsePackage :: Text}
+ | DeclarationResponse { declarationResponseType :: Text
+ , declarationResponseModule :: Text
+ , declarationResponseIdent :: Text
+ , declarationResponsePackage :: Text
+ }
+ deriving (Show,Eq)
+
+instance FromJSON PursuitResponse where
+ parseJSON (Object o) = do
+ package <- o .: "package"
+ info <- o .: "info"
+ (type' :: String) <- info .: "type"
+ case type' of
+ "module" -> do
+ name <- info .: "module"
+ return
+ ModuleResponse
+ { moduleResponseName = name
+ , moduleResponsePackage = package
+ }
+ "declaration" -> do
+ moduleName <- info .: "module"
+ Right (ident, declType) <- typeParse <$> o .: "text"
+ return
+ DeclarationResponse
+ { declarationResponseType = declType
+ , declarationResponseModule = moduleName
+ , declarationResponseIdent = ident
+ , declarationResponsePackage = package
+ }
+ _ -> mzero
+ parseJSON _ = mzero
+
+
+typeParse :: Text -> Either Text (Text, Text)
+typeParse t = case parse parseType "" t of
+ Right (x,y) -> Right (pack x, pack y)
+ Left err -> Left (pack (show err))
+ where
+ parseType :: Parser (String, String)
+ parseType = do
+ name <- identifier
+ _ <- string "::"
+ spaces
+ type' <- many1 anyChar
+ return (unpack name, type')
+
+identifier :: Parser Text
+identifier = do
+ spaces
+ ident <-
+ -- necessary for being able to parse the following ((++), concat)
+ between (char '(') (char ')') (many1 (noneOf ", )")) <|>
+ many1 (noneOf ", )")
+ spaces
+ return (pack ident)
+
+instance ToJSON PursuitResponse where
+ toJSON ModuleResponse{..} =
+ object ["module" .= moduleResponseName, "package" .= moduleResponsePackage]
+ toJSON DeclarationResponse{..} =
+ object
+ [ "module" .= declarationResponseModule
+ , "ident" .= declarationResponseIdent
+ , "type" .= declarationResponseType
+ , "package" .= declarationResponsePackage]
diff --git a/src/Language/PureScript/Ide/Watcher.hs b/src/Language/PureScript/Ide/Watcher.hs
new file mode 100644
index 0000000..9a6c1ff
--- /dev/null
+++ b/src/Language/PureScript/Ide/Watcher.hs
@@ -0,0 +1,40 @@
+{-# LANGUAGE RecordWildCards #-}
+module Language.PureScript.Ide.Watcher where
+
+import Prelude ()
+import Prelude.Compat
+
+import Control.Concurrent (threadDelay)
+import Control.Concurrent.STM
+import Control.Monad
+import Control.Monad.Trans.Except
+import qualified Data.Map as M
+import Data.Maybe (isJust)
+import Language.PureScript.Externs
+import Language.PureScript.Ide.Externs
+import Language.PureScript.Ide.State
+import Language.PureScript.Ide.Types
+import System.FilePath
+import System.FSNotify
+
+
+reloadFile :: TVar PscIdeState -> FilePath -> IO ()
+reloadFile stateVar fp = do
+ (Right ef@ExternsFile{..}) <- runExceptT $ readExternFile fp
+ reloaded <- atomically $ do
+ st <- readTVar stateVar
+ if isLoaded efModuleName st
+ then
+ insertModule' stateVar ef *> pure True
+ else
+ pure False
+ when reloaded $ putStrLn $ "Reloaded File at: " ++ fp
+ where
+ isLoaded name st = isJust (M.lookup name (externsFiles st))
+
+watcher :: TVar PscIdeState -> FilePath -> IO ()
+watcher stateVar fp = withManager $ \mgr -> do
+ _ <- watchTree mgr fp
+ (\ev -> takeFileName (eventPath ev) == "externs.json")
+ (reloadFile stateVar . eventPath)
+ forever (threadDelay 10000)
diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs
index 8ab4649..3e554ef 100644
--- a/src/Language/PureScript/Linter.hs
+++ b/src/Language/PureScript/Linter.hs
@@ -71,6 +71,7 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl
go d | Just i <- getDeclIdent d
, i `S.member` s = errorMessage (ShadowedName i)
| otherwise = mempty
+ stepE _ (OperatorSection op val) = errorMessage $ DeprecatedOperatorSection op val
stepE _ _ = mempty
stepB :: S.Set Ident -> Binder -> MultipleErrors
diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs
index 6ac06e9..68753b2 100644
--- a/src/Language/PureScript/Linter/Imports.hs
+++ b/src/Language/PureScript/Linter/Imports.hs
@@ -17,6 +17,7 @@ import Control.Monad.Writer.Class
import Data.Foldable (forM_)
import Data.List ((\\), find, intersect, nub)
import Data.Maybe (mapMaybe)
+import Data.Monoid (Sum(..))
import qualified Data.Map as M
import Language.PureScript.AST.Declarations
@@ -78,6 +79,8 @@ lintImports (Module _ _ mn mdecls mexports) env usedImps = do
let scope = maybe nullImports (\(_, imps, _) -> imps) (M.lookup mn env)
usedImps' = foldr (elaborateUsed scope) usedImps exportedModules
+ numImplicitImports = getSum $ foldMap (Sum . countImplicitImports) mdecls
+ allowImplicit = numImplicitImports == 1
imps <- M.toAscList <$> findImports mdecls
@@ -86,7 +89,7 @@ lintImports (Module _ _ mn mdecls mexports) env usedImps = do
forM_ decls $ \(ss, declType, qualifierName) ->
censor (onErrorMessages $ addModuleLocError ss) $ do
let names = nub $ M.findWithDefault [] mni usedImps'
- lintImportDecl env mni qualifierName names declType
+ lintImportDecl env mni qualifierName names declType allowImplicit
forM_ (M.toAscList (byQual imps)) $ \(mnq, entries) -> do
let mnis = nub $ map (\(_, _, mni) -> mni) entries
@@ -103,6 +106,11 @@ lintImports (Module _ _ mn mdecls mexports) env usedImps = do
where
+ countImplicitImports :: Declaration -> Int
+ countImplicitImports (ImportDeclaration mn' Implicit _ _) | not (isPrim mn') = 1
+ countImplicitImports (PositionedDeclaration _ _ d) = countImplicitImports d
+ countImplicitImports _ = 0
+
-- Checks whether a module is the Prim module - used to suppress any checks
-- made, as Prim is always implicitly imported.
isPrim :: ModuleName -> Bool
@@ -148,13 +156,13 @@ lintImports (Module _ _ mn mdecls mexports) env usedImps = do
extractByQual
:: (Eq a)
=> ModuleName
- -> M.Map (Qualified a) [(Qualified a, ModuleName)]
+ -> M.Map (Qualified a) [ImportRecord a]
-> (Qualified a -> Name)
-> [(ModuleName, Name)]
extractByQual k m toName = mapMaybe go (M.toList m)
where
go (q@(Qualified mnq _), is) | isUnqualified q || isQualifiedWith k q =
- case fst (head is) of
+ case importName (head is) of
Qualified (Just mn') name -> Just (mn', toName $ Qualified mnq name)
_ -> internalError "unqualified name in extractByQual"
go _ = Nothing
@@ -167,11 +175,12 @@ lintImportDecl
-> Maybe ModuleName
-> [Name]
-> ImportDeclarationType
+ -> Bool
-> m ()
-lintImportDecl env mni qualifierName names declType =
+lintImportDecl env mni qualifierName names declType allowImplicit =
case declType of
Implicit -> case qualifierName of
- Nothing -> checkImplicit ImplicitImport
+ Nothing -> unless allowImplicit (checkImplicit ImplicitImport)
Just q ->
let usedModuleNames = mapMaybe extractQualName names
in unless (q `elem` usedModuleNames) unused
diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs
index cf9898d..c1d327c 100644
--- a/src/Language/PureScript/Make.hs
+++ b/src/Language/PureScript/Make.hs
@@ -31,7 +31,7 @@ import Control.Monad.Writer.Class (MonadWriter(..))
import Control.Monad.Trans.Class (MonadTrans(..))
import Control.Monad.Trans.Except
import Control.Monad.IO.Class
-import Control.Monad.Reader (MonadReader(..), ReaderT(..))
+import Control.Monad.Reader (MonadReader(..), ReaderT(..), asks)
import Control.Monad.Logger
import Control.Monad.Supply
import Control.Monad.Base (MonadBase(..))
@@ -52,9 +52,12 @@ import qualified Data.ByteString.UTF8 as BU8
import qualified Data.Set as S
import qualified Data.Map as M
+import SourceMap.Types
+import SourceMap
+
import System.Directory
- (doesFileExist, getModificationTime, createDirectoryIfMissing)
-import System.FilePath ((</>), takeDirectory)
+ (doesFileExist, getModificationTime, createDirectoryIfMissing, getCurrentDirectory)
+import System.FilePath ((</>), takeDirectory, makeRelative, splitPath, normalise)
import System.IO.Error (tryIOError)
import System.IO.UTF8 (readUTF8File, writeUTF8File)
@@ -68,6 +71,7 @@ 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
@@ -324,20 +328,51 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
| not $ requiresForeign m -> do
tell $ errorMessage $ UnnecessaryFFIModule mn path
return Nothing
- | otherwise -> return $ Just $ J.JSApp (J.JSVar "require") [J.JSStringLiteral "./foreign"]
+ | otherwise -> return $ Just $ J.JSApp Nothing (J.JSVar Nothing "require") [J.JSStringLiteral Nothing "./foreign"]
Nothing | requiresForeign m -> throwError . errorMessage $ MissingFFIModule mn
| otherwise -> return Nothing
- pjs <- prettyPrintJS <$> J.moduleToJs m foreignInclude
+ rawJs <- J.moduleToJs m foreignInclude
+ dir <- lift $ makeIO (const (ErrorMessage [] $ CannotGetFileInfo ".")) getCurrentDirectory
+ sourceMaps <- lift $ asks optionsSourceMaps
+ let (pjs, mappings) = if sourceMaps then prettyPrintJSWithSourceMaps rawJs else (prettyPrintJS rawJs, [])
let filePath = runModuleName mn
jsFile = outputDir </> filePath </> "index.js"
+ mapFile = outputDir </> filePath </> "index.js.map"
externsFile = outputDir </> filePath </> "externs.json"
foreignFile = outputDir </> filePath </> "foreign.js"
prefix = ["Generated by psc version " ++ showVersion Paths.version | usePrefix]
js = unlines $ map ("// " ++) prefix ++ [pjs]
+ mapRef = if sourceMaps then "//# sourceMappingURL=index.js.map\n" else ""
lift $ do
- writeTextFile jsFile (fromString js)
+ writeTextFile jsFile (fromString $ js ++ mapRef)
for_ (mn `M.lookup` foreigns) (readTextFile >=> writeTextFile foreignFile)
writeTextFile externsFile exts
+ lift $ when sourceMaps $ genSourceMap dir mapFile (length prefix) mappings
+
+ genSourceMap :: String -> String -> Int -> [SMap] -> Make ()
+ genSourceMap dir mapFile extraLines mappings = do
+ let pathToDir = iterate (".." </>) ".." !! length (splitPath $ normalise outputDir)
+ sourceFile = case mappings of
+ ((SMap file _ _):_) -> Just $ pathToDir </> makeRelative dir file
+ _ -> Nothing
+ let rawMapping = SourceMapping { smFile = "index.js", smSourceRoot = Nothing, smMappings =
+ map (\(SMap _ orig gen) -> Mapping {
+ mapOriginal = Just $ convertPos $ add 0 (-1) orig
+ , mapSourceFile = sourceFile
+ , mapGenerated = convertPos $ add (extraLines+1) 0 gen
+ , mapName = Nothing
+ }) $
+ mappings
+ }
+ let mapping = generate rawMapping
+ writeTextFile mapFile $ BU8.toString . B.toStrict . encode $ mapping
+ where
+ add :: Int -> Int -> SourcePos -> SourcePos
+ add n m (SourcePos n' m') = SourcePos (n+n') (m+m')
+
+ convertPos :: SourcePos -> Pos
+ convertPos SourcePos { sourcePosLine = l, sourcePosColumn = c } =
+ Pos { posLine = fromIntegral l, posColumn = fromIntegral c }
requiresForeign :: CF.Module a -> Bool
requiresForeign = not . null . CF.moduleForeign
diff --git a/src/Language/PureScript/ModuleDependencies.hs b/src/Language/PureScript/ModuleDependencies.hs
index b1f3e84..93b85e8 100644
--- a/src/Language/PureScript/ModuleDependencies.hs
+++ b/src/Language/PureScript/ModuleDependencies.hs
@@ -61,7 +61,8 @@ usedModules d =
where
forDecls :: Declaration -> [ModuleName]
forDecls (ImportDeclaration mn _ _ _) = [mn]
- forDecls (FixityDeclaration _ _ (Just (Qualified (Just mn) _))) = [mn]
+ forDecls (FixityDeclaration _ _ (Just (Left (Qualified (Just mn) _)))) = [mn]
+ forDecls (FixityDeclaration _ _ (Just (Right (Qualified (Just mn) _)))) = [mn]
forDecls (TypeInstanceDeclaration _ _ (Qualified (Just mn) _) _ _) = [mn]
forDecls _ = []
diff --git a/src/Language/PureScript/Options.hs b/src/Language/PureScript/Options.hs
index 7421e56..a68bb9f 100644
--- a/src/Language/PureScript/Options.hs
+++ b/src/Language/PureScript/Options.hs
@@ -41,9 +41,12 @@ data Options = Options {
-- |
-- The path to prepend to require statements
, optionsRequirePath :: Maybe FilePath
+ -- |
+ -- Generate soure maps
+ , optionsSourceMaps :: Bool
} deriving Show
-- |
-- Default make options
defaultOptions :: Options
-defaultOptions = Options False False Nothing False False False Nothing
+defaultOptions = Options False False Nothing False False False Nothing False
diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs
index 0a5e004..c6e9ad4 100644
--- a/src/Language/PureScript/Parser/Declarations.hs
+++ b/src/Language/PureScript/Parser/Declarations.hs
@@ -122,9 +122,12 @@ parseFixityDeclaration :: TokenParser Declaration
parseFixityDeclaration = do
fixity <- parseFixity
indented
- alias <- P.optionMaybe $ parseQualified (Ident <$> identifier) <* reserved "as"
+ alias <- P.optionMaybe $ aliased <* reserved "as"
name <- symbol
return $ FixityDeclaration fixity name alias
+ where
+ aliased = (Left <$> parseQualified (Ident <$> identifier))
+ <|> (Right <$> parseQualified (ProperName <$> uname))
parseImportDeclaration :: TokenParser Declaration
parseImportDeclaration = do
@@ -312,18 +315,17 @@ parseArrayLiteral :: TokenParser Expr
parseArrayLiteral = ArrayLiteral <$> squares (commaSep parseValue)
parseObjectLiteral :: TokenParser Expr
-parseObjectLiteral = ObjectConstructor <$> braces (commaSep parseIdentifierAndValue)
+parseObjectLiteral = ObjectLiteral <$> braces (commaSep parseIdentifierAndValue)
-parseIdentifierAndValue :: TokenParser (String, Maybe Expr)
+parseIdentifierAndValue :: TokenParser (String, Expr)
parseIdentifierAndValue =
do
name <- C.indented *> lname
- b <- P.option (Just $ Var $ Qualified Nothing (Ident name)) rest
+ b <- P.option (Var $ Qualified Nothing (Ident name)) rest
return (name, b)
<|> (,) <$> (C.indented *> stringLiteral) <*> rest
where
- rest = C.indented *> colon *> C.indented *> val
- val = P.try (Just <$> parseValue) <|> (underscore *> pure Nothing)
+ rest = C.indented *> colon *> C.indented *> parseValue
parseAbs :: TokenParser Expr
parseAbs = do
@@ -373,13 +375,13 @@ parseLet = do
parseValueAtom :: TokenParser Expr
parseValueAtom = P.choice
- [ parseNumericLiteral
+ [ parseAnonymousArgument
+ , parseNumericLiteral
, parseCharLiteral
, parseStringLiteral
, parseBooleanLiteral
, parseArrayLiteral
, P.try parseObjectLiteral
- , P.try parseObjectGetter
, parseAbs
, P.try parseConstructor
, P.try parseVar
@@ -389,8 +391,6 @@ parseValueAtom = P.choice
, parseLet
, P.try $ Parens <$> parens parseValue
, parseOperatorSection
- -- TODO: combine this with parseObjectGetter
- , parseObjectUpdaterWildcard
]
-- |
@@ -406,11 +406,11 @@ parseOperatorSection = parens $ left <|> right
right = OperatorSection <$> parseInfixExpr <* indented <*> (Right <$> indexersAndAccessors)
left = flip OperatorSection <$> (Left <$> indexersAndAccessors) <* indented <*> parseInfixExpr
-parsePropertyUpdate :: TokenParser (String, Maybe Expr)
+parsePropertyUpdate :: TokenParser (String, Expr)
parsePropertyUpdate = do
name <- lname <|> stringLiteral
_ <- C.indented *> equals
- value <- C.indented *> (underscore *> pure Nothing) <|> (Just <$> parseValue)
+ value <- C.indented *> parseValue
return (name, value)
parseAccessor :: Expr -> TokenParser Expr
@@ -436,15 +436,12 @@ parseDoNotationElement = P.choice
, DoNotationValue <$> parseValue
]
-parseObjectGetter :: TokenParser Expr
-parseObjectGetter = ObjectGetter <$> (underscore *> C.indented *> dot *> C.indented *> (lname <|> stringLiteral))
-
-- | Expressions including indexers and record updates
indexersAndAccessors :: TokenParser Expr
indexersAndAccessors = C.buildPostfixParser postfixTable parseValueAtom
where
postfixTable = [ parseAccessor
- , P.try . parseUpdaterBody . Just
+ , P.try . parseUpdaterBody
]
-- |
@@ -466,11 +463,11 @@ parseValue = withSourceSpan PositionedValue
]
]
-parseUpdaterBody :: Maybe Expr -> TokenParser Expr
-parseUpdaterBody v = ObjectUpdater v <$> (C.indented *> braces (commaSep1 (C.indented *> parsePropertyUpdate)))
+parseUpdaterBody :: Expr -> TokenParser Expr
+parseUpdaterBody v = ObjectUpdate v <$> (C.indented *> braces (commaSep1 (C.indented *> parsePropertyUpdate)))
-parseObjectUpdaterWildcard :: TokenParser Expr
-parseObjectUpdaterWildcard = underscore *> C.indented *> parseUpdaterBody Nothing
+parseAnonymousArgument :: TokenParser Expr
+parseAnonymousArgument = underscore *> pure AnonymousArgument
parseStringBinder :: TokenParser Binder
parseStringBinder = StringBinder <$> stringLiteral
@@ -525,8 +522,19 @@ parseIdentifierAndBinder =
-- Parse a binder
--
parseBinder :: TokenParser Binder
-parseBinder = withSourceSpan PositionedBinder (buildPostfixParser postfixTable parseBinderAtom)
+parseBinder =
+ withSourceSpan
+ PositionedBinder
+ ( P.buildExpressionParser operators
+ . buildPostfixParser postfixTable
+ $ parseBinderAtom
+ )
where
+ operators =
+ [ [ P.Infix (P.try (C.indented *> parseOpBinder P.<?> "binder operator") >>= \op ->
+ return (BinaryNoParensBinder op)) P.AssocRight
+ ]
+ ]
-- TODO: parsePolyType when adding support for polymorphic types
postfixTable = [ \b -> flip TypedBinder b <$> (indented *> doubleColon *> parseType)
]
@@ -541,9 +549,12 @@ parseBinder = withSourceSpan PositionedBinder (buildPostfixParser postfixTable p
, parseConstructorBinder
, parseObjectBinder
, parseArrayBinder
- , parens parseBinder
+ , ParensInBinder <$> parens parseBinder
] P.<?> "binder"
+ parseOpBinder :: TokenParser Binder
+ parseOpBinder = OpBinder <$> parseQualified (Op <$> symbol)
+
-- |
-- Parse a binder as it would appear in a top level declaration
--
@@ -558,7 +569,7 @@ parseBinderNoParens = P.choice
, parseNullaryConstructorBinder
, parseObjectBinder
, parseArrayBinder
- , parens parseBinder
+ , ParensInBinder <$> parens parseBinder
] P.<?> "binder"
-- |
diff --git a/src/Language/PureScript/Pretty.hs b/src/Language/PureScript/Pretty.hs
index 7d569c5..959fed5 100644
--- a/src/Language/PureScript/Pretty.hs
+++ b/src/Language/PureScript/Pretty.hs
@@ -27,6 +27,3 @@ import Language.PureScript.Pretty.Kinds as P
import Language.PureScript.Pretty.Values as P
import Language.PureScript.Pretty.Types as P
import Language.PureScript.Pretty.JS as P
-
-
-
diff --git a/src/Language/PureScript/Pretty/Common.hs b/src/Language/PureScript/Pretty/Common.hs
index 59b5451..58aa9b2 100644
--- a/src/Language/PureScript/Pretty/Common.hs
+++ b/src/Language/PureScript/Pretty/Common.hs
@@ -13,12 +13,18 @@
--
-----------------------------------------------------------------------------
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
module Language.PureScript.Pretty.Common where
-import Control.Monad.State
-import Data.List (intercalate)
+import Prelude ()
+import Prelude.Compat
+
+import Control.Monad.State (StateT, modify, get)
+import Data.List (elemIndices, intersperse)
import Language.PureScript.Parser.Lexer (reservedPsNames, isSymbolChar)
+import Language.PureScript.AST (SourcePos(..), SourceSpan(..))
import Text.PrettyPrint.Boxes
@@ -26,9 +32,90 @@ import Text.PrettyPrint.Boxes
-- Wrap a string in parentheses
--
parens :: String -> String
-parens s = ('(':s) ++ ")"
+parens s = '(':s ++ ")"
+
+parensPos :: (Emit gen) => gen -> gen
+parensPos s = emit "(" `mappend` s `mappend` emit ")"
+
+-- |
+-- Generalize intercalate slightly for monoids
+--
+intercalate :: Monoid m => m -> [m] -> m
+intercalate x xs = mconcat (intersperse x xs)
+
+class (Monoid gen) => Emit gen where
+ emit :: String -> gen
+ addMapping :: SourceSpan -> gen
+
+data SMap = SMap String SourcePos SourcePos
+
+-- |
+-- String with length and source-map entries
+--
+newtype StrPos = StrPos (SourcePos, String, [SMap])
+
+-- |
+-- Make a monoid where append consists of concatenating the string part, adding the lengths
+-- appropriately and advancing source mappings on the right hand side to account for
+-- the length of the left.
+--
+instance Monoid StrPos where
+ mempty = StrPos (SourcePos 0 0, "", [])
+
+ StrPos (a,b,c) `mappend` StrPos (a',b',c') = StrPos (a `addPos` a', b ++ b', c ++ (bumpPos a <$> c'))
+
+ mconcat ms =
+ let s' = concatMap (\(StrPos(_, s, _)) -> s) ms
+ (p, maps) = foldl plus (SourcePos 0 0, []) ms
+ in
+ StrPos (p, s', concat $ reverse maps)
+ where
+ plus :: (SourcePos, [[SMap]]) -> StrPos -> (SourcePos, [[SMap]])
+ plus (a, c) (StrPos (a', _, c')) = (a `addPos` a', (bumpPos a <$> c') : c)
+
+instance Emit StrPos where
+ -- |
+ -- Augment a string with its length (rows/column)
+ --
+ emit str =
+ let newlines = elemIndices '\n' str
+ index = if null newlines then 0 else last newlines + 1
+ in
+ StrPos (SourcePos { sourcePosLine = length newlines, sourcePosColumn = length str - index }, str, [])
+
+ -- |
+ -- Add a new mapping entry for given source position with initially zero generated position
+ --
+ addMapping (SourceSpan { spanName = file, spanStart = startPos }) = StrPos (zeroPos, mempty, [mapping])
+ where
+ mapping = SMap file startPos zeroPos
+ zeroPos = SourcePos 0 0
+
+newtype PlainString = PlainString String deriving Monoid
+
+runPlainString :: PlainString -> String
+runPlainString (PlainString s) = s
+
+instance Emit PlainString where
+ emit = PlainString
+ addMapping _ = mempty
+
+addMapping' :: (Emit gen) => Maybe SourceSpan -> gen
+addMapping' (Just ss) = addMapping ss
+addMapping' Nothing = mempty
+
+bumpPos :: SourcePos -> SMap -> SMap
+bumpPos p (SMap f s g) = SMap f s $ p `addPos` g
+
+addPos :: SourcePos -> SourcePos -> SourcePos
+addPos (SourcePos n m) (SourcePos 0 m') = SourcePos n (m+m')
+addPos (SourcePos n _) (SourcePos n' m') = SourcePos (n+n') m'
+
+
+data PrinterState = PrinterState { indent :: Int }
-newtype PrinterState = PrinterState { indent :: Int } deriving (Show, Read, Eq, Ord)
+emptyPrinterState :: PrinterState
+emptyPrinterState = PrinterState { indent = 0 }
-- |
-- Number of characters per identation level
@@ -39,7 +126,7 @@ blockIndent = 4
-- |
-- Pretty print with a new indentation level
--
-withIndent :: StateT PrinterState Maybe String -> StateT PrinterState Maybe String
+withIndent :: (Emit gen) => StateT PrinterState Maybe gen -> StateT PrinterState Maybe gen
withIndent action = do
modify $ \st -> st { indent = indent st + blockIndent }
result <- action
@@ -49,19 +136,19 @@ withIndent action = do
-- |
-- Get the current indentation level
--
-currentIndent :: StateT PrinterState Maybe String
+currentIndent :: (Emit gen) => StateT PrinterState Maybe gen
currentIndent = do
current <- get
- return $ replicate (indent current) ' '
+ return $ emit $ replicate (indent current) ' '
-- |
-- Print many lines
--
-prettyPrintMany :: (a -> StateT PrinterState Maybe String) -> [a] -> StateT PrinterState Maybe String
+prettyPrintMany :: (Emit gen) => (a -> StateT PrinterState Maybe gen) -> [a] -> StateT PrinterState Maybe gen
prettyPrintMany f xs = do
ss <- mapM f xs
indentString <- currentIndent
- return $ intercalate "\n" $ map (indentString ++) ss
+ return $ intercalate (emit "\n") $ map (\s -> mappend indentString s) ss
-- |
-- Prints an object key, escaping reserved names.
diff --git a/src/Language/PureScript/Pretty/JS.hs b/src/Language/PureScript/Pretty/JS.hs
index 2a1f6e0..5e8a654 100644
--- a/src/Language/PureScript/Pretty/JS.hs
+++ b/src/Language/PureScript/Pretty/JS.hs
@@ -14,13 +14,12 @@
-----------------------------------------------------------------------------
module Language.PureScript.Pretty.JS (
- prettyPrintJS
+ prettyPrintJS, prettyPrintJSWithSourceMaps
) where
import Prelude ()
import Prelude.Compat
-import Data.List hiding (concat, concatMap)
import Data.Maybe (fromMaybe)
import Control.Arrow ((<+>))
@@ -34,103 +33,110 @@ import Language.PureScript.CodeGen.JS.Common
import Language.PureScript.Pretty.Common
import Language.PureScript.Comments
+
+import Language.PureScript.AST (SourceSpan(..))
+
import Numeric
-literals :: Pattern PrinterState JS String
-literals = mkPattern' match
+import Data.Monoid
+
+literals :: (Emit gen) => Pattern PrinterState JS gen
+literals = mkPattern' match'
where
- match :: JS -> StateT PrinterState Maybe String
- match (JSNumericLiteral n) = return $ either show show n
- match (JSStringLiteral s) = return $ string s
- match (JSBooleanLiteral True) = return "true"
- match (JSBooleanLiteral False) = return "false"
- match (JSArrayLiteral xs) = concat <$> sequence
- [ return "[ "
- , intercalate ", " <$> forM xs prettyPrintJS'
- , return " ]"
+ match' :: (Emit gen) => JS -> StateT PrinterState Maybe gen
+ match' js = (addMapping' (getSourceSpan js) <>) <$> match js
+
+ match :: (Emit gen) => JS -> StateT PrinterState Maybe gen
+ match (JSNumericLiteral _ n) = return $ emit $ either show show n
+ match (JSStringLiteral _ s) = return $ string s
+ match (JSBooleanLiteral _ True) = return $ emit "true"
+ match (JSBooleanLiteral _ False) = return $ emit "false"
+ match (JSArrayLiteral _ xs) = mconcat <$> sequence
+ [ return $ emit "[ "
+ , intercalate (emit ", ") <$> forM xs prettyPrintJS'
+ , return $ emit " ]"
]
- match (JSObjectLiteral []) = return "{}"
- match (JSObjectLiteral ps) = concat <$> sequence
- [ return "{\n"
+ match (JSObjectLiteral _ []) = return $ emit "{}"
+ match (JSObjectLiteral _ ps) = mconcat <$> sequence
+ [ return $ emit "{\n"
, withIndent $ do
- jss <- forM ps $ \(key, value) -> fmap ((objectPropertyToString key ++ ": ") ++) . prettyPrintJS' $ value
+ jss <- forM ps $ \(key, value) -> fmap ((objectPropertyToString key <> emit ": ") <>) . prettyPrintJS' $ value
indentString <- currentIndent
- return $ intercalate ", \n" $ map (indentString ++) jss
- , return "\n"
+ return $ intercalate (emit ", \n") $ map (indentString <>) jss
+ , return $ emit "\n"
, currentIndent
- , return "}"
+ , return $ emit "}"
]
where
- objectPropertyToString :: String -> String
- objectPropertyToString s | identNeedsEscaping s = show s
- | otherwise = s
- match (JSBlock sts) = concat <$> sequence
- [ return "{\n"
+ objectPropertyToString :: (Emit gen) => String -> gen
+ objectPropertyToString s | identNeedsEscaping s = emit $ show s
+ | otherwise = emit s
+ match (JSBlock _ sts) = mconcat <$> sequence
+ [ return $ emit "{\n"
, withIndent $ prettyStatements sts
- , return "\n"
+ , return $ emit "\n"
, currentIndent
- , return "}"
+ , return $ emit "}"
]
- match (JSVar ident) = return ident
- match (JSVariableIntroduction ident value) = concat <$> sequence
- [ return "var "
- , return ident
- , maybe (return "") (fmap (" = " ++) . prettyPrintJS') value
+ match (JSVar _ ident) = return $ emit ident
+ match (JSVariableIntroduction _ ident value) = mconcat <$> sequence
+ [ return $ emit $ "var " ++ ident
+ , maybe (return mempty) (fmap (emit " = " <>) . prettyPrintJS') value
]
- match (JSAssignment target value) = concat <$> sequence
+ match (JSAssignment _ target value) = mconcat <$> sequence
[ prettyPrintJS' target
- , return " = "
+ , return $ emit " = "
, prettyPrintJS' value
]
- match (JSWhile cond sts) = concat <$> sequence
- [ return "while ("
+ match (JSWhile _ cond sts) = mconcat <$> sequence
+ [ return $ emit "while ("
, prettyPrintJS' cond
- , return ") "
+ , return $ emit ") "
, prettyPrintJS' sts
]
- match (JSFor ident start end sts) = concat <$> sequence
- [ return $ "for (var " ++ ident ++ " = "
+ match (JSFor _ ident start end sts) = mconcat <$> sequence
+ [ return $ emit $ "for (var " ++ ident ++ " = "
, prettyPrintJS' start
- , return $ "; " ++ ident ++ " < "
+ , return $ emit $ "; " ++ ident ++ " < "
, prettyPrintJS' end
- , return $ "; " ++ ident ++ "++) "
+ , return $ emit $ "; " ++ ident ++ "++) "
, prettyPrintJS' sts
]
- match (JSForIn ident obj sts) = concat <$> sequence
- [ return $ "for (var " ++ ident ++ " in "
+ match (JSForIn _ ident obj sts) = mconcat <$> sequence
+ [ return $ emit $ "for (var " ++ ident ++ " in "
, prettyPrintJS' obj
- , return ") "
+ , return $ emit ") "
, prettyPrintJS' sts
]
- match (JSIfElse cond thens elses) = concat <$> sequence
- [ return "if ("
+ match (JSIfElse _ cond thens elses) = mconcat <$> sequence
+ [ return $ emit "if ("
, prettyPrintJS' cond
- , return ") "
+ , return $ emit ") "
, prettyPrintJS' thens
- , maybe (return "") (fmap (" else " ++) . prettyPrintJS') elses
+ , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintJS') elses
]
- match (JSReturn value) = concat <$> sequence
- [ return "return "
+ match (JSReturn _ value) = mconcat <$> sequence
+ [ return $ emit "return "
, prettyPrintJS' value
]
- match (JSThrow value) = concat <$> sequence
- [ return "throw "
+ match (JSThrow _ value) = mconcat <$> sequence
+ [ return $ emit "throw "
, prettyPrintJS' value
]
- match (JSBreak lbl) = return $ "break " ++ lbl
- match (JSContinue lbl) = return $ "continue " ++ lbl
- match (JSLabel lbl js) = concat <$> sequence
- [ return $ lbl ++ ": "
+ match (JSBreak _ lbl) = return $ emit $ "break " ++ lbl
+ match (JSContinue _ lbl) = return $ emit $ "continue " ++ lbl
+ match (JSLabel _ lbl js) = mconcat <$> sequence
+ [ return $ emit $ lbl ++ ": "
, prettyPrintJS' js
]
- match (JSComment com js) = fmap concat $ sequence $
- [ return "\n"
+ match (JSComment _ com js) = fmap mconcat $ sequence $
+ [ return $ emit "\n"
, currentIndent
- , return "/**\n"
+ , return $ emit "/**\n"
] ++
map asLine (concatMap commentLines com) ++
[ currentIndent
- , return " */\n"
+ , return $ emit " */\n"
, currentIndent
, prettyPrintJS' js
]
@@ -139,21 +145,21 @@ literals = mkPattern' match
commentLines (LineComment s) = [s]
commentLines (BlockComment s) = lines s
- asLine :: String -> StateT PrinterState Maybe String
+ asLine :: (Emit gen) => String -> StateT PrinterState Maybe gen
asLine s = do
i <- currentIndent
- return $ i ++ " * " ++ removeComments s ++ "\n"
+ return $ i <> emit " * " <> (emit . removeComments) s <> emit "\n"
removeComments :: String -> String
removeComments ('*' : '/' : s) = removeComments s
removeComments (c : s) = c : removeComments s
removeComments [] = []
- match (JSRaw js) = return js
+ match (JSRaw _ js) = return $ emit js
match _ = mzero
-string :: String -> String
-string s = '"' : concatMap encodeChar s ++ "\""
+string :: (Emit gen) => String -> gen
+string s = emit $ '"' : concatMap encodeChar s ++ "\""
where
encodeChar :: Char -> String
encodeChar '\b' = "\\b"
@@ -175,114 +181,121 @@ string s = '"' : concatMap encodeChar s ++ "\""
encodeChar c | fromEnum c > 0x7E || fromEnum c < 0x20 = "\\x" ++ showHex (fromEnum c) ""
encodeChar c = [c]
-conditional :: Pattern PrinterState JS ((JS, JS), JS)
+conditional :: Pattern PrinterState JS ((Maybe SourceSpan, JS, JS), JS)
conditional = mkPattern match
where
- match (JSConditional cond th el) = Just ((th, el), cond)
+ match (JSConditional ss cond th el) = Just ((ss, th, el), cond)
match _ = Nothing
-accessor :: Pattern PrinterState JS (String, JS)
+accessor :: (Emit gen) => Pattern PrinterState JS (gen, JS)
accessor = mkPattern match
where
- match (JSAccessor prop val) = Just (prop, val)
+ match (JSAccessor _ prop val) = Just (emit prop, val)
match _ = Nothing
-indexer :: Pattern PrinterState JS (String, JS)
+indexer :: (Emit gen) => Pattern PrinterState JS (gen, JS)
indexer = mkPattern' match
where
- match (JSIndexer index val) = (,) <$> prettyPrintJS' index <*> pure val
+ match (JSIndexer _ index val) = (,) <$> prettyPrintJS' index <*> pure val
+
match _ = mzero
-lam :: Pattern PrinterState JS ((Maybe String, [String]), JS)
+lam :: Pattern PrinterState JS ((Maybe String, [String], Maybe SourceSpan), JS)
lam = mkPattern match
where
- match (JSFunction name args ret) = Just ((name, args), ret)
+ match (JSFunction ss name args ret) = Just ((name, args, ss), ret)
match _ = Nothing
-app :: Pattern PrinterState JS (String, JS)
+app :: (Emit gen) => Pattern PrinterState JS (gen, JS)
app = mkPattern' match
where
- match (JSApp val args) = do
+ match (JSApp _ val args) = do
jss <- traverse prettyPrintJS' args
- return (intercalate ", " jss, val)
+ return (intercalate (emit ", ") jss, val)
match _ = mzero
typeOf :: Pattern PrinterState JS ((), JS)
typeOf = mkPattern match
where
- match (JSTypeOf val) = Just ((), val)
+ match (JSTypeOf _ val) = Just ((), val)
match _ = Nothing
instanceOf :: Pattern PrinterState JS (JS, JS)
instanceOf = mkPattern match
where
- match (JSInstanceOf val ty) = Just (val, ty)
+ match (JSInstanceOf _ val ty) = Just (val, ty)
match _ = Nothing
-unary' :: UnaryOperator -> (JS -> String) -> Operator PrinterState JS String
-unary' op mkStr = Wrap match (++)
+unary' :: (Emit gen) => UnaryOperator -> (JS -> String) -> Operator PrinterState JS gen
+unary' op mkStr = Wrap match (<>)
where
- match :: Pattern PrinterState JS (String, JS)
+ match :: (Emit gen) => Pattern PrinterState JS (gen, JS)
match = mkPattern match'
where
- match' (JSUnary op' val) | op' == op = Just (mkStr val, val)
+ match' (JSUnary _ op' val) | op' == op = Just (emit $ mkStr val, val)
match' _ = Nothing
-unary :: UnaryOperator -> String -> Operator PrinterState JS String
+unary :: (Emit gen) => UnaryOperator -> String -> Operator PrinterState JS gen
unary op str = unary' op (const str)
-negateOperator :: Operator PrinterState JS String
+negateOperator :: (Emit gen) => Operator PrinterState JS gen
negateOperator = unary' Negate (\v -> if isNegate v then "- " else "-")
where
- isNegate (JSUnary Negate _) = True
+ isNegate (JSUnary _ Negate _) = True
isNegate _ = False
-binary :: BinaryOperator -> String -> Operator PrinterState JS String
-binary op str = AssocL match (\v1 v2 -> v1 ++ " " ++ str ++ " " ++ v2)
+binary :: (Emit gen) => BinaryOperator -> String -> Operator PrinterState JS gen
+binary op str = AssocL match (\v1 v2 -> v1 <> emit (" " ++ str ++ " ") <> v2)
where
match :: Pattern PrinterState JS (JS, JS)
match = mkPattern match'
where
- match' (JSBinary op' v1 v2) | op' == op = Just (v1, v2)
+ match' (JSBinary _ op' v1 v2) | op' == op = Just (v1, v2)
match' _ = Nothing
-prettyStatements :: [JS] -> StateT PrinterState Maybe String
+prettyStatements :: (Emit gen) => [JS] -> StateT PrinterState Maybe gen
prettyStatements sts = do
jss <- forM sts prettyPrintJS'
indentString <- currentIndent
- return $ intercalate "\n" $ map ((++ ";") . (indentString ++)) jss
+ return $ intercalate (emit "\n") $ map ((<> emit ";") . (indentString <>)) jss
-- |
-- Generate a pretty-printed string representing a Javascript expression
--
-prettyPrintJS1 :: JS -> String
+prettyPrintJS1 :: (Emit gen) => JS -> gen
prettyPrintJS1 = fromMaybe (internalError "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyPrintJS'
-- |
-- Generate a pretty-printed string representing a collection of Javascript expressions at the same indentation level
--
+prettyPrintJSWithSourceMaps :: [JS] -> (String, [SMap])
+prettyPrintJSWithSourceMaps js =
+ let StrPos (_, s, mp) = (fromMaybe (internalError "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyStatements) js
+ in (s, mp)
+
prettyPrintJS :: [JS] -> String
-prettyPrintJS = fromMaybe (internalError "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyStatements
+prettyPrintJS = fromMaybe (internalError "Incomplete pattern") . fmap runPlainString . flip evalStateT (PrinterState 0) . prettyStatements
-- |
-- Generate an indented, pretty-printed string representing a Javascript expression
--
-prettyPrintJS' :: JS -> StateT PrinterState Maybe String
+prettyPrintJS' :: (Emit gen) => JS -> StateT PrinterState Maybe gen
prettyPrintJS' = A.runKleisli $ runPattern matchValue
where
- matchValue :: Pattern PrinterState JS String
- matchValue = buildPrettyPrinter operators (literals <+> fmap parens matchValue)
- operators :: OperatorTable PrinterState JS String
+ matchValue :: (Emit gen) => Pattern PrinterState JS gen
+ matchValue = buildPrettyPrinter operators (literals <+> fmap parensPos matchValue)
+ operators :: (Emit gen) => OperatorTable PrinterState JS gen
operators =
- OperatorTable [ [ Wrap accessor $ \prop val -> val ++ "." ++ prop ]
- , [ Wrap indexer $ \index val -> val ++ "[" ++ index ++ "]" ]
- , [ Wrap app $ \args val -> val ++ "(" ++ args ++ ")" ]
+ OperatorTable [ [ Wrap accessor $ \prop val -> val <> emit "." <> prop ]
+ , [ Wrap indexer $ \index val -> val <> emit "[" <> index <> emit "]" ]
+ , [ Wrap app $ \args val -> val <> emit "(" <> args <> emit ")" ]
, [ unary JSNew "new " ]
- , [ Wrap lam $ \(name, args) ret -> "function "
+ , [ Wrap lam $ \(name, args, ss) ret -> addMapping' ss <>
+ emit ("function "
++ fromMaybe "" name
- ++ "(" ++ intercalate ", " args ++ ") "
- ++ ret ]
- , [ Wrap typeOf $ \_ s -> "typeof " ++ s ]
+ ++ "(" ++ intercalate ", " args ++ ") ")
+ <> ret ]
+ , [ Wrap typeOf $ \_ s -> emit "typeof " <> s ]
, [ unary Not "!"
, unary BitwiseNot "~"
, unary Positive "+"
@@ -299,7 +312,7 @@ prettyPrintJS' = A.runKleisli $ runPattern matchValue
, binary LessThanOrEqualTo "<="
, binary GreaterThan ">"
, binary GreaterThanOrEqualTo ">="
- , AssocR instanceOf $ \v1 v2 -> v1 ++ " instanceof " ++ v2 ]
+ , AssocR instanceOf $ \v1 v2 -> v1 <> emit " instanceof " <> v2 ]
, [ binary EqualTo "==="
, binary NotEqualTo "!==" ]
, [ binary BitwiseAnd "&" ]
@@ -307,5 +320,5 @@ prettyPrintJS' = A.runKleisli $ runPattern matchValue
, [ binary BitwiseOr "|" ]
, [ binary And "&&" ]
, [ binary Or "||" ]
- , [ Wrap conditional $ \(th, el) cond -> cond ++ " ? " ++ prettyPrintJS1 th ++ " : " ++ prettyPrintJS1 el ]
+ , [ Wrap conditional $ \(ss, th, el) cond -> cond <> addMapping' ss <> emit " ? " <> prettyPrintJS1 th <> addMapping' ss <> emit " : " <> prettyPrintJS1 el ]
]
diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs
index 9ef9a0c..867e6f5 100644
--- a/src/Language/PureScript/Pretty/Values.hs
+++ b/src/Language/PureScript/Pretty/Values.hs
@@ -19,8 +19,6 @@ module Language.PureScript.Pretty.Values (
prettyPrintBinderAtom
) where
-import Data.List (intercalate)
-
import Control.Arrow (second)
import Language.PureScript.Crash
@@ -57,7 +55,6 @@ prettyPrintValue d (IfThenElse cond th el) =
])
prettyPrintValue d (Accessor prop val) = prettyPrintValueAtom (d - 1) val <> text ("." ++ show prop)
prettyPrintValue d (ObjectUpdate o ps) = prettyPrintValueAtom (d - 1) o <> text " " <> list '{' '}' (\(key, val) -> text (key ++ " = ") <> prettyPrintValue (d - 1) val) ps
-prettyPrintValue d (ObjectUpdater o ps) = maybe (text "_") (prettyPrintValueAtom (d - 1)) o <> text " " <> list '{' '}' (\(key, val) -> text (key ++ " = ") <> maybe (text "_") (prettyPrintValue (d - 1)) val) ps
prettyPrintValue d (App val arg) = prettyPrintValueAtom (d - 1) val `beforeWithSpace` prettyPrintValueAtom (d - 1) arg
prettyPrintValue d (Abs (Left arg) val) = text ('\\' : showIdent arg ++ " -> ") // moveRight 2 (prettyPrintValue (d - 1) val)
prettyPrintValue d (TypeClassDictionaryConstructorApp className ps) =
@@ -86,8 +83,7 @@ prettyPrintValueAtom _ (BooleanLiteral True) = text "true"
prettyPrintValueAtom _ (BooleanLiteral False) = text "false"
prettyPrintValueAtom d (ArrayLiteral xs) = list '[' ']' (prettyPrintValue (d - 1)) xs
prettyPrintValueAtom d (ObjectLiteral ps) = prettyPrintObject (d - 1) $ second Just `map` ps
-prettyPrintValueAtom d (ObjectConstructor ps) = prettyPrintObject (d - 1) ps
-prettyPrintValueAtom _ (ObjectGetter prop) = text $ "_." ++ show prop
+prettyPrintValueAtom _ AnonymousArgument = text "_"
prettyPrintValueAtom _ (Constructor name) = text $ runProperName (disqualify name)
prettyPrintValueAtom _ (Var ident) = text $ showIdent (disqualify ident)
prettyPrintValueAtom d (OperatorSection op (Right val)) = ((text "(" <> prettyPrintValue (d - 1) op) `beforeWithSpace` prettyPrintValue (d - 1) val) `before` text ")"
diff --git a/src/Language/PureScript/Publish.hs b/src/Language/PureScript/Publish.hs
index 210504f..7666d8b 100644
--- a/src/Language/PureScript/Publish.hs
+++ b/src/Language/PureScript/Publish.hs
@@ -146,15 +146,15 @@ preparePackage' opts = do
getModulesAndBookmarks :: PrepareM ([D.Bookmark], [D.Module])
getModulesAndBookmarks = do
(inputFiles, depsFiles) <- liftIO getInputAndDepsFiles
- (modules', bookmarks, env) <- parseAndDesugar inputFiles depsFiles
+ (modules', bookmarks) <- parseAndBookmark inputFiles depsFiles
- case runExcept (D.convertModulesInPackage env modules') of
+ case runExcept (D.convertModulesInPackage modules') of
Right modules -> return (bookmarks, modules)
Left err -> userError (CompileError err)
where
- parseAndDesugar inputFiles depsFiles = do
- r <- liftIO . runExceptT $ D.parseAndDesugar inputFiles depsFiles
+ parseAndBookmark inputFiles depsFiles = do
+ r <- liftIO . runExceptT $ D.parseAndBookmark inputFiles depsFiles
case r of
Right r' ->
return r'
diff --git a/src/Language/PureScript/Renamer.hs b/src/Language/PureScript/Renamer.hs
index f497b92..3dda3d4 100644
--- a/src/Language/PureScript/Renamer.hs
+++ b/src/Language/PureScript/Renamer.hs
@@ -105,8 +105,8 @@ lookupIdent name = do
findDeclIdents :: [Bind Ann] -> [Ident]
findDeclIdents = concatMap go
where
- go (NonRec ident _) = [ident]
- go (Rec ds) = map fst ds
+ go (NonRec _ ident _) = [ident]
+ go (Rec ds) = map (snd . fst) ds
-- |
-- Renames within each declaration in a module.
@@ -128,19 +128,19 @@ renameInModules = map go
-- another in the current scope.
--
renameInDecl :: Bool -> Bind Ann -> Rename (Bind Ann)
-renameInDecl isTopLevel (NonRec name val) = do
+renameInDecl isTopLevel (NonRec a name val) = do
name' <- if isTopLevel then return name else updateScope name
- NonRec name' <$> renameInValue val
+ NonRec a name' <$> renameInValue val
renameInDecl isTopLevel (Rec ds) = do
ds' <- traverse updateNames ds
Rec <$> traverse updateValues ds'
where
- updateNames :: (Ident, Expr Ann) -> Rename (Ident, Expr Ann)
- updateNames (name, val) = do
+ updateNames :: ((Ann, Ident), Expr Ann) -> Rename ((Ann, Ident), Expr Ann)
+ updateNames ((a, name), val) = do
name' <- if isTopLevel then return name else updateScope name
- return (name', val)
- updateValues :: (Ident, Expr Ann) -> Rename (Ident, Expr Ann)
- updateValues (name, val) = (,) name <$> renameInValue val
+ return ((a, name'), val)
+ updateValues :: ((Ann, Ident), Expr Ann) -> Rename ((Ann, Ident), Expr Ann)
+ updateValues (aname, val) = (,) aname <$> renameInValue val
-- |
-- Renames within a value.
diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs
index 5e75fc9..8fd50da 100644
--- a/src/Language/PureScript/Sugar/Names.hs
+++ b/src/Language/PureScript/Sugar/Names.hs
@@ -7,6 +7,8 @@ module Language.PureScript.Sugar.Names
( desugarImports
, desugarImportsWithEnv
, Env
+ , ImportRecord(..)
+ , ImportProvenance(..)
, Imports(..)
, Exports(..)
) where
@@ -17,6 +19,7 @@ import Prelude.Compat
import Data.List (find, nub)
import Data.Maybe (fromMaybe, mapMaybe)
+import Control.Arrow (first)
import Control.Monad
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.Writer (MonadWriter(..), censor)
@@ -54,7 +57,7 @@ desugarImportsWithEnv
desugarImportsWithEnv externs modules = do
env <- silence $ foldM externsEnv primEnv externs
modules' <- traverse updateExportRefs modules
- (modules'', env') <- foldM updateEnv ([], env) modules'
+ (modules'', env') <- first reverse <$> foldM updateEnv ([], env) modules'
(env',) <$> traverse (renameInModule' env') modules''
where
silence :: m a -> m a
@@ -66,7 +69,7 @@ desugarImportsWithEnv externs modules = do
let members = Exports{..}
ss = internalModuleSourceSpan "<Externs>"
env' = M.insert efModuleName (ss, nullImports, members) env
- fromEFImport (ExternsImport mn mt qmn) = (mn, [(Nothing, mt, qmn)])
+ fromEFImport (ExternsImport mn mt qmn) = (mn, [(Nothing, Just mt, qmn)])
imps <- foldM (resolveModuleImport env') nullImports (map fromEFImport efImports)
exps <- resolveExports env' efModuleName imps members efExports
return $ M.insert efModuleName (ss, imps, exps) env
@@ -168,7 +171,7 @@ renameInModule env imports (Module ss coms mn decls exps) =
updateDecl (pos, bound) (ExternDeclaration name ty) =
(,) (pos, name : bound) <$> (ExternDeclaration name <$> updateTypesEverywhere pos ty)
updateDecl (pos, bound) (FixityDeclaration fx name alias) =
- (,) (pos, bound) <$> (FixityDeclaration fx name <$> traverse (`updateValueName` pos) alias)
+ (,) (pos, bound) <$> (FixityDeclaration fx name <$> traverse (eitherM (`updateValueName` pos) (`updateDataConstructorName` pos)) alias)
updateDecl s d = return (s, d)
updateValue
@@ -203,6 +206,8 @@ renameInModule env imports (Module ss coms mn decls exps) =
return ((Just pos, bound), v)
updateBinder s@(pos, _) (ConstructorBinder name b) =
(,) s <$> (ConstructorBinder <$> updateDataConstructorName name pos <*> pure b)
+ updateBinder s@(pos, _) (OpBinder name) =
+ (,) s <$> (OpBinder <$> updateValueName name pos)
updateBinder s (TypedBinder t b) = do
(s'@ (span', _), b') <- updateBinder s b
t' <- updateTypesEverywhere span' t
@@ -281,7 +286,7 @@ renameInModule env imports (Module ss coms mn decls exps) =
update
:: (Ord a, Show a)
=> (Qualified a -> SimpleErrorMessage)
- -> M.Map (Qualified a) [(Qualified a, ModuleName)]
+ -> M.Map (Qualified a) [ImportRecord a]
-> (Exports -> a -> Maybe (Qualified a))
-> (Qualified a -> Name)
-> (a -> String)
@@ -297,8 +302,7 @@ renameInModule env imports (Module ss coms mn decls exps) =
-- re-exports. If there are multiple options for the name to resolve to
-- in scope, we throw an error.
(Just options, _) -> do
- checkImportConflicts render options
- let (Qualified (Just mnNew) _, mnOrig) = head options
+ (mnNew, mnOrig) <- checkImportConflicts mn render options
modify $ \result -> M.insert mnNew (maybe [toName qname] (toName qname :) (mnNew `M.lookup` result)) result
return $ Qualified (Just mnOrig) name
diff --git a/src/Language/PureScript/Sugar/Names/Env.hs b/src/Language/PureScript/Sugar/Names/Env.hs
index 6820ac5..5af2c76 100644
--- a/src/Language/PureScript/Sugar/Names/Env.hs
+++ b/src/Language/PureScript/Sugar/Names/Env.hs
@@ -2,7 +2,9 @@
{-# LANGUAGE ScopedTypeVariables #-}
module Language.PureScript.Sugar.Names.Env
- ( Imports(..)
+ ( ImportRecord(..)
+ , ImportProvenance(..)
+ , Imports(..)
, nullImports
, Exports(..)
, nullExports
@@ -19,13 +21,14 @@ module Language.PureScript.Sugar.Names.Env
) where
import Data.Function (on)
-import Data.List (groupBy, sortBy, nub)
+import Data.List (groupBy, sortBy, nub, delete)
import Data.Maybe (fromJust)
import qualified Data.Map as M
import qualified Data.Set as S
import Control.Monad
import Control.Monad.Error.Class (MonadError(..))
+import Control.Monad.Writer.Class (MonadWriter(..))
import Language.PureScript.AST
import Language.PureScript.Crash
@@ -34,6 +37,30 @@ import Language.PureScript.Environment
import Language.PureScript.Errors
-- |
+-- The details for an import: the name of the thing that is being imported
+-- (`A.x` if importing from `A`), the module that the thing was originally
+-- defined in (for re-export resolution), and the import provenance (see below).
+--
+data ImportRecord a =
+ ImportRecord
+ { importName :: Qualified a
+ , importSourceModule :: ModuleName
+ , importProvenance :: ImportProvenance
+ }
+ deriving (Eq, Ord, Show, Read)
+
+-- |
+-- Used to track how an import was introduced into scope. This allows us to
+-- handle the one-open-import special case that allows a name conflict to become
+-- a warning rather than being an unresolvable situation.
+--
+data ImportProvenance
+ = FromImplicit
+ | FromExplicit
+ | Local
+ deriving (Eq, Ord, Show, Read)
+
+-- |
-- The imported declarations for a module, including the module's own members.
--
data Imports = Imports
@@ -41,19 +68,19 @@ data Imports = Imports
-- |
-- Local names for types within a module mapped to to their qualified names
--
- importedTypes :: M.Map (Qualified (ProperName 'TypeName)) [(Qualified (ProperName 'TypeName), ModuleName)]
+ importedTypes :: M.Map (Qualified (ProperName 'TypeName)) [ImportRecord (ProperName 'TypeName)]
-- |
-- Local names for data constructors within a module mapped to to their qualified names
--
- , importedDataConstructors :: M.Map (Qualified (ProperName 'ConstructorName)) [(Qualified (ProperName 'ConstructorName), ModuleName)]
+ , importedDataConstructors :: M.Map (Qualified (ProperName 'ConstructorName)) [ImportRecord (ProperName 'ConstructorName)]
-- |
-- Local names for classes within a module mapped to to their qualified names
--
- , importedTypeClasses :: M.Map (Qualified (ProperName 'ClassName)) [(Qualified (ProperName 'ClassName), ModuleName)]
+ , importedTypeClasses :: M.Map (Qualified (ProperName 'ClassName)) [ImportRecord (ProperName 'ClassName)]
-- |
-- Local names for values within a module mapped to to their qualified names
--
- , importedValues :: M.Map (Qualified Ident) [(Qualified Ident, ModuleName)]
+ , importedValues :: M.Map (Qualified Ident) [ImportRecord Ident]
-- |
-- The modules that have been imported into the current scope.
--
@@ -202,16 +229,29 @@ getExports env mn = maybe (throwError . errorMessage $ UnknownModule mn) (return
--
checkImportConflicts
:: forall m a
- . (MonadError MultipleErrors m, Ord a)
- => (a -> String)
- -> [(Qualified a, ModuleName)]
- -> m ()
-checkImportConflicts render xs =
- let byOrig = groupBy ((==) `on` snd) . sortBy (compare `on` snd) $ xs
+ . (Show a, MonadError MultipleErrors m, MonadWriter MultipleErrors m, Ord a)
+ => ModuleName
+ -> (a -> String)
+ -> [ImportRecord a]
+ -> m (ModuleName, ModuleName)
+checkImportConflicts currentModule render xs =
+ let
+ byOrig = sortBy (compare `on` importSourceModule) xs
+ groups = groupBy ((==) `on` importSourceModule) byOrig
+ nonImplicit = filter ((/= FromImplicit) . importProvenance) xs
+ name = render' (importName . head $ xs)
+ conflictModules = map (getQual . importName . head) groups
in
- if length byOrig > 1
- then throwError . errorMessage $ ScopeConflict (render' (fst . head $ xs)) (map (getQual . fst . head) byOrig)
- else return ()
+ if length groups > 1
+ then case nonImplicit of
+ [ImportRecord (Qualified (Just mnNew) _) mnOrig _] -> do
+ let warningModule = if mnNew == currentModule then Nothing else Just mnNew
+ tell . errorMessage $ ScopeShadowing name warningModule $ delete mnNew conflictModules
+ return (mnNew, mnOrig)
+ _ -> throwError . errorMessage $ ScopeConflict name conflictModules
+ else
+ let ImportRecord (Qualified (Just mnNew) _) mnOrig _ = head byOrig
+ in return (mnNew, mnOrig)
where
getQual :: Qualified a -> ModuleName
getQual (Qualified (Just mn) _) = mn
diff --git a/src/Language/PureScript/Sugar/Names/Exports.hs b/src/Language/PureScript/Sugar/Names/Exports.hs
index 6b1e68e..84776cd 100644
--- a/src/Language/PureScript/Sugar/Names/Exports.hs
+++ b/src/Language/PureScript/Sugar/Names/Exports.hs
@@ -110,17 +110,17 @@ resolveExports env mn imps exps refs =
-- Extracts a list of values for a module based on a lookup table. If the
-- boolean is true the values are filtered by the qualification
extract
- :: (Ord a)
+ :: (Show a, Ord a)
=> Bool
-> ModuleName
-> (a -> String)
- -> M.Map (Qualified a) [(Qualified a, ModuleName)]
+ -> M.Map (Qualified a) [ImportRecord a]
-> m [Qualified a]
- extract useQual name render = fmap (map (fst . head . snd)) . go . M.toList
+ extract useQual name render = fmap (map (importName . head . snd)) . go . M.toList
where
go = filterM $ \(name', options) -> do
- let isMatch = if useQual then eqQual name name' else any (eqQual name . fst) options
- when (isMatch && length options > 1) $ checkImportConflicts render options
+ let isMatch = if useQual then eqQual name name' else any (eqQual name . importName) options
+ when (isMatch && length options > 1) $ void $ checkImportConflicts mn render options
return isMatch
-- Check whether a module name refers to a "pseudo module" that came into
diff --git a/src/Language/PureScript/Sugar/Names/Imports.hs b/src/Language/PureScript/Sugar/Names/Imports.hs
index 886c8fc..c0e3276 100644
--- a/src/Language/PureScript/Sugar/Names/Imports.hs
+++ b/src/Language/PureScript/Sugar/Names/Imports.hs
@@ -99,7 +99,8 @@ resolveImports env (Module ss coms currentModule decls exps) =
return ()
- let scope = M.insert currentModule [(Nothing, Implicit, Nothing)] imports
+ let imports' = M.map (map (\(ss', dt, mmn) -> (ss', Just dt, mmn))) imports
+ scope = M.insert currentModule [(Nothing, Nothing, Nothing)] imports'
resolved <- foldM (resolveModuleImport env) nullImports (M.toList scope)
return (Module ss coms currentModule decls' exps, resolved)
@@ -162,11 +163,13 @@ resolveModuleImport
. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
=> Env
-> Imports
- -> (ModuleName, [(Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)])
+ -> (ModuleName, [(Maybe SourceSpan, Maybe ImportDeclarationType, Maybe ModuleName)])
-> m Imports
resolveModuleImport env ie (mn, imps) = foldM go ie imps
where
- go :: Imports -> (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName) -> m Imports
+ go :: Imports
+ -> (Maybe SourceSpan, Maybe ImportDeclarationType, Maybe ModuleName)
+ -> m Imports
go ie' (pos, typ, impQual) = do
modExports <- positioned $ maybe (throwError . errorMessage $ UnknownModule mn) (return . envModuleExports) $ mn `M.lookup` env
let virtualModules = importedVirtualModules ie'
@@ -189,15 +192,16 @@ resolveImport
-> Exports
-> Imports
-> Maybe ModuleName
- -> ImportDeclarationType
+ -> Maybe ImportDeclarationType
-> m Imports
resolveImport importModule exps imps impQual = resolveByType
where
- resolveByType :: ImportDeclarationType -> m Imports
- resolveByType Implicit = importAll importExplicit
- resolveByType (Explicit refs) = checkRefs False refs >> foldM importExplicit imps refs
- resolveByType (Hiding refs) = do
+ resolveByType :: Maybe ImportDeclarationType -> m Imports
+ resolveByType Nothing = importAll (importRef Local)
+ resolveByType (Just Implicit) = importAll (importRef FromImplicit)
+ resolveByType (Just (Explicit refs)) = checkRefs False refs >> foldM (importRef FromExplicit) imps refs
+ resolveByType (Just (Hiding refs)) = do
imps' <- checkRefs True refs >> importAll (importNonHidden refs)
let isEmptyImport
= M.null (importedTypes imps')
@@ -246,7 +250,7 @@ resolveImport importModule exps imps impQual = resolveByType
importNonHidden :: [DeclarationRef] -> Imports -> DeclarationRef -> m Imports
importNonHidden hidden m ref | isHidden ref = return m
- | otherwise = importExplicit m ref
+ | otherwise = importRef FromImplicit m ref
where
-- TODO: rework this to be not confusing
isHidden :: DeclarationRef -> Bool
@@ -268,27 +272,26 @@ resolveImport importModule exps imps impQual = resolveByType
imp'' <- foldM (\m (name, _) -> importer m (ValueRef name)) imp' (exportedValues exps)
foldM (\m (name, _) -> importer m (TypeClassRef name)) imp'' (exportedTypeClasses exps)
- -- Import something explicitly
- importExplicit :: Imports -> DeclarationRef -> m Imports
- importExplicit imp (PositionedDeclarationRef pos _ r) =
- warnAndRethrowWithPosition pos $ importExplicit imp r
- importExplicit imp (ValueRef name) = do
- let values' = updateImports (importedValues imp) (exportedValues exps) name
+ importRef :: ImportProvenance -> Imports -> DeclarationRef -> m Imports
+ importRef prov imp (PositionedDeclarationRef pos _ r) =
+ warnAndRethrowWithPosition pos $ importRef prov imp r
+ importRef prov imp (ValueRef name) = do
+ let values' = updateImports (importedValues imp) (exportedValues exps) name prov
return $ imp { importedValues = values' }
- importExplicit imp (TypeRef name dctors) = do
- let types' = updateImports (importedTypes imp) (first fst `map` exportedTypes exps) name
+ importRef prov imp (TypeRef name dctors) = do
+ let types' = updateImports (importedTypes imp) (first fst `map` exportedTypes exps) name prov
let exportedDctors :: [(ProperName 'ConstructorName, ModuleName)]
exportedDctors = allExportedDataConstructors name
dctorNames :: [ProperName 'ConstructorName]
dctorNames = fst `map` exportedDctors
maybe (return ()) (traverse_ $ checkDctorExists name dctorNames) dctors
when (null dctorNames && isNothing dctors) . tell . errorMessage $ MisleadingEmptyTypeImport importModule name
- let dctors' = foldl (\m -> updateImports m exportedDctors) (importedDataConstructors imp) (fromMaybe dctorNames dctors)
+ let dctors' = foldl (\m d -> updateImports m exportedDctors d prov) (importedDataConstructors imp) (fromMaybe dctorNames dctors)
return $ imp { importedTypes = types', importedDataConstructors = dctors' }
- importExplicit imp (TypeClassRef name) = do
- let typeClasses' = updateImports (importedTypeClasses imp) (exportedTypeClasses exps) name
+ importRef prov imp (TypeClassRef name) = do
+ let typeClasses' = updateImports (importedTypeClasses imp) (exportedTypeClasses exps) name prov
return $ imp { importedTypeClasses = typeClasses' }
- importExplicit _ _ = internalError "Invalid argument to importExplicit"
+ importRef _ _ _ = internalError "Invalid argument to importRef"
-- Find all exported data constructors for a given type
allExportedDataConstructors :: ProperName 'TypeName -> [(ProperName 'ConstructorName, ModuleName)]
@@ -300,11 +303,17 @@ resolveImport importModule exps imps impQual = resolveByType
-- Add something to an import resolution list
updateImports
:: (Ord a)
- => M.Map (Qualified a) [(Qualified a, ModuleName)]
+ => M.Map (Qualified a) [ImportRecord a]
-> [(a, ModuleName)]
-> a
- -> M.Map (Qualified a) [(Qualified a, ModuleName)]
- updateImports imps' exps' name =
- let mnOrig = fromMaybe (internalError "Invalid state in updateImports") (name `lookup` exps')
- currNames = fromMaybe [] (M.lookup (Qualified impQual name) imps')
- in M.insert (Qualified impQual name) ((Qualified (Just importModule) name, mnOrig) : currNames) imps'
+ -> ImportProvenance
+ -> M.Map (Qualified a) [ImportRecord a]
+ updateImports imps' exps' name prov =
+ let
+ mnOrig = fromMaybe (internalError "Invalid state in updateImports") (name `lookup` exps')
+ rec = ImportRecord (Qualified (Just importModule) name) mnOrig prov
+ in
+ M.alter
+ (\currNames -> Just $ rec : fromMaybe [] currNames)
+ (Qualified impQual name)
+ imps'
diff --git a/src/Language/PureScript/Sugar/ObjectWildcards.hs b/src/Language/PureScript/Sugar/ObjectWildcards.hs
index 136e892..2e84f08 100644
--- a/src/Language/PureScript/Sugar/ObjectWildcards.hs
+++ b/src/Language/PureScript/Sugar/ObjectWildcards.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Language.PureScript.Sugar.ObjectWildcards (
@@ -8,12 +9,11 @@ module Language.PureScript.Sugar.ObjectWildcards (
import Prelude ()
import Prelude.Compat
-import Control.Arrow (second)
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.Supply.Class
import Data.List (partition)
-import Data.Maybe (isJust, fromJust, catMaybes)
+import Data.Maybe (catMaybes)
import Language.PureScript.AST
import Language.PureScript.Errors
@@ -24,30 +24,51 @@ desugarObjectConstructors (Module ss coms mn ds exts) = Module ss coms mn <$> ma
where
desugarDecl :: Declaration -> m Declaration
- (desugarDecl, _, _) = everywhereOnValuesM return desugarExpr return
+ desugarDecl (PositionedDeclaration pos com d) = rethrowWithPosition pos $ PositionedDeclaration pos com <$> desugarDecl d
+ desugarDecl other = f other
+ where
+ (f, _, _) = everywhereOnValuesTopDownM return desugarExpr return
desugarExpr :: Expr -> m Expr
- desugarExpr (ObjectConstructor ps) = wrapLambda ObjectLiteral ps
- desugarExpr (ObjectUpdater (Just obj) ps) = wrapLambda (ObjectUpdate obj) ps
- desugarExpr (ObjectUpdater Nothing ps) = do
+ desugarExpr AnonymousArgument = throwError . errorMessage $ IncorrectAnonymousArgument
+ desugarExpr (Parens b)
+ | b' <- stripPositionInfo b
+ , BinaryNoParens op val u <- b'
+ , isAnonymousArgument u = return $ OperatorSection op (Left val)
+ | b' <- stripPositionInfo b
+ , BinaryNoParens op u val <- b'
+ , isAnonymousArgument u = return $ OperatorSection op (Right val)
+ desugarExpr (ObjectLiteral ps) = wrapLambda ObjectLiteral ps
+ desugarExpr (ObjectUpdate u ps) | isAnonymousArgument u = do
obj <- freshIdent'
Abs (Left obj) <$> wrapLambda (ObjectUpdate (Var (Qualified Nothing obj))) ps
- desugarExpr (ObjectGetter prop) = do
+ desugarExpr (ObjectUpdate obj ps) = wrapLambda (ObjectUpdate obj) ps
+ desugarExpr (Accessor prop u) | isAnonymousArgument u = do
arg <- freshIdent'
return $ Abs (Left arg) (Accessor prop (Var (Qualified Nothing arg)))
desugarExpr e = return e
- wrapLambda :: ([(String, Expr)] -> Expr) -> [(String, Maybe Expr)] -> m Expr
+ wrapLambda :: ([(String, Expr)] -> Expr) -> [(String, Expr)] -> m Expr
wrapLambda mkVal ps =
- let (props, args) = partition (isJust . snd) ps
+ let (args, props) = partition (isAnonymousArgument . snd) ps
in if null args
- then return . mkVal $ second fromJust `map` props
+ then return $ mkVal props
else do
(args', ps') <- unzip <$> mapM mkProp ps
return $ foldr (Abs . Left) (mkVal ps') (catMaybes args')
- mkProp :: (String, Maybe Expr) -> m (Maybe Ident, (String, Expr))
- mkProp (name, Just e) = return (Nothing, (name, e))
- mkProp (name, Nothing) = do
- arg <- freshIdent'
- return (Just arg, (name, Var (Qualified Nothing arg)))
+ stripPositionInfo :: Expr -> Expr
+ stripPositionInfo (PositionedValue _ _ e) = stripPositionInfo e
+ stripPositionInfo e = e
+
+ isAnonymousArgument :: Expr -> Bool
+ isAnonymousArgument AnonymousArgument = True
+ isAnonymousArgument (PositionedValue _ _ e) = isAnonymousArgument e
+ isAnonymousArgument _ = False
+
+ mkProp :: (String, Expr) -> m (Maybe Ident, (String, Expr))
+ mkProp (name, e)
+ | isAnonymousArgument e = do
+ arg <- freshIdent'
+ return (Just arg, (name, Var (Qualified Nothing arg)))
+ | otherwise = return (Nothing, (name, e))
diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs
index 4d401fa..4b09c2c 100644
--- a/src/Language/PureScript/Sugar/Operators.hs
+++ b/src/Language/PureScript/Sugar/Operators.hs
@@ -20,51 +20,92 @@ module Language.PureScript.Sugar.Operators (
import Prelude ()
import Prelude.Compat
-import Language.PureScript.Crash
import Language.PureScript.AST
+import Language.PureScript.Crash
import Language.PureScript.Errors
-import Language.PureScript.Names
import Language.PureScript.Externs
+import Language.PureScript.Names
+import Language.PureScript.Sugar.Operators.Binders
+import Language.PureScript.Sugar.Operators.Expr
+import Language.PureScript.Traversals (defS)
-import Control.Monad.State
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.Supply.Class
import Data.Function (on)
-import Data.Functor.Identity
import Data.List (groupBy, sortBy)
-import Data.Maybe (mapMaybe, fromMaybe)
+import Data.Maybe (mapMaybe)
import qualified Data.Map as M
-import qualified Text.Parsec as P
-import qualified Text.Parsec.Pos as P
-import qualified Text.Parsec.Expr as P
-
import qualified Language.PureScript.Constants as C
+-- TODO: in 0.9 operators names can have their own type rather than being in a sum with `Ident`, and `AliasName` no longer needs to be optional
+
+-- |
+-- An operator associated with its declaration position, fixity, and the name
+-- of the function or data constructor it is an alias for.
+--
+type FixityRecord = (Qualified Ident, SourceSpan, Fixity, Maybe AliasName)
+
+-- |
+-- An operator can be an alias for a function or a data constructor.
+--
+type AliasName = Either (Qualified Ident) (Qualified (ProperName 'ConstructorName))
+
-- |
-- Remove explicit parentheses and reorder binary operator applications
--
-rebracket :: (Applicative m, MonadError MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module]
+rebracket
+ :: forall m
+ . (Applicative m, MonadError MultipleErrors m)
+ => [ExternsFile]
+ -> [Module]
+ -> m [Module]
rebracket externs ms = do
let fixities = concatMap externsFixities externs ++ concatMap collectFixities ms
ensureNoDuplicates $ map (\(i, pos, _, _) -> (i, pos)) fixities
let opTable = customOperatorTable $ map (\(i, _, f, _) -> (i, f)) fixities
ms' <- traverse (rebracketModule opTable) ms
let aliased = M.fromList (mapMaybe makeLookupEntry fixities)
- return $ renameAliasedOperators aliased `map` ms'
+ mapM (renameAliasedOperators aliased) ms'
where
- makeLookupEntry :: (Qualified Ident, SourceSpan, Fixity, Maybe (Qualified Ident)) -> Maybe (Qualified Ident, Qualified Ident)
+ makeLookupEntry :: FixityRecord -> Maybe (Qualified Ident, AliasName)
makeLookupEntry (qname, _, _, alias) = (qname, ) <$> alias
- renameAliasedOperators :: M.Map (Qualified Ident) (Qualified Ident) -> Module -> Module
- renameAliasedOperators aliased (Module ss coms mn ds exts) = Module ss coms mn (map f' ds) exts
+ renameAliasedOperators :: M.Map (Qualified Ident) AliasName -> Module -> m Module
+ renameAliasedOperators aliased (Module ss coms mn ds exts) =
+ Module ss coms mn <$> mapM f' ds <*> pure exts
where
- (f', _, _) = everywhereOnValues id go id
- go (Var name) = Var $ fromMaybe name (name `M.lookup` aliased)
- go other = other
+ (f', _, _, _, _) = everywhereWithContextOnValuesM Nothing goDecl goExpr goBinder defS defS
+
+ goDecl :: Maybe SourceSpan -> Declaration -> m (Maybe SourceSpan, Declaration)
+ goDecl _ d@(PositionedDeclaration pos _ _) = return (Just pos, d)
+ goDecl pos other = return (pos, other)
+
+ goExpr :: Maybe SourceSpan -> Expr -> m (Maybe SourceSpan, Expr)
+ goExpr _ e@(PositionedValue pos _ _) = return (Just pos, e)
+ goExpr pos (Var name) = return (pos, case name `M.lookup` aliased of
+ Just (Left alias) -> Var alias
+ Just (Right alias) -> Constructor alias
+ Nothing -> Var name)
+ goExpr pos other = return (pos, other)
+
+ goBinder :: Maybe SourceSpan -> Binder -> m (Maybe SourceSpan, Binder)
+ goBinder _ b@(PositionedBinder pos _ _) = return (Just pos, b)
+ goBinder pos (BinaryNoParensBinder (OpBinder name) lhs rhs) = case name `M.lookup` aliased of
+ Just (Left alias) ->
+ maybe id rethrowWithPosition pos $
+ throwError . errorMessage $ InvalidOperatorInBinder (disqualify name) (disqualify alias)
+ Just (Right alias) ->
+ return (pos, ConstructorBinder alias [lhs, rhs])
+ Nothing ->
+ maybe id rethrowWithPosition pos $
+ throwError . errorMessage $ UnknownValue name
+ goBinder _ (BinaryNoParensBinder _ _ _) =
+ internalError "BinaryNoParensBinder has no OpBinder"
+ goBinder pos other = return (pos, other)
removeSignedLiterals :: Module -> Module
removeSignedLiterals (Module ss coms mn ds exts) = Module ss coms mn (map f' ds) exts
@@ -74,35 +115,46 @@ removeSignedLiterals (Module ss coms mn ds exts) = Module ss coms mn (map f' ds)
go (UnaryMinus val) = App (Var (Qualified Nothing (Ident C.negate))) val
go other = other
-rebracketModule :: (Applicative m, MonadError MultipleErrors m) => [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]] -> Module -> m Module
+rebracketModule
+ :: (Applicative m, MonadError MultipleErrors m)
+ => [[(Qualified Ident, Associativity)]]
+ -> Module
+ -> m Module
rebracketModule opTable (Module ss coms mn ds exts) =
- let (f, _, _) = everywhereOnValuesTopDownM return (matchOperators opTable) return
+ let (f, _, _) = everywhereOnValuesTopDownM return (matchExprOperators opTable) (matchBinderOperators opTable)
in Module ss coms mn <$> (map removeParens <$> parU ds f) <*> pure exts
removeParens :: Declaration -> Declaration
removeParens =
- let (f, _, _) = everywhereOnValues id go id
+ let (f, _, _) = everywhereOnValues id goExpr goBinder
in f
where
- go (Parens val) = val
- go val = val
-
-externsFixities :: ExternsFile -> [(Qualified Ident, SourceSpan, Fixity, Maybe (Qualified Ident))]
+ goExpr (Parens val) = val
+ goExpr val = val
+ goBinder (ParensInBinder b) = b
+ goBinder b = b
+
+externsFixities
+ :: ExternsFile
+ -> [FixityRecord]
externsFixities ExternsFile{..} =
[ (Qualified (Just efModuleName) (Op op), internalModuleSourceSpan "", Fixity assoc prec, alias)
| ExternsFixity assoc prec op alias <- efFixities
]
-collectFixities :: Module -> [(Qualified Ident, SourceSpan, Fixity, Maybe (Qualified Ident))]
+collectFixities :: Module -> [FixityRecord]
collectFixities (Module _ _ moduleName ds _) = concatMap collect ds
where
- collect :: Declaration -> [(Qualified Ident, SourceSpan, Fixity, Maybe (Qualified Ident))]
+ collect :: Declaration -> [FixityRecord]
collect (PositionedDeclaration pos _ (FixityDeclaration fixity name alias)) =
[(Qualified (Just moduleName) (Op name), pos, fixity, alias)]
collect FixityDeclaration{} = internalError "Fixity without srcpos info"
collect _ = []
-ensureNoDuplicates :: (MonadError MultipleErrors m) => [(Qualified Ident, SourceSpan)] -> m ()
+ensureNoDuplicates
+ :: MonadError MultipleErrors m
+ => [(Qualified Ident, SourceSpan)]
+ -> m ()
ensureNoDuplicates m = go $ sortBy (compare `on` fst) m
where
go [] = return ()
@@ -113,63 +165,24 @@ ensureNoDuplicates m = go $ sortBy (compare `on` fst) m
throwError . errorMessage $ MultipleFixities name
go (_ : rest) = go rest
-customOperatorTable :: [(Qualified Ident, Fixity)] -> [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]]
+customOperatorTable
+ :: [(Qualified Ident, Fixity)]
+ -> [[(Qualified Ident, Associativity)]]
customOperatorTable fixities =
let
- applyUserOp ident t1 = App (App (Var ident) t1)
- userOps = map (\(name, Fixity a p) -> (name, applyUserOp name, p, a)) fixities
- sorted = sortBy (flip compare `on` (\(_, _, p, _) -> p)) userOps
- groups = groupBy ((==) `on` (\(_, _, p, _) -> p)) sorted
+ userOps = map (\(name, Fixity a p) -> (name, p, a)) fixities
+ sorted = sortBy (flip compare `on` (\(_, p, _) -> p)) userOps
+ groups = groupBy ((==) `on` (\(_, p, _) -> p)) sorted
in
- map (map (\(name, f, _, a) -> (name, f, a))) groups
-
-type Chain = [Either Expr Expr]
-
-matchOperators :: forall m. (MonadError MultipleErrors m) => [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]] -> Expr -> m Expr
-matchOperators ops = parseChains
- where
- parseChains :: Expr -> m Expr
- parseChains b@BinaryNoParens{} = bracketChain (extendChain b)
- parseChains other = return other
- extendChain :: Expr -> Chain
- extendChain (BinaryNoParens op l r) = Left l : Right op : extendChain r
- extendChain other = [Left other]
- bracketChain :: Chain -> m Expr
- bracketChain = either (\_ -> internalError "matchOperators: cannot reorder operators") return . P.parse (P.buildExpressionParser opTable parseValue <* P.eof) "operator expression"
- opTable = [P.Infix (P.try (parseTicks >>= \op -> return (\t1 t2 -> App (App op t1) t2))) P.AssocLeft]
- : map (map (\(name, f, a) -> P.Infix (P.try (matchOp name) >> return f) (toAssoc a))) ops
- ++ [[ P.Infix (P.try (parseOp >>= \ident -> return (\t1 t2 -> App (App (Var ident) t1) t2))) P.AssocLeft ]]
-
-toAssoc :: Associativity -> P.Assoc
-toAssoc Infixl = P.AssocLeft
-toAssoc Infixr = P.AssocRight
-toAssoc Infix = P.AssocNone
-
-token :: (P.Stream s Identity t) => (t -> Maybe a) -> P.Parsec s u a
-token = P.token (const "") (const (P.initialPos ""))
-
-parseValue :: P.Parsec Chain () Expr
-parseValue = token (either Just (const Nothing)) P.<?> "expression"
-
-parseOp :: P.Parsec Chain () (Qualified Ident)
-parseOp = token (either (const Nothing) fromOp) P.<?> "operator"
- where
- fromOp (Var q@(Qualified _ (Op _))) = Just q
- fromOp _ = Nothing
-
-parseTicks :: P.Parsec Chain () Expr
-parseTicks = token (either (const Nothing) fromOther) P.<?> "infix function"
- where
- fromOther (Var (Qualified _ (Op _))) = Nothing
- fromOther v = Just v
-
-matchOp :: Qualified Ident -> P.Parsec Chain () ()
-matchOp op = do
- ident <- parseOp
- guard $ ident == op
-
-desugarOperatorSections :: forall m. (Applicative m, MonadSupply m, MonadError MultipleErrors m) => Module -> m Module
-desugarOperatorSections (Module ss coms mn ds exts) = Module ss coms mn <$> traverse goDecl ds <*> pure exts
+ map (map (\(name, _, a) -> (name, a))) groups
+
+desugarOperatorSections
+ :: forall m
+ . (Applicative m, MonadSupply m, MonadError MultipleErrors m)
+ => Module
+ -> m Module
+desugarOperatorSections (Module ss coms mn ds exts) =
+ Module ss coms mn <$> traverse goDecl ds <*> pure exts
where
goDecl :: Declaration -> m Declaration
diff --git a/src/Language/PureScript/Sugar/Operators/Binders.hs b/src/Language/PureScript/Sugar/Operators/Binders.hs
new file mode 100644
index 0000000..fc6fbf7
--- /dev/null
+++ b/src/Language/PureScript/Sugar/Operators/Binders.hs
@@ -0,0 +1,43 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Language.PureScript.Sugar.Operators.Binders where
+
+import Prelude ()
+import Prelude.Compat
+
+import Control.Monad.Error.Class (MonadError(..))
+
+import qualified Text.Parsec as P
+import qualified Text.Parsec.Expr as P
+
+import Language.PureScript.Crash
+import Language.PureScript.AST
+import Language.PureScript.Errors
+import Language.PureScript.Names
+import Language.PureScript.Sugar.Operators.Common
+
+matchBinderOperators
+ :: forall m
+ . MonadError MultipleErrors m
+ => [[(Qualified Ident, Associativity)]]
+ -> Binder
+ -> m Binder
+matchBinderOperators ops = parseChains
+ where
+ parseChains :: Binder -> m Binder
+ parseChains b@BinaryNoParensBinder{} = bracketChain (extendChain b)
+ parseChains other = return other
+ extendChain :: Binder -> Chain Binder
+ extendChain (BinaryNoParensBinder op l r) = Left l : Right op : extendChain r
+ extendChain other = [Left other]
+ bracketChain :: Chain Binder -> m Binder
+ bracketChain =
+ either
+ (\_ -> internalError "matchBinderOperators: cannot reorder operators")
+ return
+ . P.parse opParser "operator expression"
+ opParser = P.buildExpressionParser (opTable ops fromOp reapply) parseValue <* P.eof
+ fromOp (OpBinder q@(Qualified _ (Op _))) = Just q
+ fromOp _ = Nothing
+ reapply = BinaryNoParensBinder . OpBinder
diff --git a/src/Language/PureScript/Sugar/Operators/Common.hs b/src/Language/PureScript/Sugar/Operators/Common.hs
new file mode 100644
index 0000000..a447ab6
--- /dev/null
+++ b/src/Language/PureScript/Sugar/Operators/Common.hs
@@ -0,0 +1,53 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Language.PureScript.Sugar.Operators.Common where
+
+import Prelude ()
+import Prelude.Compat
+
+import Control.Monad.State
+
+import Data.Functor.Identity
+
+import qualified Text.Parsec as P
+import qualified Text.Parsec.Pos as P
+import qualified Text.Parsec.Expr as P
+
+import Language.PureScript.AST
+import Language.PureScript.Names
+
+type Chain a = [Either a a]
+
+toAssoc :: Associativity -> P.Assoc
+toAssoc Infixl = P.AssocLeft
+toAssoc Infixr = P.AssocRight
+toAssoc Infix = P.AssocNone
+
+token :: (P.Stream s Identity t) => (t -> Maybe a) -> P.Parsec s u a
+token = P.token (const "") (const (P.initialPos ""))
+
+parseValue :: P.Parsec (Chain a) () a
+parseValue = token (either Just (const Nothing)) P.<?> "expression"
+
+parseOp
+ :: (a -> (Maybe (Qualified Ident)))
+ -> P.Parsec (Chain a) () (Qualified Ident)
+parseOp fromOp = token (either (const Nothing) fromOp) P.<?> "operator"
+
+matchOp
+ :: (a -> (Maybe (Qualified Ident)))
+ -> Qualified Ident
+ -> P.Parsec (Chain a) () ()
+matchOp fromOp op = do
+ ident <- parseOp fromOp
+ guard $ ident == op
+
+opTable
+ :: [[(Qualified Ident, Associativity)]]
+ -> (a -> Maybe (Qualified Ident))
+ -> (Qualified Ident -> a -> a -> a)
+ -> [[P.Operator (Chain a) () Identity a]]
+opTable ops fromOp reapply =
+ map (map (\(name, a) -> P.Infix (P.try (matchOp fromOp name) >> return (reapply name)) (toAssoc a))) ops
+ ++ [[ P.Infix (P.try (parseOp fromOp >>= \ident -> return (reapply ident))) P.AssocLeft ]]
diff --git a/src/Language/PureScript/Sugar/Operators/Expr.hs b/src/Language/PureScript/Sugar/Operators/Expr.hs
new file mode 100644
index 0000000..7ffafdf
--- /dev/null
+++ b/src/Language/PureScript/Sugar/Operators/Expr.hs
@@ -0,0 +1,52 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Language.PureScript.Sugar.Operators.Expr where
+
+import Prelude ()
+import Prelude.Compat
+
+import Control.Monad.Error.Class (MonadError(..))
+
+import qualified Text.Parsec as P
+import qualified Text.Parsec.Expr as P
+
+import Language.PureScript.Crash
+import Language.PureScript.AST
+import Language.PureScript.Errors
+import Language.PureScript.Names
+import Language.PureScript.Sugar.Operators.Common
+
+matchExprOperators
+ :: forall m
+ . MonadError MultipleErrors m
+ => [[(Qualified Ident, Associativity)]]
+ -> Expr
+ -> m Expr
+matchExprOperators ops = parseChains
+ where
+ parseChains :: Expr -> m Expr
+ parseChains b@BinaryNoParens{} = bracketChain (extendChain b)
+ parseChains other = return other
+ extendChain :: Expr -> Chain Expr
+ extendChain (BinaryNoParens op l r) = Left l : Right op : extendChain r
+ extendChain other = [Left other]
+ bracketChain :: Chain Expr -> m Expr
+ bracketChain =
+ either
+ (\_ -> internalError "matchExprOperators: cannot reorder operators")
+ return
+ . P.parse opParser "operator expression"
+ opParser = P.buildExpressionParser opTable' parseValue <* P.eof
+ opTable' =
+ [ P.Infix (P.try (parseTicks >>= \op -> return (\t1 t2 -> App (App op t1) t2))) P.AssocLeft ]
+ : opTable ops fromOp reapply
+ fromOp (Var q@(Qualified _ (Op _))) = Just q
+ fromOp _ = Nothing
+ reapply op t1 t2 = App (App (Var op) t1) t2
+
+parseTicks :: P.Parsec (Chain Expr) () Expr
+parseTicks = token (either (const Nothing) fromOther) P.<?> "infix function"
+ where
+ fromOther (Var (Qualified _ (Op _))) = Nothing
+ fromOther v = Just v
diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs
index d011a35..6a9344c 100644
--- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs
+++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs
@@ -50,6 +50,14 @@ deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@[ty] Derived
, Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor ty
, mn == fromMaybe mn mn'
= TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveGeneric mn ds tyCon args
+ | className == Qualified (Just (ModuleName [ ProperName "Prelude" ])) (ProperName "Eq")
+ , Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty
+ , mn == fromMaybe mn mn'
+ = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveEq mn ds tyCon
+ | className == Qualified (Just (ModuleName [ ProperName "Prelude" ])) (ProperName "Ord")
+ , Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty
+ , mn == fromMaybe mn mn'
+ = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveOrd mn ds tyCon
deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance)
= throwError . errorMessage $ CannotDerive className tys
deriveInstance mn ds (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> deriveInstance mn ds d
@@ -74,21 +82,279 @@ typesProxy :: ModuleName
typesProxy = ModuleName [ ProperName "Type", ProperName "Proxy" ]
deriveGeneric
- :: (Functor m, MonadError MultipleErrors m, MonadSupply m)
+ :: forall m. (Functor m, MonadError MultipleErrors m, MonadSupply m)
=> ModuleName
-> [Declaration]
-> ProperName 'TypeName
-> [Type]
-> m [Declaration]
-deriveGeneric mn ds tyConNm args = do
+deriveGeneric mn ds tyConNm dargs = do
tyCon <- findTypeDecl tyConNm ds
- toSpine <- mkSpineFunction mn tyCon
- fromSpine <- mkFromSpineFunction mn tyCon
- let toSignature = mkSignatureFunction mn tyCon args
+ toSpine <- mkSpineFunction tyCon
+ fromSpine <- mkFromSpineFunction tyCon
+ let toSignature = mkSignatureFunction tyCon dargs
return [ ValueDeclaration (Ident C.toSpine) Public [] (Right toSpine)
, ValueDeclaration (Ident C.fromSpine) Public [] (Right fromSpine)
, ValueDeclaration (Ident C.toSignature) Public [] (Right toSignature)
]
+ where
+ mkSpineFunction :: Declaration -> m Expr
+ mkSpineFunction (DataDeclaration _ _ _ args) = do
+ x <- freshIdent'
+ lamCase x <$> mapM mkCtorClause args
+ where
+ prodConstructor :: Expr -> Expr
+ prodConstructor = App (Constructor (Qualified (Just dataGeneric) (ProperName "SProd")))
+
+ recordConstructor :: Expr -> Expr
+ recordConstructor = App (Constructor (Qualified (Just dataGeneric) (ProperName "SRecord")))
+
+ mkCtorClause :: (ProperName 'ConstructorName, [Type]) -> m CaseAlternative
+ mkCtorClause (ctorName, tys) = do
+ idents <- replicateM (length tys) freshIdent'
+ return $ CaseAlternative [ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)] (Right (caseResult idents))
+ where
+ caseResult idents =
+ App (prodConstructor (StringLiteral . showQualified runProperName $ Qualified (Just mn) ctorName))
+ . ArrayLiteral
+ $ zipWith toSpineFun (map (Var . Qualified Nothing) idents) tys
+
+ toSpineFun :: Expr -> Type -> Expr
+ toSpineFun i r | Just rec <- objectType r =
+ lamNull . recordConstructor . ArrayLiteral .
+ map (\(str,typ) -> ObjectLiteral [("recLabel", StringLiteral str), ("recValue", toSpineFun (Accessor str i) typ)])
+ $ decomposeRec rec
+ toSpineFun i _ = lamNull $ App (mkGenVar (Ident C.toSpine)) i
+ mkSpineFunction (PositionedDeclaration _ _ d) = mkSpineFunction d
+ mkSpineFunction _ = internalError "mkSpineFunction: expected DataDeclaration"
+
+ mkSignatureFunction :: Declaration -> [Type] -> Expr
+ mkSignatureFunction (DataDeclaration _ name tyArgs args) classArgs = lamNull . mkSigProd $ map mkProdClause args
+ where
+ mkSigProd :: [Expr] -> Expr
+ mkSigProd = App (App (Constructor (Qualified (Just dataGeneric) (ProperName "SigProd")))
+ (StringLiteral (showQualified runProperName (Qualified (Just mn) name)))
+ ) . ArrayLiteral
+
+ mkSigRec :: [Expr] -> Expr
+ mkSigRec = App (Constructor (Qualified (Just dataGeneric) (ProperName "SigRecord"))) . ArrayLiteral
+
+ proxy :: Type -> Type
+ proxy = TypeApp (TypeConstructor (Qualified (Just typesProxy) (ProperName "Proxy")))
+
+ mkProdClause :: (ProperName 'ConstructorName, [Type]) -> Expr
+ mkProdClause (ctorName, tys) =
+ ObjectLiteral
+ [ ("sigConstructor", StringLiteral (showQualified runProperName (Qualified (Just mn) ctorName)))
+ , ("sigValues", ArrayLiteral . map (mkProductSignature . instantiate) $ tys)
+ ]
+
+ mkProductSignature :: Type -> Expr
+ mkProductSignature r | Just rec <- objectType r =
+ lamNull . mkSigRec $ [ ObjectLiteral [ ("recLabel", StringLiteral str)
+ , ("recValue", mkProductSignature typ)
+ ]
+ | (str, typ) <- decomposeRec rec
+ ]
+ mkProductSignature typ = lamNull $ App (mkGenVar (Ident C.toSignature))
+ (TypedValue False (mkGenVar (Ident "anyProxy")) (proxy typ))
+ instantiate = replaceAllTypeVars (zipWith (\(arg, _) ty -> (arg, ty)) tyArgs classArgs)
+ mkSignatureFunction (PositionedDeclaration _ _ d) classArgs = mkSignatureFunction d classArgs
+ mkSignatureFunction _ _ = internalError "mkSignatureFunction: expected DataDeclaration"
+
+ mkFromSpineFunction :: Declaration -> m Expr
+ mkFromSpineFunction (DataDeclaration _ _ _ args) = do
+ x <- freshIdent'
+ lamCase x <$> (addCatch <$> mapM mkAlternative args)
+ where
+ mkJust :: Expr -> Expr
+ mkJust = App (Constructor (Qualified (Just dataMaybe) (ProperName "Just")))
+
+ mkNothing :: Expr
+ mkNothing = Constructor (Qualified (Just dataMaybe) (ProperName "Nothing"))
+
+ prodBinder :: [Binder] -> Binder
+ prodBinder = ConstructorBinder (Qualified (Just dataGeneric) (ProperName "SProd"))
+
+ recordBinder :: [Binder] -> Binder
+ recordBinder = ConstructorBinder (Qualified (Just dataGeneric) (ProperName "SRecord"))
+
+ mkAlternative :: (ProperName 'ConstructorName, [Type]) -> m CaseAlternative
+ mkAlternative (ctorName, tys) = do
+ idents <- replicateM (length tys) freshIdent'
+ return $ CaseAlternative [ prodBinder [ StringBinder (showQualified runProperName (Qualified (Just mn) ctorName)), ArrayBinder (map VarBinder idents)]]
+ . Right
+ $ liftApplicative (mkJust $ Constructor (Qualified (Just mn) ctorName))
+ (zipWith fromSpineFun (map (Var . Qualified Nothing) idents) tys)
+
+ addCatch :: [CaseAlternative] -> [CaseAlternative]
+ addCatch = (++ [catchAll])
+ where
+ catchAll = CaseAlternative [NullBinder] (Right mkNothing)
+
+ fromSpineFun :: Expr -> Type -> Expr
+ fromSpineFun e r
+ | Just rec <- objectType r
+ = App (lamCase (Ident "r") [ mkRecCase (decomposeRec rec)
+ , CaseAlternative [NullBinder] (Right mkNothing)
+ ])
+ (App e (mkPrelVar (Ident "unit")))
+ fromSpineFun e _ = App (mkGenVar (Ident C.fromSpine)) (App e (mkPrelVar (Ident "unit")))
+
+ mkRecCase :: [(String, Type)] -> CaseAlternative
+ mkRecCase rs = CaseAlternative [ recordBinder [ ArrayBinder (map (VarBinder . Ident . fst) rs)
+ ]
+ ]
+ . Right
+ $ liftApplicative (mkRecFun rs) (map (\(x, y) -> fromSpineFun (Accessor "recValue" (mkVar (Ident x))) y) rs)
+
+ mkRecFun :: [(String, Type)] -> Expr
+ mkRecFun xs = mkJust $ foldr lam recLiteral (map (Ident . fst) xs)
+ where recLiteral = ObjectLiteral $ map (\(s,_) -> (s, mkVar (Ident s))) xs
+ mkFromSpineFunction (PositionedDeclaration _ _ d) = mkFromSpineFunction d
+ mkFromSpineFunction _ = internalError "mkFromSpineFunction: expected DataDeclaration"
+
+ -- Helpers
+
+ liftApplicative :: Expr -> [Expr] -> Expr
+ liftApplicative = foldl' (\x e -> App (App (mkPrelVar (Ident "apply")) x) e)
+
+ mkPrelVar :: Ident -> Expr
+ mkPrelVar = mkVarMn (Just (ModuleName [ProperName C.prelude]))
+
+ mkGenVar :: Ident -> Expr
+ mkGenVar = mkVarMn (Just (ModuleName [ProperName "Data", ProperName C.generic]))
+
+deriveEq ::
+ forall m. (Functor m, MonadError MultipleErrors m, MonadSupply m)
+ => ModuleName
+ -> [Declaration]
+ -> ProperName 'TypeName
+ -> m [Declaration]
+deriveEq mn ds tyConNm = do
+ tyCon <- findTypeDecl tyConNm ds
+ eqFun <- mkEqFunction tyCon
+ return [ ValueDeclaration (Ident C.eq) Public [] (Right eqFun) ]
+ where
+ mkEqFunction :: Declaration -> m Expr
+ mkEqFunction (DataDeclaration _ _ _ args) = do
+ x <- freshIdent "x"
+ y <- freshIdent "y"
+ lamCase2 x y <$> (addCatch <$> mapM mkCtorClause args)
+ mkEqFunction (PositionedDeclaration _ _ d) = mkEqFunction d
+ mkEqFunction _ = internalError "mkEqFunction: expected DataDeclaration"
+
+ preludeConj :: Expr -> Expr -> Expr
+ preludeConj = App . App (Var (Qualified (Just (ModuleName [ProperName C.prelude])) (Ident C.conj)))
+
+ preludeEq :: Expr -> Expr -> Expr
+ preludeEq = App . App (Var (Qualified (Just (ModuleName [ProperName C.prelude])) (Ident C.eq)))
+
+ addCatch :: [CaseAlternative] -> [CaseAlternative]
+ addCatch xs
+ | length xs /= 1 = xs ++ [catchAll]
+ | otherwise = xs -- Avoid redundant case
+ where
+ catchAll = CaseAlternative [NullBinder, NullBinder] (Right (BooleanLiteral False))
+
+ mkCtorClause :: (ProperName 'ConstructorName, [Type]) -> m CaseAlternative
+ mkCtorClause (ctorName, tys) = do
+ identsL <- replicateM (length tys) (freshIdent "l")
+ identsR <- replicateM (length tys) (freshIdent "r")
+ let tests = zipWith3 toEqTest (map (Var . Qualified Nothing) identsL) (map (Var . Qualified Nothing) identsR) tys
+ return $ CaseAlternative [caseBinder identsL, caseBinder identsR] (Right (conjAll tests))
+ where
+ caseBinder idents = ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)
+
+ conjAll :: [Expr] -> Expr
+ conjAll [] = BooleanLiteral True
+ conjAll xs = foldl1 preludeConj xs
+
+ toEqTest :: Expr -> Expr -> Type -> Expr
+ toEqTest l r ty | Just rec <- objectType ty =
+ conjAll
+ . map (\(str, typ) -> toEqTest (Accessor str l) (Accessor str r) typ)
+ $ decomposeRec rec
+ toEqTest l r _ = preludeEq l r
+
+deriveOrd ::
+ forall m. (Functor m, MonadError MultipleErrors m, MonadSupply m)
+ => ModuleName
+ -> [Declaration]
+ -> ProperName 'TypeName
+ -> m [Declaration]
+deriveOrd mn ds tyConNm = do
+ tyCon <- findTypeDecl tyConNm ds
+ compareFun <- mkCompareFunction tyCon
+ return [ ValueDeclaration (Ident C.compare) Public [] (Right compareFun) ]
+ where
+ mkCompareFunction :: Declaration -> m Expr
+ mkCompareFunction (DataDeclaration _ _ _ args) = do
+ x <- freshIdent "x"
+ y <- freshIdent "y"
+ lamCase2 x y <$> (addCatch . concat <$> mapM mkCtorClauses (splitLast args))
+ mkCompareFunction (PositionedDeclaration _ _ d) = mkCompareFunction d
+ mkCompareFunction _ = internalError "mkCompareFunction: expected DataDeclaration"
+
+ splitLast :: [a] -> [(a, Bool)]
+ splitLast [] = []
+ splitLast [x] = [(x, True)]
+ splitLast (x : xs) = (x, False) : splitLast xs
+
+ addCatch :: [CaseAlternative] -> [CaseAlternative]
+ addCatch xs
+ | null xs = [catchAll] -- No type constructors
+ | otherwise = xs
+ where
+ catchAll = CaseAlternative [NullBinder, NullBinder] (Right (preludeCtor "EQ"))
+
+ preludeCtor :: String -> Expr
+ preludeCtor = Constructor . Qualified (Just (ModuleName [ProperName C.prelude])) . ProperName
+
+ preludeCompare :: Expr -> Expr -> Expr
+ preludeCompare = App . App (Var (Qualified (Just (ModuleName [ProperName C.prelude])) (Ident C.compare)))
+
+ mkCtorClauses :: ((ProperName 'ConstructorName, [Type]), Bool) -> m [CaseAlternative]
+ mkCtorClauses ((ctorName, tys), isLast) = do
+ identsL <- replicateM (length tys) (freshIdent "l")
+ identsR <- replicateM (length tys) (freshIdent "r")
+ let tests = zipWith3 toOrdering (map (Var . Qualified Nothing) identsL) (map (Var . Qualified Nothing) identsR) tys
+ extras | not isLast = [ CaseAlternative [ ConstructorBinder (Qualified (Just mn) ctorName) (replicate (length tys) NullBinder)
+ , NullBinder
+ ]
+ (Right (preludeCtor "LT"))
+ , CaseAlternative [ NullBinder
+ , ConstructorBinder (Qualified (Just mn) ctorName) (replicate (length tys) NullBinder)
+ ]
+ (Right (preludeCtor "GT"))
+ ]
+ | otherwise = []
+ return $ CaseAlternative [ caseBinder identsL
+ , caseBinder identsR
+ ]
+ (Right (appendAll tests))
+ : extras
+
+ where
+ caseBinder idents = ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)
+
+ appendAll :: [Expr] -> Expr
+ appendAll [] = preludeCtor "EQ"
+ appendAll [x] = x
+ appendAll (x : xs) = Case [x] [ CaseAlternative [ ConstructorBinder (Qualified (Just (ModuleName [ProperName C.prelude])) (ProperName "LT")) [] ]
+ (Right (preludeCtor "LT"))
+ , CaseAlternative [ ConstructorBinder (Qualified (Just (ModuleName [ProperName C.prelude])) (ProperName "GT")) [] ]
+ (Right (preludeCtor "GT"))
+ , CaseAlternative [ NullBinder ]
+ (Right (appendAll xs))
+ ]
+
+ toOrdering :: Expr -> Expr -> Type -> Expr
+ toOrdering l r ty | Just rec <- objectType ty =
+ appendAll
+ . map (\(str, typ) -> toOrdering (Accessor str l) (Accessor str r) typ)
+ $ decomposeRec rec
+ toOrdering l r _ = preludeCompare l r
findTypeDecl
:: (Functor m, MonadError MultipleErrors m)
@@ -102,148 +368,29 @@ findTypeDecl tyConNm = maybe (throwError . errorMessage $ CannotFindDerivingType
isTypeDecl (PositionedDeclaration _ _ d) = isTypeDecl d
isTypeDecl _ = False
-mkSpineFunction :: forall m. (Functor m, MonadSupply m) => ModuleName -> Declaration -> m Expr
-mkSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> mapM mkCtorClause args
- where
- prodConstructor :: Expr -> Expr
- prodConstructor = App (Constructor (Qualified (Just dataGeneric) (ProperName "SProd")))
-
- recordConstructor :: Expr -> Expr
- recordConstructor = App (Constructor (Qualified (Just dataGeneric) (ProperName "SRecord")))
-
- mkCtorClause :: (ProperName 'ConstructorName, [Type]) -> m CaseAlternative
- mkCtorClause (ctorName, tys) = do
- idents <- replicateM (length tys) freshIdent'
- return $ CaseAlternative [ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)] (Right (caseResult idents))
- where
- caseResult idents =
- App (prodConstructor (StringLiteral . showQualified runProperName $ Qualified (Just mn) ctorName))
- . ArrayLiteral
- $ zipWith toSpineFun (map (Var . Qualified Nothing) idents) tys
-
- toSpineFun :: Expr -> Type -> Expr
- toSpineFun i r | Just rec <- objectType r =
- lamNull . recordConstructor . ArrayLiteral .
- map (\(str,typ) -> ObjectLiteral [("recLabel", StringLiteral str), ("recValue", toSpineFun (Accessor str i) typ)])
- $ decomposeRec rec
- toSpineFun i _ = lamNull $ App (mkGenVar C.toSpine) i
-mkSpineFunction mn (PositionedDeclaration _ _ d) = mkSpineFunction mn d
-mkSpineFunction _ _ = internalError "mkSpineFunction: expected DataDeclaration"
-
-mkSignatureFunction :: ModuleName -> Declaration -> [Type] -> Expr
-mkSignatureFunction mn (DataDeclaration _ name tyArgs args) classArgs = lamNull . mkSigProd $ map mkProdClause args
- where
- mkSigProd :: [Expr] -> Expr
- mkSigProd = App (App (Constructor (Qualified (Just dataGeneric) (ProperName "SigProd")))
- (StringLiteral (showQualified runProperName (Qualified (Just mn) name)))
- ) . ArrayLiteral
-
- mkSigRec :: [Expr] -> Expr
- mkSigRec = App (Constructor (Qualified (Just dataGeneric) (ProperName "SigRecord"))) . ArrayLiteral
-
- proxy :: Type -> Type
- proxy = TypeApp (TypeConstructor (Qualified (Just typesProxy) (ProperName "Proxy")))
-
- mkProdClause :: (ProperName 'ConstructorName, [Type]) -> Expr
- mkProdClause (ctorName, tys) =
- ObjectLiteral
- [ ("sigConstructor", StringLiteral (showQualified runProperName (Qualified (Just mn) ctorName)))
- , ("sigValues", ArrayLiteral . map (mkProductSignature . instantiate) $ tys)
- ]
-
- mkProductSignature :: Type -> Expr
- mkProductSignature r | Just rec <- objectType r =
- lamNull . mkSigRec $ [ ObjectLiteral [ ("recLabel", StringLiteral str)
- , ("recValue", mkProductSignature typ)
- ]
- | (str, typ) <- decomposeRec rec
- ]
- mkProductSignature typ = lamNull $ App (mkGenVar C.toSignature)
- (TypedValue False (mkGenVar "anyProxy") (proxy typ))
- instantiate = replaceAllTypeVars (zipWith (\(arg, _) ty -> (arg, ty)) tyArgs classArgs)
-mkSignatureFunction mn (PositionedDeclaration _ _ d) classArgs = mkSignatureFunction mn d classArgs
-mkSignatureFunction _ _ _ = internalError "mkSignatureFunction: expected DataDeclaration"
-
-mkFromSpineFunction :: forall m. (Functor m, MonadSupply m) => ModuleName -> Declaration -> m Expr
-mkFromSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> (addCatch <$> mapM mkAlternative args)
- where
- mkJust :: Expr -> Expr
- mkJust = App (Constructor (Qualified (Just dataMaybe) (ProperName "Just")))
-
- mkNothing :: Expr
- mkNothing = Constructor (Qualified (Just dataMaybe) (ProperName "Nothing"))
-
- prodBinder :: [Binder] -> Binder
- prodBinder = ConstructorBinder (Qualified (Just dataGeneric) (ProperName "SProd"))
-
- recordBinder :: [Binder] -> Binder
- recordBinder = ConstructorBinder (Qualified (Just dataGeneric) (ProperName "SRecord"))
-
- mkAlternative :: (ProperName 'ConstructorName, [Type]) -> m CaseAlternative
- mkAlternative (ctorName, tys) = do
- idents <- replicateM (length tys) freshIdent'
- return $ CaseAlternative [ prodBinder [ StringBinder (showQualified runProperName (Qualified (Just mn) ctorName)), ArrayBinder (map VarBinder idents)]]
- . Right
- $ liftApplicative (mkJust $ Constructor (Qualified (Just mn) ctorName))
- (zipWith fromSpineFun (map (Var . Qualified Nothing) idents) tys)
-
- addCatch :: [CaseAlternative] -> [CaseAlternative]
- addCatch = (++ [catchAll])
- where
- catchAll = CaseAlternative [NullBinder] (Right mkNothing)
-
- fromSpineFun e r
- | Just rec <- objectType r
- = App (lamCase "r" [ mkRecCase (decomposeRec rec)
- , CaseAlternative [NullBinder] (Right mkNothing)
- ])
- (App e (mkPrelVar "unit"))
-
- fromSpineFun e _ = App (mkGenVar C.fromSpine) (App e (mkPrelVar "unit"))
-
- mkRecCase rs = CaseAlternative [ recordBinder [ ArrayBinder (map (VarBinder . Ident . fst) rs)
- ]
- ]
- . Right
- $ liftApplicative (mkRecFun rs) (map (\(x, y) -> fromSpineFun (Accessor "recValue" (mkVar x)) y) rs)
-
- mkRecFun :: [(String, Type)] -> Expr
- mkRecFun xs = mkJust $ foldr lam recLiteral (map fst xs)
- where recLiteral = ObjectLiteral $ map (\(s,_) -> (s,mkVar s)) xs
-mkFromSpineFunction mn (PositionedDeclaration _ _ d) = mkFromSpineFunction mn d
-mkFromSpineFunction _ _ = internalError "mkFromSpineFunction: expected DataDeclaration"
-
--- Helpers
-
-objectType :: Type -> Maybe Type
-objectType (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName "Object"))) rec) = Just rec
-objectType _ = Nothing
-
-lam :: String -> Expr -> Expr
-lam s = Abs (Left (Ident s))
+lam :: Ident -> Expr -> Expr
+lam = Abs . Left
lamNull :: Expr -> Expr
-lamNull = lam "$q"
+lamNull = lam (Ident "$q") -- TODO: use GenIdent
-lamCase :: String -> [CaseAlternative] -> Expr
+lamCase :: Ident -> [CaseAlternative] -> Expr
lamCase s = lam s . Case [mkVar s]
-liftApplicative :: Expr -> [Expr] -> Expr
-liftApplicative = foldl' (\x e -> App (App (mkPrelVar "apply") x) e)
+lamCase2 :: Ident -> Ident -> [CaseAlternative] -> Expr
+lamCase2 s t = lam s . lam t . Case [mkVar s, mkVar t]
-mkVarMn :: Maybe ModuleName -> String -> Expr
-mkVarMn mn s = Var (Qualified mn (Ident s))
+mkVarMn :: Maybe ModuleName -> Ident -> Expr
+mkVarMn mn = Var . Qualified mn
-mkVar :: String -> Expr
+mkVar :: Ident -> Expr
mkVar = mkVarMn Nothing
-mkPrelVar :: String -> Expr
-mkPrelVar = mkVarMn (Just (ModuleName [ProperName C.prelude]))
-
-mkGenVar :: String -> Expr
-mkGenVar = mkVarMn (Just (ModuleName [ProperName "Data", ProperName C.generic]))
+objectType :: Type -> Maybe Type
+objectType (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName "Object"))) rec) = Just rec
+objectType _ = Nothing
decomposeRec :: Type -> [(String, Type)]
decomposeRec = sortBy (comparing fst) . go
- where go (RCons str typ typs) = (str, typ) : decomposeRec typs
- go _ = []
+ where go (RCons str typ typs) = (str, typ) : decomposeRec typs
+ go _ = []
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
index 21401ba..6684639 100644
--- a/src/Language/PureScript/TypeChecker.hs
+++ b/src/Language/PureScript/TypeChecker.hs
@@ -19,7 +19,7 @@ import Language.PureScript.TypeChecker.Types as T
import Language.PureScript.TypeChecker.Synonyms as T
import Data.Maybe
-import Data.List (nub, (\\), sort, group)
+import Data.List (nub, nubBy, (\\), sort, group)
import Data.Foldable (for_, traverse_)
import qualified Data.Map as M
@@ -30,14 +30,14 @@ import Control.Monad.State.Class (MonadState(..), modify)
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.Writer.Class (MonadWriter(..))
-import Language.PureScript.Crash
-import Language.PureScript.Types
-import Language.PureScript.Names
-import Language.PureScript.Kinds
import Language.PureScript.AST
-import Language.PureScript.TypeClassDictionaries
+import Language.PureScript.Crash
import Language.PureScript.Environment
import Language.PureScript.Errors
+import Language.PureScript.Kinds
+import Language.PureScript.Names
+import Language.PureScript.TypeClassDictionaries
+import Language.PureScript.Types
addDataType
:: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
@@ -230,14 +230,14 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds
let args' = args `withKinds` kind
addTypeSynonym moduleName name args' ty kind
return $ TypeSynonymDeclaration name args ty
- go (TypeDeclaration{}) = internalError "Type declarations should have been removed"
+ go TypeDeclaration{} = internalError "Type declarations should have been removed"
go (ValueDeclaration name nameKind [] (Right val)) =
warnAndRethrow (addHint (ErrorInValueDeclaration name)) $ do
valueIsNotDefined moduleName name
[(_, (val', ty))] <- typesOf moduleName [(name, val)]
addValue moduleName name ty nameKind
return $ ValueDeclaration name nameKind [] $ Right val'
- go (ValueDeclaration{}) = internalError "Binders were not desugared"
+ go ValueDeclaration{} = internalError "Binders were not desugared"
go (BindingGroupDeclaration vals) =
warnAndRethrow (addHint (ErrorInBindingGroup (map (\(ident, _, _) -> ident) vals))) $ do
for_ (map (\(ident, _, _) -> ident) vals) $ \name ->
@@ -264,8 +264,8 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds
Just _ -> throwError . errorMessage $ RedefinedIdent name
Nothing -> putEnv (env { names = M.insert (moduleName, name) (ty, External, Defined) (names env) })
return d
- go (d@(FixityDeclaration{})) = return d
- go (d@(ImportDeclaration{})) = return d
+ go (d@FixityDeclaration{}) = return d
+ go (d@ImportDeclaration{}) = return d
go (d@(TypeClassDeclaration pn args implies tys)) = do
addTypeClass moduleName pn args implies tys
return d
@@ -281,9 +281,14 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds
warnAndRethrowWithPosition pos $ PositionedDeclaration pos com <$> go d
checkFixities :: Declaration -> m ()
- checkFixities (FixityDeclaration _ name (Just alias)) = do
+ checkFixities (FixityDeclaration _ name (Just (Left alias))) = do
ty <- lookupVariable moduleName alias
addValue moduleName (Op name) ty Public
+ checkFixities (FixityDeclaration _ name (Just (Right alias))) = do
+ env <- getEnv
+ case M.lookup alias (dataConstructors env) of
+ Nothing -> throwError . errorMessage $ UnknownDataConstructor alias Nothing
+ Just (_, _, ty, _) -> addValue moduleName (Op name) ty Public
checkFixities (FixityDeclaration _ name _) = do
env <- getEnv
guardWith (errorMessage (OrphanFixityDeclaration name)) $ M.member (moduleName, Op name) $ names env
@@ -349,7 +354,7 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint
checkTypesAreExported e
checkClassMembersAreExported e
checkClassesAreExported e
- checkNonAliasesAreExported e
+ checkNonAliasesAreExported (exportedDataConstructors exps) e
return $ Module ss coms mn decls' (Just exps)
where
@@ -374,7 +379,7 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint
checkExport :: DeclarationRef -> (Type -> [DeclarationRef]) -> Type -> m ()
checkExport dr extract ty = case filter (not . exported) (extract ty) of
[] -> return ()
- hidden -> throwError . errorMessage $ TransitiveExportError dr hidden
+ hidden -> throwError . errorMessage $ TransitiveExportError dr (nubBy nubEq hidden)
where
exported e = any (exports e) exps
exports (TypeRef pn1 _) (TypeRef pn2 _) = pn1 == pn2
@@ -383,6 +388,11 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint
exports (PositionedDeclarationRef _ _ r1) r2 = exports r1 r2
exports r1 (PositionedDeclarationRef _ _ r2) = exports r1 r2
exports _ _ = False
+ -- We avoid Eq for `nub`bing as the dctor part of `TypeRef` evaluates to
+ -- `error` for the values generated here (we don't need them anyway)
+ nubEq (TypeRef pn1 _) (TypeRef pn2 _) = pn1 == pn2
+ nubEq r1 r2 = r1 == r2
+
-- Check that all the type constructors defined in the current module that appear in member types
-- have also been exported from the module
@@ -425,17 +435,30 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint
extractMemberName _ = internalError "Unexpected declaration in typeclass member list"
checkClassMembersAreExported _ = return ()
- checkNonAliasesAreExported :: DeclarationRef -> m ()
- checkNonAliasesAreExported dr@(ValueRef (Op name)) =
+ checkNonAliasesAreExported :: [ProperName 'ConstructorName] -> DeclarationRef -> m ()
+ checkNonAliasesAreExported exportedDctors dr@(ValueRef (Op name)) =
case listToMaybe (mapMaybe getAlias decls) of
- Just alias ->
- when (not $ any (== ValueRef alias) exps) $
- throwError . errorMessage $ TransitiveExportError dr [ValueRef alias]
+ Just (Left ident) ->
+ unless (ValueRef ident `elem` exps) $
+ throwError . errorMessage $ TransitiveExportError dr [ValueRef ident]
+ Just (Right ctor) ->
+ unless (ctor `elem` exportedDctors) $
+ throwError . errorMessage $ TransitiveDctorExportError dr ctor
_ -> return ()
where
- getAlias :: Declaration -> Maybe Ident
+ getAlias :: Declaration -> Maybe (Either Ident (ProperName 'ConstructorName))
getAlias (PositionedDeclaration _ _ d) = getAlias d
- getAlias (FixityDeclaration _ name' (Just (Qualified (Just mn') alias)))
- | mn == mn' && name == name' = Just alias
+ getAlias (FixityDeclaration _ name' (Just alias)) | name == name' =
+ case alias of
+ Left (Qualified (Just mn') ident) | mn == mn' -> Just (Left ident)
+ Right (Qualified (Just mn') ctor) | mn == mn' -> Just (Right ctor)
+ _ -> Nothing
getAlias _ = Nothing
- checkNonAliasesAreExported _ = return ()
+ checkNonAliasesAreExported _ _ = return ()
+
+ exportedDataConstructors :: [DeclarationRef] -> [ProperName 'ConstructorName]
+ exportedDataConstructors = foldMap extractCtor
+ where
+ extractCtor :: DeclarationRef -> [ProperName 'ConstructorName]
+ extractCtor (TypeRef _ (Just ctors)) = ctors
+ extractCtor _ = []
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index fbeb321..74bd82f 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -297,7 +297,9 @@ infer' (TypedValue checkType val ty) = do
ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty
val' <- if checkType then withScopedTypeVars moduleName args (check val ty') else return val
return $ TypedValue True val' ty'
-infer' (PositionedValue pos _ val) = warnAndRethrowWithPosition pos $ infer' val
+infer' (PositionedValue pos c val) = warnAndRethrowWithPosition pos $ do
+ TypedValue t v ty <- infer' val
+ return $ TypedValue t (PositionedValue pos c v) ty
infer' _ = internalError "Invalid argument to infer"
inferLetBinding ::
@@ -400,6 +402,12 @@ inferBinder val (TypedBinder ty binder) = do
ty1 <- replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty
unifyTypes val ty1
inferBinder val binder
+inferBinder _ OpBinder{} =
+ internalError "OpBinder should have been desugared before inferBinder"
+inferBinder _ BinaryNoParensBinder{} =
+ internalError "BinaryNoParensBinder should have been desugared before inferBinder"
+inferBinder _ ParensInBinder{} =
+ internalError "ParensInBinder should have been desugared before inferBinder"
-- | Returns true if a binder requires its argument type to be a monotype.
-- | If this is the case, we need to instantiate any polymorphic types before checking binders.
@@ -617,8 +625,9 @@ check' val kt@(KindedType ty kind) = do
checkTypeKind ty kind
val' <- check' val ty
return $ TypedValue True val' kt
-check' (PositionedValue pos _ val) ty =
- warnAndRethrowWithPosition pos $ check' val ty
+check' (PositionedValue pos c val) ty = warnAndRethrowWithPosition pos $ do
+ TypedValue t v ty' <- check' val ty
+ return $ TypedValue t (PositionedValue pos c v) ty'
check' val ty = do
TypedValue _ val' ty' <- infer val
mt <- subsumes (Just val') ty' ty
diff --git a/stack-lts-2.yaml b/stack-lts-2.yaml
index 6bf1652..49a6a68 100644
--- a/stack-lts-2.yaml
+++ b/stack-lts-2.yaml
@@ -1,4 +1,4 @@
-flags: {}
+resolver: lts-2.22
packages:
- '.'
extra-deps:
@@ -6,4 +6,8 @@ extra-deps:
- bower-json-0.7.0.0
- boxes-0.1.4
- pattern-arrows-0.0.2
-resolver: lts-2.22
+- sourcemap-0.1.6
+- fsnotify-0.2.1
+- hfsevents-0.1.6
+- pipes-http-1.0.2
+flags: {}
diff --git a/stack-lts-3.yaml b/stack-lts-3.yaml
index c69fe3d..69f14a9 100644
--- a/stack-lts-3.yaml
+++ b/stack-lts-3.yaml
@@ -1,5 +1,6 @@
-flags: {}
+resolver: lts-3.22
packages:
- '.'
extra-deps:
-resolver: lts-3.6
+- sourcemap-0.1.6
+flags: {}
diff --git a/stack-nightly.yaml b/stack-nightly.yaml
index cd12fa3..2a5da38 100644
--- a/stack-nightly.yaml
+++ b/stack-nightly.yaml
@@ -1,5 +1,5 @@
flags: {}
packages:
- '.'
-extra-deps:
-resolver: nightly-2015-09-29
+extra-deps: []
+resolver: nightly-2016-02-25
diff --git a/stack.yaml b/stack.yaml
index c69fe3d..34bfedc 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -1,5 +1,5 @@
-flags: {}
+resolver: lts-5.4
packages:
- '.'
-extra-deps:
-resolver: lts-3.6
+extra-deps: []
+flags: {}
diff --git a/tests/Main.hs b/tests/Main.hs
index 9433b19..152cd44 100644
--- a/tests/Main.hs
+++ b/tests/Main.hs
@@ -16,171 +16,29 @@
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE FlexibleInstances #-}
--- Failing tests can specify the kind of error that should be thrown with a
--- @shouldFailWith declaration. For example:
---
--- "-- @shouldFailWith TypesDoNotUnify"
---
--- will cause the test to fail unless that module fails to compile with exactly
--- one TypesDoNotUnify error.
---
--- If a module is expected to produce multiple type errors, then use multiple
--- @shouldFailWith lines; for example:
---
--- -- @shouldFailWith TypesDoNotUnify
--- -- @shouldFailWith TypesDoNotUnify
--- -- @shouldFailWith TransitiveExportError
---
-
module Main (main) where
import Prelude ()
import Prelude.Compat
-import qualified Language.PureScript as P
-import qualified Language.PureScript.CodeGen.JS as J
-import qualified Language.PureScript.CoreFn as CF
-import qualified Language.PureScript.Docs as Docs
-
-import Data.Char (isSpace)
-import Data.Maybe (mapMaybe, fromMaybe)
-import Data.List (isSuffixOf, sort, stripPrefix)
-import Data.Time.Clock (UTCTime())
-
-import qualified Data.Map as M
-
-import Control.Monad
-import Control.Monad.IO.Class (liftIO)
-import Control.Arrow ((>>>))
-
-import Control.Monad.Reader
-import Control.Monad.Writer.Strict
-import Control.Monad.Trans.Maybe
-import Control.Monad.Trans.Except
-import Control.Monad.Error.Class
-
-import System.Exit
-import System.Process
-import System.FilePath
-import System.Directory
-import System.IO.UTF8
-import qualified System.Info
-import qualified System.FilePath.Glob as Glob
-
-import Text.Parsec (ParseError)
-
-import TestsSetup
-import TestPscPublish
+import qualified TestCompiler
+import qualified TestPscPublish
import qualified TestDocs
-
-modulesDir :: FilePath
-modulesDir = ".test_modules" </> "node_modules"
-
-makeActions :: M.Map P.ModuleName FilePath -> P.MakeActions P.Make
-makeActions foreigns = (P.buildMakeActions modulesDir (P.internalError "makeActions: input file map was read.") foreigns False)
- { P.getInputTimestamp = getInputTimestamp
- , P.getOutputTimestamp = getOutputTimestamp
- }
- where
- getInputTimestamp :: P.ModuleName -> P.Make (Either P.RebuildPolicy (Maybe UTCTime))
- getInputTimestamp mn
- | isSupportModule (P.runModuleName mn) = return (Left P.RebuildNever)
- | otherwise = return (Left P.RebuildAlways)
- where
- isSupportModule = flip elem supportModules
-
- getOutputTimestamp :: P.ModuleName -> P.Make (Maybe UTCTime)
- getOutputTimestamp mn = do
- let filePath = modulesDir </> P.runModuleName mn
- exists <- liftIO $ doesDirectoryExist filePath
- return (if exists then Just (P.internalError "getOutputTimestamp: read timestamp") else Nothing)
-
-readInput :: [FilePath] -> IO [(FilePath, String)]
-readInput inputFiles = forM inputFiles $ \inputFile -> do
- text <- readUTF8File inputFile
- return (inputFile, text)
-
-type TestM = WriterT [(FilePath, String)] IO
-
-runTest :: P.Make a -> IO (Either P.MultipleErrors a)
-runTest = fmap fst . P.runMake P.defaultOptions
-
-compile :: [FilePath] -> M.Map P.ModuleName FilePath -> IO (Either P.MultipleErrors P.Environment)
-compile inputFiles foreigns = runTest $ do
- fs <- liftIO $ readInput inputFiles
- ms <- P.parseModulesFromFiles id fs
- P.make (makeActions foreigns) (map snd ms)
-
-assert :: [FilePath] ->
- M.Map P.ModuleName FilePath ->
- (Either P.MultipleErrors P.Environment -> IO (Maybe String)) ->
- TestM ()
-assert inputFiles foreigns f = do
- e <- liftIO $ compile inputFiles foreigns
- maybeErr <- liftIO $ f e
- case maybeErr of
- Just err -> tell [(last inputFiles, err)]
- Nothing -> return ()
-
-assertCompiles :: [FilePath] -> M.Map P.ModuleName FilePath -> TestM ()
-assertCompiles inputFiles foreigns = do
- liftIO . putStrLn $ "Assert " ++ last inputFiles ++ " compiles successfully"
- assert inputFiles foreigns $ \e ->
- case e of
- Left errs -> return . Just . P.prettyPrintMultipleErrors False $ errs
- Right _ -> do
- process <- findNodeProcess
- let entryPoint = modulesDir </> "index.js"
- writeFile entryPoint "require('Main').main()"
- result <- traverse (\node -> readProcessWithExitCode node [entryPoint] "") process
- case result of
- Just (ExitSuccess, out, _) -> putStrLn out >> return Nothing
- Just (ExitFailure _, _, err) -> return $ Just err
- Nothing -> return $ Just "Couldn't find node.js executable"
-
-assertDoesNotCompile :: [FilePath] -> M.Map P.ModuleName FilePath -> TestM ()
-assertDoesNotCompile inputFiles foreigns = do
- let testFile = last inputFiles
- liftIO . putStrLn $ "Assert " ++ testFile ++ " does not compile"
- shouldFailWith <- getShouldFailWith testFile
- assert inputFiles foreigns $ \e ->
- case e of
- Left errs -> do
- putStrLn (P.prettyPrintMultipleErrors False errs)
- return $ if null shouldFailWith
- then Just $ "shouldFailWith declaration is missing (errors were: "
- ++ show (map P.errorCode (P.runMultipleErrors errs))
- ++ ")"
- else checkShouldFailWith shouldFailWith errs
- Right _ ->
- return $ Just "Should not have compiled"
-
- where
- getShouldFailWith =
- readUTF8File
- >>> liftIO
- >>> fmap ( lines
- >>> mapMaybe (stripPrefix "-- @shouldFailWith ")
- >>> map trim
- )
-
- checkShouldFailWith expected errs =
- let actual = map P.errorCode $ P.runMultipleErrors errs
- in if sort expected == sort actual
- then Nothing
- else Just $ "Expected these errors: " ++ show expected ++ ", but got these: " ++ show actual
-
- trim =
- dropWhile isSpace >>> reverse >>> dropWhile isSpace >>> reverse
+import qualified TestPsci
+import qualified TestPscIde
main :: IO ()
main = do
heading "Main compiler test suite"
- testCompiler
+ TestCompiler.main
heading "Documentation test suite"
TestDocs.main
- -- heading "psc-publish test suite"
- -- testPscPublish
+ heading "psc-publish test suite"
+ TestPscPublish.main
+ heading "psci test suite"
+ TestPsci.main
+ heading "psc-ide test suite"
+ TestPscIde.main
where
heading msg = do
@@ -189,54 +47,3 @@ main = do
putStrLn $ "# " ++ msg
putStrLn $ replicate 79 '#'
putStrLn ""
-
-testCompiler :: IO ()
-testCompiler = do
- fetchSupportCode
- cwd <- getCurrentDirectory
-
- let supportDir = cwd </> "tests" </> "support" </> "flattened"
- let supportFiles ext = Glob.globDir1 (Glob.compile ("*." ++ ext)) supportDir
-
- supportPurs <- supportFiles "purs"
- supportJS <- supportFiles "js"
-
- foreignFiles <- forM supportJS (\f -> (f,) <$> readUTF8File f)
- Right (foreigns, _) <- runExceptT $ runWriterT $ P.parseForeignModulesFromFiles foreignFiles
-
- let passing = cwd </> "examples" </> "passing"
- passingTestCases <- sort . filter (".purs" `isSuffixOf`) <$> getDirectoryContents passing
- let failing = cwd </> "examples" </> "failing"
- failingTestCases <- sort . filter (".purs" `isSuffixOf`) <$> getDirectoryContents failing
-
- failures <- execWriterT $ do
- forM_ passingTestCases $ \inputFile ->
- assertCompiles (supportPurs ++ [passing </> inputFile]) foreigns
- forM_ failingTestCases $ \inputFile ->
- assertDoesNotCompile (supportPurs ++ [failing </> inputFile]) foreigns
-
- if null failures
- then pure ()
- else do
- putStrLn "Failures:"
- forM_ failures $ \(fp, err) ->
- let fp' = fromMaybe fp $ stripPrefix (failing ++ [pathSeparator]) fp
- in putStrLn $ fp' ++ ": " ++ err
- exitFailure
-
-testPscPublish :: IO ()
-testPscPublish = do
- testPackage "tests/support/prelude"
-
-
-supportModules :: [String]
-supportModules =
- [ "Control.Monad.Eff.Class"
- , "Control.Monad.Eff.Console"
- , "Control.Monad.Eff"
- , "Control.Monad.Eff.Unsafe"
- , "Control.Monad.ST"
- , "Data.Function"
- , "Prelude"
- , "Test.Assert"
- ]
diff --git a/tests/PscIdeSpec.hs b/tests/PscIdeSpec.hs
new file mode 100644
index 0000000..1dbe9bb
--- /dev/null
+++ b/tests/PscIdeSpec.hs
@@ -0,0 +1 @@
+{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=PscIdeSpec #-}
diff --git a/tests/TestCompiler.hs b/tests/TestCompiler.hs
new file mode 100644
index 0000000..43b0728
--- /dev/null
+++ b/tests/TestCompiler.hs
@@ -0,0 +1,194 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DoAndIfThenElse #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE FlexibleInstances #-}
+
+module TestCompiler where
+
+-- Failing tests can specify the kind of error that should be thrown with a
+-- @shouldFailWith declaration. For example:
+--
+-- "-- @shouldFailWith TypesDoNotUnify"
+--
+-- will cause the test to fail unless that module fails to compile with exactly
+-- one TypesDoNotUnify error.
+--
+-- If a module is expected to produce multiple type errors, then use multiple
+-- @shouldFailWith lines; for example:
+--
+-- -- @shouldFailWith TypesDoNotUnify
+-- -- @shouldFailWith TypesDoNotUnify
+-- -- @shouldFailWith TransitiveExportError
+
+import Prelude ()
+import Prelude.Compat
+
+import qualified Language.PureScript as P
+
+import Data.Char (isSpace)
+import Data.Maybe (mapMaybe, fromMaybe)
+import Data.List (isSuffixOf, sort, stripPrefix)
+import Data.Time.Clock (UTCTime())
+
+import qualified Data.Map as M
+
+import Control.Monad
+import Control.Arrow ((>>>))
+
+import Control.Monad.Reader
+import Control.Monad.Writer.Strict
+import Control.Monad.Trans.Except
+
+import System.Exit
+import System.Process hiding (cwd)
+import System.FilePath
+import System.Directory
+import System.IO.UTF8
+import qualified System.FilePath.Glob as Glob
+
+import TestUtils
+
+main :: IO ()
+main = do
+ cwd <- getCurrentDirectory
+
+ let supportDir = cwd </> "tests" </> "support" </> "flattened"
+ let supportFiles ext = Glob.globDir1 (Glob.compile ("*." ++ ext)) supportDir
+
+ supportPurs <- supportFiles "purs"
+ supportJS <- supportFiles "js"
+
+ foreignFiles <- forM supportJS (\f -> (f,) <$> readUTF8File f)
+ Right (foreigns, _) <- runExceptT $ runWriterT $ P.parseForeignModulesFromFiles foreignFiles
+
+ let passing = cwd </> "examples" </> "passing"
+ passingTestCases <- sort . filter (".purs" `isSuffixOf`) <$> getDirectoryContents passing
+ let failing = cwd </> "examples" </> "failing"
+ failingTestCases <- sort . filter (".purs" `isSuffixOf`) <$> getDirectoryContents failing
+
+ failures <- execWriterT $ do
+ forM_ passingTestCases $ \inputFile ->
+ assertCompiles (supportPurs ++ [passing </> inputFile]) foreigns
+ forM_ failingTestCases $ \inputFile ->
+ assertDoesNotCompile (supportPurs ++ [failing </> inputFile]) foreigns
+
+ if null failures
+ then pure ()
+ else do
+ putStrLn "Failures:"
+ forM_ failures $ \(fp, err) ->
+ let fp' = fromMaybe fp $ stripPrefix (failing ++ [pathSeparator]) fp
+ in putStrLn $ fp' ++ ": " ++ err
+ exitFailure
+
+modulesDir :: FilePath
+modulesDir = ".test_modules" </> "node_modules"
+
+makeActions :: M.Map P.ModuleName FilePath -> P.MakeActions P.Make
+makeActions foreigns = (P.buildMakeActions modulesDir (P.internalError "makeActions: input file map was read.") foreigns False)
+ { P.getInputTimestamp = getInputTimestamp
+ , P.getOutputTimestamp = getOutputTimestamp
+ }
+ where
+ getInputTimestamp :: P.ModuleName -> P.Make (Either P.RebuildPolicy (Maybe UTCTime))
+ getInputTimestamp mn
+ | isSupportModule (P.runModuleName mn) = return (Left P.RebuildNever)
+ | otherwise = return (Left P.RebuildAlways)
+ where
+ isSupportModule = flip elem supportModules
+
+ getOutputTimestamp :: P.ModuleName -> P.Make (Maybe UTCTime)
+ getOutputTimestamp mn = do
+ let filePath = modulesDir </> P.runModuleName mn
+ exists <- liftIO $ doesDirectoryExist filePath
+ return (if exists then Just (P.internalError "getOutputTimestamp: read timestamp") else Nothing)
+
+readInput :: [FilePath] -> IO [(FilePath, String)]
+readInput inputFiles = forM inputFiles $ \inputFile -> do
+ text <- readUTF8File inputFile
+ return (inputFile, text)
+
+type TestM = WriterT [(FilePath, String)] IO
+
+runTest :: P.Make a -> IO (Either P.MultipleErrors a)
+runTest = fmap fst . P.runMake P.defaultOptions
+
+compile :: [FilePath] -> M.Map P.ModuleName FilePath -> IO (Either P.MultipleErrors P.Environment)
+compile inputFiles foreigns = runTest $ do
+ fs <- liftIO $ readInput inputFiles
+ ms <- P.parseModulesFromFiles id fs
+ P.make (makeActions foreigns) (map snd ms)
+
+assert :: [FilePath] ->
+ M.Map P.ModuleName FilePath ->
+ (Either P.MultipleErrors P.Environment -> IO (Maybe String)) ->
+ TestM ()
+assert inputFiles foreigns f = do
+ e <- liftIO $ compile inputFiles foreigns
+ maybeErr <- liftIO $ f e
+ case maybeErr of
+ Just err -> tell [(last inputFiles, err)]
+ Nothing -> return ()
+
+assertCompiles :: [FilePath] -> M.Map P.ModuleName FilePath -> TestM ()
+assertCompiles inputFiles foreigns = do
+ liftIO . putStrLn $ "Assert " ++ last inputFiles ++ " compiles successfully"
+ assert inputFiles foreigns $ \e ->
+ case e of
+ Left errs -> return . Just . P.prettyPrintMultipleErrors False $ errs
+ Right _ -> do
+ process <- findNodeProcess
+ let entryPoint = modulesDir </> "index.js"
+ writeFile entryPoint "require('Main').main()"
+ result <- traverse (\node -> readProcessWithExitCode node [entryPoint] "") process
+ case result of
+ Just (ExitSuccess, out, _) -> putStrLn out >> return Nothing
+ Just (ExitFailure _, _, err) -> return $ Just err
+ Nothing -> return $ Just "Couldn't find node.js executable"
+
+assertDoesNotCompile :: [FilePath] -> M.Map P.ModuleName FilePath -> TestM ()
+assertDoesNotCompile inputFiles foreigns = do
+ let testFile = last inputFiles
+ liftIO . putStrLn $ "Assert " ++ testFile ++ " does not compile"
+ shouldFailWith <- getShouldFailWith testFile
+ assert inputFiles foreigns $ \e ->
+ case e of
+ Left errs -> do
+ putStrLn (P.prettyPrintMultipleErrors False errs)
+ return $ if null shouldFailWith
+ then Just $ "shouldFailWith declaration is missing (errors were: "
+ ++ show (map P.errorCode (P.runMultipleErrors errs))
+ ++ ")"
+ else checkShouldFailWith shouldFailWith errs
+ Right _ ->
+ return $ Just "Should not have compiled"
+
+ where
+ getShouldFailWith =
+ readUTF8File
+ >>> liftIO
+ >>> fmap ( lines
+ >>> mapMaybe (stripPrefix "-- @shouldFailWith ")
+ >>> map trim
+ )
+
+ checkShouldFailWith expected errs =
+ let actual = map P.errorCode $ P.runMultipleErrors errs
+ in if sort expected == sort actual
+ then Nothing
+ else Just $ "Expected these errors: " ++ show expected ++ ", but got these: " ++ show actual
+
+ trim =
+ dropWhile isSpace >>> reverse >>> dropWhile isSpace >>> reverse
+
+supportModules :: [String]
+supportModules =
+ [ "Control.Monad.Eff.Class"
+ , "Control.Monad.Eff.Console"
+ , "Control.Monad.Eff"
+ , "Control.Monad.Eff.Unsafe"
+ , "Control.Monad.ST"
+ , "Data.Function"
+ , "Prelude"
+ , "Test.Assert"
+ ]
diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs
index 477cc13..5fdb416 100644
--- a/tests/TestDocs.hs
+++ b/tests/TestDocs.hs
@@ -9,21 +9,17 @@ import Prelude.Compat
import Data.Version (Version(..))
-import Control.Monad hiding (forM_)
-import Control.Applicative
-import Control.Arrow
+import Data.Monoid
import Data.Maybe (fromMaybe)
import Data.List ((\\))
import Data.Foldable
-import Data.Traversable
import System.Exit
-import qualified Text.Parsec as Parsec
import qualified Language.PureScript as P
import qualified Language.PureScript.Docs as Docs
import qualified Language.PureScript.Publish as Publish
-import qualified TestPscPublish
+import TestUtils
publishOpts :: Publish.PublishOptions
publishOpts = Publish.defaultPublishOptions
@@ -34,10 +30,10 @@ publishOpts = Publish.defaultPublishOptions
main :: IO ()
main = do
- TestPscPublish.pushd "examples/docs" $ do
+ pushd "examples/docs" $ do
Docs.Package{..} <- Publish.preparePackage publishOpts
- forM_ testCases $ \(mn, pragmas) ->
- let mdl = takeJust ("module not found in docs: " ++ mn)
+ forM_ testCases $ \(P.moduleNameFromString -> mn, pragmas) ->
+ let mdl = takeJust ("module not found in docs: " ++ P.runModuleName mn)
(find ((==) mn . Docs.modName) pkgModules)
in forM_ pragmas (flip runAssertionIO mdl)
@@ -56,8 +52,16 @@ data Assertion
-- | Assert that a particular declaration has a particular type class
-- constraint.
| ShouldBeConstrained P.ModuleName String String
+ -- | Assert that a particular value declaration exists, and its type
+ -- satisfies the given predicate.
+ | ValueShouldHaveTypeSignature P.ModuleName String (ShowFn (P.Type -> Bool))
deriving (Show)
+newtype ShowFn a = ShowFn a
+
+instance Show (ShowFn a) where
+ show _ = "<function>"
+
data AssertionFailure
-- | A declaration was not documented, but should have been
= NotDocumented P.ModuleName String
@@ -72,6 +76,11 @@ data AssertionFailure
-- | A declaration had the wrong "type" (ie, value, type, type class)
-- Fields: declaration title, expected "type", actual "type".
| WrongDeclarationType P.ModuleName String String String
+ -- | A value declaration had the wrong type (in the sense of "type
+ -- checking"), eg, because the inferred type was used when the explicit type
+ -- should have been.
+ -- Fields: module name, declaration name, actual type.
+ | ValueDeclarationWrongType P.ModuleName String P.Type
deriving (Show)
data AssertionResult
@@ -121,9 +130,24 @@ runAssertion assertion Docs.Module{..} =
Fail (WrongDeclarationType mn decl "value"
(Docs.declInfoToString declInfo))
+ ValueShouldHaveTypeSignature mn decl (ShowFn tyPredicate) ->
+ case find ((==) decl . Docs.declTitle) (declarationsFor mn) of
+ Nothing ->
+ Fail (NotDocumented mn decl)
+ Just Docs.Declaration{..} ->
+ case declInfo of
+ Docs.ValueDeclaration ty ->
+ if tyPredicate ty
+ then Pass
+ else Fail
+ (ValueDeclarationWrongType mn decl ty)
+ _ ->
+ Fail (WrongDeclarationType mn decl "value"
+ (Docs.declInfoToString declInfo))
+
where
declarationsFor mn =
- if P.runModuleName mn == modName
+ if mn == modName
then modDeclarations
else fromMaybe [] (lookup mn modReExports)
@@ -132,6 +156,7 @@ runAssertion assertion Docs.Module{..} =
childrenTitles = map Docs.cdeclTitle . Docs.declChildren
+checkConstrained :: P.Type -> String -> Bool
checkConstrained ty tyClass =
-- Note that we don't recurse on ConstrainedType if none of the constraints
-- match; this is by design, as constraints should be moved to the front
@@ -149,11 +174,11 @@ checkConstrained ty tyClass =
runAssertionIO :: Assertion -> Docs.Module -> IO ()
runAssertionIO assertion mdl = do
- putStrLn ("In " ++ Docs.modName mdl ++ ": " ++ show assertion)
+ putStrLn ("In " ++ P.runModuleName (Docs.modName mdl) ++ ": " ++ show assertion)
case runAssertion assertion mdl of
Pass -> pure ()
- fail -> do
- putStrLn (show fail)
+ Fail reason -> do
+ putStrLn ("Failed: " <> show reason)
exitFailure
testCases :: [(String, [Assertion])]
@@ -226,7 +251,19 @@ testCases =
, ("NewOperators",
[ ShouldBeDocumented (n "NewOperators2") "(>>>)" []
])
+
+ , ("ExplicitTypeSignatures",
+ [ ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "explicit" (ShowFn (hasTypeVar "something"))
+ , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "anInt" (ShowFn ((==) P.tyInt))
+ , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "aNumber" (ShowFn ((==) P.tyNumber))
+ ])
]
where
n = P.moduleNameFromString
+
+ hasTypeVar varName =
+ getAny . P.everythingOnTypes (<>) (Any . isVar varName)
+
+ isVar varName (P.TypeVar name) | varName == name = True
+ isVar _ _ = False
diff --git a/tests/TestPscIde.hs b/tests/TestPscIde.hs
new file mode 100644
index 0000000..1a6e072
--- /dev/null
+++ b/tests/TestPscIde.hs
@@ -0,0 +1,7 @@
+module TestPscIde where
+
+import qualified PscIdeSpec
+import Test.Hspec
+
+main :: IO ()
+main = hspec PscIdeSpec.spec
diff --git a/tests/TestPscPublish.hs b/tests/TestPscPublish.hs
index 657105d..49321ed 100644
--- a/tests/TestPscPublish.hs
+++ b/tests/TestPscPublish.hs
@@ -20,13 +20,11 @@ import Data.Version
import Language.PureScript.Docs
import Language.PureScript.Publish
-pushd :: forall a. FilePath -> IO a -> IO a
-pushd dir act = do
- original <- getCurrentDirectory
- setCurrentDirectory dir
- result <- try act :: IO (Either IOException a)
- setCurrentDirectory original
- either throwIO return result
+import TestUtils
+
+main :: IO ()
+main = do
+ testPackage "tests/support/prelude"
data TestResult
= ParseFailed String
@@ -48,6 +46,7 @@ roundTrip pkg =
testRunOptions :: PublishOptions
testRunOptions = defaultPublishOptions
{ publishGetVersion = return testVersion
+ , publishWorkingTreeDirty = return ()
}
where testVersion = ("v999.0.0", Version [999,0,0] [])
@@ -58,7 +57,9 @@ testPackage dir = do
pushd dir $ do
r <- roundTrip <$> preparePackage testRunOptions
case r of
- Pass _ -> pure ()
+ Pass _ -> do
+ putStrLn ("psc-publish test passed for: " ++ dir)
+ pure ()
other -> do
putStrLn ("psc-publish tests failed on " ++ dir ++ ":")
putStrLn (show other)
diff --git a/psci/tests/Main.hs b/tests/TestPsci.hs
index af24736..3d058df 100644
--- a/psci/tests/Main.hs
+++ b/tests/TestPsci.hs
@@ -1,7 +1,7 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
-module Main where
+module TestPsci where
import Prelude ()
import Prelude.Compat
@@ -23,15 +23,12 @@ import Test.HUnit
import qualified Language.PureScript as P
-import PSCi
-import Completion
-import Types
-
-import TestsSetup
+import PSCi.Module (loadAllModules)
+import PSCi.Completion
+import PSCi.Types
main :: IO ()
main = do
- fetchSupportCode
Counts{..} <- runTestTT allTests
when (errors + failures > 0) exitFailure
@@ -65,8 +62,8 @@ completionTestData =
, ("import qualified Control.Monad.Eff.", map ("import qualified Control.Monad.Eff" ++) [".Unsafe", ".Class", ".Console"])
-- :load, :module should complete file paths
- , (":l psci/tests/data/", [":l psci/tests/data/Sample.purs"])
- , (":module psci/tests/data/", [":module psci/tests/data/Sample.purs"])
+ , (":l tests/support/psci/", [":l tests/support/psci/Sample.purs"])
+ , (":module tests/support/psci/", [":module tests/support/psci/Sample.purs"])
-- :quit, :help, :reset should not complete
, (":help ", [])
diff --git a/tests/common/TestsSetup.hs b/tests/TestUtils.hs
index 1ec2cd1..7195db2 100644
--- a/tests/common/TestsSetup.hs
+++ b/tests/TestUtils.hs
@@ -10,7 +10,9 @@
-- |
--
-----------------------------------------------------------------------------
-module TestsSetup where
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module TestUtils where
import Prelude ()
import Prelude.Compat
@@ -18,6 +20,7 @@ import Prelude.Compat
import Data.Maybe (fromMaybe)
import Control.Monad
import Control.Monad.Trans.Maybe
+import Control.Exception
import System.Process
import System.Directory
@@ -30,8 +33,16 @@ findNodeProcess = runMaybeT . msum $ map (MaybeT . findExecutable) names
where
names = ["nodejs", "node"]
-fetchSupportCode :: IO ()
-fetchSupportCode = do
+-- |
+-- Fetches code necessary to run the tests with. The resulting support code
+-- should then be checked in, so that npm/bower etc is not required to run the
+-- tests.
+--
+-- Simply rerun this (via ghci is probably easiest) when the support code needs
+-- updating.
+--
+updateSupportCode :: IO ()
+updateSupportCode = do
node <- fromMaybe (internalError "cannot find node executable") <$> findNodeProcess
setCurrentDirectory "tests/support"
if System.Info.os == "mingw32"
@@ -43,3 +54,12 @@ fetchSupportCode = do
callProcess "node_modules/.bin/bower" ["--allow-root", "install", "--config.interactive=false"]
callProcess node ["setup.js"]
setCurrentDirectory "../.."
+
+pushd :: forall a. FilePath -> IO a -> IO a
+pushd dir act = do
+ original <- getCurrentDirectory
+ setCurrentDirectory dir
+ result <- try act :: IO (Either IOException a)
+ setCurrentDirectory original
+ either throwIO return result
+
diff --git a/tests/support/flattened/Control-Monad-Eff-Class.purs b/tests/support/flattened/Control-Monad-Eff-Class.purs
new file mode 100644
index 0000000..dbfd58e
--- /dev/null
+++ b/tests/support/flattened/Control-Monad-Eff-Class.purs
@@ -0,0 +1,24 @@
+module Control.Monad.Eff.Class
+ ( MonadEff
+ , liftEff
+ ) where
+
+import Prelude
+
+import Control.Monad.Eff
+
+-- | The `MonadEff` class captures those monads which support native effects.
+-- |
+-- | Instances are provided for `Eff` itself, and the standard monad transformers.
+-- |
+-- | `liftEff` can be used in any appropriate monad transformer stack to lift an action
+-- | of type `Eff eff a` into the monad.
+-- |
+-- | Note that `MonadEff` is parameterized by the row of effects, so type inference can be
+-- | tricky. It is generally recommended to either work with a polymorphic row of effects,
+-- | or a concrete, closed row of effects such as `(trace :: Trace)`.
+class (Monad m) <= MonadEff eff m where
+ liftEff :: forall a. Eff eff a -> m a
+
+instance monadEffEff :: MonadEff eff (Eff eff) where
+ liftEff = id
diff --git a/tests/support/flattened/Control-Monad-Eff-Console.js b/tests/support/flattened/Control-Monad-Eff-Console.js
new file mode 100644
index 0000000..9ccfc26
--- /dev/null
+++ b/tests/support/flattened/Control-Monad-Eff-Console.js
@@ -0,0 +1,18 @@
+/* global exports, console */
+"use strict";
+
+// module Control.Monad.Eff.Console
+
+exports.log = function (s) {
+ return function () {
+ console.log(s);
+ return {};
+ };
+};
+
+exports.error = function (s) {
+ return function () {
+ console.error(s);
+ return {};
+ };
+};
diff --git a/tests/support/flattened/Control-Monad-Eff-Console.purs b/tests/support/flattened/Control-Monad-Eff-Console.purs
new file mode 100644
index 0000000..0a03ee4
--- /dev/null
+++ b/tests/support/flattened/Control-Monad-Eff-Console.purs
@@ -0,0 +1,18 @@
+module Control.Monad.Eff.Console where
+
+import Prelude
+
+import Control.Monad.Eff
+
+-- | The `CONSOLE` effect represents those computations which write to the console.
+foreign import data CONSOLE :: !
+
+-- | Write a message to the console.
+foreign import log :: forall eff. String -> Eff (console :: CONSOLE | eff) Unit
+
+-- | Write an error to the console.
+foreign import error :: forall eff. String -> Eff (console :: CONSOLE | eff) Unit
+
+-- | Write a value to the console, using its `Show` instance to produce a `String`.
+print :: forall a eff. (Show a) => a -> Eff (console :: CONSOLE | eff) Unit
+print = log <<< show
diff --git a/tests/support/flattened/Control-Monad-Eff-Unsafe.js b/tests/support/flattened/Control-Monad-Eff-Unsafe.js
new file mode 100644
index 0000000..bada18a
--- /dev/null
+++ b/tests/support/flattened/Control-Monad-Eff-Unsafe.js
@@ -0,0 +1,8 @@
+/* global exports */
+"use strict";
+
+// module Control.Monad.Eff.Unsafe
+
+exports.unsafeInterleaveEff = function (f) {
+ return f;
+};
diff --git a/tests/support/flattened/Control-Monad-Eff-Unsafe.purs b/tests/support/flattened/Control-Monad-Eff-Unsafe.purs
new file mode 100644
index 0000000..5d6f104
--- /dev/null
+++ b/tests/support/flattened/Control-Monad-Eff-Unsafe.purs
@@ -0,0 +1,10 @@
+module Control.Monad.Eff.Unsafe where
+
+import Prelude
+
+import Control.Monad.Eff
+
+-- | Change the type of an effectful computation, allowing it to be run in another context.
+-- |
+-- | Note: use of this function can result in arbitrary side-effects.
+foreign import unsafeInterleaveEff :: forall eff1 eff2 a. Eff eff1 a -> Eff eff2 a
diff --git a/tests/support/flattened/Control-Monad-Eff.js b/tests/support/flattened/Control-Monad-Eff.js
new file mode 100644
index 0000000..1498f21
--- /dev/null
+++ b/tests/support/flattened/Control-Monad-Eff.js
@@ -0,0 +1,62 @@
+/* global exports */
+"use strict";
+
+// module Control.Monad.Eff
+
+exports.returnE = function (a) {
+ return function () {
+ return a;
+ };
+};
+
+exports.bindE = function (a) {
+ return function (f) {
+ return function () {
+ return f(a())();
+ };
+ };
+};
+
+exports.runPure = function (f) {
+ return f();
+};
+
+exports.untilE = function (f) {
+ return function () {
+ while (!f());
+ return {};
+ };
+};
+
+exports.whileE = function (f) {
+ return function (a) {
+ return function () {
+ while (f()) {
+ a();
+ }
+ return {};
+ };
+ };
+};
+
+exports.forE = function (lo) {
+ return function (hi) {
+ return function (f) {
+ return function () {
+ for (var i = lo; i < hi; i++) {
+ f(i)();
+ }
+ };
+ };
+ };
+};
+
+exports.foreachE = function (as) {
+ return function (f) {
+ return function () {
+ for (var i = 0, l = as.length; i < l; i++) {
+ f(as[i])();
+ }
+ };
+ };
+};
diff --git a/tests/support/flattened/Control-Monad-Eff.purs b/tests/support/flattened/Control-Monad-Eff.purs
new file mode 100644
index 0000000..0417c19
--- /dev/null
+++ b/tests/support/flattened/Control-Monad-Eff.purs
@@ -0,0 +1,67 @@
+module Control.Monad.Eff
+ ( Eff()
+ , Pure()
+ , runPure
+ , untilE, whileE, forE, foreachE
+ ) where
+
+import Prelude
+
+-- | The `Eff` type constructor is used to represent _native_ effects.
+-- |
+-- | See [Handling Native Effects with the Eff Monad](https://github.com/purescript/purescript/wiki/Handling-Native-Effects-with-the-Eff-Monad) for more details.
+-- |
+-- | The first type parameter is a row of effects which represents the contexts in which a computation can be run, and the second type parameter is the return type.
+foreign import data Eff :: # ! -> * -> *
+
+foreign import returnE :: forall e a. a -> Eff e a
+
+foreign import bindE :: forall e a b. Eff e a -> (a -> Eff e b) -> Eff e b
+
+-- | The `Pure` type synonym represents _pure_ computations, i.e. ones in which all effects have been handled.
+-- |
+-- | The `runPure` function can be used to run pure computations and obtain their result.
+type Pure a = forall e. Eff e a
+
+-- | Run a pure computation and return its result.
+-- |
+-- | Note: since this function has a rank-2 type, it may cause problems to apply this function using the `$` operator. The recommended approach
+-- | is to use parentheses instead.
+foreign import runPure :: forall a. Pure a -> a
+
+instance functorEff :: Functor (Eff e) where
+ map = liftA1
+
+instance applyEff :: Apply (Eff e) where
+ apply = ap
+
+instance applicativeEff :: Applicative (Eff e) where
+ pure = returnE
+
+instance bindEff :: Bind (Eff e) where
+ bind = bindE
+
+instance monadEff :: Monad (Eff e)
+
+-- | Loop until a condition becomes `true`.
+-- |
+-- | `untilE b` is an effectful computation which repeatedly runs the effectful computation `b`,
+-- | until its return value is `true`.
+foreign import untilE :: forall e. Eff e Boolean -> Eff e Unit
+
+-- | Loop while a condition is `true`.
+-- |
+-- | `whileE b m` is effectful computation which runs the effectful computation `b`. If its result is
+-- | `true`, it runs the effectful computation `m` and loops. If not, the computation ends.
+foreign import whileE :: forall e a. Eff e Boolean -> Eff e a -> Eff e Unit
+
+-- | Loop over a consecutive collection of numbers.
+-- |
+-- | `forE lo hi f` runs the computation returned by the function `f` for each of the inputs
+-- | between `lo` (inclusive) and `hi` (exclusive).
+foreign import forE :: forall e. Number -> Number -> (Number -> Eff e Unit) -> Eff e Unit
+
+-- | Loop over an array of values.
+-- |
+-- | `foreach xs f` runs the computation returned by the function `f` for each of the inputs `xs`.
+foreign import foreachE :: forall e a. Array a -> (a -> Eff e Unit) -> Eff e Unit
diff --git a/tests/support/flattened/Control-Monad-ST.js b/tests/support/flattened/Control-Monad-ST.js
new file mode 100644
index 0000000..64597c1
--- /dev/null
+++ b/tests/support/flattened/Control-Monad-ST.js
@@ -0,0 +1,38 @@
+/* global exports */
+"use strict";
+
+// module Control.Monad.ST
+
+exports.newSTRef = function (val) {
+ return function () {
+ return { value: val };
+ };
+};
+
+exports.readSTRef = function (ref) {
+ return function () {
+ return ref.value;
+ };
+};
+
+exports.modifySTRef = function (ref) {
+ return function (f) {
+ return function () {
+ /* jshint boss: true */
+ return ref.value = f(ref.value);
+ };
+ };
+};
+
+exports.writeSTRef = function (ref) {
+ return function (a) {
+ return function () {
+ /* jshint boss: true */
+ return ref.value = a;
+ };
+ };
+};
+
+exports.runST = function (f) {
+ return f;
+};
diff --git a/tests/support/flattened/Control-Monad-ST.purs b/tests/support/flattened/Control-Monad-ST.purs
new file mode 100644
index 0000000..ac113e5
--- /dev/null
+++ b/tests/support/flattened/Control-Monad-ST.purs
@@ -0,0 +1,42 @@
+module Control.Monad.ST where
+
+import Prelude
+
+import Control.Monad.Eff (Eff(), runPure)
+
+-- | The `ST` effect represents _local mutation_, i.e. mutation which does not "escape" into the surrounding computation.
+-- |
+-- | An `ST` computation is parameterized by a phantom type which is used to restrict the set of reference cells it is allowed to access.
+-- |
+-- | The `runST` function can be used to handle the `ST` effect.
+foreign import data ST :: * -> !
+
+-- | The type `STRef s a` represents a mutable reference holding a value of type `a`, which can be used with the `ST s` effect.
+foreign import data STRef :: * -> * -> *
+
+-- | Create a new mutable reference.
+foreign import newSTRef :: forall a h r. a -> Eff (st :: ST h | r) (STRef h a)
+
+-- | Read the current value of a mutable reference.
+foreign import readSTRef :: forall a h r. STRef h a -> Eff (st :: ST h | r) a
+
+-- | Modify the value of a mutable reference by applying a function to the current value.
+foreign import modifySTRef :: forall a h r. STRef h a -> (a -> a) -> Eff (st :: ST h | r) a
+
+-- | Set the value of a mutable reference.
+foreign import writeSTRef :: forall a h r. STRef h a -> a -> Eff (st :: ST h | r) a
+
+-- | Run an `ST` computation.
+-- |
+-- | Note: the type of `runST` uses a rank-2 type to constrain the phantom type `s`, such that the computation must not leak any mutable references
+-- | to the surrounding computation.
+-- |
+-- | It may cause problems to apply this function using the `$` operator. The recommended approach is to use parentheses instead.
+foreign import runST :: forall a r. (forall h. Eff (st :: ST h | r) a) -> Eff r a
+
+-- | A convenience function which combines `runST` with `runPure`, which can be used when the only required effect is `ST`.
+-- |
+-- | Note: since this function has a rank-2 type, it may cause problems to apply this function using the `$` operator. The recommended approach
+-- | is to use parentheses instead.
+pureST :: forall a. (forall h r. Eff (st :: ST h | r) a) -> a
+pureST st = runPure (runST st)
diff --git a/tests/support/flattened/Data-Function.js b/tests/support/flattened/Data-Function.js
new file mode 100644
index 0000000..0d6d0f4
--- /dev/null
+++ b/tests/support/flattened/Data-Function.js
@@ -0,0 +1,233 @@
+/* global exports */
+"use strict";
+
+// module Data.Function
+
+exports.mkFn0 = function (fn) {
+ return function () {
+ return fn({});
+ };
+};
+
+exports.mkFn1 = function (fn) {
+ return function (a) {
+ return fn(a);
+ };
+};
+
+exports.mkFn2 = function (fn) {
+ /* jshint maxparams: 2 */
+ return function (a, b) {
+ return fn(a)(b);
+ };
+};
+
+exports.mkFn3 = function (fn) {
+ /* jshint maxparams: 3 */
+ return function (a, b, c) {
+ return fn(a)(b)(c);
+ };
+};
+
+exports.mkFn4 = function (fn) {
+ /* jshint maxparams: 4 */
+ return function (a, b, c, d) {
+ return fn(a)(b)(c)(d);
+ };
+};
+
+exports.mkFn5 = function (fn) {
+ /* jshint maxparams: 5 */
+ return function (a, b, c, d, e) {
+ return fn(a)(b)(c)(d)(e);
+ };
+};
+
+exports.mkFn6 = function (fn) {
+ /* jshint maxparams: 6 */
+ return function (a, b, c, d, e, f) {
+ return fn(a)(b)(c)(d)(e)(f);
+ };
+};
+
+exports.mkFn7 = function (fn) {
+ /* jshint maxparams: 7 */
+ return function (a, b, c, d, e, f, g) {
+ return fn(a)(b)(c)(d)(e)(f)(g);
+ };
+};
+
+exports.mkFn8 = function (fn) {
+ /* jshint maxparams: 8 */
+ return function (a, b, c, d, e, f, g, h) {
+ return fn(a)(b)(c)(d)(e)(f)(g)(h);
+ };
+};
+
+exports.mkFn9 = function (fn) {
+ /* jshint maxparams: 9 */
+ return function (a, b, c, d, e, f, g, h, i) {
+ return fn(a)(b)(c)(d)(e)(f)(g)(h)(i);
+ };
+};
+
+exports.mkFn10 = function (fn) {
+ /* jshint maxparams: 10 */
+ return function (a, b, c, d, e, f, g, h, i, j) {
+ return fn(a)(b)(c)(d)(e)(f)(g)(h)(i)(j);
+ };
+};
+
+exports.runFn0 = function (fn) {
+ return fn();
+};
+
+exports.runFn1 = function (fn) {
+ return function (a) {
+ return fn(a);
+ };
+};
+
+exports.runFn2 = function (fn) {
+ return function (a) {
+ return function (b) {
+ return fn(a, b);
+ };
+ };
+};
+
+exports.runFn3 = function (fn) {
+ return function (a) {
+ return function (b) {
+ return function (c) {
+ return fn(a, b, c);
+ };
+ };
+ };
+};
+
+exports.runFn4 = function (fn) {
+ return function (a) {
+ return function (b) {
+ return function (c) {
+ return function (d) {
+ return fn(a, b, c, d);
+ };
+ };
+ };
+ };
+};
+
+exports.runFn5 = function (fn) {
+ return function (a) {
+ return function (b) {
+ return function (c) {
+ return function (d) {
+ return function (e) {
+ return fn(a, b, c, d, e);
+ };
+ };
+ };
+ };
+ };
+};
+
+exports.runFn6 = function (fn) {
+ return function (a) {
+ return function (b) {
+ return function (c) {
+ return function (d) {
+ return function (e) {
+ return function (f) {
+ return fn(a, b, c, d, e, f);
+ };
+ };
+ };
+ };
+ };
+ };
+};
+
+exports.runFn7 = function (fn) {
+ return function (a) {
+ return function (b) {
+ return function (c) {
+ return function (d) {
+ return function (e) {
+ return function (f) {
+ return function (g) {
+ return fn(a, b, c, d, e, f, g);
+ };
+ };
+ };
+ };
+ };
+ };
+ };
+};
+
+exports.runFn8 = function (fn) {
+ return function (a) {
+ return function (b) {
+ return function (c) {
+ return function (d) {
+ return function (e) {
+ return function (f) {
+ return function (g) {
+ return function (h) {
+ return fn(a, b, c, d, e, f, g, h);
+ };
+ };
+ };
+ };
+ };
+ };
+ };
+ };
+};
+
+exports.runFn9 = function (fn) {
+ return function (a) {
+ return function (b) {
+ return function (c) {
+ return function (d) {
+ return function (e) {
+ return function (f) {
+ return function (g) {
+ return function (h) {
+ return function (i) {
+ return fn(a, b, c, d, e, f, g, h, i);
+ };
+ };
+ };
+ };
+ };
+ };
+ };
+ };
+ };
+};
+
+exports.runFn10 = function (fn) {
+ return function (a) {
+ return function (b) {
+ return function (c) {
+ return function (d) {
+ return function (e) {
+ return function (f) {
+ return function (g) {
+ return function (h) {
+ return function (i) {
+ return function (j) {
+ return fn(a, b, c, d, e, f, g, h, i, j);
+ };
+ };
+ };
+ };
+ };
+ };
+ };
+ };
+ };
+ };
+};
diff --git a/tests/support/flattened/Data-Function.purs b/tests/support/flattened/Data-Function.purs
new file mode 100644
index 0000000..37ceca1
--- /dev/null
+++ b/tests/support/flattened/Data-Function.purs
@@ -0,0 +1,113 @@
+module Data.Function where
+
+import Prelude
+
+-- | The `on` function is used to change the domain of a binary operator.
+-- |
+-- | For example, we can create a function which compares two records based on the values of their `x` properties:
+-- |
+-- | ```purescript
+-- | compareX :: forall r. { x :: Number | r } -> { x :: Number | r } -> Ordering
+-- | compareX = compare `on` _.x
+-- | ```
+on :: forall a b c. (b -> b -> c) -> (a -> b) -> a -> a -> c
+on f g x y = g x `f` g y
+
+-- | A function of zero arguments
+foreign import data Fn0 :: * -> *
+
+-- | A function of one argument
+foreign import data Fn1 :: * -> * -> *
+
+-- | A function of two arguments
+foreign import data Fn2 :: * -> * -> * -> *
+
+-- | A function of three arguments
+foreign import data Fn3 :: * -> * -> * -> * -> *
+
+-- | A function of four arguments
+foreign import data Fn4 :: * -> * -> * -> * -> * -> *
+
+-- | A function of five arguments
+foreign import data Fn5 :: * -> * -> * -> * -> * -> * -> *
+
+-- | A function of six arguments
+foreign import data Fn6 :: * -> * -> * -> * -> * -> * -> * -> *
+
+-- | A function of seven arguments
+foreign import data Fn7 :: * -> * -> * -> * -> * -> * -> * -> * -> *
+
+-- | A function of eight arguments
+foreign import data Fn8 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> *
+
+-- | A function of nine arguments
+foreign import data Fn9 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> *
+
+-- | A function of ten arguments
+foreign import data Fn10 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> *
+
+-- | Create a function of no arguments
+foreign import mkFn0 :: forall a. (Unit -> a) -> Fn0 a
+
+-- | Create a function of one argument
+foreign import mkFn1 :: forall a b. (a -> b) -> Fn1 a b
+
+-- | Create a function of two arguments from a curried function
+foreign import mkFn2 :: forall a b c. (a -> b -> c) -> Fn2 a b c
+
+-- | Create a function of three arguments from a curried function
+foreign import mkFn3 :: forall a b c d. (a -> b -> c -> d) -> Fn3 a b c d
+
+-- | Create a function of four arguments from a curried function
+foreign import mkFn4 :: forall a b c d e. (a -> b -> c -> d -> e) -> Fn4 a b c d e
+
+-- | Create a function of five arguments from a curried function
+foreign import mkFn5 :: forall a b c d e f. (a -> b -> c -> d -> e -> f) -> Fn5 a b c d e f
+
+-- | Create a function of six arguments from a curried function
+foreign import mkFn6 :: forall a b c d e f g. (a -> b -> c -> d -> e -> f -> g) -> Fn6 a b c d e f g
+
+-- | Create a function of seven arguments from a curried function
+foreign import mkFn7 :: forall a b c d e f g h. (a -> b -> c -> d -> e -> f -> g -> h) -> Fn7 a b c d e f g h
+
+-- | Create a function of eight arguments from a curried function
+foreign import mkFn8 :: forall a b c d e f g h i. (a -> b -> c -> d -> e -> f -> g -> h -> i) -> Fn8 a b c d e f g h i
+
+-- | Create a function of nine arguments from a curried function
+foreign import mkFn9 :: forall a b c d e f g h i j. (a -> b -> c -> d -> e -> f -> g -> h -> i -> j) -> Fn9 a b c d e f g h i j
+
+-- | Create a function of ten arguments from a curried function
+foreign import mkFn10 :: forall a b c d e f g h i j k. (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k) -> Fn10 a b c d e f g h i j k
+
+-- | Apply a function of no arguments
+foreign import runFn0 :: forall a. Fn0 a -> a
+
+-- | Apply a function of one argument
+foreign import runFn1 :: forall a b. Fn1 a b -> a -> b
+
+-- | Apply a function of two arguments
+foreign import runFn2 :: forall a b c. Fn2 a b c -> a -> b -> c
+
+-- | Apply a function of three arguments
+foreign import runFn3 :: forall a b c d. Fn3 a b c d -> a -> b -> c -> d
+
+-- | Apply a function of four arguments
+foreign import runFn4 :: forall a b c d e. Fn4 a b c d e -> a -> b -> c -> d -> e
+
+-- | Apply a function of five arguments
+foreign import runFn5 :: forall a b c d e f. Fn5 a b c d e f -> a -> b -> c -> d -> e -> f
+
+-- | Apply a function of six arguments
+foreign import runFn6 :: forall a b c d e f g. Fn6 a b c d e f g -> a -> b -> c -> d -> e -> f -> g
+
+-- | Apply a function of seven arguments
+foreign import runFn7 :: forall a b c d e f g h. Fn7 a b c d e f g h -> a -> b -> c -> d -> e -> f -> g -> h
+
+-- | Apply a function of eight arguments
+foreign import runFn8 :: forall a b c d e f g h i. Fn8 a b c d e f g h i -> a -> b -> c -> d -> e -> f -> g -> h -> i
+
+-- | Apply a function of nine arguments
+foreign import runFn9 :: forall a b c d e f g h i j. Fn9 a b c d e f g h i j -> a -> b -> c -> d -> e -> f -> g -> h -> i -> j
+
+-- | Apply a function of ten arguments
+foreign import runFn10 :: forall a b c d e f g h i j k. Fn10 a b c d e f g h i j k -> a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k
diff --git a/tests/support/flattened/Prelude.js b/tests/support/flattened/Prelude.js
new file mode 100644
index 0000000..72a855a
--- /dev/null
+++ b/tests/support/flattened/Prelude.js
@@ -0,0 +1,228 @@
+/* global exports */
+"use strict";
+
+// module Prelude
+
+//- Functor --------------------------------------------------------------------
+
+exports.arrayMap = function (f) {
+ return function (arr) {
+ var l = arr.length;
+ var result = new Array(l);
+ for (var i = 0; i < l; i++) {
+ result[i] = f(arr[i]);
+ }
+ return result;
+ };
+};
+
+//- Bind -----------------------------------------------------------------------
+
+exports.arrayBind = function (arr) {
+ return function (f) {
+ var result = [];
+ for (var i = 0, l = arr.length; i < l; i++) {
+ Array.prototype.push.apply(result, f(arr[i]));
+ }
+ return result;
+ };
+};
+
+//- Monoid ---------------------------------------------------------------------
+
+exports.concatString = function (s1) {
+ return function (s2) {
+ return s1 + s2;
+ };
+};
+
+exports.concatArray = function (xs) {
+ return function (ys) {
+ return xs.concat(ys);
+ };
+};
+
+//- Semiring -------------------------------------------------------------------
+
+exports.intAdd = function (x) {
+ return function (y) {
+ /* jshint bitwise: false */
+ return x + y | 0;
+ };
+};
+
+exports.intMul = function (x) {
+ return function (y) {
+ /* jshint bitwise: false */
+ return x * y | 0;
+ };
+};
+
+exports.numAdd = function (n1) {
+ return function (n2) {
+ return n1 + n2;
+ };
+};
+
+exports.numMul = function (n1) {
+ return function (n2) {
+ return n1 * n2;
+ };
+};
+
+//- ModuloSemiring -------------------------------------------------------------
+
+exports.intDiv = function (x) {
+ return function (y) {
+ /* jshint bitwise: false */
+ return x / y | 0;
+ };
+};
+
+exports.intMod = function (x) {
+ return function (y) {
+ return x % y;
+ };
+};
+
+exports.numDiv = function (n1) {
+ return function (n2) {
+ return n1 / n2;
+ };
+};
+
+//- Ring -----------------------------------------------------------------------
+
+exports.intSub = function (x) {
+ return function (y) {
+ /* jshint bitwise: false */
+ return x - y | 0;
+ };
+};
+
+exports.numSub = function (n1) {
+ return function (n2) {
+ return n1 - n2;
+ };
+};
+
+//- Eq -------------------------------------------------------------------------
+
+exports.refEq = function (r1) {
+ return function (r2) {
+ return r1 === r2;
+ };
+};
+
+exports.refIneq = function (r1) {
+ return function (r2) {
+ return r1 !== r2;
+ };
+};
+
+exports.eqArrayImpl = function (f) {
+ return function (xs) {
+ return function (ys) {
+ if (xs.length !== ys.length) return false;
+ for (var i = 0; i < xs.length; i++) {
+ if (!f(xs[i])(ys[i])) return false;
+ }
+ return true;
+ };
+ };
+};
+
+exports.ordArrayImpl = function (f) {
+ return function (xs) {
+ return function (ys) {
+ var i = 0;
+ var xlen = xs.length;
+ var ylen = ys.length;
+ while (i < xlen && i < ylen) {
+ var x = xs[i];
+ var y = ys[i];
+ var o = f(x)(y);
+ if (o !== 0) {
+ return o;
+ }
+ i++;
+ }
+ if (xlen === ylen) {
+ return 0;
+ } else if (xlen > ylen) {
+ return -1;
+ } else {
+ return 1;
+ }
+ };
+ };
+};
+
+//- Ord ------------------------------------------------------------------------
+
+exports.unsafeCompareImpl = function (lt) {
+ return function (eq) {
+ return function (gt) {
+ return function (x) {
+ return function (y) {
+ return x < y ? lt : x > y ? gt : eq;
+ };
+ };
+ };
+ };
+};
+
+//- Bounded --------------------------------------------------------------------
+
+exports.topInt = 2147483647;
+exports.bottomInt = -2147483648;
+
+exports.topChar = String.fromCharCode(65535);
+exports.bottomChar = String.fromCharCode(0);
+
+//- BooleanAlgebra -------------------------------------------------------------
+
+exports.boolOr = function (b1) {
+ return function (b2) {
+ return b1 || b2;
+ };
+};
+
+exports.boolAnd = function (b1) {
+ return function (b2) {
+ return b1 && b2;
+ };
+};
+
+exports.boolNot = function (b) {
+ return !b;
+};
+
+//- Show -----------------------------------------------------------------------
+
+exports.showIntImpl = function (n) {
+ return n.toString();
+};
+
+exports.showNumberImpl = function (n) {
+ /* jshint bitwise: false */
+ return n === (n | 0) ? n + ".0" : n.toString();
+};
+
+exports.showCharImpl = function (c) {
+ return c === "'" ? "'\\''" : "'" + c + "'";
+};
+
+exports.showStringImpl = function (s) {
+ return JSON.stringify(s);
+};
+
+exports.showArrayImpl = function (f) {
+ return function (xs) {
+ var ss = [];
+ for (var i = 0, l = xs.length; i < l; i++) {
+ ss[i] = f(xs[i]);
+ }
+ return "[" + ss.join(",") + "]";
+ };
+};
diff --git a/tests/support/flattened/Prelude.purs b/tests/support/flattened/Prelude.purs
new file mode 100644
index 0000000..21ec909
--- /dev/null
+++ b/tests/support/flattened/Prelude.purs
@@ -0,0 +1,872 @@
+module Prelude
+ ( Unit(), unit
+ , ($), (#)
+ , flip
+ , const
+ , asTypeOf
+ , otherwise
+ , Semigroupoid, compose, (<<<), (>>>)
+ , Category, id
+ , Functor, map, (<$>), (<#>), void
+ , Apply, apply, (<*>)
+ , Applicative, pure, liftA1
+ , Bind, bind, (>>=)
+ , Monad, return, liftM1, ap
+ , Semigroup, append, (<>), (++)
+ , Semiring, add, zero, mul, one, (+), (*)
+ , ModuloSemiring, div, mod, (/)
+ , Ring, sub, negate, (-)
+ , Num
+ , DivisionRing
+ , Eq, eq, (==), (/=)
+ , Ordering(..), Ord, compare, (<), (>), (<=), (>=)
+ , unsafeCompare
+ , Bounded, top, bottom
+ , BoundedOrd
+ , BooleanAlgebra, conj, disj, not, (&&), (||)
+ , Show, show
+ ) where
+
+-- | The `Unit` type has a single inhabitant, called `unit`. It represents
+-- | values with no computational content.
+-- |
+-- | `Unit` is often used, wrapped in a monadic type constructor, as the
+-- | return type of a computation where only
+-- | the _effects_ are important.
+newtype Unit = Unit {}
+
+-- | `unit` is the sole inhabitant of the `Unit` type.
+unit :: Unit
+unit = Unit {}
+
+infixr 0 $
+infixl 1 #
+
+-- | Applies a function to its argument.
+-- |
+-- | ```purescript
+-- | length $ groupBy productCategory $ filter isInStock $ products
+-- | ```
+-- |
+-- | is equivalent to:
+-- |
+-- | ```purescript
+-- | length (groupBy productCategory (filter isInStock products))
+-- | ```
+-- |
+-- | `($)` is different from [`(#)`](#-2) because it is right-infix instead of
+-- | left: `a $ b $ c $ d x = a $ (b $ (c $ (d $ x))) = a (b (c (d x)))`
+($) :: forall a b. (a -> b) -> a -> b
+($) f x = f x
+
+-- | Applies an argument to a function.
+-- |
+-- | ```purescript
+-- | products # filter isInStock # groupBy productCategory # length
+-- | ```
+-- |
+-- | is equivalent to:
+-- |
+-- | ```purescript
+-- | length (groupBy productCategory (filter isInStock products))
+-- | ```
+-- |
+-- | `(#)` is different from [`($)`](#-1) because it is left-infix instead of
+-- | right: `x # a # b # c # d = (((x # a) # b) # c) # d = d (c (b (a x)))`
+(#) :: forall a b. a -> (a -> b) -> b
+(#) x f = f x
+
+-- | Flips the order of the arguments to a function of two arguments.
+-- |
+-- | ```purescript
+-- | flip const 1 2 = const 2 1 = 2
+-- | ```
+flip :: forall a b c. (a -> b -> c) -> b -> a -> c
+flip f b a = f a b
+
+-- | Returns its first argument and ignores its second.
+-- |
+-- | ```purescript
+-- | const 1 "hello" = 1
+-- | ```
+const :: forall a b. a -> b -> a
+const a _ = a
+
+-- | This function returns its first argument, and can be used to assert type
+-- | equalities. This can be useful when types are otherwise ambiguous.
+-- |
+-- | ```purescript
+-- | main = print $ [] `asTypeOf` [0]
+-- | ```
+-- |
+-- | If instead, we had written `main = print []`, the type of the argument
+-- | `[]` would have been ambiguous, resulting in a compile-time error.
+asTypeOf :: forall a. a -> a -> a
+asTypeOf x _ = x
+
+-- | An alias for `true`, which can be useful in guard clauses:
+-- |
+-- | ```purescript
+-- | max x y | x >= y = x
+-- | | otherwise = y
+-- | ```
+otherwise :: Boolean
+otherwise = true
+
+-- | A `Semigroupoid` is similar to a [`Category`](#category) but does not
+-- | require an identity element `id`, just composable morphisms.
+-- |
+-- | `Semigroupoid`s must satisfy the following law:
+-- |
+-- | - Associativity: `p <<< (q <<< r) = (p <<< q) <<< r`
+-- |
+-- | One example of a `Semigroupoid` is the function type constructor `(->)`,
+-- | with `(<<<)` defined as function composition.
+class Semigroupoid a where
+ compose :: forall b c d. a c d -> a b c -> a b d
+
+instance semigroupoidFn :: Semigroupoid (->) where
+ compose f g x = f (g x)
+
+infixr 9 >>>
+infixr 9 <<<
+
+-- | `(<<<)` is an alias for `compose`.
+(<<<) :: forall a b c d. (Semigroupoid a) => a c d -> a b c -> a b d
+(<<<) = compose
+
+-- | Forwards composition, or `(<<<)` with its arguments reversed.
+(>>>) :: forall a b c d. (Semigroupoid a) => a b c -> a c d -> a b d
+(>>>) = flip compose
+
+-- | `Category`s consist of objects and composable morphisms between them, and
+-- | as such are [`Semigroupoids`](#semigroupoid), but unlike `semigroupoids`
+-- | must have an identity element.
+-- |
+-- | Instances must satisfy the following law in addition to the
+-- | `Semigroupoid` law:
+-- |
+-- | - Identity: `id <<< p = p <<< id = p`
+class (Semigroupoid a) <= Category a where
+ id :: forall t. a t t
+
+instance categoryFn :: Category (->) where
+ id x = x
+
+-- | A `Functor` is a type constructor which supports a mapping operation
+-- | `(<$>)`.
+-- |
+-- | `(<$>)` can be used to turn functions `a -> b` into functions
+-- | `f a -> f b` whose argument and return types use the type constructor `f`
+-- | to represent some computational context.
+-- |
+-- | Instances must satisfy the following laws:
+-- |
+-- | - Identity: `(<$>) id = id`
+-- | - Composition: `(<$>) (f <<< g) = (f <$>) <<< (g <$>)`
+class Functor f where
+ map :: forall a b. (a -> b) -> f a -> f b
+
+instance functorFn :: Functor ((->) r) where
+ map = compose
+
+instance functorArray :: Functor Array where
+ map = arrayMap
+
+foreign import arrayMap :: forall a b. (a -> b) -> Array a -> Array b
+
+infixl 4 <$>
+infixl 1 <#>
+
+-- | `(<$>)` is an alias for `map`
+(<$>) :: forall f a b. (Functor f) => (a -> b) -> f a -> f b
+(<$>) = map
+
+-- | `(<#>)` is `(<$>)` with its arguments reversed. For example:
+-- |
+-- | ```purescript
+-- | [1, 2, 3] <#> \n -> n * n
+-- | ```
+(<#>) :: forall f a b. (Functor f) => f a -> (a -> b) -> f b
+(<#>) fa f = f <$> fa
+
+-- | The `void` function is used to ignore the type wrapped by a
+-- | [`Functor`](#functor), replacing it with `Unit` and keeping only the type
+-- | information provided by the type constructor itself.
+-- |
+-- | `void` is often useful when using `do` notation to change the return type
+-- | of a monadic computation:
+-- |
+-- | ```purescript
+-- | main = forE 1 10 \n -> void do
+-- | print n
+-- | print (n * n)
+-- | ```
+void :: forall f a. (Functor f) => f a -> f Unit
+void fa = const unit <$> fa
+
+-- | The `Apply` class provides the `(<*>)` which is used to apply a function
+-- | to an argument under a type constructor.
+-- |
+-- | `Apply` can be used to lift functions of two or more arguments to work on
+-- | values wrapped with the type constructor `f`. It might also be understood
+-- | in terms of the `lift2` function:
+-- |
+-- | ```purescript
+-- | lift2 :: forall f a b c. (Apply f) => (a -> b -> c) -> f a -> f b -> f c
+-- | lift2 f a b = f <$> a <*> b
+-- | ```
+-- |
+-- | `(<*>)` is recovered from `lift2` as `lift2 ($)`. That is, `(<*>)` lifts
+-- | the function application operator `($)` to arguments wrapped with the
+-- | type constructor `f`.
+-- |
+-- | Instances must satisfy the following law in addition to the `Functor`
+-- | laws:
+-- |
+-- | - Associative composition: `(<<<) <$> f <*> g <*> h = f <*> (g <*> h)`
+-- |
+-- | Formally, `Apply` represents a strong lax semi-monoidal endofunctor.
+class (Functor f) <= Apply f where
+ apply :: forall a b. f (a -> b) -> f a -> f b
+
+instance applyFn :: Apply ((->) r) where
+ apply f g x = f x (g x)
+
+instance applyArray :: Apply Array where
+ apply = ap
+
+infixl 4 <*>
+
+-- | `(<*>)` is an alias for `apply`.
+(<*>) :: forall f a b. (Apply f) => f (a -> b) -> f a -> f b
+(<*>) = apply
+
+-- | The `Applicative` type class extends the [`Apply`](#apply) type class
+-- | with a `pure` function, which can be used to create values of type `f a`
+-- | from values of type `a`.
+-- |
+-- | Where [`Apply`](#apply) provides the ability to lift functions of two or
+-- | more arguments to functions whose arguments are wrapped using `f`, and
+-- | [`Functor`](#functor) provides the ability to lift functions of one
+-- | argument, `pure` can be seen as the function which lifts functions of
+-- | _zero_ arguments. That is, `Applicative` functors support a lifting
+-- | operation for any number of function arguments.
+-- |
+-- | Instances must satisfy the following laws in addition to the `Apply`
+-- | laws:
+-- |
+-- | - Identity: `(pure id) <*> v = v`
+-- | - Composition: `(pure <<<) <*> f <*> g <*> h = f <*> (g <*> h)`
+-- | - Homomorphism: `(pure f) <*> (pure x) = pure (f x)`
+-- | - Interchange: `u <*> (pure y) = (pure ($ y)) <*> u`
+class (Apply f) <= Applicative f where
+ pure :: forall a. a -> f a
+
+instance applicativeFn :: Applicative ((->) r) where
+ pure = const
+
+instance applicativeArray :: Applicative Array where
+ pure x = [x]
+
+-- | `return` is an alias for `pure`.
+return :: forall m a. (Applicative m) => a -> m a
+return = pure
+
+-- | `liftA1` provides a default implementation of `(<$>)` for any
+-- | [`Applicative`](#applicative) functor, without using `(<$>)` as provided
+-- | by the [`Functor`](#functor)-[`Applicative`](#applicative) superclass
+-- | relationship.
+-- |
+-- | `liftA1` can therefore be used to write [`Functor`](#functor) instances
+-- | as follows:
+-- |
+-- | ```purescript
+-- | instance functorF :: Functor F where
+-- | map = liftA1
+-- | ```
+liftA1 :: forall f a b. (Applicative f) => (a -> b) -> f a -> f b
+liftA1 f a = pure f <*> a
+
+-- | The `Bind` type class extends the [`Apply`](#apply) type class with a
+-- | "bind" operation `(>>=)` which composes computations in sequence, using
+-- | the return value of one computation to determine the next computation.
+-- |
+-- | The `>>=` operator can also be expressed using `do` notation, as follows:
+-- |
+-- | ```purescript
+-- | x >>= f = do y <- x
+-- | f y
+-- | ```
+-- |
+-- | where the function argument of `f` is given the name `y`.
+-- |
+-- | Instances must satisfy the following law in addition to the `Apply`
+-- | laws:
+-- |
+-- | - Associativity: `(x >>= f) >>= g = x >>= (\k => f k >>= g)`
+-- |
+-- | Associativity tells us that we can regroup operations which use `do`
+-- | notation so that we can unambiguously write, for example:
+-- |
+-- | ```purescript
+-- | do x <- m1
+-- | y <- m2 x
+-- | m3 x y
+-- | ```
+class (Apply m) <= Bind m where
+ bind :: forall a b. m a -> (a -> m b) -> m b
+
+instance bindFn :: Bind ((->) r) where
+ bind m f x = f (m x) x
+
+instance bindArray :: Bind Array where
+ bind = arrayBind
+
+foreign import arrayBind :: forall a b. Array a -> (a -> Array b) -> Array b
+
+infixl 1 >>=
+
+-- | `(>>=)` is an alias for `bind`.
+(>>=) :: forall m a b. (Bind m) => m a -> (a -> m b) -> m b
+(>>=) = bind
+
+-- | The `Monad` type class combines the operations of the `Bind` and
+-- | `Applicative` type classes. Therefore, `Monad` instances represent type
+-- | constructors which support sequential composition, and also lifting of
+-- | functions of arbitrary arity.
+-- |
+-- | Instances must satisfy the following laws in addition to the
+-- | `Applicative` and `Bind` laws:
+-- |
+-- | - Left Identity: `pure x >>= f = f x`
+-- | - Right Identity: `x >>= pure = x`
+class (Applicative m, Bind m) <= Monad m
+
+instance monadFn :: Monad ((->) r)
+instance monadArray :: Monad Array
+
+-- | `liftM1` provides a default implementation of `(<$>)` for any
+-- | [`Monad`](#monad), without using `(<$>)` as provided by the
+-- | [`Functor`](#functor)-[`Monad`](#monad) superclass relationship.
+-- |
+-- | `liftM1` can therefore be used to write [`Functor`](#functor) instances
+-- | as follows:
+-- |
+-- | ```purescript
+-- | instance functorF :: Functor F where
+-- | map = liftM1
+-- | ```
+liftM1 :: forall m a b. (Monad m) => (a -> b) -> m a -> m b
+liftM1 f a = do
+ a' <- a
+ return (f a')
+
+-- | `ap` provides a default implementation of `(<*>)` for any
+-- | [`Monad`](#monad), without using `(<*>)` as provided by the
+-- | [`Apply`](#apply)-[`Monad`](#monad) superclass relationship.
+-- |
+-- | `ap` can therefore be used to write [`Apply`](#apply) instances as
+-- | follows:
+-- |
+-- | ```purescript
+-- | instance applyF :: Apply F where
+-- | apply = ap
+-- | ```
+ap :: forall m a b. (Monad m) => m (a -> b) -> m a -> m b
+ap f a = do
+ f' <- f
+ a' <- a
+ return (f' a')
+
+-- | The `Semigroup` type class identifies an associative operation on a type.
+-- |
+-- | Instances are required to satisfy the following law:
+-- |
+-- | - Associativity: `(x <> y) <> z = x <> (y <> z)`
+-- |
+-- | One example of a `Semigroup` is `String`, with `(<>)` defined as string
+-- | concatenation.
+class Semigroup a where
+ append :: a -> a -> a
+
+infixr 5 <>
+infixr 5 ++
+
+-- | `(<>)` is an alias for `append`.
+(<>) :: forall s. (Semigroup s) => s -> s -> s
+(<>) = append
+
+-- | `(++)` is an alternative alias for `append`.
+(++) :: forall s. (Semigroup s) => s -> s -> s
+(++) = append
+
+instance semigroupString :: Semigroup String where
+ append = concatString
+
+instance semigroupUnit :: Semigroup Unit where
+ append _ _ = unit
+
+instance semigroupFn :: (Semigroup s') => Semigroup (s -> s') where
+ append f g = \x -> f x <> g x
+
+instance semigroupOrdering :: Semigroup Ordering where
+ append LT _ = LT
+ append GT _ = GT
+ append EQ y = y
+
+instance semigroupArray :: Semigroup (Array a) where
+ append = concatArray
+
+foreign import concatString :: String -> String -> String
+foreign import concatArray :: forall a. Array a -> Array a -> Array a
+
+-- | The `Semiring` class is for types that support an addition and
+-- | multiplication operation.
+-- |
+-- | Instances must satisfy the following laws:
+-- |
+-- | - Commutative monoid under addition:
+-- | - Associativity: `(a + b) + c = a + (b + c)`
+-- | - Identity: `zero + a = a + zero = a`
+-- | - Commutative: `a + b = b + a`
+-- | - Monoid under multiplication:
+-- | - Associativity: `(a * b) * c = a * (b * c)`
+-- | - Identity: `one * a = a * one = a`
+-- | - Multiplication distributes over addition:
+-- | - Left distributivity: `a * (b + c) = (a * b) + (a * c)`
+-- | - Right distributivity: `(a + b) * c = (a * c) + (b * c)`
+-- | - Annihiliation: `zero * a = a * zero = zero`
+class Semiring a where
+ add :: a -> a -> a
+ zero :: a
+ mul :: a -> a -> a
+ one :: a
+
+instance semiringInt :: Semiring Int where
+ add = intAdd
+ zero = 0
+ mul = intMul
+ one = 1
+
+instance semiringNumber :: Semiring Number where
+ add = numAdd
+ zero = 0.0
+ mul = numMul
+ one = 1.0
+
+instance semiringUnit :: Semiring Unit where
+ add _ _ = unit
+ zero = unit
+ mul _ _ = unit
+ one = unit
+
+infixl 6 +
+infixl 7 *
+
+-- | `(+)` is an alias for `add`.
+(+) :: forall a. (Semiring a) => a -> a -> a
+(+) = add
+
+-- | `(*)` is an alias for `mul`.
+(*) :: forall a. (Semiring a) => a -> a -> a
+(*) = mul
+
+foreign import intAdd :: Int -> Int -> Int
+foreign import intMul :: Int -> Int -> Int
+foreign import numAdd :: Number -> Number -> Number
+foreign import numMul :: Number -> Number -> Number
+
+-- | The `Ring` class is for types that support addition, multiplication,
+-- | and subtraction operations.
+-- |
+-- | Instances must satisfy the following law in addition to the `Semiring`
+-- | laws:
+-- |
+-- | - Additive inverse: `a - a = (zero - a) + a = zero`
+class (Semiring a) <= Ring a where
+ sub :: a -> a -> a
+
+instance ringInt :: Ring Int where
+ sub = intSub
+
+instance ringNumber :: Ring Number where
+ sub = numSub
+
+instance ringUnit :: Ring Unit where
+ sub _ _ = unit
+
+infixl 6 -
+
+-- | `(-)` is an alias for `sub`.
+(-) :: forall a. (Ring a) => a -> a -> a
+(-) = sub
+
+-- | `negate x` can be used as a shorthand for `zero - x`.
+negate :: forall a. (Ring a) => a -> a
+negate a = zero - a
+
+foreign import intSub :: Int -> Int -> Int
+foreign import numSub :: Number -> Number -> Number
+
+-- | The `ModuloSemiring` class is for types that support addition,
+-- | multiplication, division, and modulo (division remainder) operations.
+-- |
+-- | Instances must satisfy the following law in addition to the `Semiring`
+-- | laws:
+-- |
+-- | - Remainder: ``a / b * b + (a `mod` b) = a``
+class (Semiring a) <= ModuloSemiring a where
+ div :: a -> a -> a
+ mod :: a -> a -> a
+
+instance moduloSemiringInt :: ModuloSemiring Int where
+ div = intDiv
+ mod = intMod
+
+instance moduloSemiringNumber :: ModuloSemiring Number where
+ div = numDiv
+ mod _ _ = 0.0
+
+instance moduloSemiringUnit :: ModuloSemiring Unit where
+ div _ _ = unit
+ mod _ _ = unit
+
+infixl 7 /
+
+-- | `(/)` is an alias for `div`.
+(/) :: forall a. (ModuloSemiring a) => a -> a -> a
+(/) = div
+
+foreign import intDiv :: Int -> Int -> Int
+foreign import numDiv :: Number -> Number -> Number
+foreign import intMod :: Int -> Int -> Int
+
+-- | A `Ring` where every nonzero element has a multiplicative inverse.
+-- |
+-- | Instances must satisfy the following law in addition to the `Ring` and
+-- | `ModuloSemiring` laws:
+-- |
+-- | - Multiplicative inverse: `(one / x) * x = one`
+-- |
+-- | As a consequence of this ```a `mod` b = zero``` as no divide operation
+-- | will have a remainder.
+class (Ring a, ModuloSemiring a) <= DivisionRing a
+
+instance divisionRingNumber :: DivisionRing Number
+instance divisionRingUnit :: DivisionRing Unit
+
+-- | The `Num` class is for types that are commutative fields.
+-- |
+-- | Instances must satisfy the following law in addition to the
+-- | `DivisionRing` laws:
+-- |
+-- | - Commutative multiplication: `a * b = b * a`
+class (DivisionRing a) <= Num a
+
+instance numNumber :: Num Number
+instance numUnit :: Num Unit
+
+-- | The `Eq` type class represents types which support decidable equality.
+-- |
+-- | `Eq` instances should satisfy the following laws:
+-- |
+-- | - Reflexivity: `x == x = true`
+-- | - Symmetry: `x == y = y == x`
+-- | - Transitivity: if `x == y` and `y == z` then `x == z`
+class Eq a where
+ eq :: a -> a -> Boolean
+
+infix 4 ==
+infix 4 /=
+
+-- | `(==)` is an alias for `eq`. Tests whether one value is equal to another.
+(==) :: forall a. (Eq a) => a -> a -> Boolean
+(==) = eq
+
+-- | `(/=)` tests whether one value is _not equal_ to another. Shorthand for
+-- | `not (x == y)`.
+(/=) :: forall a. (Eq a) => a -> a -> Boolean
+(/=) x y = not (x == y)
+
+instance eqBoolean :: Eq Boolean where
+ eq = refEq
+
+instance eqInt :: Eq Int where
+ eq = refEq
+
+instance eqNumber :: Eq Number where
+ eq = refEq
+
+instance eqChar :: Eq Char where
+ eq = refEq
+
+instance eqString :: Eq String where
+ eq = refEq
+
+instance eqUnit :: Eq Unit where
+ eq _ _ = true
+
+instance eqArray :: (Eq a) => Eq (Array a) where
+ eq = eqArrayImpl (==)
+
+instance eqOrdering :: Eq Ordering where
+ eq LT LT = true
+ eq GT GT = true
+ eq EQ EQ = true
+ eq _ _ = false
+
+foreign import refEq :: forall a. a -> a -> Boolean
+foreign import refIneq :: forall a. a -> a -> Boolean
+foreign import eqArrayImpl :: forall a. (a -> a -> Boolean) -> Array a -> Array a -> Boolean
+
+-- | The `Ordering` data type represents the three possible outcomes of
+-- | comparing two values:
+-- |
+-- | `LT` - The first value is _less than_ the second.
+-- | `GT` - The first value is _greater than_ the second.
+-- | `EQ` - The first value is _equal to_ the second.
+data Ordering = LT | GT | EQ
+
+-- | The `Ord` type class represents types which support comparisons with a
+-- | _total order_.
+-- |
+-- | `Ord` instances should satisfy the laws of total orderings:
+-- |
+-- | - Reflexivity: `a <= a`
+-- | - Antisymmetry: if `a <= b` and `b <= a` then `a = b`
+-- | - Transitivity: if `a <= b` and `b <= c` then `a <= c`
+class (Eq a) <= Ord a where
+ compare :: a -> a -> Ordering
+
+instance ordBoolean :: Ord Boolean where
+ compare = unsafeCompare
+
+instance ordInt :: Ord Int where
+ compare = unsafeCompare
+
+instance ordNumber :: Ord Number where
+ compare = unsafeCompare
+
+instance ordString :: Ord String where
+ compare = unsafeCompare
+
+instance ordChar :: Ord Char where
+ compare = unsafeCompare
+
+instance ordUnit :: Ord Unit where
+ compare _ _ = EQ
+
+instance ordArray :: (Ord a) => Ord (Array a) where
+ compare xs ys = compare 0 $ ordArrayImpl (\x y -> case compare x y of
+ EQ -> 0
+ LT -> 1
+ GT -> -1) xs ys
+
+foreign import ordArrayImpl :: forall a. (a -> a -> Int) -> Array a -> Array a -> Int
+
+instance ordOrdering :: Ord Ordering where
+ compare LT LT = EQ
+ compare EQ EQ = EQ
+ compare GT GT = EQ
+ compare LT _ = LT
+ compare EQ LT = GT
+ compare EQ GT = LT
+ compare GT _ = GT
+
+infixl 4 <
+infixl 4 >
+infixl 4 <=
+infixl 4 >=
+
+-- | Test whether one value is _strictly less than_ another.
+(<) :: forall a. (Ord a) => a -> a -> Boolean
+(<) a1 a2 = case a1 `compare` a2 of
+ LT -> true
+ _ -> false
+
+-- | Test whether one value is _strictly greater than_ another.
+(>) :: forall a. (Ord a) => a -> a -> Boolean
+(>) a1 a2 = case a1 `compare` a2 of
+ GT -> true
+ _ -> false
+
+-- | Test whether one value is _non-strictly less than_ another.
+(<=) :: forall a. (Ord a) => a -> a -> Boolean
+(<=) a1 a2 = case a1 `compare` a2 of
+ GT -> false
+ _ -> true
+
+-- | Test whether one value is _non-strictly greater than_ another.
+(>=) :: forall a. (Ord a) => a -> a -> Boolean
+(>=) a1 a2 = case a1 `compare` a2 of
+ LT -> false
+ _ -> true
+
+unsafeCompare :: forall a. a -> a -> Ordering
+unsafeCompare = unsafeCompareImpl LT EQ GT
+
+foreign import unsafeCompareImpl :: forall a. Ordering -> Ordering -> Ordering -> a -> a -> Ordering
+
+-- | The `Bounded` type class represents types that are finite.
+-- |
+-- | Although there are no "internal" laws for `Bounded`, every value of `a`
+-- | should be considered less than or equal to `top` by some means, and greater
+-- | than or equal to `bottom`.
+-- |
+-- | The lack of explicit `Ord` constraint allows flexibility in the use of
+-- | `Bounded` so it can apply to total and partially ordered sets, boolean
+-- | algebras, etc.
+class Bounded a where
+ top :: a
+ bottom :: a
+
+instance boundedBoolean :: Bounded Boolean where
+ top = true
+ bottom = false
+
+instance boundedUnit :: Bounded Unit where
+ top = unit
+ bottom = unit
+
+instance boundedOrdering :: Bounded Ordering where
+ top = GT
+ bottom = LT
+
+instance boundedInt :: Bounded Int where
+ top = topInt
+ bottom = bottomInt
+
+-- | Characters fall within the Unicode range.
+instance boundedChar :: Bounded Char where
+ top = topChar
+ bottom = bottomChar
+
+instance boundedFn :: (Bounded b) => Bounded (a -> b) where
+ top _ = top
+ bottom _ = bottom
+
+foreign import topInt :: Int
+foreign import bottomInt :: Int
+
+foreign import topChar :: Char
+foreign import bottomChar :: Char
+
+-- | The `BoundedOrd` type class represents totally ordered finite data types.
+-- |
+-- | Instances should satisfy the following law in addition to the `Ord` laws:
+-- |
+-- | - Ordering: `bottom <= a <= top`
+class (Bounded a, Ord a) <= BoundedOrd a
+
+instance boundedOrdBoolean :: BoundedOrd Boolean where
+instance boundedOrdUnit :: BoundedOrd Unit where
+instance boundedOrdOrdering :: BoundedOrd Ordering where
+instance boundedOrdInt :: BoundedOrd Int where
+instance boundedOrdChar :: BoundedOrd Char where
+
+-- | The `BooleanAlgebra` type class represents types that behave like boolean
+-- | values.
+-- |
+-- | Instances should satisfy the following laws in addition to the `Bounded`
+-- | laws:
+-- |
+-- | - Associativity:
+-- | - `a || (b || c) = (a || b) || c`
+-- | - `a && (b && c) = (a && b) && c`
+-- | - Commutativity:
+-- | - `a || b = b || a`
+-- | - `a && b = b && a`
+-- | - Distributivity:
+-- | - `a && (b || c) = (a && b) || (a && c)`
+-- | - `a || (b && c) = (a || b) && (a || c)`
+-- | - Identity:
+-- | - `a || bottom = a`
+-- | - `a && top = a`
+-- | - Idempotent:
+-- | - `a || a = a`
+-- | - `a && a = a`
+-- | - Absorption:
+-- | - `a || (a && b) = a`
+-- | - `a && (a || b) = a`
+-- | - Annhiliation:
+-- | - `a || top = top`
+-- | - Complementation:
+-- | - `a && not a = bottom`
+-- | - `a || not a = top`
+class (Bounded a) <= BooleanAlgebra a where
+ conj :: a -> a -> a
+ disj :: a -> a -> a
+ not :: a -> a
+
+instance booleanAlgebraBoolean :: BooleanAlgebra Boolean where
+ conj = boolAnd
+ disj = boolOr
+ not = boolNot
+
+instance booleanAlgebraUnit :: BooleanAlgebra Unit where
+ conj _ _ = unit
+ disj _ _ = unit
+ not _ = unit
+
+instance booleanAlgebraFn :: (BooleanAlgebra b) => BooleanAlgebra (a -> b) where
+ conj fx fy a = fx a `conj` fy a
+ disj fx fy a = fx a `disj` fy a
+ not fx a = not (fx a)
+
+infixr 3 &&
+infixr 2 ||
+
+-- | `(&&)` is an alias for `conj`.
+(&&) :: forall a. (BooleanAlgebra a) => a -> a -> a
+(&&) = conj
+
+-- | `(||)` is an alias for `disj`.
+(||) :: forall a. (BooleanAlgebra a) => a -> a -> a
+(||) = disj
+
+foreign import boolOr :: Boolean -> Boolean -> Boolean
+foreign import boolAnd :: Boolean -> Boolean -> Boolean
+foreign import boolNot :: Boolean -> Boolean
+
+-- | The `Show` type class represents those types which can be converted into
+-- | a human-readable `String` representation.
+-- |
+-- | While not required, it is recommended that for any expression `x`, the
+-- | string `show x` be executable PureScript code which evaluates to the same
+-- | value as the expression `x`.
+class Show a where
+ show :: a -> String
+
+instance showBoolean :: Show Boolean where
+ show true = "true"
+ show false = "false"
+
+instance showInt :: Show Int where
+ show = showIntImpl
+
+instance showNumber :: Show Number where
+ show = showNumberImpl
+
+instance showChar :: Show Char where
+ show = showCharImpl
+
+instance showString :: Show String where
+ show = showStringImpl
+
+instance showUnit :: Show Unit where
+ show _ = "unit"
+
+instance showArray :: (Show a) => Show (Array a) where
+ show = showArrayImpl show
+
+instance showOrdering :: Show Ordering where
+ show LT = "LT"
+ show GT = "GT"
+ show EQ = "EQ"
+
+foreign import showIntImpl :: Int -> String
+foreign import showNumberImpl :: Number -> String
+foreign import showCharImpl :: Char -> String
+foreign import showStringImpl :: String -> String
+foreign import showArrayImpl :: forall a. (a -> String) -> Array a -> String
diff --git a/tests/support/flattened/Test-Assert.js b/tests/support/flattened/Test-Assert.js
new file mode 100644
index 0000000..ad1a67c
--- /dev/null
+++ b/tests/support/flattened/Test-Assert.js
@@ -0,0 +1,27 @@
+/* global exports */
+"use strict";
+
+// module Test.Assert
+
+exports["assert'"] = function (message) {
+ return function (success) {
+ return function () {
+ if (!success) throw new Error(message);
+ return {};
+ };
+ };
+};
+
+exports.checkThrows = function (fn) {
+ return function () {
+ try {
+ fn();
+ return false;
+ } catch (e) {
+ if (e instanceof Error) return true;
+ var err = new Error("Threw something other than an Error");
+ err.something = e;
+ throw err;
+ }
+ };
+};
diff --git a/tests/support/flattened/Test-Assert.purs b/tests/support/flattened/Test-Assert.purs
new file mode 100644
index 0000000..66b8622
--- /dev/null
+++ b/tests/support/flattened/Test-Assert.purs
@@ -0,0 +1,46 @@
+module Test.Assert
+ ( assert'
+ , assert
+ , assertThrows
+ , assertThrows'
+ , ASSERT()
+ ) where
+
+import Control.Monad.Eff (Eff())
+import Prelude
+
+-- | Assertion effect type.
+foreign import data ASSERT :: !
+
+-- | Throws a runtime exception with message "Assertion failed" when the boolean
+-- | value is false.
+assert :: forall e. Boolean -> Eff (assert :: ASSERT | e) Unit
+assert = assert' "Assertion failed"
+
+-- | Throws a runtime exception with the specified message when the boolean
+-- | value is false.
+foreign import assert' :: forall e. String -> Boolean -> Eff (assert :: ASSERT | e) Unit
+
+-- | Throws a runtime exception with message "Assertion failed: An error should
+-- | have been thrown", unless the argument throws an exception when evaluated.
+-- |
+-- | This function is specifically for testing unsafe pure code; for example,
+-- | to make sure that an exception is thrown if a precondition is not
+-- | satisfied. Functions which use `Eff (err :: EXCEPTION | eff) a` can be
+-- | tested with `catchException` instead.
+assertThrows :: forall e a. (Unit -> a) -> Eff (assert :: ASSERT | e) Unit
+assertThrows = assertThrows' "Assertion failed: An error should have been thrown"
+
+-- | Throws a runtime exception with the specified message, unless the argument
+-- | throws an exception when evaluated.
+-- |
+-- | This function is specifically for testing unsafe pure code; for example,
+-- | to make sure that an exception is thrown if a precondition is not
+-- | satisfied. Functions which use `Eff (err :: EXCEPTION | eff) a` can be
+-- | tested with `catchException` instead.
+assertThrows' :: forall e a. String -> (Unit -> a) -> Eff (assert :: ASSERT | e) Unit
+assertThrows' msg fn =
+ checkThrows fn >>= assert' msg
+
+
+foreign import checkThrows :: forall e a. (Unit -> a) -> Eff (assert :: ASSERT | e) Boolean
diff --git a/tests/support/prelude/LICENSE b/tests/support/prelude/LICENSE
new file mode 100644
index 0000000..d3249fe
--- /dev/null
+++ b/tests/support/prelude/LICENSE
@@ -0,0 +1,20 @@
+The MIT License (MIT)
+
+Copyright (c) 2015 PureScript
+
+Permission is hereby granted, free of charge, to any person obtaining a copy of
+this software and associated documentation files (the "Software"), to deal in
+the Software without restriction, including without limitation the rights to
+use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
+the Software, and to permit persons to whom the Software is furnished to do so,
+subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
+FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
+COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
+IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
+CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
diff --git a/tests/support/prelude/bower.json b/tests/support/prelude/bower.json
new file mode 100644
index 0000000..4182b35
--- /dev/null
+++ b/tests/support/prelude/bower.json
@@ -0,0 +1,23 @@
+{
+ "name": "purescript-prelude",
+ "homepage": "https://github.com/purescript/purescript-prelude",
+ "description": "The PureScript Prelude",
+ "keywords": [
+ "purescript"
+ ],
+ "license": "MIT",
+ "repository": {
+ "type": "git",
+ "url": "git://github.com/purescript/purescript-prelude.git"
+ },
+ "ignore": [
+ "**/.*",
+ "bower_components",
+ "node_modules",
+ "output",
+ "test",
+ "bower.json",
+ "gulpfile.js",
+ "package.json"
+ ]
+}
diff --git a/tests/support/prelude/src/Prelude.js b/tests/support/prelude/src/Prelude.js
new file mode 100644
index 0000000..72a855a
--- /dev/null
+++ b/tests/support/prelude/src/Prelude.js
@@ -0,0 +1,228 @@
+/* global exports */
+"use strict";
+
+// module Prelude
+
+//- Functor --------------------------------------------------------------------
+
+exports.arrayMap = function (f) {
+ return function (arr) {
+ var l = arr.length;
+ var result = new Array(l);
+ for (var i = 0; i < l; i++) {
+ result[i] = f(arr[i]);
+ }
+ return result;
+ };
+};
+
+//- Bind -----------------------------------------------------------------------
+
+exports.arrayBind = function (arr) {
+ return function (f) {
+ var result = [];
+ for (var i = 0, l = arr.length; i < l; i++) {
+ Array.prototype.push.apply(result, f(arr[i]));
+ }
+ return result;
+ };
+};
+
+//- Monoid ---------------------------------------------------------------------
+
+exports.concatString = function (s1) {
+ return function (s2) {
+ return s1 + s2;
+ };
+};
+
+exports.concatArray = function (xs) {
+ return function (ys) {
+ return xs.concat(ys);
+ };
+};
+
+//- Semiring -------------------------------------------------------------------
+
+exports.intAdd = function (x) {
+ return function (y) {
+ /* jshint bitwise: false */
+ return x + y | 0;
+ };
+};
+
+exports.intMul = function (x) {
+ return function (y) {
+ /* jshint bitwise: false */
+ return x * y | 0;
+ };
+};
+
+exports.numAdd = function (n1) {
+ return function (n2) {
+ return n1 + n2;
+ };
+};
+
+exports.numMul = function (n1) {
+ return function (n2) {
+ return n1 * n2;
+ };
+};
+
+//- ModuloSemiring -------------------------------------------------------------
+
+exports.intDiv = function (x) {
+ return function (y) {
+ /* jshint bitwise: false */
+ return x / y | 0;
+ };
+};
+
+exports.intMod = function (x) {
+ return function (y) {
+ return x % y;
+ };
+};
+
+exports.numDiv = function (n1) {
+ return function (n2) {
+ return n1 / n2;
+ };
+};
+
+//- Ring -----------------------------------------------------------------------
+
+exports.intSub = function (x) {
+ return function (y) {
+ /* jshint bitwise: false */
+ return x - y | 0;
+ };
+};
+
+exports.numSub = function (n1) {
+ return function (n2) {
+ return n1 - n2;
+ };
+};
+
+//- Eq -------------------------------------------------------------------------
+
+exports.refEq = function (r1) {
+ return function (r2) {
+ return r1 === r2;
+ };
+};
+
+exports.refIneq = function (r1) {
+ return function (r2) {
+ return r1 !== r2;
+ };
+};
+
+exports.eqArrayImpl = function (f) {
+ return function (xs) {
+ return function (ys) {
+ if (xs.length !== ys.length) return false;
+ for (var i = 0; i < xs.length; i++) {
+ if (!f(xs[i])(ys[i])) return false;
+ }
+ return true;
+ };
+ };
+};
+
+exports.ordArrayImpl = function (f) {
+ return function (xs) {
+ return function (ys) {
+ var i = 0;
+ var xlen = xs.length;
+ var ylen = ys.length;
+ while (i < xlen && i < ylen) {
+ var x = xs[i];
+ var y = ys[i];
+ var o = f(x)(y);
+ if (o !== 0) {
+ return o;
+ }
+ i++;
+ }
+ if (xlen === ylen) {
+ return 0;
+ } else if (xlen > ylen) {
+ return -1;
+ } else {
+ return 1;
+ }
+ };
+ };
+};
+
+//- Ord ------------------------------------------------------------------------
+
+exports.unsafeCompareImpl = function (lt) {
+ return function (eq) {
+ return function (gt) {
+ return function (x) {
+ return function (y) {
+ return x < y ? lt : x > y ? gt : eq;
+ };
+ };
+ };
+ };
+};
+
+//- Bounded --------------------------------------------------------------------
+
+exports.topInt = 2147483647;
+exports.bottomInt = -2147483648;
+
+exports.topChar = String.fromCharCode(65535);
+exports.bottomChar = String.fromCharCode(0);
+
+//- BooleanAlgebra -------------------------------------------------------------
+
+exports.boolOr = function (b1) {
+ return function (b2) {
+ return b1 || b2;
+ };
+};
+
+exports.boolAnd = function (b1) {
+ return function (b2) {
+ return b1 && b2;
+ };
+};
+
+exports.boolNot = function (b) {
+ return !b;
+};
+
+//- Show -----------------------------------------------------------------------
+
+exports.showIntImpl = function (n) {
+ return n.toString();
+};
+
+exports.showNumberImpl = function (n) {
+ /* jshint bitwise: false */
+ return n === (n | 0) ? n + ".0" : n.toString();
+};
+
+exports.showCharImpl = function (c) {
+ return c === "'" ? "'\\''" : "'" + c + "'";
+};
+
+exports.showStringImpl = function (s) {
+ return JSON.stringify(s);
+};
+
+exports.showArrayImpl = function (f) {
+ return function (xs) {
+ var ss = [];
+ for (var i = 0, l = xs.length; i < l; i++) {
+ ss[i] = f(xs[i]);
+ }
+ return "[" + ss.join(",") + "]";
+ };
+};
diff --git a/tests/support/prelude/src/Prelude.purs b/tests/support/prelude/src/Prelude.purs
new file mode 100644
index 0000000..21ec909
--- /dev/null
+++ b/tests/support/prelude/src/Prelude.purs
@@ -0,0 +1,872 @@
+module Prelude
+ ( Unit(), unit
+ , ($), (#)
+ , flip
+ , const
+ , asTypeOf
+ , otherwise
+ , Semigroupoid, compose, (<<<), (>>>)
+ , Category, id
+ , Functor, map, (<$>), (<#>), void
+ , Apply, apply, (<*>)
+ , Applicative, pure, liftA1
+ , Bind, bind, (>>=)
+ , Monad, return, liftM1, ap
+ , Semigroup, append, (<>), (++)
+ , Semiring, add, zero, mul, one, (+), (*)
+ , ModuloSemiring, div, mod, (/)
+ , Ring, sub, negate, (-)
+ , Num
+ , DivisionRing
+ , Eq, eq, (==), (/=)
+ , Ordering(..), Ord, compare, (<), (>), (<=), (>=)
+ , unsafeCompare
+ , Bounded, top, bottom
+ , BoundedOrd
+ , BooleanAlgebra, conj, disj, not, (&&), (||)
+ , Show, show
+ ) where
+
+-- | The `Unit` type has a single inhabitant, called `unit`. It represents
+-- | values with no computational content.
+-- |
+-- | `Unit` is often used, wrapped in a monadic type constructor, as the
+-- | return type of a computation where only
+-- | the _effects_ are important.
+newtype Unit = Unit {}
+
+-- | `unit` is the sole inhabitant of the `Unit` type.
+unit :: Unit
+unit = Unit {}
+
+infixr 0 $
+infixl 1 #
+
+-- | Applies a function to its argument.
+-- |
+-- | ```purescript
+-- | length $ groupBy productCategory $ filter isInStock $ products
+-- | ```
+-- |
+-- | is equivalent to:
+-- |
+-- | ```purescript
+-- | length (groupBy productCategory (filter isInStock products))
+-- | ```
+-- |
+-- | `($)` is different from [`(#)`](#-2) because it is right-infix instead of
+-- | left: `a $ b $ c $ d x = a $ (b $ (c $ (d $ x))) = a (b (c (d x)))`
+($) :: forall a b. (a -> b) -> a -> b
+($) f x = f x
+
+-- | Applies an argument to a function.
+-- |
+-- | ```purescript
+-- | products # filter isInStock # groupBy productCategory # length
+-- | ```
+-- |
+-- | is equivalent to:
+-- |
+-- | ```purescript
+-- | length (groupBy productCategory (filter isInStock products))
+-- | ```
+-- |
+-- | `(#)` is different from [`($)`](#-1) because it is left-infix instead of
+-- | right: `x # a # b # c # d = (((x # a) # b) # c) # d = d (c (b (a x)))`
+(#) :: forall a b. a -> (a -> b) -> b
+(#) x f = f x
+
+-- | Flips the order of the arguments to a function of two arguments.
+-- |
+-- | ```purescript
+-- | flip const 1 2 = const 2 1 = 2
+-- | ```
+flip :: forall a b c. (a -> b -> c) -> b -> a -> c
+flip f b a = f a b
+
+-- | Returns its first argument and ignores its second.
+-- |
+-- | ```purescript
+-- | const 1 "hello" = 1
+-- | ```
+const :: forall a b. a -> b -> a
+const a _ = a
+
+-- | This function returns its first argument, and can be used to assert type
+-- | equalities. This can be useful when types are otherwise ambiguous.
+-- |
+-- | ```purescript
+-- | main = print $ [] `asTypeOf` [0]
+-- | ```
+-- |
+-- | If instead, we had written `main = print []`, the type of the argument
+-- | `[]` would have been ambiguous, resulting in a compile-time error.
+asTypeOf :: forall a. a -> a -> a
+asTypeOf x _ = x
+
+-- | An alias for `true`, which can be useful in guard clauses:
+-- |
+-- | ```purescript
+-- | max x y | x >= y = x
+-- | | otherwise = y
+-- | ```
+otherwise :: Boolean
+otherwise = true
+
+-- | A `Semigroupoid` is similar to a [`Category`](#category) but does not
+-- | require an identity element `id`, just composable morphisms.
+-- |
+-- | `Semigroupoid`s must satisfy the following law:
+-- |
+-- | - Associativity: `p <<< (q <<< r) = (p <<< q) <<< r`
+-- |
+-- | One example of a `Semigroupoid` is the function type constructor `(->)`,
+-- | with `(<<<)` defined as function composition.
+class Semigroupoid a where
+ compose :: forall b c d. a c d -> a b c -> a b d
+
+instance semigroupoidFn :: Semigroupoid (->) where
+ compose f g x = f (g x)
+
+infixr 9 >>>
+infixr 9 <<<
+
+-- | `(<<<)` is an alias for `compose`.
+(<<<) :: forall a b c d. (Semigroupoid a) => a c d -> a b c -> a b d
+(<<<) = compose
+
+-- | Forwards composition, or `(<<<)` with its arguments reversed.
+(>>>) :: forall a b c d. (Semigroupoid a) => a b c -> a c d -> a b d
+(>>>) = flip compose
+
+-- | `Category`s consist of objects and composable morphisms between them, and
+-- | as such are [`Semigroupoids`](#semigroupoid), but unlike `semigroupoids`
+-- | must have an identity element.
+-- |
+-- | Instances must satisfy the following law in addition to the
+-- | `Semigroupoid` law:
+-- |
+-- | - Identity: `id <<< p = p <<< id = p`
+class (Semigroupoid a) <= Category a where
+ id :: forall t. a t t
+
+instance categoryFn :: Category (->) where
+ id x = x
+
+-- | A `Functor` is a type constructor which supports a mapping operation
+-- | `(<$>)`.
+-- |
+-- | `(<$>)` can be used to turn functions `a -> b` into functions
+-- | `f a -> f b` whose argument and return types use the type constructor `f`
+-- | to represent some computational context.
+-- |
+-- | Instances must satisfy the following laws:
+-- |
+-- | - Identity: `(<$>) id = id`
+-- | - Composition: `(<$>) (f <<< g) = (f <$>) <<< (g <$>)`
+class Functor f where
+ map :: forall a b. (a -> b) -> f a -> f b
+
+instance functorFn :: Functor ((->) r) where
+ map = compose
+
+instance functorArray :: Functor Array where
+ map = arrayMap
+
+foreign import arrayMap :: forall a b. (a -> b) -> Array a -> Array b
+
+infixl 4 <$>
+infixl 1 <#>
+
+-- | `(<$>)` is an alias for `map`
+(<$>) :: forall f a b. (Functor f) => (a -> b) -> f a -> f b
+(<$>) = map
+
+-- | `(<#>)` is `(<$>)` with its arguments reversed. For example:
+-- |
+-- | ```purescript
+-- | [1, 2, 3] <#> \n -> n * n
+-- | ```
+(<#>) :: forall f a b. (Functor f) => f a -> (a -> b) -> f b
+(<#>) fa f = f <$> fa
+
+-- | The `void` function is used to ignore the type wrapped by a
+-- | [`Functor`](#functor), replacing it with `Unit` and keeping only the type
+-- | information provided by the type constructor itself.
+-- |
+-- | `void` is often useful when using `do` notation to change the return type
+-- | of a monadic computation:
+-- |
+-- | ```purescript
+-- | main = forE 1 10 \n -> void do
+-- | print n
+-- | print (n * n)
+-- | ```
+void :: forall f a. (Functor f) => f a -> f Unit
+void fa = const unit <$> fa
+
+-- | The `Apply` class provides the `(<*>)` which is used to apply a function
+-- | to an argument under a type constructor.
+-- |
+-- | `Apply` can be used to lift functions of two or more arguments to work on
+-- | values wrapped with the type constructor `f`. It might also be understood
+-- | in terms of the `lift2` function:
+-- |
+-- | ```purescript
+-- | lift2 :: forall f a b c. (Apply f) => (a -> b -> c) -> f a -> f b -> f c
+-- | lift2 f a b = f <$> a <*> b
+-- | ```
+-- |
+-- | `(<*>)` is recovered from `lift2` as `lift2 ($)`. That is, `(<*>)` lifts
+-- | the function application operator `($)` to arguments wrapped with the
+-- | type constructor `f`.
+-- |
+-- | Instances must satisfy the following law in addition to the `Functor`
+-- | laws:
+-- |
+-- | - Associative composition: `(<<<) <$> f <*> g <*> h = f <*> (g <*> h)`
+-- |
+-- | Formally, `Apply` represents a strong lax semi-monoidal endofunctor.
+class (Functor f) <= Apply f where
+ apply :: forall a b. f (a -> b) -> f a -> f b
+
+instance applyFn :: Apply ((->) r) where
+ apply f g x = f x (g x)
+
+instance applyArray :: Apply Array where
+ apply = ap
+
+infixl 4 <*>
+
+-- | `(<*>)` is an alias for `apply`.
+(<*>) :: forall f a b. (Apply f) => f (a -> b) -> f a -> f b
+(<*>) = apply
+
+-- | The `Applicative` type class extends the [`Apply`](#apply) type class
+-- | with a `pure` function, which can be used to create values of type `f a`
+-- | from values of type `a`.
+-- |
+-- | Where [`Apply`](#apply) provides the ability to lift functions of two or
+-- | more arguments to functions whose arguments are wrapped using `f`, and
+-- | [`Functor`](#functor) provides the ability to lift functions of one
+-- | argument, `pure` can be seen as the function which lifts functions of
+-- | _zero_ arguments. That is, `Applicative` functors support a lifting
+-- | operation for any number of function arguments.
+-- |
+-- | Instances must satisfy the following laws in addition to the `Apply`
+-- | laws:
+-- |
+-- | - Identity: `(pure id) <*> v = v`
+-- | - Composition: `(pure <<<) <*> f <*> g <*> h = f <*> (g <*> h)`
+-- | - Homomorphism: `(pure f) <*> (pure x) = pure (f x)`
+-- | - Interchange: `u <*> (pure y) = (pure ($ y)) <*> u`
+class (Apply f) <= Applicative f where
+ pure :: forall a. a -> f a
+
+instance applicativeFn :: Applicative ((->) r) where
+ pure = const
+
+instance applicativeArray :: Applicative Array where
+ pure x = [x]
+
+-- | `return` is an alias for `pure`.
+return :: forall m a. (Applicative m) => a -> m a
+return = pure
+
+-- | `liftA1` provides a default implementation of `(<$>)` for any
+-- | [`Applicative`](#applicative) functor, without using `(<$>)` as provided
+-- | by the [`Functor`](#functor)-[`Applicative`](#applicative) superclass
+-- | relationship.
+-- |
+-- | `liftA1` can therefore be used to write [`Functor`](#functor) instances
+-- | as follows:
+-- |
+-- | ```purescript
+-- | instance functorF :: Functor F where
+-- | map = liftA1
+-- | ```
+liftA1 :: forall f a b. (Applicative f) => (a -> b) -> f a -> f b
+liftA1 f a = pure f <*> a
+
+-- | The `Bind` type class extends the [`Apply`](#apply) type class with a
+-- | "bind" operation `(>>=)` which composes computations in sequence, using
+-- | the return value of one computation to determine the next computation.
+-- |
+-- | The `>>=` operator can also be expressed using `do` notation, as follows:
+-- |
+-- | ```purescript
+-- | x >>= f = do y <- x
+-- | f y
+-- | ```
+-- |
+-- | where the function argument of `f` is given the name `y`.
+-- |
+-- | Instances must satisfy the following law in addition to the `Apply`
+-- | laws:
+-- |
+-- | - Associativity: `(x >>= f) >>= g = x >>= (\k => f k >>= g)`
+-- |
+-- | Associativity tells us that we can regroup operations which use `do`
+-- | notation so that we can unambiguously write, for example:
+-- |
+-- | ```purescript
+-- | do x <- m1
+-- | y <- m2 x
+-- | m3 x y
+-- | ```
+class (Apply m) <= Bind m where
+ bind :: forall a b. m a -> (a -> m b) -> m b
+
+instance bindFn :: Bind ((->) r) where
+ bind m f x = f (m x) x
+
+instance bindArray :: Bind Array where
+ bind = arrayBind
+
+foreign import arrayBind :: forall a b. Array a -> (a -> Array b) -> Array b
+
+infixl 1 >>=
+
+-- | `(>>=)` is an alias for `bind`.
+(>>=) :: forall m a b. (Bind m) => m a -> (a -> m b) -> m b
+(>>=) = bind
+
+-- | The `Monad` type class combines the operations of the `Bind` and
+-- | `Applicative` type classes. Therefore, `Monad` instances represent type
+-- | constructors which support sequential composition, and also lifting of
+-- | functions of arbitrary arity.
+-- |
+-- | Instances must satisfy the following laws in addition to the
+-- | `Applicative` and `Bind` laws:
+-- |
+-- | - Left Identity: `pure x >>= f = f x`
+-- | - Right Identity: `x >>= pure = x`
+class (Applicative m, Bind m) <= Monad m
+
+instance monadFn :: Monad ((->) r)
+instance monadArray :: Monad Array
+
+-- | `liftM1` provides a default implementation of `(<$>)` for any
+-- | [`Monad`](#monad), without using `(<$>)` as provided by the
+-- | [`Functor`](#functor)-[`Monad`](#monad) superclass relationship.
+-- |
+-- | `liftM1` can therefore be used to write [`Functor`](#functor) instances
+-- | as follows:
+-- |
+-- | ```purescript
+-- | instance functorF :: Functor F where
+-- | map = liftM1
+-- | ```
+liftM1 :: forall m a b. (Monad m) => (a -> b) -> m a -> m b
+liftM1 f a = do
+ a' <- a
+ return (f a')
+
+-- | `ap` provides a default implementation of `(<*>)` for any
+-- | [`Monad`](#monad), without using `(<*>)` as provided by the
+-- | [`Apply`](#apply)-[`Monad`](#monad) superclass relationship.
+-- |
+-- | `ap` can therefore be used to write [`Apply`](#apply) instances as
+-- | follows:
+-- |
+-- | ```purescript
+-- | instance applyF :: Apply F where
+-- | apply = ap
+-- | ```
+ap :: forall m a b. (Monad m) => m (a -> b) -> m a -> m b
+ap f a = do
+ f' <- f
+ a' <- a
+ return (f' a')
+
+-- | The `Semigroup` type class identifies an associative operation on a type.
+-- |
+-- | Instances are required to satisfy the following law:
+-- |
+-- | - Associativity: `(x <> y) <> z = x <> (y <> z)`
+-- |
+-- | One example of a `Semigroup` is `String`, with `(<>)` defined as string
+-- | concatenation.
+class Semigroup a where
+ append :: a -> a -> a
+
+infixr 5 <>
+infixr 5 ++
+
+-- | `(<>)` is an alias for `append`.
+(<>) :: forall s. (Semigroup s) => s -> s -> s
+(<>) = append
+
+-- | `(++)` is an alternative alias for `append`.
+(++) :: forall s. (Semigroup s) => s -> s -> s
+(++) = append
+
+instance semigroupString :: Semigroup String where
+ append = concatString
+
+instance semigroupUnit :: Semigroup Unit where
+ append _ _ = unit
+
+instance semigroupFn :: (Semigroup s') => Semigroup (s -> s') where
+ append f g = \x -> f x <> g x
+
+instance semigroupOrdering :: Semigroup Ordering where
+ append LT _ = LT
+ append GT _ = GT
+ append EQ y = y
+
+instance semigroupArray :: Semigroup (Array a) where
+ append = concatArray
+
+foreign import concatString :: String -> String -> String
+foreign import concatArray :: forall a. Array a -> Array a -> Array a
+
+-- | The `Semiring` class is for types that support an addition and
+-- | multiplication operation.
+-- |
+-- | Instances must satisfy the following laws:
+-- |
+-- | - Commutative monoid under addition:
+-- | - Associativity: `(a + b) + c = a + (b + c)`
+-- | - Identity: `zero + a = a + zero = a`
+-- | - Commutative: `a + b = b + a`
+-- | - Monoid under multiplication:
+-- | - Associativity: `(a * b) * c = a * (b * c)`
+-- | - Identity: `one * a = a * one = a`
+-- | - Multiplication distributes over addition:
+-- | - Left distributivity: `a * (b + c) = (a * b) + (a * c)`
+-- | - Right distributivity: `(a + b) * c = (a * c) + (b * c)`
+-- | - Annihiliation: `zero * a = a * zero = zero`
+class Semiring a where
+ add :: a -> a -> a
+ zero :: a
+ mul :: a -> a -> a
+ one :: a
+
+instance semiringInt :: Semiring Int where
+ add = intAdd
+ zero = 0
+ mul = intMul
+ one = 1
+
+instance semiringNumber :: Semiring Number where
+ add = numAdd
+ zero = 0.0
+ mul = numMul
+ one = 1.0
+
+instance semiringUnit :: Semiring Unit where
+ add _ _ = unit
+ zero = unit
+ mul _ _ = unit
+ one = unit
+
+infixl 6 +
+infixl 7 *
+
+-- | `(+)` is an alias for `add`.
+(+) :: forall a. (Semiring a) => a -> a -> a
+(+) = add
+
+-- | `(*)` is an alias for `mul`.
+(*) :: forall a. (Semiring a) => a -> a -> a
+(*) = mul
+
+foreign import intAdd :: Int -> Int -> Int
+foreign import intMul :: Int -> Int -> Int
+foreign import numAdd :: Number -> Number -> Number
+foreign import numMul :: Number -> Number -> Number
+
+-- | The `Ring` class is for types that support addition, multiplication,
+-- | and subtraction operations.
+-- |
+-- | Instances must satisfy the following law in addition to the `Semiring`
+-- | laws:
+-- |
+-- | - Additive inverse: `a - a = (zero - a) + a = zero`
+class (Semiring a) <= Ring a where
+ sub :: a -> a -> a
+
+instance ringInt :: Ring Int where
+ sub = intSub
+
+instance ringNumber :: Ring Number where
+ sub = numSub
+
+instance ringUnit :: Ring Unit where
+ sub _ _ = unit
+
+infixl 6 -
+
+-- | `(-)` is an alias for `sub`.
+(-) :: forall a. (Ring a) => a -> a -> a
+(-) = sub
+
+-- | `negate x` can be used as a shorthand for `zero - x`.
+negate :: forall a. (Ring a) => a -> a
+negate a = zero - a
+
+foreign import intSub :: Int -> Int -> Int
+foreign import numSub :: Number -> Number -> Number
+
+-- | The `ModuloSemiring` class is for types that support addition,
+-- | multiplication, division, and modulo (division remainder) operations.
+-- |
+-- | Instances must satisfy the following law in addition to the `Semiring`
+-- | laws:
+-- |
+-- | - Remainder: ``a / b * b + (a `mod` b) = a``
+class (Semiring a) <= ModuloSemiring a where
+ div :: a -> a -> a
+ mod :: a -> a -> a
+
+instance moduloSemiringInt :: ModuloSemiring Int where
+ div = intDiv
+ mod = intMod
+
+instance moduloSemiringNumber :: ModuloSemiring Number where
+ div = numDiv
+ mod _ _ = 0.0
+
+instance moduloSemiringUnit :: ModuloSemiring Unit where
+ div _ _ = unit
+ mod _ _ = unit
+
+infixl 7 /
+
+-- | `(/)` is an alias for `div`.
+(/) :: forall a. (ModuloSemiring a) => a -> a -> a
+(/) = div
+
+foreign import intDiv :: Int -> Int -> Int
+foreign import numDiv :: Number -> Number -> Number
+foreign import intMod :: Int -> Int -> Int
+
+-- | A `Ring` where every nonzero element has a multiplicative inverse.
+-- |
+-- | Instances must satisfy the following law in addition to the `Ring` and
+-- | `ModuloSemiring` laws:
+-- |
+-- | - Multiplicative inverse: `(one / x) * x = one`
+-- |
+-- | As a consequence of this ```a `mod` b = zero``` as no divide operation
+-- | will have a remainder.
+class (Ring a, ModuloSemiring a) <= DivisionRing a
+
+instance divisionRingNumber :: DivisionRing Number
+instance divisionRingUnit :: DivisionRing Unit
+
+-- | The `Num` class is for types that are commutative fields.
+-- |
+-- | Instances must satisfy the following law in addition to the
+-- | `DivisionRing` laws:
+-- |
+-- | - Commutative multiplication: `a * b = b * a`
+class (DivisionRing a) <= Num a
+
+instance numNumber :: Num Number
+instance numUnit :: Num Unit
+
+-- | The `Eq` type class represents types which support decidable equality.
+-- |
+-- | `Eq` instances should satisfy the following laws:
+-- |
+-- | - Reflexivity: `x == x = true`
+-- | - Symmetry: `x == y = y == x`
+-- | - Transitivity: if `x == y` and `y == z` then `x == z`
+class Eq a where
+ eq :: a -> a -> Boolean
+
+infix 4 ==
+infix 4 /=
+
+-- | `(==)` is an alias for `eq`. Tests whether one value is equal to another.
+(==) :: forall a. (Eq a) => a -> a -> Boolean
+(==) = eq
+
+-- | `(/=)` tests whether one value is _not equal_ to another. Shorthand for
+-- | `not (x == y)`.
+(/=) :: forall a. (Eq a) => a -> a -> Boolean
+(/=) x y = not (x == y)
+
+instance eqBoolean :: Eq Boolean where
+ eq = refEq
+
+instance eqInt :: Eq Int where
+ eq = refEq
+
+instance eqNumber :: Eq Number where
+ eq = refEq
+
+instance eqChar :: Eq Char where
+ eq = refEq
+
+instance eqString :: Eq String where
+ eq = refEq
+
+instance eqUnit :: Eq Unit where
+ eq _ _ = true
+
+instance eqArray :: (Eq a) => Eq (Array a) where
+ eq = eqArrayImpl (==)
+
+instance eqOrdering :: Eq Ordering where
+ eq LT LT = true
+ eq GT GT = true
+ eq EQ EQ = true
+ eq _ _ = false
+
+foreign import refEq :: forall a. a -> a -> Boolean
+foreign import refIneq :: forall a. a -> a -> Boolean
+foreign import eqArrayImpl :: forall a. (a -> a -> Boolean) -> Array a -> Array a -> Boolean
+
+-- | The `Ordering` data type represents the three possible outcomes of
+-- | comparing two values:
+-- |
+-- | `LT` - The first value is _less than_ the second.
+-- | `GT` - The first value is _greater than_ the second.
+-- | `EQ` - The first value is _equal to_ the second.
+data Ordering = LT | GT | EQ
+
+-- | The `Ord` type class represents types which support comparisons with a
+-- | _total order_.
+-- |
+-- | `Ord` instances should satisfy the laws of total orderings:
+-- |
+-- | - Reflexivity: `a <= a`
+-- | - Antisymmetry: if `a <= b` and `b <= a` then `a = b`
+-- | - Transitivity: if `a <= b` and `b <= c` then `a <= c`
+class (Eq a) <= Ord a where
+ compare :: a -> a -> Ordering
+
+instance ordBoolean :: Ord Boolean where
+ compare = unsafeCompare
+
+instance ordInt :: Ord Int where
+ compare = unsafeCompare
+
+instance ordNumber :: Ord Number where
+ compare = unsafeCompare
+
+instance ordString :: Ord String where
+ compare = unsafeCompare
+
+instance ordChar :: Ord Char where
+ compare = unsafeCompare
+
+instance ordUnit :: Ord Unit where
+ compare _ _ = EQ
+
+instance ordArray :: (Ord a) => Ord (Array a) where
+ compare xs ys = compare 0 $ ordArrayImpl (\x y -> case compare x y of
+ EQ -> 0
+ LT -> 1
+ GT -> -1) xs ys
+
+foreign import ordArrayImpl :: forall a. (a -> a -> Int) -> Array a -> Array a -> Int
+
+instance ordOrdering :: Ord Ordering where
+ compare LT LT = EQ
+ compare EQ EQ = EQ
+ compare GT GT = EQ
+ compare LT _ = LT
+ compare EQ LT = GT
+ compare EQ GT = LT
+ compare GT _ = GT
+
+infixl 4 <
+infixl 4 >
+infixl 4 <=
+infixl 4 >=
+
+-- | Test whether one value is _strictly less than_ another.
+(<) :: forall a. (Ord a) => a -> a -> Boolean
+(<) a1 a2 = case a1 `compare` a2 of
+ LT -> true
+ _ -> false
+
+-- | Test whether one value is _strictly greater than_ another.
+(>) :: forall a. (Ord a) => a -> a -> Boolean
+(>) a1 a2 = case a1 `compare` a2 of
+ GT -> true
+ _ -> false
+
+-- | Test whether one value is _non-strictly less than_ another.
+(<=) :: forall a. (Ord a) => a -> a -> Boolean
+(<=) a1 a2 = case a1 `compare` a2 of
+ GT -> false
+ _ -> true
+
+-- | Test whether one value is _non-strictly greater than_ another.
+(>=) :: forall a. (Ord a) => a -> a -> Boolean
+(>=) a1 a2 = case a1 `compare` a2 of
+ LT -> false
+ _ -> true
+
+unsafeCompare :: forall a. a -> a -> Ordering
+unsafeCompare = unsafeCompareImpl LT EQ GT
+
+foreign import unsafeCompareImpl :: forall a. Ordering -> Ordering -> Ordering -> a -> a -> Ordering
+
+-- | The `Bounded` type class represents types that are finite.
+-- |
+-- | Although there are no "internal" laws for `Bounded`, every value of `a`
+-- | should be considered less than or equal to `top` by some means, and greater
+-- | than or equal to `bottom`.
+-- |
+-- | The lack of explicit `Ord` constraint allows flexibility in the use of
+-- | `Bounded` so it can apply to total and partially ordered sets, boolean
+-- | algebras, etc.
+class Bounded a where
+ top :: a
+ bottom :: a
+
+instance boundedBoolean :: Bounded Boolean where
+ top = true
+ bottom = false
+
+instance boundedUnit :: Bounded Unit where
+ top = unit
+ bottom = unit
+
+instance boundedOrdering :: Bounded Ordering where
+ top = GT
+ bottom = LT
+
+instance boundedInt :: Bounded Int where
+ top = topInt
+ bottom = bottomInt
+
+-- | Characters fall within the Unicode range.
+instance boundedChar :: Bounded Char where
+ top = topChar
+ bottom = bottomChar
+
+instance boundedFn :: (Bounded b) => Bounded (a -> b) where
+ top _ = top
+ bottom _ = bottom
+
+foreign import topInt :: Int
+foreign import bottomInt :: Int
+
+foreign import topChar :: Char
+foreign import bottomChar :: Char
+
+-- | The `BoundedOrd` type class represents totally ordered finite data types.
+-- |
+-- | Instances should satisfy the following law in addition to the `Ord` laws:
+-- |
+-- | - Ordering: `bottom <= a <= top`
+class (Bounded a, Ord a) <= BoundedOrd a
+
+instance boundedOrdBoolean :: BoundedOrd Boolean where
+instance boundedOrdUnit :: BoundedOrd Unit where
+instance boundedOrdOrdering :: BoundedOrd Ordering where
+instance boundedOrdInt :: BoundedOrd Int where
+instance boundedOrdChar :: BoundedOrd Char where
+
+-- | The `BooleanAlgebra` type class represents types that behave like boolean
+-- | values.
+-- |
+-- | Instances should satisfy the following laws in addition to the `Bounded`
+-- | laws:
+-- |
+-- | - Associativity:
+-- | - `a || (b || c) = (a || b) || c`
+-- | - `a && (b && c) = (a && b) && c`
+-- | - Commutativity:
+-- | - `a || b = b || a`
+-- | - `a && b = b && a`
+-- | - Distributivity:
+-- | - `a && (b || c) = (a && b) || (a && c)`
+-- | - `a || (b && c) = (a || b) && (a || c)`
+-- | - Identity:
+-- | - `a || bottom = a`
+-- | - `a && top = a`
+-- | - Idempotent:
+-- | - `a || a = a`
+-- | - `a && a = a`
+-- | - Absorption:
+-- | - `a || (a && b) = a`
+-- | - `a && (a || b) = a`
+-- | - Annhiliation:
+-- | - `a || top = top`
+-- | - Complementation:
+-- | - `a && not a = bottom`
+-- | - `a || not a = top`
+class (Bounded a) <= BooleanAlgebra a where
+ conj :: a -> a -> a
+ disj :: a -> a -> a
+ not :: a -> a
+
+instance booleanAlgebraBoolean :: BooleanAlgebra Boolean where
+ conj = boolAnd
+ disj = boolOr
+ not = boolNot
+
+instance booleanAlgebraUnit :: BooleanAlgebra Unit where
+ conj _ _ = unit
+ disj _ _ = unit
+ not _ = unit
+
+instance booleanAlgebraFn :: (BooleanAlgebra b) => BooleanAlgebra (a -> b) where
+ conj fx fy a = fx a `conj` fy a
+ disj fx fy a = fx a `disj` fy a
+ not fx a = not (fx a)
+
+infixr 3 &&
+infixr 2 ||
+
+-- | `(&&)` is an alias for `conj`.
+(&&) :: forall a. (BooleanAlgebra a) => a -> a -> a
+(&&) = conj
+
+-- | `(||)` is an alias for `disj`.
+(||) :: forall a. (BooleanAlgebra a) => a -> a -> a
+(||) = disj
+
+foreign import boolOr :: Boolean -> Boolean -> Boolean
+foreign import boolAnd :: Boolean -> Boolean -> Boolean
+foreign import boolNot :: Boolean -> Boolean
+
+-- | The `Show` type class represents those types which can be converted into
+-- | a human-readable `String` representation.
+-- |
+-- | While not required, it is recommended that for any expression `x`, the
+-- | string `show x` be executable PureScript code which evaluates to the same
+-- | value as the expression `x`.
+class Show a where
+ show :: a -> String
+
+instance showBoolean :: Show Boolean where
+ show true = "true"
+ show false = "false"
+
+instance showInt :: Show Int where
+ show = showIntImpl
+
+instance showNumber :: Show Number where
+ show = showNumberImpl
+
+instance showChar :: Show Char where
+ show = showCharImpl
+
+instance showString :: Show String where
+ show = showStringImpl
+
+instance showUnit :: Show Unit where
+ show _ = "unit"
+
+instance showArray :: (Show a) => Show (Array a) where
+ show = showArrayImpl show
+
+instance showOrdering :: Show Ordering where
+ show LT = "LT"
+ show GT = "GT"
+ show EQ = "EQ"
+
+foreign import showIntImpl :: Int -> String
+foreign import showNumberImpl :: Number -> String
+foreign import showCharImpl :: Char -> String
+foreign import showStringImpl :: String -> String
+foreign import showArrayImpl :: forall a. (a -> String) -> Array a -> String
diff --git a/psci/tests/data/Sample.purs b/tests/support/psci/Sample.purs
index e69de29..e69de29 100644
--- a/psci/tests/data/Sample.purs
+++ b/tests/support/psci/Sample.purs