summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2016-01-31 22:07:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2016-01-31 22:07:00 (GMT)
commit43cd0c9c2258e12e695109d47d435ca0634cf3b0 (patch)
tree5b7d353683d4df84425b35d56154e78000f234d8
parentd75ce7f45344db8d92286cd08068533fa7ffc910 (diff)
version 0.8.0.00.8.0.0
-rw-r--r--CONTRIBUTORS.md7
-rw-r--r--INSTALL.md2
-rw-r--r--examples/docs/bower.json19
-rw-r--r--examples/docs/bower_components/purescript-prelude/src/Prelude.purs8
-rw-r--r--examples/docs/src/Clash.purs32
-rw-r--r--examples/docs/src/DuplicateNames.purs9
-rw-r--r--examples/docs/src/Example.purs7
-rw-r--r--examples/docs/src/Example2.purs7
-rw-r--r--examples/docs/src/ImportedTwice.purs27
-rw-r--r--examples/docs/src/MultiVirtual.purs27
-rw-r--r--examples/docs/src/NewOperators.purs12
-rw-r--r--examples/docs/src/NotAllCtors.purs5
-rw-r--r--examples/docs/src/OldOperators.purs10
-rw-r--r--examples/docs/src/ReExportedTypeClass.purs5
-rw-r--r--examples/docs/src/SolitaryTypeClassMember.purs6
-rw-r--r--examples/docs/src/SomeTypeClass.purs5
-rw-r--r--examples/docs/src/Transitive1.purs5
-rw-r--r--examples/docs/src/Transitive2.purs5
-rw-r--r--examples/docs/src/Transitive3.purs4
-rw-r--r--examples/docs/src/TypeClassWithoutMembers.purs11
-rw-r--r--examples/docs/src/UTF8.purs7
-rw-r--r--examples/docs/src/Virtual.purs5
-rw-r--r--examples/failing/1733.purs13
-rw-r--r--examples/failing/1825.purs9
-rw-r--r--examples/failing/CaseBinderLengthsDiffer.purs6
-rw-r--r--examples/failing/ConflictingExports.purs16
-rw-r--r--examples/failing/ConflictingExports2.purs13
-rw-r--r--examples/failing/ConflictingImports.purs19
-rw-r--r--examples/failing/ConflictingImports2.purs16
-rw-r--r--examples/failing/ConflictingQualifiedImports.purs17
-rw-r--r--examples/failing/ConflictingQualifiedImports2.purs15
-rw-r--r--examples/failing/IntOutOfRange.purs6
-rw-r--r--examples/failing/OperatorAliasNoExport.purs7
-rw-r--r--examples/passing/1185.purs13
-rw-r--r--examples/passing/1664.purs16
-rw-r--r--examples/passing/1697.purs24
-rw-r--r--examples/passing/CaseMultipleExpressions.purs19
-rw-r--r--examples/passing/ClassRefSyntax.purs13
-rw-r--r--examples/passing/EmptyTypeClass.purs6
-rw-r--r--examples/passing/NakedConstraint.purs2
-rw-r--r--examples/passing/NegativeIntInRange.purs8
-rw-r--r--examples/passing/NonConflictingExports.purs14
-rw-r--r--examples/passing/OperatorAlias.purs11
-rw-r--r--examples/passing/OperatorAliasElsewhere.purs14
-rw-r--r--examples/passing/PendingConflictingImports.purs17
-rw-r--r--examples/passing/PendingConflictingImports2.purs14
-rw-r--r--examples/passing/ShadowedModuleName.purs15
-rw-r--r--examples/passing/TCO.purs20
-rw-r--r--examples/passing/TypeWithoutParens.purs16
-rw-r--r--examples/passing/UnicodeIdentifier.purs5
-rw-r--r--examples/passing/UnicodeOperators.purs20
-rw-r--r--examples/passing/UnicodeType.purs23
-rw-r--r--examples/passing/UntupledConstraints.purs17
-rw-r--r--hierarchy/Main.hs3
-rw-r--r--psc-bundle/Main.hs2
-rw-r--r--psc-docs/Main.hs86
-rw-r--r--psc-docs/Tags.hs6
-rw-r--r--psc/JSON.hs80
-rw-r--r--psc/Main.hs60
-rw-r--r--psci/Completion.hs10
-rw-r--r--psci/PSCi.hs139
-rw-r--r--psci/Parser.hs4
-rw-r--r--psci/Types.hs66
-rw-r--r--psci/tests/Main.hs2
-rw-r--r--purescript.cabal24
-rw-r--r--src/Control/Monad/Logger.hs2
-rw-r--r--src/Control/Monad/Supply/Class.hs22
-rw-r--r--src/Language/PureScript.hs1
-rw-r--r--src/Language/PureScript/AST/Binders.hs24
-rw-r--r--src/Language/PureScript/AST/Declarations.hs124
-rw-r--r--src/Language/PureScript/AST/Exported.hs58
-rw-r--r--src/Language/PureScript/AST/Operators.hs25
-rw-r--r--src/Language/PureScript/AST/SourcePos.hs23
-rw-r--r--src/Language/PureScript/AST/Traversals.hs111
-rw-r--r--src/Language/PureScript/Bundle.hs25
-rw-r--r--src/Language/PureScript/CodeGen/JS.hs166
-rw-r--r--src/Language/PureScript/CodeGen/JS/AST.hs24
-rw-r--r--src/Language/PureScript/CodeGen/JS/Common.hs280
-rw-r--r--src/Language/PureScript/CodeGen/JS/Optimizer.hs42
-rw-r--r--src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs27
-rw-r--r--src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs328
-rw-r--r--src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs53
-rw-r--r--src/Language/PureScript/Comments.hs20
-rw-r--r--src/Language/PureScript/Constants.hs124
-rw-r--r--src/Language/PureScript/CoreFn/Binders.hs27
-rw-r--r--src/Language/PureScript/CoreFn/Desugar.hs39
-rw-r--r--src/Language/PureScript/CoreFn/Expr.hs31
-rw-r--r--src/Language/PureScript/CoreFn/Literals.hs23
-rw-r--r--src/Language/PureScript/CoreFn/Meta.hs25
-rw-r--r--src/Language/PureScript/CoreFn/Traversals.hs1
-rw-r--r--src/Language/PureScript/Docs/AsMarkdown.hs42
-rw-r--r--src/Language/PureScript/Docs/Convert.hs257
-rw-r--r--src/Language/PureScript/Docs/Convert/ReExports.hs486
-rw-r--r--src/Language/PureScript/Docs/Convert/Single.hs232
-rw-r--r--src/Language/PureScript/Docs/ParseAndDesugar.hs82
-rw-r--r--src/Language/PureScript/Docs/Render.hs22
-rw-r--r--src/Language/PureScript/Docs/RenderedCode/Render.hs14
-rw-r--r--src/Language/PureScript/Docs/RenderedCode/Types.hs6
-rw-r--r--src/Language/PureScript/Docs/Types.hs95
-rw-r--r--src/Language/PureScript/Environment.hs79
-rw-r--r--src/Language/PureScript/Errors.hs554
-rw-r--r--src/Language/PureScript/Externs.hs46
-rw-r--r--src/Language/PureScript/Kinds.hs19
-rw-r--r--src/Language/PureScript/Linter.hs92
-rw-r--r--src/Language/PureScript/Linter/Exhaustive.hs155
-rw-r--r--src/Language/PureScript/Linter/Imports.hs310
-rw-r--r--src/Language/PureScript/Make.hs54
-rw-r--r--src/Language/PureScript/ModuleDependencies.hs13
-rw-r--r--src/Language/PureScript/Names.hs107
-rw-r--r--src/Language/PureScript/Parser/Common.hs23
-rw-r--r--src/Language/PureScript/Parser/Declarations.hs203
-rw-r--r--src/Language/PureScript/Parser/Kinds.hs7
-rw-r--r--src/Language/PureScript/Parser/Lexer.hs16
-rw-r--r--src/Language/PureScript/Parser/Types.hs63
-rw-r--r--src/Language/PureScript/Pretty/Common.hs4
-rw-r--r--src/Language/PureScript/Pretty/Types.hs54
-rw-r--r--src/Language/PureScript/Pretty/Values.hs1
-rw-r--r--src/Language/PureScript/Publish.hs29
-rw-r--r--src/Language/PureScript/Publish/ErrorsWarnings.hs17
-rw-r--r--src/Language/PureScript/Renamer.hs56
-rw-r--r--src/Language/PureScript/Sugar/BindingGroups.hs147
-rw-r--r--src/Language/PureScript/Sugar/CaseDeclarations.hs97
-rw-r--r--src/Language/PureScript/Sugar/DoNotation.hs20
-rw-r--r--src/Language/PureScript/Sugar/Names.hs231
-rw-r--r--src/Language/PureScript/Sugar/Names/Env.hs99
-rw-r--r--src/Language/PureScript/Sugar/Names/Exports.hs102
-rw-r--r--src/Language/PureScript/Sugar/Names/Imports.hs272
-rw-r--r--src/Language/PureScript/Sugar/ObjectWildcards.hs20
-rw-r--r--src/Language/PureScript/Sugar/Operators.hs62
-rw-r--r--src/Language/PureScript/Sugar/TypeClasses.hs101
-rw-r--r--src/Language/PureScript/Sugar/TypeClasses/Deriving.hs83
-rw-r--r--src/Language/PureScript/TypeChecker.hs206
-rw-r--r--src/Language/PureScript/TypeChecker/Entailment.hs55
-rw-r--r--src/Language/PureScript/TypeChecker/Kinds.hs117
-rw-r--r--src/Language/PureScript/TypeChecker/Monad.hs105
-rw-r--r--src/Language/PureScript/TypeChecker/Skolems.hs16
-rw-r--r--src/Language/PureScript/TypeChecker/Subsumption.hs2
-rw-r--r--src/Language/PureScript/TypeChecker/Types.hs79
-rw-r--r--src/Language/PureScript/TypeChecker/Unify.hs16
-rw-r--r--src/Language/PureScript/TypeClassDictionaries.hs27
-rw-r--r--src/Language/PureScript/Types.hs33
-rw-r--r--src/System/IO/UTF8.hs24
-rw-r--r--tests/Main.hs28
-rw-r--r--tests/TestDocs.hs232
-rw-r--r--tests/TestPscPublish.hs65
-rw-r--r--tests/support/bower.json2
146 files changed, 5441 insertions, 2694 deletions
diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md
index fde3d54..b4c76eb 100644
--- a/CONTRIBUTORS.md
+++ b/CONTRIBUTORS.md
@@ -12,6 +12,7 @@ This file lists the contributors to the PureScript compiler project, and the ter
- [@balajirrao](https://github.com/balajirrao) (Balaji Rao) - My existing contributions and all future contributions until further notice are Copyright Balaji Rao, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license.
- [@bergmark](https://github.com/bergmark) (Adam Bergmark) - My existing contributions and all future contributions until further notice are Copyright Adam Bergmark, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license.
- [@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).
- [@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).
- [@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).
@@ -26,7 +27,9 @@ This file lists the contributors to the PureScript compiler project, and the ter
- [@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.
- [@kRITZCREEK](https://github.com/kRITZCREEK) (Christoph Hegemann) - My existing contributions and all future contributions until further notice are Copyright Christoph Hegemann, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license.
- [@L8D](https://github.com/L8D) (Tenor Biel) My existing contributions and all future contributions until further notice are Copyright Tenor Biel, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
+- [@leighman](http://github.com/leighman) (Jack Leigh) My existing contributions and all future contributions until further notice are Copyright Jack Leigh, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
- [@lukerandall](https://github.com/lukerandall) (Luke Randall) My existing contributions and all future contributions until further notice are Copyright Luke Randall, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
+- [@mgmeier](https://github.com/mgmeier) (Michael Karg) My existing contributions and all future contributions until further notice are Copyright Michael Gilliland, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
- [@michaelficarra](https://github.com/michaelficarra) (Michael Ficarra) My existing contributions and all future contributions until further notice are Copyright Michael Ficarra, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
- [@MichaelXavier](https://github.com/MichaelXavier) (Michael Xavier) - My existing contributions and all future contributions until further notice are Copyright Michael Xavier, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license.
- [@mjgpy3](https://github.com/mjgpy3) (Michael Gilliland) My existing contributions and all future contributions until further notice are Copyright Michael Gilliland, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
@@ -48,6 +51,7 @@ 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.
+- [@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).
- [@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).
- [@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).
@@ -58,6 +62,9 @@ This file lists the contributors to the PureScript compiler project, and the ter
<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/INSTALL.md b/INSTALL.md
index 5e4bc78..c58652f 100644
--- a/INSTALL.md
+++ b/INSTALL.md
@@ -27,7 +27,7 @@ GHC 7.6.1 or newer is required to compile from source. The easiest way is to
use stack:
```
-$ stack install purescript
+$ stack install --resolver lts purescript
```
This will then copy the compiler and utilities into `~/.local/bin`.
diff --git a/examples/docs/bower.json b/examples/docs/bower.json
new file mode 100644
index 0000000..f4f13d5
--- /dev/null
+++ b/examples/docs/bower.json
@@ -0,0 +1,19 @@
+{
+ "name": "docs-test-package",
+ "version": "1.0.0",
+ "moduleType": [
+ "node"
+ ],
+ "repository": {
+ "type": "git",
+ "url": "git://github.com/not-real/not-a-real-repo.git"
+ },
+ "ignore": [
+ "**/.*",
+ "node_modules",
+ "bower_components",
+ "output"
+ ],
+ "dependencies": {
+ }
+}
diff --git a/examples/docs/bower_components/purescript-prelude/src/Prelude.purs b/examples/docs/bower_components/purescript-prelude/src/Prelude.purs
new file mode 100644
index 0000000..84b40b0
--- /dev/null
+++ b/examples/docs/bower_components/purescript-prelude/src/Prelude.purs
@@ -0,0 +1,8 @@
+module Prelude where
+
+newtype Unit = Unit {}
+
+unit :: Unit
+unit = Unit {}
+
+data Boolean2 = True | False
diff --git a/examples/docs/src/Clash.purs b/examples/docs/src/Clash.purs
new file mode 100644
index 0000000..6da44ee
--- /dev/null
+++ b/examples/docs/src/Clash.purs
@@ -0,0 +1,32 @@
+module Clash (module Clash1) where
+
+import Clash1 as Clash1
+import Clash2 as Clash2
+
+module Clash1 (module Clash1a) where
+
+import Clash1a
+
+module Clash1a where
+
+value :: Int
+value = 0
+
+type Type = Int
+
+class TypeClass a where
+ typeClassMember :: a
+
+module Clash2 (module Clash2a) where
+
+import Clash2a
+
+module Clash2a where
+
+value :: String
+value = "hello"
+
+type Type = String
+
+class TypeClass a b where
+ typeClassMember :: a -> b
diff --git a/examples/docs/src/DuplicateNames.purs b/examples/docs/src/DuplicateNames.purs
new file mode 100644
index 0000000..879fec0
--- /dev/null
+++ b/examples/docs/src/DuplicateNames.purs
@@ -0,0 +1,9 @@
+module DuplicateNames
+ ( module DuplicateNames
+ , module Prelude
+ ) where
+
+import Prelude (Unit)
+
+unit :: Int
+unit = 0
diff --git a/examples/docs/src/Example.purs b/examples/docs/src/Example.purs
new file mode 100644
index 0000000..0babd1d
--- /dev/null
+++ b/examples/docs/src/Example.purs
@@ -0,0 +1,7 @@
+module Example
+ ( module Prelude
+ , module Example2
+ ) where
+
+import Prelude (Unit())
+import Example2 (one)
diff --git a/examples/docs/src/Example2.purs b/examples/docs/src/Example2.purs
new file mode 100644
index 0000000..f038961
--- /dev/null
+++ b/examples/docs/src/Example2.purs
@@ -0,0 +1,7 @@
+module Example2 where
+
+one :: Int
+one = 1
+
+two :: Int
+two = 2
diff --git a/examples/docs/src/ImportedTwice.purs b/examples/docs/src/ImportedTwice.purs
new file mode 100644
index 0000000..fc13545
--- /dev/null
+++ b/examples/docs/src/ImportedTwice.purs
@@ -0,0 +1,27 @@
+-- See also an example in the wild: purescript-transformers v0.8.4.
+-- Control.Monad.RWS.Trans re-exports `lift` from both Control.Monad.Trans
+-- (where it is originally defined) and Control.Monad.RWS.Class (which
+-- re-exports it from Control.Monad.Trans).
+
+module ImportedTwice
+ ( module A
+ , module B
+ )
+ where
+
+import A
+import B
+
+module A
+ ( module B )
+ where
+
+import B
+
+bar :: Int
+bar = 1
+
+module B where
+
+foo :: Int
+foo = 0
diff --git a/examples/docs/src/MultiVirtual.purs b/examples/docs/src/MultiVirtual.purs
new file mode 100644
index 0000000..61ef6f8
--- /dev/null
+++ b/examples/docs/src/MultiVirtual.purs
@@ -0,0 +1,27 @@
+module MultiVirtual
+ ( module X )
+ where
+
+import MultiVirtual1 as X
+import MultiVirtual2 as X
+
+
+module MultiVirtual1 where
+
+foo :: Int
+foo = 1
+
+module MultiVirtual2
+ ( module MultiVirtual2
+ , module MultiVirtual3
+ ) where
+
+import MultiVirtual3
+
+bar :: Int
+bar = 2
+
+module MultiVirtual3 where
+
+baz :: Int
+baz = 3
diff --git a/examples/docs/src/NewOperators.purs b/examples/docs/src/NewOperators.purs
new file mode 100644
index 0000000..b8c20c4
--- /dev/null
+++ b/examples/docs/src/NewOperators.purs
@@ -0,0 +1,12 @@
+module NewOperators
+ ( module NewOperators2 )
+ where
+
+import NewOperators2
+
+module NewOperators2 where
+
+infixl 8 _compose as >>>
+
+_compose :: forall a b c. (b -> c) -> (a -> b) -> (a -> c)
+_compose f g x = f (g x)
diff --git a/examples/docs/src/NotAllCtors.purs b/examples/docs/src/NotAllCtors.purs
new file mode 100644
index 0000000..bfe9ffc
--- /dev/null
+++ b/examples/docs/src/NotAllCtors.purs
@@ -0,0 +1,5 @@
+module NotAllCtors
+ ( module Prelude )
+ where
+
+import Prelude (Boolean2(True))
diff --git a/examples/docs/src/OldOperators.purs b/examples/docs/src/OldOperators.purs
new file mode 100644
index 0000000..6a69323
--- /dev/null
+++ b/examples/docs/src/OldOperators.purs
@@ -0,0 +1,10 @@
+
+-- Remove this after 0.9.
+module OldOperators (module OldOperators2) where
+
+import OldOperators2
+
+module OldOperators2 where
+
+(>>) :: forall a. a -> a -> a
+(>>) a b = b
diff --git a/examples/docs/src/ReExportedTypeClass.purs b/examples/docs/src/ReExportedTypeClass.purs
new file mode 100644
index 0000000..17d5c4d
--- /dev/null
+++ b/examples/docs/src/ReExportedTypeClass.purs
@@ -0,0 +1,5 @@
+module ReExportedTypeClass
+ ( module SomeTypeClass )
+ where
+
+import SomeTypeClass
diff --git a/examples/docs/src/SolitaryTypeClassMember.purs b/examples/docs/src/SolitaryTypeClassMember.purs
new file mode 100644
index 0000000..2e94edc
--- /dev/null
+++ b/examples/docs/src/SolitaryTypeClassMember.purs
@@ -0,0 +1,6 @@
+module SolitaryTypeClassMember
+ ( module SomeTypeClass )
+ where
+
+import SomeTypeClass (member)
+
diff --git a/examples/docs/src/SomeTypeClass.purs b/examples/docs/src/SomeTypeClass.purs
new file mode 100644
index 0000000..204820f
--- /dev/null
+++ b/examples/docs/src/SomeTypeClass.purs
@@ -0,0 +1,5 @@
+
+module SomeTypeClass where
+
+class SomeClass a where
+ member :: a
diff --git a/examples/docs/src/Transitive1.purs b/examples/docs/src/Transitive1.purs
new file mode 100644
index 0000000..862f128
--- /dev/null
+++ b/examples/docs/src/Transitive1.purs
@@ -0,0 +1,5 @@
+module Transitive1
+ ( module Transitive2 )
+ where
+
+import Transitive2
diff --git a/examples/docs/src/Transitive2.purs b/examples/docs/src/Transitive2.purs
new file mode 100644
index 0000000..e607d1e
--- /dev/null
+++ b/examples/docs/src/Transitive2.purs
@@ -0,0 +1,5 @@
+module Transitive2
+ ( module Transitive3 )
+ where
+
+import Transitive3
diff --git a/examples/docs/src/Transitive3.purs b/examples/docs/src/Transitive3.purs
new file mode 100644
index 0000000..abf974b
--- /dev/null
+++ b/examples/docs/src/Transitive3.purs
@@ -0,0 +1,4 @@
+module Transitive3 where
+
+transitive3 :: Int
+transitive3 = 0
diff --git a/examples/docs/src/TypeClassWithoutMembers.purs b/examples/docs/src/TypeClassWithoutMembers.purs
new file mode 100644
index 0000000..fb926cf
--- /dev/null
+++ b/examples/docs/src/TypeClassWithoutMembers.purs
@@ -0,0 +1,11 @@
+module TypeClassWithoutMembers
+ ( module Intermediate )
+ where
+
+import Intermediate
+
+module Intermediate
+ ( module SomeTypeClass )
+ where
+
+import SomeTypeClass (SomeClass)
diff --git a/examples/docs/src/UTF8.purs b/examples/docs/src/UTF8.purs
new file mode 100644
index 0000000..258c6e1
--- /dev/null
+++ b/examples/docs/src/UTF8.purs
@@ -0,0 +1,7 @@
+module UTF8 where
+
+import Prelude (Unit, unit)
+
+-- | ΓΌΓœΓ€Γ„ 😰
+thing :: Unit
+thing = unit
diff --git a/examples/docs/src/Virtual.purs b/examples/docs/src/Virtual.purs
new file mode 100644
index 0000000..35f454a
--- /dev/null
+++ b/examples/docs/src/Virtual.purs
@@ -0,0 +1,5 @@
+module Virtual
+ ( module VirtualPrelude )
+ where
+
+import Prelude as VirtualPrelude
diff --git a/examples/failing/1733.purs b/examples/failing/1733.purs
new file mode 100644
index 0000000..8dfbf18
--- /dev/null
+++ b/examples/failing/1733.purs
@@ -0,0 +1,13 @@
+-- @shouldFailWith UnknownValue
+
+module Main where
+
+import Thingy as Thing
+
+main = Thing.doesntExist "hi"
+
+module Thingy where
+
+foo :: Int
+foo = 1
+
diff --git a/examples/failing/1825.purs b/examples/failing/1825.purs
new file mode 100644
index 0000000..0ffc5f2
--- /dev/null
+++ b/examples/failing/1825.purs
@@ -0,0 +1,9 @@
+-- @shouldFailWith UnknownValue
+
+module Main where
+
+data W = X | Y | Z
+
+bad X a = a
+bad Y _ = a
+bad Z a = a
diff --git a/examples/failing/CaseBinderLengthsDiffer.purs b/examples/failing/CaseBinderLengthsDiffer.purs
new file mode 100644
index 0000000..69e0e0a
--- /dev/null
+++ b/examples/failing/CaseBinderLengthsDiffer.purs
@@ -0,0 +1,6 @@
+-- @shouldFailWith CaseBinderLengthDiffers
+module Main where
+
+test = case 1, 2 of
+ 1, 2, 3 -> 42
+ _, _ -> 43
diff --git a/examples/failing/ConflictingExports.purs b/examples/failing/ConflictingExports.purs
new file mode 100644
index 0000000..1aef23b
--- /dev/null
+++ b/examples/failing/ConflictingExports.purs
@@ -0,0 +1,16 @@
+-- @shouldFailWith ScopeConflict
+module A where
+
+ thing :: Int
+ thing = 1
+
+module B where
+
+ thing :: Int
+ thing = 2
+
+-- Fails here because re-exporting forces any scope conflicts to be resolved
+module Main (module A, module B) where
+
+ import A
+ import B
diff --git a/examples/failing/ConflictingExports2.purs b/examples/failing/ConflictingExports2.purs
new file mode 100644
index 0000000..352548c
--- /dev/null
+++ b/examples/failing/ConflictingExports2.purs
@@ -0,0 +1,13 @@
+-- @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/ConflictingImports.purs b/examples/failing/ConflictingImports.purs
new file mode 100644
index 0000000..64eb1cc
--- /dev/null
+++ b/examples/failing/ConflictingImports.purs
@@ -0,0 +1,19 @@
+-- @shouldFailWith ScopeConflict
+module A where
+
+ thing :: Int
+ thing = 1
+
+module B where
+
+ thing :: Int
+ thing = 2
+
+module Main where
+
+ import A
+ import B
+
+ -- Error due to referencing `thing` which is in scope as A.thing and B.thing
+ what :: Int
+ what = thing
diff --git a/examples/failing/ConflictingImports2.purs b/examples/failing/ConflictingImports2.purs
new file mode 100644
index 0000000..ef56fdd
--- /dev/null
+++ b/examples/failing/ConflictingImports2.purs
@@ -0,0 +1,16 @@
+-- @shouldFailWith ScopeConflict
+module A where
+
+ thing :: Int
+ thing = 1
+
+module Main where
+
+ import A
+
+ thing :: Int
+ thing = 2
+
+ -- Error due to referencing `thing` which is in scope as A.thing and Main.thing
+ what :: Int
+ what = thing
diff --git a/examples/failing/ConflictingQualifiedImports.purs b/examples/failing/ConflictingQualifiedImports.purs
new file mode 100644
index 0000000..a85aa60
--- /dev/null
+++ b/examples/failing/ConflictingQualifiedImports.purs
@@ -0,0 +1,17 @@
+-- @shouldFailWith ScopeConflict
+module A where
+
+ thing :: Int
+ thing = 1
+
+module B where
+
+ thing :: Int
+ thing = 2
+
+module Main where
+
+ import A as X
+ import B as X
+
+ foo = X.thing
diff --git a/examples/failing/ConflictingQualifiedImports2.purs b/examples/failing/ConflictingQualifiedImports2.purs
new file mode 100644
index 0000000..fd5efa5
--- /dev/null
+++ b/examples/failing/ConflictingQualifiedImports2.purs
@@ -0,0 +1,15 @@
+-- @shouldFailWith ScopeConflict
+module A where
+
+ thing :: Int
+ thing = 1
+
+module B where
+
+ thing :: Int
+ thing = 2
+
+module Main (module X) where
+
+ import A as X
+ import B as X
diff --git a/examples/failing/IntOutOfRange.purs b/examples/failing/IntOutOfRange.purs
new file mode 100644
index 0000000..1d22217
--- /dev/null
+++ b/examples/failing/IntOutOfRange.purs
@@ -0,0 +1,6 @@
+-- @shouldFailWith IntOutOfRange
+
+module Main where
+
+n :: Int
+n = 2147483648
diff --git a/examples/failing/OperatorAliasNoExport.purs b/examples/failing/OperatorAliasNoExport.purs
new file mode 100644
index 0000000..5a089ba
--- /dev/null
+++ b/examples/failing/OperatorAliasNoExport.purs
@@ -0,0 +1,7 @@
+-- @shouldFailWith TransitiveExportError
+module Test ((?!)) where
+
+infixl 4 what as ?!
+
+what :: forall a b. a -> b -> a
+what a _ = a
diff --git a/examples/passing/1185.purs b/examples/passing/1185.purs
new file mode 100644
index 0000000..eddb589
--- /dev/null
+++ b/examples/passing/1185.purs
@@ -0,0 +1,13 @@
+module Main where
+
+data Person = Person String Boolean
+
+getName :: Person -> String
+getName p = case p of
+ Person name true -> name
+ _ -> "Unknown"
+
+name :: String
+name = getName (Person "John Smith" true)
+
+main = Control.Monad.Eff.Console.log "Done"
diff --git a/examples/passing/1664.purs b/examples/passing/1664.purs
new file mode 100644
index 0000000..40260c7
--- /dev/null
+++ b/examples/passing/1664.purs
@@ -0,0 +1,16 @@
+module Main where
+
+import Prelude
+import Control.Monad.Eff
+import Control.Monad.Eff.Console
+
+data Identity a = Identity a
+
+newtype IdentityEff e a = IdentityEff (Eff e (Identity a))
+
+test :: forall e a. IdentityEff e a -> IdentityEff e Unit
+test (IdentityEff action) = IdentityEff $ do
+ (Identity x :: Identity _) <- action
+ return $ Identity unit
+
+main = log "Done"
diff --git a/examples/passing/1697.purs b/examples/passing/1697.purs
new file mode 100644
index 0000000..44f4289
--- /dev/null
+++ b/examples/passing/1697.purs
@@ -0,0 +1,24 @@
+module Main where
+
+import Prelude
+
+_2 :: forall a. a -> a
+_2 a = a
+
+x :: forall m. (Monad m) => m Unit
+x = do
+ _ <- pure unit
+ pure unit
+
+y :: forall m. (Monad m) => m Unit
+y = do
+ _ <- pure unit
+ pure unit
+
+wtf :: forall m. (Monad m) => m Unit
+wtf = do
+ _ <- pure unit
+ let tmp = _2 1
+ pure unit
+
+main = Control.Monad.Eff.Console.log "Done"
diff --git a/examples/passing/CaseMultipleExpressions.purs b/examples/passing/CaseMultipleExpressions.purs
new file mode 100644
index 0000000..763a425
--- /dev/null
+++ b/examples/passing/CaseMultipleExpressions.purs
@@ -0,0 +1,19 @@
+module Main where
+
+import Prelude
+import Control.Monad.Eff.Console
+import Control.Monad.Eff
+
+doIt :: forall eff. Eff eff Boolean
+doIt = return true
+
+set = do
+ log "Testing..."
+ case 42, 10 of
+ 42, 10 -> doIt
+ _ , _ -> return false
+
+main = do
+ b <- set
+ case b of
+ true -> log "Done"
diff --git a/examples/passing/ClassRefSyntax.purs b/examples/passing/ClassRefSyntax.purs
new file mode 100644
index 0000000..b4a187d
--- /dev/null
+++ b/examples/passing/ClassRefSyntax.purs
@@ -0,0 +1,13 @@
+module Lib (class X, go) where
+
+ class X a where
+ go :: a -> a
+
+module Main where
+
+ import Lib (class X, go)
+
+ go' :: forall a. (X a) => a -> a
+ go' = go
+
+ main = Control.Monad.Eff.Console.log "Done"
diff --git a/examples/passing/EmptyTypeClass.purs b/examples/passing/EmptyTypeClass.purs
index 81d5ab3..065a829 100644
--- a/examples/passing/EmptyTypeClass.purs
+++ b/examples/passing/EmptyTypeClass.purs
@@ -2,11 +2,11 @@ module Main where
import Prelude
-class Partial
+class PartialP
-head :: forall a. (Partial) => Array a -> a
+head :: forall a. (PartialP) => Array a -> a
head [x] = x
-instance allowPartials :: Partial
+instance allowPartials :: PartialP
main = Control.Monad.Eff.Console.log $ head ["Done"]
diff --git a/examples/passing/NakedConstraint.purs b/examples/passing/NakedConstraint.purs
index 1fe4e9d..f4b3a55 100644
--- a/examples/passing/NakedConstraint.purs
+++ b/examples/passing/NakedConstraint.purs
@@ -2,8 +2,6 @@ module Main where
import Control.Monad.Eff.Console
-class Partial
-
data List a = Nil | Cons a (List a)
head :: (Partial) => List Int -> Int
diff --git a/examples/passing/NegativeIntInRange.purs b/examples/passing/NegativeIntInRange.purs
new file mode 100644
index 0000000..734d4a1
--- /dev/null
+++ b/examples/passing/NegativeIntInRange.purs
@@ -0,0 +1,8 @@
+module Main where
+
+import Prelude
+
+n :: Int
+n = -2147483648
+
+main = Control.Monad.Eff.Console.log "Done"
diff --git a/examples/passing/NonConflictingExports.purs b/examples/passing/NonConflictingExports.purs
new file mode 100644
index 0000000..9dff502
--- /dev/null
+++ b/examples/passing/NonConflictingExports.purs
@@ -0,0 +1,14 @@
+module A where
+
+ thing :: Int
+ thing = 1
+
+-- No failure here as the export `thing` only refers to Main.thing
+module Main (thing, main) where
+
+ import A
+
+ thing :: Int
+ thing = 2
+
+ main = Control.Monad.Eff.Console.log "Done"
diff --git a/examples/passing/OperatorAlias.purs b/examples/passing/OperatorAlias.purs
new file mode 100644
index 0000000..d3615de
--- /dev/null
+++ b/examples/passing/OperatorAlias.purs
@@ -0,0 +1,11 @@
+module Main where
+
+import Prelude
+import Control.Monad.Eff.Console
+
+infixl 4 what as ?!
+
+what :: forall a b. a -> b -> a
+what a _ = a
+
+main = log $ "Done" ?! true
diff --git a/examples/passing/OperatorAliasElsewhere.purs b/examples/passing/OperatorAliasElsewhere.purs
new file mode 100644
index 0000000..952fa83
--- /dev/null
+++ b/examples/passing/OperatorAliasElsewhere.purs
@@ -0,0 +1,14 @@
+module Def where
+
+what :: forall a b. a -> b -> a
+what a _ = a
+
+module Main where
+
+import Prelude
+import Def (what)
+import Control.Monad.Eff.Console
+
+infixl 4 what as ?!
+
+main = log $ "Done" ?! true
diff --git a/examples/passing/PendingConflictingImports.purs b/examples/passing/PendingConflictingImports.purs
new file mode 100644
index 0000000..942ed42
--- /dev/null
+++ b/examples/passing/PendingConflictingImports.purs
@@ -0,0 +1,17 @@
+module A where
+
+ thing :: Int
+ thing = 1
+
+module B where
+
+ thing :: Int
+ thing = 2
+
+module Main where
+
+ -- No error as we never force `thing` to be resolved in `Main`
+ import A
+ import B
+
+ main = Control.Monad.Eff.Console.log "Done"
diff --git a/examples/passing/PendingConflictingImports2.purs b/examples/passing/PendingConflictingImports2.purs
new file mode 100644
index 0000000..f578dde
--- /dev/null
+++ b/examples/passing/PendingConflictingImports2.purs
@@ -0,0 +1,14 @@
+module A where
+
+ thing :: Int
+ thing = 1
+
+module Main where
+
+ import A
+
+ -- No error as we never force `thing` to be resolved in `Main`
+ thing :: Int
+ thing = 2
+
+ main = Control.Monad.Eff.Console.log "Done"
diff --git a/examples/passing/ShadowedModuleName.purs b/examples/passing/ShadowedModuleName.purs
new file mode 100644
index 0000000..3b30390
--- /dev/null
+++ b/examples/passing/ShadowedModuleName.purs
@@ -0,0 +1,15 @@
+module Test where
+
+ data Z = Z String
+
+ runZ :: Z -> String
+ runZ (Z s) = s
+
+module Main where
+
+ import Test
+ import Control.Monad.Eff.Console
+
+ data Test = Test
+
+ main = log (runZ (Z "done"))
diff --git a/examples/passing/TCO.purs b/examples/passing/TCO.purs
new file mode 100644
index 0000000..8567178
--- /dev/null
+++ b/examples/passing/TCO.purs
@@ -0,0 +1,20 @@
+module Main where
+
+import Prelude
+import Control.Monad.Eff.Console (print)
+
+main = do
+ let f x = x + 1
+ let v = 0
+ print (applyN 0 f v)
+ print (applyN 1 f v)
+ print (applyN 2 f v)
+ print (applyN 3 f v)
+ print (applyN 4 f v)
+
+applyN :: forall a. Int -> (a -> a) -> a -> a
+applyN = go id
+ where
+ go f n _ | n <= 0 = f
+ go f n g = go (f >>> g) (n - 1) g
+
diff --git a/examples/passing/TypeWithoutParens.purs b/examples/passing/TypeWithoutParens.purs
new file mode 100644
index 0000000..4aca413
--- /dev/null
+++ b/examples/passing/TypeWithoutParens.purs
@@ -0,0 +1,16 @@
+module Lib (X, Y) where
+
+ data X = X
+ type Y = X
+
+module Main where
+
+ import Lib (X, Y)
+
+ idX :: X -> X
+ idX x = x
+
+ idY :: Y -> Y
+ idY y = y
+
+ main = Control.Monad.Eff.Console.log "Done"
diff --git a/examples/passing/UnicodeIdentifier.purs b/examples/passing/UnicodeIdentifier.purs
new file mode 100644
index 0000000..0be0e3e
--- /dev/null
+++ b/examples/passing/UnicodeIdentifier.purs
@@ -0,0 +1,5 @@
+module Main where
+
+f asgΓ₯rd = asgΓ₯rd
+
+main = Control.Monad.Eff.Console.log (f "Done")
diff --git a/examples/passing/UnicodeOperators.purs b/examples/passing/UnicodeOperators.purs
new file mode 100644
index 0000000..3fa3347
--- /dev/null
+++ b/examples/passing/UnicodeOperators.purs
@@ -0,0 +1,20 @@
+module Main where
+
+compose :: forall a b c. (b -> c) -> (a -> b) -> a -> c
+compose f g a = f (g a)
+
+infixr 9 compose as ∘
+
+test1 = (\x -> x) ∘ \y -> y
+
+elem :: forall a b. a -> (a -> Boolean) -> Boolean
+elem x f = f x
+
+infixl 1 elem as ∈
+
+emptySet :: forall a. a -> Boolean
+emptySet _ = true
+
+test2 = 1 ∈ emptySet
+
+main = Control.Monad.Eff.Console.log "Done"
diff --git a/examples/passing/UnicodeType.purs b/examples/passing/UnicodeType.purs
new file mode 100644
index 0000000..7e4ecb9
--- /dev/null
+++ b/examples/passing/UnicodeType.purs
@@ -0,0 +1,23 @@
+module Main where
+
+import Prelude
+
+class (Monad m) ⇐ Monad1 m where
+ f1 :: Int
+
+class (Monad m) <= Monad2 m where
+ f2 :: Int
+
+f ∷ βˆ€ m. Monad m β‡’ Int β†’ m Int
+f n = do
+ n' ← return n
+ return n'
+
+f' :: forall m. Monad m => Int -> m Int
+f' n = do
+ n' <- return n
+ return n'
+
+(←→) a b = a ←→ b
+
+main = Control.Monad.Eff.Console.log "Done"
diff --git a/examples/passing/UntupledConstraints.purs b/examples/passing/UntupledConstraints.purs
new file mode 100644
index 0000000..55cff87
--- /dev/null
+++ b/examples/passing/UntupledConstraints.purs
@@ -0,0 +1,17 @@
+module Main where
+
+import Prelude
+import Control.Monad.Eff.Console
+
+class Show a <= Nonsense a where
+ method :: a -> a
+
+data Box a = Box a
+
+instance showBox :: Show a => Show (Box a) where
+ show (Box a) = "Box " <> show a
+
+strangeThing :: forall m. Semigroup (m Unit) => m Unit -> m Unit -> m Unit
+strangeThing x y = x <> y
+
+main = log "Done"
diff --git a/hierarchy/Main.hs b/hierarchy/Main.hs
index 76b8c95..dcba309 100644
--- a/hierarchy/Main.hs
+++ b/hierarchy/Main.hs
@@ -14,6 +14,7 @@
-----------------------------------------------------------------------------
{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE DataKinds #-}
module Main where
@@ -38,7 +39,7 @@ data HierarchyOptions = HierarchyOptions
, hierarchyOutput :: Maybe FilePath
}
-newtype SuperMap = SuperMap { unSuperMap :: Either P.ProperName (P.ProperName, P.ProperName) }
+newtype SuperMap = SuperMap { unSuperMap :: Either (P.ProperName 'P.ClassName) ((P.ProperName 'P.ClassName), (P.ProperName 'P.ClassName)) }
deriving Eq
instance Show SuperMap where
diff --git a/psc-bundle/Main.hs b/psc-bundle/Main.hs
index 819c87a..5a4201b 100644
--- a/psc-bundle/Main.hs
+++ b/psc-bundle/Main.hs
@@ -70,7 +70,7 @@ app Options{..} = do
input <- for inputFiles $ \filename -> do
js <- liftIO (readFile filename)
mid <- guessModuleIdentifier filename
- return (mid, js)
+ length js `seq` return (mid, js) -- evaluate readFile till EOF before returning, not to exhaust file handles
let entryIds = map (`ModuleIdentifier` Regular) optionsEntryPoints
diff --git a/psc-docs/Main.hs b/psc-docs/Main.hs
index 79b7fdc..f979587 100644
--- a/psc-docs/Main.hs
+++ b/psc-docs/Main.hs
@@ -16,6 +16,7 @@
module Main where
import Control.Applicative
+import Control.Monad.Trans.Except (runExceptT)
import Control.Arrow (first, second)
import Control.Category ((>>>))
import Control.Monad.Writer
@@ -68,61 +69,68 @@ docgen (PSCDocsOptions fmt inputGlob output) = do
Etags -> dumpTags input dumpEtags
Ctags -> dumpTags input dumpCtags
Markdown -> do
- e <- D.parseAndDesugar input [] (\_ ms -> return ms)
- case e of
- Left (D.ParseError err) -> do
- hPutStrLn stderr $ show err
- exitFailure
- Left (D.SortModulesError err) -> do
- hPutStrLn stderr $ P.prettyPrintMultipleErrors False err
- exitFailure
- Left (D.DesugarError err) -> do
- hPutStrLn stderr $ P.prettyPrintMultipleErrors False err
- exitFailure
- Right ms' ->
- case output of
- EverythingToStdOut ->
- putStrLn (D.renderModulesAsMarkdown ms')
- ToStdOut names -> do
- let (ms, missing) = takeModulesByName ms' names
- guardMissing missing
- putStrLn (D.renderModulesAsMarkdown ms)
- ToFiles names -> do
- let (ms, missing) = takeModulesByName' ms' names
- guardMissing missing
- let ms'' = groupBy ((==) `on` fst) . sortBy (compare `on` fst) $ map swap ms
- forM_ ms'' $ \grp -> do
- let fp = fst (head grp)
- createDirectoryIfMissing True (takeDirectory fp)
- writeFile fp (D.renderModulesAsMarkdown $ snd `map` grp)
+ ms <- runExceptT (D.parseAndDesugar input []
+ >>= ((\(ms, _, env) -> D.convertModulesInPackage env ms)))
+ >>= successOrExit
+
+ case output of
+ EverythingToStdOut ->
+ putStrLn (D.runDocs (D.modulesAsMarkdown ms))
+ ToStdOut names -> do
+ let (ms', missing) = takeByName ms (map P.runModuleName names)
+ guardMissing missing
+ putStrLn (D.runDocs (D.modulesAsMarkdown ms'))
+ ToFiles names -> do
+ let (ms', missing) = takeByName' ms (map (first P.runModuleName) names)
+ guardMissing missing
+
+ let ms'' = groupBy ((==) `on` fst) . sortBy (compare `on` fst) $ map swap ms'
+ forM_ ms'' $ \grp -> do
+ let fp = fst (head grp)
+ createDirectoryIfMissing True (takeDirectory fp)
+ writeFile fp (D.runDocs (D.modulesAsMarkdown (map snd grp)))
+
where
guardMissing [] = return ()
guardMissing [mn] = do
- hPutStrLn stderr ("psc-docs: error: unknown module \"" ++ show mn ++ "\"")
+ hPutStrLn stderr ("psc-docs: error: unknown module \"" ++ mn ++ "\"")
exitFailure
guardMissing mns = do
hPutStrLn stderr "psc-docs: error: unknown modules:"
forM_ mns $ \mn ->
- hPutStrLn stderr (" * " ++ show mn)
+ hPutStrLn stderr (" * " ++ mn)
exitFailure
+ successOrExit :: Either P.MultipleErrors a -> IO a
+ successOrExit act =
+ case act of
+ Right x ->
+ return x
+ Left err -> do
+ hPutStrLn stderr $ P.prettyPrintMultipleErrors False err
+ exitFailure
+
+ takeByName = takeModulesByName D.modName
+ takeByName' = takeModulesByName' D.modName
+
-- |
-- Given a list of module names and a list of modules, return a list of modules
-- whose names appeared in the given name list, together with a list of names
-- for which no module could be found in the module list.
--
-takeModulesByName :: [P.Module] -> [P.ModuleName] -> ([P.Module], [P.ModuleName])
-takeModulesByName modules names =
- first (map fst) (takeModulesByName' modules (map (,()) names))
+takeModulesByName :: (Eq n) => (m -> n) -> [m] -> [n] -> ([m], [n])
+takeModulesByName getModuleName modules names =
+ first (map fst) (takeModulesByName' getModuleName modules (map (,()) names))
-- |
--- Like takeModulesByName but also keeps some extra data with the module.
+-- Like takeModulesByName, but also keeps some extra information with each
+-- module.
--
-takeModulesByName' :: [P.Module] -> [(P.ModuleName, a)] -> ([(P.Module, a)], [P.ModuleName])
-takeModulesByName' modules = foldl go ([], [])
+takeModulesByName' :: (Eq n) => (m -> n) -> [m] -> [(n, a)] -> ([(m, a)], [n])
+takeModulesByName' getModuleName modules = foldl go ([], [])
where
go (ms, missing) (name, x) =
- case find ((== name) . P.getModuleName) modules of
+ case find ((== name) . getModuleName) modules of
Just m -> ((m, x) : ms, missing)
Nothing -> (ms, name : missing)
@@ -236,16 +244,16 @@ examples =
PP.vcat $ map PP.text
[ "Examples:"
, " print documentation for Data.List to stdout:"
- , " psc-docs src/**/*.purs bower_components/*/src/**/*.purs \\"
+ , " psc-docs \"src/**/*.purs\" \"bower_components/*/src/**/*.purs\" \\"
, " --docgen Data.List"
, ""
, " write documentation for Data.List to docs/Data.List.md:"
- , " psc-docs src/**/*.purs bower_components/*/src/**/*.purs \\"
+ , " psc-docs \"src/**/*.purs\" \"bower_components/*/src/**/*.purs\" \\"
, " --docgen Data.List:docs/Data.List.md"
, ""
, " write documentation for Data.List to docs/Data.List.md, and"
, " documentation for Data.List.Lazy to docs/Data.List.Lazy.md:"
- , " psc-docs src/**/*.purs bower_components/*/src/**/*.purs \\"
+ , " psc-docs \"src/**/*.purs\" \"bower_components/*/src/**/*.purs\" \\"
, " --docgen Data.List:docs/Data.List.md \\"
, " --docgen Data.List.Lazy:docs/Data.List.Lazy.md"
]
diff --git a/psc-docs/Tags.hs b/psc-docs/Tags.hs
index 461a7f6..d370f05 100644
--- a/psc-docs/Tags.hs
+++ b/psc-docs/Tags.hs
@@ -10,9 +10,9 @@ tags = concatMap dtags . P.exportedDeclarations
dtags _ = []
names (P.DataDeclaration _ name _ dcons) = P.runProperName name : consNames
where consNames = map (\(cname, _) -> P.runProperName cname) dcons
- names (P.TypeDeclaration ident _) = [show ident]
- names (P.ExternDeclaration ident _) = [show ident]
+ names (P.TypeDeclaration ident _) = [P.showIdent ident]
+ names (P.ExternDeclaration ident _) = [P.showIdent ident]
names (P.TypeSynonymDeclaration name _ _) = [P.runProperName name]
names (P.TypeClassDeclaration name _ _ _) = [P.runProperName name]
- names (P.TypeInstanceDeclaration name _ _ _ _) = [show name]
+ names (P.TypeInstanceDeclaration name _ _ _ _) = [P.showIdent name]
names _ = []
diff --git a/psc/JSON.hs b/psc/JSON.hs
new file mode 100644
index 0000000..c6fb051
--- /dev/null
+++ b/psc/JSON.hs
@@ -0,0 +1,80 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Main
+-- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
+-- License : MIT (http://opensource.org/licenses/MIT)
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+--
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE TemplateHaskell #-}
+
+module JSON where
+
+import Prelude ()
+import Prelude.Compat
+
+import qualified Data.Aeson.TH as A
+
+import qualified Language.PureScript as P
+
+data ErrorPosition = ErrorPosition
+ { startLine :: Int
+ , startColumn :: Int
+ , endLine :: Int
+ , endColumn :: Int
+ }
+
+data ErrorSuggestion = ErrorSuggestion { replacement :: String }
+
+data JSONError = JSONError
+ { position :: Maybe ErrorPosition
+ , message :: String
+ , errorCode :: String
+ , errorLink :: String
+ , filename :: Maybe String
+ , moduleName :: Maybe String
+ , suggestion :: Maybe ErrorSuggestion
+ }
+
+data JSONResult = JSONResult
+ { warnings :: [JSONError]
+ , errors :: [JSONError]
+ }
+
+$(A.deriveJSON A.defaultOptions ''ErrorPosition)
+$(A.deriveJSON A.defaultOptions ''JSONError)
+$(A.deriveJSON A.defaultOptions ''JSONResult)
+$(A.deriveJSON A.defaultOptions ''ErrorSuggestion)
+
+
+toJSONErrors :: Bool -> P.Level -> P.MultipleErrors -> [JSONError]
+toJSONErrors verbose level = map (toJSONError verbose level) . P.runMultipleErrors
+
+toJSONError :: Bool -> P.Level -> P.ErrorMessage -> JSONError
+toJSONError verbose level e =
+ JSONError (toErrorPosition <$> sspan)
+ (P.renderBox (P.prettyPrintSingleError verbose level False (P.stripModuleAndSpan e)))
+ (P.errorCode e)
+ (P.wikiUri e)
+ (P.spanName <$> sspan)
+ (P.runModuleName <$> P.errorModule e)
+ (toSuggestion <$> (P.errorSuggestion $ P.unwrapErrorMessage e))
+ where
+ sspan :: Maybe P.SourceSpan
+ sspan = P.errorSpan e
+
+ toErrorPosition :: P.SourceSpan -> ErrorPosition
+ toErrorPosition ss =
+ ErrorPosition (P.sourcePosLine (P.spanStart ss))
+ (P.sourcePosColumn (P.spanStart ss))
+ (P.sourcePosLine (P.spanEnd ss))
+ (P.sourcePosColumn (P.spanEnd ss))
+ toSuggestion :: P.ErrorSuggestion -> ErrorSuggestion
+-- TODO: Adding a newline because source spans chomp everything up to the next character
+ toSuggestion (P.ErrorSuggestion s) = ErrorSuggestion $ if null s then s else s ++ "\n"
diff --git a/psc/Main.hs b/psc/Main.hs
index 1914cf5..6f7d8d0 100644
--- a/psc/Main.hs
+++ b/psc/Main.hs
@@ -27,6 +27,9 @@ import Control.Monad.Writer.Strict
import Data.List (isSuffixOf, partition)
import Data.Version (showVersion)
import qualified Data.Map as M
+import qualified Data.Aeson as A
+import qualified Data.ByteString.Lazy as B
+import qualified Data.ByteString.UTF8 as BU8
import Options.Applicative as Opts
@@ -40,45 +43,54 @@ import qualified Paths_purescript as Paths
import Language.PureScript.Make
+import JSON
+
data PSCMakeOptions = PSCMakeOptions
{ pscmInput :: [FilePath]
, pscmForeignInput :: [FilePath]
, pscmOutputDir :: FilePath
, pscmOpts :: P.Options
, pscmUsePrefix :: Bool
+ , pscmJSONErrors :: Bool
}
data InputOptions = InputOptions
{ ioInputFiles :: [FilePath]
}
+-- | Argumnets: verbose, use JSON, warnings, errors
+printWarningsAndErrors :: Bool -> Bool -> P.MultipleErrors -> Either P.MultipleErrors a -> IO ()
+printWarningsAndErrors verbose False warnings errors = do
+ when (P.nonEmpty warnings) $
+ hPutStrLn stderr (P.prettyPrintMultipleWarnings verbose warnings)
+ case errors of
+ Left errs -> do
+ hPutStrLn stderr (P.prettyPrintMultipleErrors verbose errs)
+ exitFailure
+ Right _ -> return ()
+printWarningsAndErrors verbose True warnings errors = do
+ hPutStrLn stderr . BU8.toString . B.toStrict . A.encode $
+ JSONResult (toJSONErrors verbose P.Warning warnings)
+ (either (toJSONErrors verbose P.Error) (const []) errors)
+ either (const exitFailure) (const (return ())) errors
+
compile :: PSCMakeOptions -> IO ()
-compile (PSCMakeOptions inputGlob inputForeignGlob outputDir opts usePrefix) = do
- input <- globWarningOnMisses warnFileTypeNotFound inputGlob
- when (null input) $ do
+compile PSCMakeOptions{..} = do
+ input <- globWarningOnMisses (unless pscmJSONErrors . warnFileTypeNotFound) pscmInput
+ when (null input && not pscmJSONErrors) $ do
hPutStrLn stderr "psc: No input files."
exitFailure
let (jsFiles, pursFiles) = partition (isSuffixOf ".js") input
moduleFiles <- readInput (InputOptions pursFiles)
- inputForeign <- globWarningOnMisses warnFileTypeNotFound inputForeignGlob
+ inputForeign <- globWarningOnMisses (unless pscmJSONErrors . warnFileTypeNotFound) pscmForeignInput
foreignFiles <- forM (inputForeign ++ jsFiles) (\inFile -> (inFile,) <$> readUTF8File inFile)
- case runWriterT (parseInputs moduleFiles foreignFiles) of
- Left errs -> do
- hPutStrLn stderr (P.prettyPrintMultipleErrors (P.optionsVerboseErrors opts) errs)
- exitFailure
- Right ((ms, foreigns), warnings) -> do
- when (P.nonEmpty warnings) $
- hPutStrLn stderr (P.prettyPrintMultipleWarnings (P.optionsVerboseErrors opts) warnings)
- let filePathMap = M.fromList $ map (\(fp, P.Module _ _ mn _ _) -> (mn, fp)) ms
- makeActions = buildMakeActions outputDir filePathMap foreigns usePrefix
- (e, warnings') <- runMake opts $ P.make makeActions (map snd ms)
- when (P.nonEmpty warnings') $
- hPutStrLn stderr (P.prettyPrintMultipleWarnings (P.optionsVerboseErrors opts) warnings')
- case e of
- Left errs -> do
- hPutStrLn stderr (P.prettyPrintMultipleErrors (P.optionsVerboseErrors opts) errs)
- exitFailure
- Right _ -> exitSuccess
+ (makeErrors, makeWarnings) <- runMake pscmOpts $ do
+ (ms, foreigns) <- parseInputs moduleFiles foreignFiles
+ let filePathMap = M.fromList $ map (\(fp, P.Module _ _ mn _ _) -> (mn, fp)) ms
+ makeActions = buildMakeActions pscmOutputDir filePathMap foreigns pscmUsePrefix
+ P.make makeActions (map snd ms)
+ printWarningsAndErrors (P.optionsVerboseErrors pscmOpts) pscmJSONErrors makeWarnings makeErrors
+ exitSuccess
warnFileTypeNotFound :: String -> IO ()
warnFileTypeNotFound = hPutStrLn stderr . ("psc: No files found using pattern: " ++)
@@ -161,6 +173,10 @@ noPrefix = switch $
<> long "no-prefix"
<> help "Do not include comment header"
+jsonErrors :: Parser Bool
+jsonErrors = switch $
+ long "json-errors"
+ <> help "Print errors to stderr as JSON"
options :: Parser P.Options
options = P.Options <$> noTco
@@ -177,7 +193,7 @@ pscMakeOptions = PSCMakeOptions <$> many inputFile
<*> outputDirectory
<*> options
<*> (not <$> noPrefix)
-
+ <*> jsonErrors
main :: IO ()
main = execParser opts >>= compile
diff --git a/psci/Completion.hs b/psci/Completion.hs
index 8a52463..564d904 100644
--- a/psci/Completion.hs
+++ b/psci/Completion.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE DataKinds #-}
+
module Completion where
import Prelude ()
@@ -184,10 +186,10 @@ getAllImportsOf = asks . allImportsOf
nubOnFst :: Eq a => [(a, b)] -> [(a, b)]
nubOnFst = nubBy ((==) `on` fst)
-typeDecls :: P.Module -> [(N.ProperName, P.Declaration)]
+typeDecls :: P.Module -> [(N.ProperName 'N.TypeName, P.Declaration)]
typeDecls = mapMaybe getTypeName . filter P.isDataDecl . P.exportedDeclarations
where
- getTypeName :: P.Declaration -> Maybe (N.ProperName, P.Declaration)
+ getTypeName :: P.Declaration -> Maybe (N.ProperName 'N.TypeName, P.Declaration)
getTypeName d@(P.TypeSynonymDeclaration name _ _) = Just (name, d)
getTypeName d@(P.DataDeclaration _ name _ _) = Just (name, d)
getTypeName (P.PositionedDeclaration _ _ d) = getTypeName d
@@ -204,10 +206,10 @@ identNames = nubOnFst . concatMap getDeclNames . P.exportedDeclarations
getDeclNames (P.PositionedDeclaration _ _ d) = getDeclNames d
getDeclNames _ = []
-dctorNames :: P.Module -> [(N.ProperName, P.Declaration)]
+dctorNames :: P.Module -> [(N.ProperName 'N.ConstructorName, P.Declaration)]
dctorNames = nubOnFst . concatMap go . P.exportedDeclarations
where
- go :: P.Declaration -> [(N.ProperName, P.Declaration)]
+ go :: P.Declaration -> [(N.ProperName 'N.ConstructorName, P.Declaration)]
go decl@(P.DataDeclaration _ _ _ ctors) = map (\n -> (n, decl)) (map fst ctors)
go (P.PositionedDeclaration _ _ d) = go d
go _ = []
diff --git a/psci/PSCi.hs b/psci/PSCi.hs
index d75ccee..4ea0342 100644
--- a/psci/PSCi.hs
+++ b/psci/PSCi.hs
@@ -1,23 +1,12 @@
------------------------------------------------------------------------------
---
--- Module : PSCi
--- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
--- License : MIT (http://opensource.org/licenses/MIT)
---
--- Maintainer : Phil Freeman <paf31@cantab.net>
--- Stability : experimental
--- Portability :
---
--- |
--- PureScript Compiler Interactive.
---
------------------------------------------------------------------------------
-
{-# LANGUAGE DoAndIfThenElse #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE DataKinds #-}
+-- |
+-- PureScript Compiler Interactive.
+--
module PSCi where
import Prelude ()
@@ -25,7 +14,7 @@ import Prelude.Compat
import Data.Foldable (traverse_)
import Data.Maybe (mapMaybe)
-import Data.List (intersperse, intercalate, nub, sort)
+import Data.List (intersperse, intercalate, nub, sort, find)
import Data.Tuple (swap)
import Data.Version (showVersion)
import qualified Data.Map as M
@@ -125,12 +114,12 @@ loadModule filename = do
-- |
-- Load all modules.
--
-loadAllModules :: [FilePath] -> IO (Either P.MultipleErrors [(Either P.RebuildPolicy FilePath, P.Module)])
+loadAllModules :: [FilePath] -> IO (Either P.MultipleErrors [(FilePath, P.Module)])
loadAllModules files = do
filesAndContent <- forM files $ \filename -> do
content <- readFile filename
- return (Right filename, content)
- return $ P.parseModulesFromFiles (either (const "") id) filesAndContent
+ return (filename, content)
+ return $ P.parseModulesFromFiles id filesAndContent
-- |
-- Load all modules, updating the application state
@@ -141,7 +130,7 @@ loadAllImportedModules = do
modulesOrFirstError <- psciIO $ loadAllModules files
case modulesOrFirstError of
Left errs -> printErrors errs
- Right modules -> PSCI . lift . modify $ \st -> st { psciLoadedModules = modules }
+ Right modules -> PSCI . lift . modify $ updateModules modules
-- |
-- Expands tilde in path.
@@ -214,7 +203,7 @@ createTemporaryModule exec PSCiState{psciImportedModules = imports, psciLetBindi
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
+ 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
@@ -242,7 +231,7 @@ createTemporaryModuleForImports PSCiState{psciImportedModules = imports} =
P.Module (P.internalModuleSourceSpan "<internal>") [] moduleName (importDecl `map` imports) Nothing
importDecl :: ImportedModule -> P.Declaration
-importDecl (mn, declType, asQ) = P.ImportDeclaration mn declType asQ
+importDecl (mn, declType, asQ) = P.ImportDeclaration mn declType asQ False
indexFile :: FilePath
indexFile = ".psci_modules" ++ pathSeparator : "index.js"
@@ -260,26 +249,28 @@ makeIO f io = do
e <- liftIO $ tryIOError io
either (throwError . P.singleError . f) return e
-make :: PSCiState -> [(Either P.RebuildPolicy FilePath, P.Module)] -> P.Make P.Environment
-make PSCiState{..} ms = P.make actions' (map snd (psciLoadedModules ++ ms))
+make :: PSCiState -> [P.Module] -> P.Make P.Environment
+make st@PSCiState{..} ms = P.make actions' (map snd loadedModules ++ ms)
where
- filePathMap = M.fromList $ (first P.getModuleName . swap) `map` (psciLoadedModules ++ ms)
+ filePathMap = M.fromList $ (first P.getModuleName . swap) `map` allModules
actions = P.buildMakeActions modulesDir filePathMap psciForeignFiles False
actions' = actions { P.progress = const (return ()) }
+ loadedModules = psciLoadedModules st
+ allModules = map (first Right) loadedModules ++ map (Left P.RebuildAlways,) ms
-- |
--- Takes a value declaration and evaluates it with the current state.
+-- Takes a value expression and evaluates it with the current state.
--
-handleDeclaration :: P.Expr -> PSCI ()
-handleDeclaration val = do
+handleExpression :: P.Expr -> PSCI ()
+handleExpression val = do
st <- PSCI $ lift get
let m = createTemporaryModule True st val
let nodeArgs = psciNodeFlags st ++ [indexFile]
- e <- psciIO . runMake $ make st [(Left P.RebuildAlways, supportModule), (Left P.RebuildAlways, m)]
+ e <- psciIO . runMake $ make st [supportModule, m]
case e of
Left errs -> printErrors errs
Right _ -> do
- psciIO $ writeFile indexFile "require('$PSCI').main();"
+ psciIO $ writeFile indexFile "require('$PSCI')['$main']();"
process <- psciIO findNodeProcess
result <- psciIO $ traverse (\node -> readProcessWithExitCode node nodeArgs "") process
case result of
@@ -296,7 +287,7 @@ handleDecls ds = do
st <- PSCI $ lift get
let st' = updateLets ds st
let m = createTemporaryModule False st' (P.ObjectLiteral [])
- e <- psciIO . runMake $ make st' [(Left P.RebuildAlways, m)]
+ e <- psciIO . runMake $ make st' [m]
case e of
Left err -> printErrors err
Right _ -> PSCI $ lift (put st')
@@ -306,7 +297,7 @@ handleDecls ds = do
--
handleShowLoadedModules :: PSCI ()
handleShowLoadedModules = do
- PSCiState { psciLoadedModules = loadedModules } <- PSCI $ lift get
+ loadedModules <- PSCI $ lift $ gets psciLoadedModules
psciIO $ readModules loadedModules >>= putStrLn
return ()
where readModules = return . unlines . sort . nub . map toModuleName
@@ -329,15 +320,16 @@ handleShowImportedModules = do
showDeclType P.Implicit = ""
showDeclType (P.Explicit refs) = refsList refs
- showDeclType (P.Hiding refs) = "hiding " ++ refsList refs
- refsList refs = "(" ++ commaList (map showRef refs) ++ ")"
+ showDeclType (P.Hiding refs) = " hiding " ++ refsList refs
+ refsList refs = " (" ++ commaList (map showRef refs) ++ ")"
showRef :: P.DeclarationRef -> String
- showRef (P.TypeRef pn dctors) = show pn ++ "(" ++ maybe ".." (commaList . map N.runProperName) dctors ++ ")"
- showRef (P.ValueRef ident) = show ident
- showRef (P.TypeClassRef pn) = show pn
- showRef (P.TypeInstanceRef ident) = show ident
- showRef (P.ModuleRef name) = "module " ++ show name
+ showRef (P.TypeRef pn dctors) = N.runProperName pn ++ "(" ++ maybe ".." (commaList . map N.runProperName) dctors ++ ")"
+ showRef (P.ValueRef ident) = N.runIdent ident
+ showRef (P.TypeClassRef pn) = N.runProperName pn
+ showRef (P.ProperRef pn) = pn
+ showRef (P.TypeInstanceRef ident) = N.runIdent ident
+ showRef (P.ModuleRef name) = "module " ++ N.runModuleName name
showRef (P.PositionedDeclarationRef _ _ ref) = showRef ref
commaList :: [String] -> String
@@ -350,7 +342,7 @@ handleImport :: ImportedModule -> PSCI ()
handleImport im = do
st <- updateImportedModules im <$> PSCI (lift get)
let m = createTemporaryModuleForImports st
- e <- psciIO . runMake $ make st [(Left P.RebuildAlways, m)]
+ e <- psciIO . runMake $ make st [m]
case e of
Left errs -> printErrors errs
Right _ -> do
@@ -364,7 +356,7 @@ handleTypeOf :: P.Expr -> PSCI ()
handleTypeOf val = do
st <- PSCI $ lift get
let m = createTemporaryModule False st val
- e <- psciIO . runMake $ make st [(Left P.RebuildAlways, m)]
+ e <- psciIO . runMake $ make st [m]
case e of
Left errs -> printErrors errs
Right env' ->
@@ -400,10 +392,15 @@ printModuleSignatures moduleName (P.Environment {..}) =
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) ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint]) -> P.Qualified P.ProperName -> (P.Qualified P.ProperName, Maybe ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint]))
+ 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, Maybe ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint])) -> Maybe Box.Box
+ 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 =
@@ -427,18 +424,22 @@ printModuleSignatures moduleName (P.Environment {..}) =
Box.// Box.moveRight 2 classBody
- findType :: M.Map (P.Qualified P.ProperName) (P.Kind, P.TypeKind) -> P.Qualified P.ProperName -> (P.Qualified P.ProperName, Maybe (P.Kind, P.TypeKind))
+ 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) ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint])
- -> M.Map (P.Qualified P.ProperName) (P.DataDeclType, P.ProperName, P.Type, [P.Ident])
- -> M.Map (P.Qualified P.ProperName) ([(String, Maybe P.Kind)], P.Type)
- -> (P.Qualified P.ProperName, Maybe (P.Kind, P.TypeKind))
- -> Maybe Box.Box
+ 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 n typeClassesEnv
+ if M.member (fmap P.coerceProperName n) typeClassesEnv
then
Nothing
else
@@ -485,9 +486,22 @@ handleBrowse moduleName = do
case env of
Left errs -> printErrors errs
Right env' ->
- if moduleName `notElem` (nub . map ((\ (P.Module _ _ modName _ _ ) -> modName) . snd)) (psciLoadedModules st)
- then PSCI $ outputStrLn $ "Module '" ++ N.runModuleName moduleName ++ "' is not valid."
- else printModuleSignatures moduleName env'
+ if isModInEnv moduleName st
+ then printModuleSignatures moduleName env'
+ else case lookupUnQualifiedModName moduleName st of
+ Just unQualifiedName ->
+ if isModInEnv unQualifiedName st
+ then printModuleSignatures unQualifiedName env'
+ else failNotInEnv moduleName
+ Nothing ->
+ failNotInEnv moduleName
+ where
+ isModInEnv modName =
+ any ((== modName) . P.getModuleName . snd) . psciLoadedModules
+ failNotInEnv modName =
+ PSCI $ outputStrLn $ "Module '" ++ N.runModuleName modName ++ "' is not valid."
+ lookupUnQualifiedModName quaModName st =
+ (\(modName,_,_) -> modName) <$> find ( \(_, _, mayQuaName) -> mayQuaName == Just quaModName) (psciImportedModules st)
-- | Pretty-print errors
printErrors :: P.MultipleErrors -> PSCI ()
@@ -501,7 +515,7 @@ handleKindOf typ = do
st <- PSCI $ lift get
let m = createTemporaryModuleForKind st typ
mName = P.ModuleName [P.ProperName "$PSCI"]
- e <- psciIO . runMake $ make st [(Left P.RebuildAlways, m)]
+ e <- psciIO . runMake $ make st [m]
case e of
Left errs -> printErrors errs
Right env' ->
@@ -538,16 +552,15 @@ getCommand singleLineMode = handleInterrupt (return (Right Nothing)) $ do
-- Performs an action for each meta-command given, and also for expressions.
--
handleCommand :: Command -> PSCI ()
-handleCommand (Expression val) = handleDeclaration val
+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
- PSCI . lift $ modify (updateImportedFiles absPath)
m <- psciIO $ loadModule absPath
case m of
Left err -> PSCI $ outputStrLn err
- Right mods -> PSCI . lift $ modify (updateModules (map ((,) (Right absPath)) mods))
+ 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)
@@ -556,12 +569,10 @@ handleCommand (LoadForeign filePath) = whenFileExists filePath $ \absPath -> do
Left err -> PSCI $ outputStrLn $ P.prettyPrintMultipleErrors False err
Right foreigns -> PSCI . lift $ modify (updateForeignFiles foreigns)
handleCommand ResetState = do
- files <- psciImportedFilenames <$> PSCI (lift get)
- PSCI . lift . modify $ \st -> st
- { psciImportedFilenames = files
- , psciImportedModules = []
- , psciLetBindings = []
- }
+ PSCI . lift . modify $ \st ->
+ st { psciImportedModules = []
+ , psciLetBindings = []
+ }
loadAllImportedModules
handleCommand (TypeOf val) = handleTypeOf val
handleCommand (KindOf typ) = handleKindOf typ
@@ -624,7 +635,7 @@ loop PSCiOptions{..} = do
case foreignsOrError of
Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> exitFailure
Right foreigns ->
- flip evalStateT (PSCiState inputFiles [] modules foreigns [] psciInputNodeFlags) . runInputT (setComplete completion settings) $ do
+ flip evalStateT (mkPSCiState [] modules foreigns [] psciInputNodeFlags) . runInputT (setComplete completion settings) $ do
outputStrLn prologueMessage
traverse_ (traverse_ (runPSCI . handleCommand)) config
modules' <- lift $ gets psciLoadedModules
diff --git a/psci/Parser.hs b/psci/Parser.hs
index cb00db1..b8b0675 100644
--- a/psci/Parser.hs
+++ b/psci/Parser.hs
@@ -106,7 +106,9 @@ psciLet = Decls <$> (P.reserved "let" *> P.indented *> manyDecls)
-- | Imports must be handled separately from other declarations, so that
-- :show import works, for example.
psciImport :: P.TokenParser Command
-psciImport = Import <$> P.parseImportDeclaration'
+psciImport = do
+ (mn, declType, asQ, _) <- P.parseImportDeclaration'
+ return $ Import (mn, declType, asQ)
-- | Any other declaration that we don't need a 'special case' parser for
-- (like let or import declarations).
diff --git a/psci/Types.hs b/psci/Types.hs
index 107a353..7465cdf 100644
--- a/psci/Types.hs
+++ b/psci/Types.hs
@@ -15,7 +15,9 @@
module Types where
-import qualified Data.Map as M
+import Control.Arrow (second)
+import Data.Map (Map)
+import qualified Data.Map as Map
import qualified Language.PureScript as P
data PSCiOptions = PSCiOptions
@@ -32,14 +34,48 @@ data PSCiOptions = PSCiOptions
-- because it makes more sense to apply the binding to the final evaluated expression.
--
data PSCiState = PSCiState
- { psciImportedFilenames :: [FilePath]
- , psciImportedModules :: [ImportedModule]
- , psciLoadedModules :: [(Either P.RebuildPolicy FilePath, P.Module)]
- , psciForeignFiles :: M.Map P.ModuleName FilePath
+ { psciImportedModules :: [ImportedModule]
+ , _psciLoadedModules :: Map FilePath [P.Module]
+ , psciForeignFiles :: Map P.ModuleName FilePath
, psciLetBindings :: [P.Declaration]
, psciNodeFlags :: [String]
}
+initialPSCiState :: PSCiState
+initialPSCiState =
+ PSCiState [] Map.empty Map.empty [] []
+
+mkPSCiState :: [ImportedModule]
+ -> [(FilePath, P.Module)]
+ -> Map P.ModuleName FilePath
+ -> [P.Declaration]
+ -> [String]
+ -> PSCiState
+mkPSCiState imported loaded foreigns lets nodeFlags =
+ (initialPSCiState
+ |> each imported updateImportedModules
+ |> updateModules loaded)
+ { psciForeignFiles = foreigns
+ , psciLetBindings = lets
+ , psciNodeFlags = nodeFlags
+ }
+ where
+ x |> f = f x
+ each xs f st = foldl (flip f) st xs
+
+-- Public psci state accessors
+
+-- | Get the imported filenames as a list.
+psciImportedFilenames :: PSCiState -> [FilePath]
+psciImportedFilenames = Map.keys . _psciLoadedModules
+
+-- | Get the loaded modules as a list.
+psciLoadedModules :: PSCiState -> [(FilePath, P.Module)]
+psciLoadedModules = collect . Map.toList . _psciLoadedModules
+ where
+ collect :: [(k, [v])] -> [(k, v)]
+ collect vss = [ (k, v) | (k, vs) <- vss, v <- vs ]
+
-- | All of the data that is contained by an ImportDeclaration in the AST.
-- That is:
--
@@ -67,20 +103,18 @@ allImportsOf m (PSCiState{psciImportedModules = is}) =
-- |
-- Updates the state to have more imported modules.
--
-updateImportedFiles :: FilePath -> PSCiState -> PSCiState
-updateImportedFiles filename st = st { psciImportedFilenames = filename : psciImportedFilenames st }
-
--- |
--- Updates the state to have more imported modules.
---
updateImportedModules :: ImportedModule -> PSCiState -> PSCiState
updateImportedModules im st = st { psciImportedModules = im : psciImportedModules st }
-- |
--- Updates the state to have more loaded files.
+-- Updates the state to have more loaded modules (available for import, but
+-- not necessarily imported).
--
-updateModules :: [(Either P.RebuildPolicy FilePath, P.Module)] -> PSCiState -> PSCiState
-updateModules modules st = st { psciLoadedModules = psciLoadedModules st ++ modules }
+updateModules :: [(FilePath, P.Module)] -> PSCiState -> PSCiState
+updateModules modules st =
+ st { _psciLoadedModules = Map.union (go modules) (_psciLoadedModules st) }
+ where
+ go = Map.fromListWith (++) . map (second (:[]))
-- |
-- Updates the state to have more let bindings.
@@ -91,8 +125,8 @@ updateLets ds st = st { psciLetBindings = psciLetBindings st ++ ds }
-- |
-- Updates the state to have more let bindings.
--
-updateForeignFiles :: M.Map P.ModuleName FilePath -> PSCiState -> PSCiState
-updateForeignFiles fs st = st { psciForeignFiles = psciForeignFiles st `M.union` fs }
+updateForeignFiles :: Map P.ModuleName FilePath -> PSCiState -> PSCiState
+updateForeignFiles fs st = st { psciForeignFiles = psciForeignFiles st `Map.union` fs }
-- |
-- Valid Meta-commands for PSCI
diff --git a/psci/tests/Main.hs b/psci/tests/Main.hs
index d3d6d3b..af24736 100644
--- a/psci/tests/Main.hs
+++ b/psci/tests/Main.hs
@@ -142,7 +142,7 @@ getPSCiState = do
print err >> exitFailure
Right modules ->
let imports = [controlMonadSTasST, (P.ModuleName [P.ProperName "Prelude"], P.Implicit, Nothing)]
- in return (PSCiState [] imports modules foreigns [] [])
+ in return (mkPSCiState imports modules foreigns [] [])
controlMonadSTasST :: ImportedModule
controlMonadSTasST = (s "Control.Monad.ST", P.Implicit, Just (s "ST"))
diff --git a/purescript.cabal b/purescript.cabal
index 65b733a..a1a21a8 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,5 +1,5 @@
name: purescript
-version: 0.7.6.1
+version: 0.8.0.0
cabal-version: >=1.8
build-type: Simple
license: MIT
@@ -20,6 +20,9 @@ tested-with: GHC==7.8
extra-source-files: examples/passing/*.purs
, examples/failing/*.purs
+ , examples/docs/bower_components/purescript-prelude/src/*.purs
+ , examples/docs/bower.json
+ , examples/docs/src/*.purs
, tests/support/setup.js
, tests/support/package.json
, tests/support/bower.json
@@ -159,6 +162,8 @@ library
Language.PureScript.Docs
Language.PureScript.Docs.Convert
+ Language.PureScript.Docs.Convert.Single
+ Language.PureScript.Docs.Convert.ReExports
Language.PureScript.Docs.Render
Language.PureScript.Docs.Types
Language.PureScript.Docs.RenderedCode
@@ -178,6 +183,8 @@ library
Control.Monad.Supply.Class
System.IO.UTF8
+
+ extensions: DataKinds
exposed: True
buildable: True
hs-source-dirs: src
@@ -185,12 +192,15 @@ library
ghc-options: -Wall -O2
executable psc
- build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,
+ build-depends: base >=4 && <5, base-compat >=0.6.0,
+ 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
+ time -any, transformers -any, transformers-compat -any, Glob >= 0.7 && < 0.8,
+ aeson >= 0.8 && < 0.11, bytestring -any, utf8-string >= 1 && < 2
main-is: Main.hs
buildable: True
hs-source-dirs: psc
+ other-modules: JSON
ghc-options: -Wall -O2 -fno-warn-unused-do-bind -threaded -rtsopts "-with-rtsopts=-N"
executable psci
@@ -215,7 +225,8 @@ executable psc-docs
build-depends: base >=4 && <5, purescript -any,
optparse-applicative >= 0.10.0, process -any, mtl -any,
split -any, ansi-wl-pprint -any, directory -any,
- filepath -any, Glob -any
+ filepath -any, Glob -any, transformers -any,
+ transformers-compat -any
main-is: Main.hs
buildable: True
hs-source-dirs: psc-docs
@@ -261,10 +272,13 @@ 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, base-compat >=0.6.0
+ Glob -any, aeson-better-errors -any, bytestring -any, aeson -any,
+ base-compat -any
type: exitcode-stdio-1.0
main-is: Main.hs
other-modules: TestsSetup
+ TestPscPublish
+ TestDocs
buildable: True
hs-source-dirs: tests tests/common
diff --git a/src/Control/Monad/Logger.hs b/src/Control/Monad/Logger.hs
index 069b781..f8e8e7c 100644
--- a/src/Control/Monad/Logger.hs
+++ b/src/Control/Monad/Logger.hs
@@ -30,7 +30,7 @@ import Control.Monad.Base (MonadBase(..))
import Control.Monad.Trans.Control (MonadBaseControl(..))
-- | A replacement for WriterT IO which uses mutable references.
-data Logger w a = Logger { runLogger :: IORef w -> IO a }
+newtype Logger w a = Logger { runLogger :: IORef w -> IO a }
-- | Run a Logger computation, starting with an empty log.
runLogger' :: (Monoid w) => Logger w a -> IO (a, w)
diff --git a/src/Control/Monad/Supply/Class.hs b/src/Control/Monad/Supply/Class.hs
index 3869224..02c185a 100644
--- a/src/Control/Monad/Supply/Class.hs
+++ b/src/Control/Monad/Supply/Class.hs
@@ -1,20 +1,8 @@
------------------------------------------------------------------------------
---
--- Module : Control.Monad.Supply.Class
--- Copyright : (c) PureScript 2015
--- License : MIT
---
--- Maintainer : Phil Freeman <paf31@cantab.net>
--- Stability : experimental
--- Portability :
---
+{-# LANGUAGE MultiParamTypeClasses #-}
+
-- |
-- A class for monads supporting a supply of fresh names
--
------------------------------------------------------------------------------
-
-{-# LANGUAGE MultiParamTypeClasses #-}
-
module Control.Monad.Supply.Class where
import Control.Monad.Supply
@@ -22,15 +10,15 @@ import Control.Monad.State
class (Monad m) => MonadSupply m where
fresh :: m Integer
-
+
instance (Monad m) => MonadSupply (SupplyT m) where
fresh = SupplyT $ do
n <- get
put (n + 1)
return n
-
+
instance (MonadSupply m) => MonadSupply (StateT s m) where
fresh = lift fresh
freshName :: (MonadSupply m) => m String
-freshName = liftM (('_' :) . show) fresh
+freshName = liftM (('$' :) . show) fresh
diff --git a/src/Language/PureScript.hs b/src/Language/PureScript.hs
index ea6b195..21ecd64 100644
--- a/src/Language/PureScript.hs
+++ b/src/Language/PureScript.hs
@@ -13,7 +13,6 @@
--
-----------------------------------------------------------------------------
-{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
diff --git a/src/Language/PureScript/AST/Binders.hs b/src/Language/PureScript/AST/Binders.hs
index d228bf6..d0b6b81 100644
--- a/src/Language/PureScript/AST/Binders.hs
+++ b/src/Language/PureScript/AST/Binders.hs
@@ -1,23 +1,8 @@
------------------------------------------------------------------------------
---
--- Module : Language.PureScript.AST.Binders
--- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
--- License : MIT
---
--- Maintainer : Phil Freeman <paf31@cantab.net>
--- Stability : experimental
--- Portability :
---
--- | Case binders
+-- |
+-- Case binders
--
------------------------------------------------------------------------------
-
-{-# LANGUAGE DeriveDataTypeable #-}
-
module Language.PureScript.AST.Binders where
-import qualified Data.Data as D
-
import Language.PureScript.AST.SourcePos
import Language.PureScript.Names
import Language.PureScript.Comments
@@ -54,7 +39,7 @@ data Binder
-- |
-- A binder which matches a data constructor
--
- | ConstructorBinder (Qualified ProperName) [Binder]
+ | ConstructorBinder (Qualified (ProperName 'ConstructorName)) [Binder]
-- |
-- A binder which matches a record and binds its properties
--
@@ -74,7 +59,8 @@ data Binder
-- |
-- A binder with a type annotation
--
- | TypedBinder Type Binder deriving (Show, Read, Eq, D.Data, D.Typeable)
+ | TypedBinder Type Binder
+ deriving (Show, Read, Eq)
-- |
-- Collect all names introduced in binders in an expression
diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs
index 07ff4b1..858df12 100644
--- a/src/Language/PureScript/AST/Declarations.hs
+++ b/src/Language/PureScript/AST/Declarations.hs
@@ -1,29 +1,19 @@
------------------------------------------------------------------------------
---
--- Module : Language.PureScript.AST.Declarations
--- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
--- License : MIT (http://opensource.org/licenses/MIT)
---
--- Maintainer : Phil Freeman <paf31@cantab.net>
--- Stability : experimental
--- Portability :
---
--- | Data types for modules and declarations
---
------------------------------------------------------------------------------
-
-{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE LambdaCase #-}
+-- |
+-- Data types for modules and declarations
+--
module Language.PureScript.AST.Declarations where
import Prelude ()
import Prelude.Compat
import Data.Aeson.TH
+import Data.List (nub, (\\))
+import Data.Maybe (mapMaybe)
-import qualified Data.Data as D
import qualified Data.Map as M
import Control.Monad.Identity
@@ -43,20 +33,33 @@ import Language.PureScript.Environment
-- a list of declarations, and a list of the declarations that are
-- explicitly exported. If the export list is Nothing, everything is exported.
--
-data Module = Module SourceSpan [Comment] ModuleName [Declaration] (Maybe [DeclarationRef]) deriving (Show, Read, D.Data, D.Typeable)
+data Module = Module SourceSpan [Comment] ModuleName [Declaration] (Maybe [DeclarationRef])
+ deriving (Show, Read)
-- | Return a module's name.
getModuleName :: Module -> ModuleName
getModuleName (Module _ _ name _ _) = name
-- |
+-- Add an import declaration for a module if it does not already explicitly import it.
+--
+addDefaultImport :: ModuleName -> Module -> Module
+addDefaultImport toImport m@(Module ss coms mn decls exps) =
+ if isExistingImport `any` decls || mn == toImport then m
+ else Module ss coms mn (ImportDeclaration toImport Implicit Nothing False : decls) exps
+ where
+ isExistingImport (ImportDeclaration mn' _ _ _) | mn' == toImport = True
+ isExistingImport (PositionedDeclaration _ _ d) = isExistingImport d
+ isExistingImport _ = False
+
+-- |
-- An item in a list of explicit imports or exports
--
data DeclarationRef
-- |
-- A type constructor with data constructors
--
- = TypeRef ProperName (Maybe [ProperName])
+ = TypeRef (ProperName 'TypeName) (Maybe [ProperName 'ConstructorName])
-- |
-- A value
--
@@ -64,7 +67,7 @@ data DeclarationRef
-- |
-- A type class
--
- | TypeClassRef ProperName
+ | TypeClassRef (ProperName 'ClassName)
-- |
-- A type class instance, created during typeclass desugaring (name, class name, instance types)
--
@@ -74,31 +77,59 @@ data DeclarationRef
--
| ModuleRef ModuleName
-- |
+ -- An unspecified ProperName ref. This will be replaced with a TypeClassRef
+ -- or TypeRef during name desugaring.
+ | ProperRef String
+ -- |
-- A declaration reference with source position information
--
| PositionedDeclarationRef SourceSpan [Comment] DeclarationRef
- deriving (Show, Read, D.Data, D.Typeable)
+ deriving (Show, Read)
instance Eq DeclarationRef where
(TypeRef name dctors) == (TypeRef name' dctors') = name == name' && dctors == dctors'
(ValueRef name) == (ValueRef name') = name == name'
(TypeClassRef name) == (TypeClassRef name') = name == name'
(TypeInstanceRef name) == (TypeInstanceRef name') = name == name'
- (ModuleRef name) == (ModuleRef name') = name == name'
+ (ModuleRef name) == (ModuleRef name') = name == name'
+ (ProperRef name) == (ProperRef name') = name == name'
(PositionedDeclarationRef _ _ r) == r' = r == r'
r == (PositionedDeclarationRef _ _ r') = r == r'
_ == _ = False
isModuleRef :: DeclarationRef -> Bool
+isModuleRef (PositionedDeclarationRef _ _ r) = isModuleRef r
isModuleRef (ModuleRef _) = True
isModuleRef _ = False
-- |
+-- Finds duplicate values in a list of declaration refs. The returned values
+-- are the duplicate refs with data constructors elided, and then a separate
+-- list of duplicate data constructors.
+--
+findDuplicateRefs :: [DeclarationRef] -> ([DeclarationRef], [ProperName 'ConstructorName])
+findDuplicateRefs refs =
+ let positionless = stripPosInfo `map` refs
+ simplified = simplifyTypeRefs `map` positionless
+ dupeRefs = nub $ simplified \\ nub simplified
+ dupeCtors = concat $ flip mapMaybe positionless $ \case
+ TypeRef _ (Just dctors) ->
+ let dupes = dctors \\ nub dctors
+ in if null dupes then Nothing else Just dupes
+ _ -> Nothing
+ in (dupeRefs, dupeCtors)
+ where
+ stripPosInfo (PositionedDeclarationRef _ _ ref) = stripPosInfo ref
+ stripPosInfo other = other
+ simplifyTypeRefs (TypeRef pn _) = TypeRef pn Nothing
+ simplifyTypeRefs other = other
+
+-- |
-- The data type which specifies type of import declaration
--
data ImportDeclarationType
-- |
- -- An import with no explicit list: `import M`
+ -- An import with no explicit list: `import M`.
--
= Implicit
-- |
@@ -109,7 +140,15 @@ data ImportDeclarationType
-- An import with a list of references to hide: `import M hiding (foo)`
--
| Hiding [DeclarationRef]
- deriving (Show, Read, D.Data, D.Typeable)
+ deriving (Eq, Show, Read)
+
+isImplicit :: ImportDeclarationType -> Bool
+isImplicit Implicit = True
+isImplicit _ = False
+
+isExplicit :: ImportDeclarationType -> Bool
+isExplicit (Explicit _) = True
+isExplicit _ = False
-- |
-- The data type of declarations
@@ -118,7 +157,7 @@ data Declaration
-- |
-- A data type declaration (data or newtype, name, arguments, data constructors)
--
- = DataDeclaration DataDeclType ProperName [(String, Maybe Kind)] [(ProperName, [Type])]
+ = DataDeclaration DataDeclType (ProperName 'TypeName) [(String, Maybe Kind)] [(ProperName 'ConstructorName, [Type])]
-- |
-- A minimal mutually recursive set of data type declarations
--
@@ -126,7 +165,7 @@ data Declaration
-- |
-- A type synonym declaration (name, arguments, type)
--
- | TypeSynonymDeclaration ProperName [(String, Maybe Kind)] Type
+ | TypeSynonymDeclaration (ProperName 'TypeName) [(String, Maybe Kind)] Type
-- |
-- A type declaration for a value (name, ty)
--
@@ -146,29 +185,30 @@ data Declaration
-- |
-- A data type foreign import (name, kind)
--
- | ExternDataDeclaration ProperName Kind
+ | ExternDataDeclaration (ProperName 'TypeName) Kind
-- |
- -- A fixity declaration (fixity data, operator name)
+ -- A fixity declaration (fixity data, operator name, value the operator is an alias for)
--
- | FixityDeclaration Fixity String
+ | FixityDeclaration Fixity String (Maybe (Qualified Ident))
-- |
-- 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)
--
- | ImportDeclaration ModuleName ImportDeclarationType (Maybe ModuleName)
+ | ImportDeclaration ModuleName ImportDeclarationType (Maybe ModuleName) Bool
-- |
-- A type class declaration (name, argument, implies, member declarations)
--
- | TypeClassDeclaration ProperName [(String, Maybe Kind)] [Constraint] [Declaration]
+ | TypeClassDeclaration (ProperName 'ClassName) [(String, Maybe Kind)] [Constraint] [Declaration]
-- |
-- A type instance declaration (name, dependencies, class name, instance types, member
-- declarations)
--
- | TypeInstanceDeclaration Ident [Constraint] (Qualified ProperName) [Type] TypeInstanceBody
+ | TypeInstanceDeclaration Ident [Constraint] (Qualified (ProperName 'ClassName)) [Type] TypeInstanceBody
-- |
-- A declaration with source position information
--
| PositionedDeclaration SourceSpan [Comment] Declaration
- deriving (Show, Read, D.Data, D.Typeable)
+ deriving (Show, Read)
-- | The members of a type class instance declaration
data TypeInstanceBody
@@ -176,7 +216,7 @@ data TypeInstanceBody
= DerivedInstance
-- | This is a regular (explicit) instance
| ExplicitInstance [Declaration]
- deriving (Show, Read, D.Data, D.Typeable)
+ deriving (Show, Read)
mapTypeInstanceBody :: ([Declaration] -> [Declaration]) -> TypeInstanceBody -> TypeInstanceBody
mapTypeInstanceBody f = runIdentity . traverseTypeInstanceBody (Identity . f)
@@ -353,7 +393,7 @@ data Expr
-- |
-- A data constructor
--
- | Constructor (Qualified ProperName)
+ | Constructor (Qualified (ProperName 'ConstructorName))
-- |
-- A case expression. During the case expansion phase of desugaring, top-level binders will get
-- desugared into case expressions, hence the need for guards and multiple binders per branch here.
@@ -375,7 +415,7 @@ data Expr
-- An application of a typeclass dictionary constructor. The value should be
-- an ObjectLiteral.
--
- | TypeClassDictionaryConstructorApp (Qualified ProperName) Expr
+ | TypeClassDictionaryConstructorApp (Qualified (ProperName 'ClassName)) Expr
-- |
-- A placeholder for a type class dictionary to be inserted later. At the end of type checking, these
-- placeholders will be replaced with actual expressions representing type classes dictionaries which
@@ -383,19 +423,20 @@ data Expr
-- at superclass implementations when searching for a dictionary, the type class name and
-- instance type, and the type class dictionaries in scope.
--
- | TypeClassDictionary Constraint (M.Map (Maybe ModuleName) (M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope)))
+ | TypeClassDictionary Constraint (M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope)))
-- |
-- A typeclass dictionary accessor, the implementation is left unspecified until CoreFn desugaring.
--
- | TypeClassDictionaryAccessor (Qualified ProperName) Ident
+ | TypeClassDictionaryAccessor (Qualified (ProperName 'ClassName)) Ident
-- |
-- A placeholder for a superclass dictionary to be turned into a TypeClassDictionary during typechecking
--
- | SuperClassDictionary (Qualified ProperName) [Type]
+ | SuperClassDictionary (Qualified (ProperName 'ClassName)) [Type]
-- |
-- A value with source position information
--
- | PositionedValue SourceSpan [Comment] Expr deriving (Show, Read, D.Data, D.Typeable)
+ | PositionedValue SourceSpan [Comment] Expr
+ deriving (Show, Read)
-- |
-- An alternative in a case statement
@@ -409,7 +450,7 @@ data CaseAlternative = CaseAlternative
-- The result expression or a collect of guarded expressions
--
, caseAlternativeResult :: Either [(Guard, Expr)] Expr
- } deriving (Show, Read, D.Data, D.Typeable)
+ } deriving (Show, Read)
-- |
-- A statement in a do-notation block
@@ -430,7 +471,8 @@ data DoNotationElement
-- |
-- A do notation element with source position information
--
- | PositionedDoNotationElement SourceSpan [Comment] DoNotationElement deriving (Show, Read, D.Data, D.Typeable)
+ | PositionedDoNotationElement SourceSpan [Comment] DoNotationElement
+ deriving (Show, Read)
$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''DeclarationRef)
$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ImportDeclarationType)
diff --git a/src/Language/PureScript/AST/Exported.hs b/src/Language/PureScript/AST/Exported.hs
index a7ad53f..ec04824 100644
--- a/src/Language/PureScript/AST/Exported.hs
+++ b/src/Language/PureScript/AST/Exported.hs
@@ -1,8 +1,7 @@
-
-module Language.PureScript.AST.Exported (
- exportedDeclarations,
- isExported
-) where
+module Language.PureScript.AST.Exported
+ ( exportedDeclarations
+ , isExported
+ ) where
import Control.Category ((>>>))
import Data.Maybe (mapMaybe)
@@ -23,12 +22,12 @@ import Language.PureScript.Names
-- instances will be incorrectly removed in some cases.
--
exportedDeclarations :: Module -> [Declaration]
-exportedDeclarations (Module _ _ _ decls exps) = go decls
+exportedDeclarations (Module _ _ mn decls exps) = go decls
where
go = flattenDecls
>>> filter (isExported exps)
>>> map (filterDataConstructors exps)
- >>> filterInstances exps
+ >>> filterInstances mn exps
-- |
-- Filter out all data constructors from a declaration which are not exported.
@@ -52,10 +51,15 @@ filterDataConstructors _ other = other
-- produce incorrect results if this is not the case - for example, type class
-- instances will be incorrectly removed in some cases.
--
-filterInstances :: Maybe [DeclarationRef] -> [Declaration] -> [Declaration]
-filterInstances Nothing = id
-filterInstances (Just exps) =
- let refs = mapMaybe typeName exps ++ mapMaybe typeClassName exps
+filterInstances
+ :: ModuleName
+ -> Maybe [DeclarationRef]
+ -> [Declaration]
+ -> [Declaration]
+filterInstances _ Nothing = id
+filterInstances mn (Just exps) =
+ let refs = Left `map` mapMaybe typeClassName exps
+ ++ Right `map` mapMaybe typeName exps
in filter (all (visibleOutside refs) . typeInstanceConstituents)
where
-- Given a Qualified ProperName, and a list of all exported types and type
@@ -65,13 +69,24 @@ filterInstances (Just exps) =
-- * the name is defined in the same module and is exported,
-- * the name is defined in a different module (and must be exported from
-- that module; the code would fail to compile otherwise).
- visibleOutside _ (Qualified (Just _) _) = True
- visibleOutside refs (Qualified Nothing n) = n `elem` refs
-
+ visibleOutside
+ :: [Either (ProperName 'ClassName) (ProperName 'TypeName)]
+ -> Either (Qualified (ProperName 'ClassName)) (Qualified (ProperName 'TypeName))
+ -> Bool
+ visibleOutside refs q
+ | either checkQual checkQual q = True
+ | otherwise = either (Left . disqualify) (Right . disqualify) q `elem` refs
+
+ -- Check that a qualified name is qualified for a different module
+ checkQual :: Qualified a -> Bool
+ checkQual q = isQualified q && not (isQualifiedWith mn q)
+
+ typeName :: DeclarationRef -> Maybe (ProperName 'TypeName)
typeName (TypeRef n _) = Just n
typeName (PositionedDeclarationRef _ _ r) = typeName r
typeName _ = Nothing
+ typeClassName :: DeclarationRef -> Maybe (ProperName 'ClassName)
typeClassName (TypeClassRef n) = Just n
typeClassName (PositionedDeclarationRef _ _ r) = typeClassName r
typeClassName _ = Nothing
@@ -79,17 +94,17 @@ filterInstances (Just exps) =
-- |
-- Get all type and type class names referenced by a type instance declaration.
--
-typeInstanceConstituents :: Declaration -> [Qualified ProperName]
+typeInstanceConstituents :: Declaration -> [Either (Qualified (ProperName 'ClassName)) (Qualified (ProperName 'TypeName))]
typeInstanceConstituents (TypeInstanceDeclaration _ constraints className tys _) =
- className : (concatMap fromConstraint constraints ++ concatMap fromType tys)
+ Left className : (concatMap fromConstraint constraints ++ concatMap fromType tys)
where
- fromConstraint (name, tys') = name : concatMap fromType tys'
+ fromConstraint (name, tys') = Left name : concatMap fromType tys'
fromType = everythingOnTypes (++) go
-- Note that type synonyms are disallowed in instance declarations, so
-- we don't need to handle them here.
- go (TypeConstructor n) = [n]
+ go (TypeConstructor n) = [Right n]
go (ConstrainedType cs _) = concatMap fromConstraint cs
go _ = []
@@ -112,12 +127,15 @@ isExported (Just exps) decl = any (matches decl) exps
matches (TypeDeclaration ident _) (ValueRef ident') = ident == ident'
matches (ValueDeclaration ident _ _ _) (ValueRef ident') = ident == ident'
matches (ExternDeclaration ident _) (ValueRef ident') = ident == ident'
- matches (FixityDeclaration _ name) (ValueRef ident') = name == runIdent ident'
+ matches (FixityDeclaration _ name _) (ValueRef ident') = name == runIdent ident'
matches (DataDeclaration _ ident _ _) (TypeRef ident' _) = ident == ident'
matches (ExternDataDeclaration ident _) (TypeRef ident' _) = ident == ident'
matches (TypeSynonymDeclaration ident _ _) (TypeRef ident' _) = ident == ident'
matches (TypeClassDeclaration ident _ _ _) (TypeClassRef ident') = ident == ident'
+ matches (DataDeclaration _ ident _ _) (ProperRef ident') = runProperName ident == ident'
+ matches (TypeClassDeclaration ident _ _ _) (ProperRef ident') = runProperName ident == ident'
+
matches (PositionedDeclaration _ _ d) r = d `matches` r
matches d (PositionedDeclarationRef _ _ r) = d `matches` r
matches _ _ = False
@@ -126,7 +144,7 @@ isExported (Just exps) decl = any (matches decl) exps
-- Test if a data constructor for a given type is exported, given a module's
-- export list. Prefer 'exportedDeclarations' to this function, where possible.
--
-isDctorExported :: ProperName -> Maybe [DeclarationRef] -> ProperName -> Bool
+isDctorExported :: ProperName 'TypeName -> Maybe [DeclarationRef] -> ProperName 'ConstructorName -> Bool
isDctorExported _ Nothing _ = True
isDctorExported ident (Just exps) ctor = test `any` exps
where
diff --git a/src/Language/PureScript/AST/Operators.hs b/src/Language/PureScript/AST/Operators.hs
index 2afae9a..241f6c4 100644
--- a/src/Language/PureScript/AST/Operators.hs
+++ b/src/Language/PureScript/AST/Operators.hs
@@ -1,23 +1,10 @@
------------------------------------------------------------------------------
---
--- Module : Language.PureScript.AST.Operators
--- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
--- License : MIT
---
--- Maintainer : Phil Freeman <paf31@cantab.net>
--- Stability : experimental
--- Portability :
---
--- | Operators fixity and associativity
---
------------------------------------------------------------------------------
-
{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE DeriveDataTypeable #-}
+-- |
+-- Operators fixity and associativity
+--
module Language.PureScript.AST.Operators where
-import qualified Data.Data as D
import Data.Aeson ((.=))
import qualified Data.Aeson as A
@@ -31,7 +18,8 @@ type Precedence = Integer
-- |
-- Associativity for infix operators
--
-data Associativity = Infixl | Infixr | Infix deriving (Show, Read, Eq, Ord, D.Data, D.Typeable)
+data Associativity = Infixl | Infixr | Infix
+ deriving (Show, Read, Eq, Ord)
showAssoc :: Associativity -> String
showAssoc Infixl = "infixl"
@@ -53,7 +41,8 @@ instance A.FromJSON Associativity where
-- |
-- Fixity data for infix operators
--
-data Fixity = Fixity Associativity Precedence deriving (Show, Read, Eq, Ord, D.Data, D.Typeable)
+data Fixity = Fixity Associativity Precedence
+ deriving (Show, Read, Eq, Ord)
instance A.ToJSON Fixity where
toJSON (Fixity associativity precedence) =
diff --git a/src/Language/PureScript/AST/SourcePos.hs b/src/Language/PureScript/AST/SourcePos.hs
index 10fd8c9..35d5903 100644
--- a/src/Language/PureScript/AST/SourcePos.hs
+++ b/src/Language/PureScript/AST/SourcePos.hs
@@ -1,28 +1,15 @@
------------------------------------------------------------------------------
---
--- Module : Language.PureScript.AST.SourcePos
--- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
--- License : MIT (http://opensource.org/licenses/MIT)
---
--- Maintainer : Phil Freeman <paf31@cantab.net>
--- Stability : experimental
--- Portability :
---
--- | Source position information
---
------------------------------------------------------------------------------
-
-{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
+-- |
+-- Source position information
+--
module Language.PureScript.AST.SourcePos where
import Prelude ()
import Prelude.Compat
-import qualified Data.Data as D
import Data.Aeson ((.=), (.:))
import qualified Data.Aeson as A
@@ -38,7 +25,7 @@ data SourcePos = SourcePos
-- Column number
--
, sourcePosColumn :: Int
- } deriving (Show, Read, Eq, Ord, D.Data, D.Typeable)
+ } deriving (Show, Read, Eq, Ord)
displaySourcePos :: SourcePos -> String
displaySourcePos sp =
@@ -66,7 +53,7 @@ data SourceSpan = SourceSpan
-- End of the span
--
, spanEnd :: SourcePos
- } deriving (Show, Read, Eq, Ord, D.Data, D.Typeable)
+ } deriving (Show, Read, Eq, Ord)
displayStartEndPos :: SourceSpan -> String
displayStartEndPos sp =
diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs
index 3378a6c..0f7e62c 100644
--- a/src/Language/PureScript/AST/Traversals.hs
+++ b/src/Language/PureScript/AST/Traversals.hs
@@ -18,6 +18,10 @@ import Prelude ()
import Prelude.Compat
import Data.Maybe (mapMaybe)
+import Data.List (mapAccumL)
+import Data.Foldable (fold)
+import qualified Data.Set as S
+
import Control.Monad
import Control.Arrow ((***), (+++), second)
@@ -25,6 +29,7 @@ import Language.PureScript.AST.Binders
import Language.PureScript.AST.Declarations
import Language.PureScript.Types
import Language.PureScript.Traversals
+import Language.PureScript.Names
everywhereOnValues :: (Declaration -> Declaration) ->
(Expr -> Expr) ->
@@ -389,6 +394,112 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j
j' s (DoNotationLet ds) = DoNotationLet <$> traverse (f'' s) ds
j' s (PositionedDoNotationElement pos com e1) = PositionedDoNotationElement pos com <$> j'' s e1
+everythingWithScope ::
+ (Monoid r) =>
+ (S.Set Ident -> Declaration -> r) ->
+ (S.Set Ident -> Expr -> r) ->
+ (S.Set Ident -> Binder -> r) ->
+ (S.Set Ident -> CaseAlternative -> r) ->
+ (S.Set Ident -> DoNotationElement -> r) ->
+ ( S.Set Ident -> Declaration -> r
+ , S.Set Ident -> Expr -> r
+ , S.Set Ident -> Binder -> r
+ , S.Set Ident -> CaseAlternative -> r
+ , S.Set Ident -> DoNotationElement -> r)
+everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)
+ where
+ -- Avoid importing Data.Monoid and getting shadowed names above
+ (<>) = mappend
+
+ f'' s a = f s a <> f' s a
+
+ f' s (DataBindingGroupDeclaration ds) =
+ let s' = S.union s (S.fromList (mapMaybe getDeclIdent ds))
+ in foldMap (f'' s') ds
+ f' s (ValueDeclaration name _ bs (Right val)) =
+ let s' = S.insert name s
+ in foldMap (h'' s') bs <> g'' s' val
+ f' s (ValueDeclaration name _ bs (Left gs)) =
+ let s' = S.insert name s
+ s'' = S.union s' (S.fromList (concatMap binderNames bs))
+ in foldMap (h'' s') bs <> foldMap (\(grd, val) -> g'' s'' grd <> g'' s'' val) gs
+ f' s (BindingGroupDeclaration ds) =
+ let s' = S.union s (S.fromList (map (\(name, _, _) -> name) ds))
+ in foldMap (\(_, _, val) -> g'' s' val) ds
+ f' s (TypeClassDeclaration _ _ _ ds) = foldMap (f'' s) ds
+ f' s (TypeInstanceDeclaration _ _ _ _ (ExplicitInstance ds)) = foldMap (f'' s) ds
+ f' s (PositionedDeclaration _ _ d) = f'' s d
+ f' _ _ = mempty
+
+ g'' s a = g s a <> g' s a
+
+ g' s (UnaryMinus v1) = g'' s v1
+ g' s (BinaryNoParens op v1 v2) = g' s op <> g' s v1 <> g' s v2
+ g' s (Parens v1) = g'' s v1
+ g' s (OperatorSection op (Left v)) = g'' s op <> g'' s v
+ 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
+ g' s (Abs (Right b) v1) =
+ let s' = S.union (S.fromList (binderNames b)) s
+ in 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
+ g' s (Case vs alts) = foldMap (g'' s) vs <> foldMap (i'' s) alts
+ g' s (TypedValue _ v1 _) = g'' s v1
+ g' s (Let ds v1) =
+ let s' = S.union s (S.fromList (mapMaybe getDeclIdent ds))
+ in foldMap (f'' s') ds <> g'' s' v1
+ g' s (Do es) = fold . snd . mapAccumL j'' s $ es
+ g' s (PositionedValue _ _ v1) = g'' s v1
+ g' _ _ = mempty
+
+ h'' s a = h s a <> h' s a
+
+ h' s (ConstructorBinder _ bs) = foldMap (h'' s) bs
+ 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 (PositionedBinder _ _ b1) = h'' s b1
+ h' s (TypedBinder _ b1) = h'' s b1
+ h' _ _ = mempty
+
+ i'' s a = i s a <> i' s a
+
+ i' s (CaseAlternative bs (Right val)) =
+ let s' = S.union s (S.fromList (concatMap binderNames bs))
+ in foldMap (h'' s) bs <> g'' s' val
+ i' s (CaseAlternative bs (Left gs)) =
+ let s' = S.union s (S.fromList (concatMap binderNames bs))
+ in foldMap (h'' s) bs <> foldMap (\(grd, val) -> g'' s' grd <> g'' s' val) gs
+
+ j'' s a = let (s', r) = j' s a in (s', j s a <> r)
+
+ j' s (DoNotationValue v) = (s, g'' s v)
+ j' s (DoNotationBind b v) =
+ let s' = S.union (S.fromList (binderNames b)) s
+ in (s', h'' s b <> g'' s' v)
+ j' s (DoNotationLet ds) =
+ let s' = S.union s (S.fromList (mapMaybe getDeclIdent ds))
+ in (s', foldMap (f'' s') ds)
+ j' s (PositionedDoNotationElement _ _ e1) = j'' s e1
+
+ getDeclIdent :: Declaration -> Maybe Ident
+ getDeclIdent (PositionedDeclaration _ _ d) = getDeclIdent d
+ getDeclIdent (ValueDeclaration ident _ _ _) = Just ident
+ getDeclIdent (TypeDeclaration ident _) = Just ident
+ getDeclIdent _ = Nothing
+
accumTypes :: (Monoid r) => (Type -> r) -> (Declaration -> r, Expr -> r, Binder -> r, CaseAlternative -> r, DoNotationElement -> r)
accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (const mempty) (const mempty)
where
diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs
index cee556f..3efa43f 100644
--- a/src/Language/PureScript/Bundle.hs
+++ b/src/Language/PureScript/Bundle.hs
@@ -95,7 +95,7 @@ data ExportType
-- Each is labelled with the original AST node which generated it, so that we can dump it back
-- into the output during codegen.
data ModuleElement
- = Require JSNode String ModuleIdentifier
+ = Require JSNode String (Either String ModuleIdentifier)
| Member JSNode Bool String [JSNode] [Key]
| ExportsList [(ExportType, String, JSNode, [Key])]
| Other JSNode
@@ -137,13 +137,13 @@ node (NN n) = n
node (NT n _ _) = n
-- | Calculate the ModuleIdentifier which a require(...) statement imports.
-checkImportPath :: Maybe FilePath -> String -> ModuleIdentifier -> S.Set String -> Maybe ModuleIdentifier
+checkImportPath :: Maybe FilePath -> String -> ModuleIdentifier -> S.Set String -> Either String ModuleIdentifier
checkImportPath _ "./foreign" m _ =
- Just (ModuleIdentifier (moduleName m) Foreign)
+ Right (ModuleIdentifier (moduleName m) Foreign)
checkImportPath requirePath name _ names
| Just name' <- stripPrefix (fromMaybe "" requirePath) name
- , name' `S.member` names = Just (ModuleIdentifier name' Regular)
-checkImportPath _ _ _ _ = Nothing
+ , name' `S.member` names = Right (ModuleIdentifier name' Regular)
+checkImportPath _ name _ _ = Left name
-- | Compute the dependencies of all elements in a module, and add them to the tree.
--
@@ -166,7 +166,7 @@ withDeps (Module modulePath es) = Module modulePath (map expandDeps es)
imports = mapMaybe toImport es
where
toImport :: ModuleElement -> Maybe (String, ModuleIdentifier)
- toImport (Require _ nm mid) = Just (nm, mid)
+ toImport (Require _ nm (Right mid)) = Just (nm, mid)
toImport _ = Nothing
-- | Collects all member names in scope, so that we can identify dependencies of the second type.
@@ -226,7 +226,7 @@ toModule requirePath mids mid top
, JSIdentifier "require" <- node req
, JSArguments _ [ impS ] _ <- node impP
, JSStringLiteral _ importPath <- node impS
- , Just importPath' <- checkImportPath requirePath importPath mid mids
+ , importPath' <- checkImportPath requirePath importPath mid mids
= pure (Require n importName importPath')
toModuleElement n
| JSVariables var [ varIntro ] _ <- node n
@@ -371,7 +371,7 @@ sortModules modules = map (\v -> case nodeFor v of (n, _, _) -> n) (reverse (top
return (m, mid, mapMaybe getKey els)
getKey :: ModuleElement -> Maybe ModuleIdentifier
- getKey (Require _ _ mi) = Just mi
+ getKey (Require _ _ (Right mi)) = Just mi
getKey _ = Nothing
-- | A module is empty if it contains no exported members (in other words,
@@ -416,9 +416,7 @@ codeGen optionsMainModule optionsNamespace ms = renderToString (NN (JSSourceElem
declToJS (Require _ nm req) =
[ NN (JSVariables (NT (JSLiteral "var") tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n " ])
[ NN (JSVarDecl (sp (JSIdentifier nm))
- [ sp (JSLiteral "=")
- , moduleReference sp (moduleName req)
- ])
+ (sp (JSLiteral "=") : either require (return . moduleReference sp . moduleName) req))
]
(nt (JSLiteral ";"))) ]
declToJS (ExportsList exps) = map toExport exps
@@ -467,6 +465,11 @@ codeGen optionsMainModule optionsNamespace ms = renderToString (NN (JSSourceElem
, lf
]
+ require :: String -> [JSNode]
+ require mn = [ sp (JSIdentifier "require")
+ , NN (JSArguments (nt (JSLiteral "(")) [ nt (JSStringLiteral '"' mn) ] (nt (JSLiteral ")")))
+ ]
+
moduleReference :: (Node -> JSNode) -> String -> JSNode
moduleReference f mn =
NN (JSMemberSquare [ f (JSIdentifier optionsNamespace) ]
diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index e409330..c77df0f 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -1,39 +1,29 @@
------------------------------------------------------------------------------
---
--- Module : Language.PureScript.CodeGen.JS
--- Copyright : (c) Phil Freeman 2013
--- License : MIT
---
--- Maintainer : Phil Freeman <paf31@cantab.net>
--- Stability : experimental
--- Portability :
---
--- |
--- This module generates code in the simplified Javascript intermediate representation from Purescript code
---
------------------------------------------------------------------------------
-
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
+-- |
+-- This module generates code in the simplified Javascript intermediate representation from Purescript code
+--
module Language.PureScript.CodeGen.JS
( module AST
, module Common
, moduleToJs
- , mainCall
) where
import Prelude ()
import Prelude.Compat
import Data.List ((\\), delete, intersect)
-import Data.Maybe (isNothing)
-import qualified Data.Traversable as T (traverse)
+import Data.Maybe (isNothing, fromMaybe)
+import qualified Data.Map as M
+import qualified Data.Foldable as F
+import qualified Data.Traversable as T
import Control.Arrow ((&&&))
-import Control.Monad (replicateM, forM)
+import Control.Monad (replicateM, forM, void)
+import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.Reader (MonadReader, asks)
import Control.Monad.Supply.Class
@@ -43,6 +33,7 @@ import Language.PureScript.CodeGen.JS.AST as AST
import Language.PureScript.CodeGen.JS.Common as Common
import Language.PureScript.CoreFn
import Language.PureScript.Names
+import Language.PureScript.Errors
import Language.PureScript.CodeGen.JS.Optimizer
import Language.PureScript.Options
import Language.PureScript.Traversals (sndM)
@@ -54,33 +45,95 @@ import System.FilePath.Posix ((</>))
-- Generate code in the simplified Javascript intermediate representation for all declarations in a
-- module.
--
-moduleToJs :: forall m. (Applicative m, Monad m, MonadReader Options m, MonadSupply m)
- => Module Ann -> Maybe JS -> m [JS]
-moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = do
- jsImports <- T.traverse importToJs . delete (ModuleName [ProperName C.prim]) . (\\ [mn]) $ imps
- jsDecls <- mapM bindToJs decls
- optimized <- T.traverse (T.traverse optimize) jsDecls
- 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 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
- ++ map (runIdent &&& foreignIdent) foreignExps
- return $ moduleBody ++ [JSAssignment (JSAccessor "exports" (JSVar "module")) exps']
+moduleToJs
+ :: forall m
+ . (Applicative m, Monad m, MonadReader Options m, MonadSupply m, MonadError MultipleErrors m)
+ => Module Ann
+ -> Maybe JS
+ -> m [JS]
+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
+ 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 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
+ ++ map (runIdent &&& foreignIdent) foreignExps
+ return $ moduleBody ++ [JSAssignment (JSAccessor "exports" (JSVar "module")) exps']
where
-- |
- -- Generates Javascript code for a module import.
+ -- Extracts all declaration names from a binding group.
--
- importToJs :: ModuleName -> m JS
- importToJs mn' = do
+ getNames :: Bind Ann -> [Ident]
+ getNames (NonRec ident _) = [ident]
+ getNames (Rec vals) = map 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 ids mns = go M.empty ids mns
+ where
+ go :: M.Map ModuleName ModuleName -> [Ident] -> [ModuleName] -> M.Map ModuleName ModuleName
+ go acc used (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'
+ go acc _ [] = acc
+
+ freshModuleName :: Integer -> ModuleName -> [Ident] -> ModuleName
+ freshModuleName i mn'@(ModuleName pns) used =
+ let newName = ModuleName $ init pns ++ [ProperName $ runProperName (last pns) ++ "_" ++ show i]
+ in if Ident (runModuleName newName) `elem` used
+ then freshModuleName (i + 1) mn' used
+ else newName
+
+ -- |
+ -- Generates Javascript code for a module import, binding the required module
+ -- to the alternative
+ --
+ importToJs :: M.Map ModuleName 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 mn') (Just moduleBody)
+ return $ JSVariableIntroduction (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 mnLookup binds =
+ let (f, _, _) = everywhereOnValues id goExpr goBinder
+ in map f binds
+ where
+ goExpr :: Expr a -> Expr a
+ goExpr (Var ann q) = Var ann (renameQual q)
+ goExpr e = e
+ goBinder :: Binder a -> Binder a
+ goBinder (ConstructorBinder ann q1 q2 bs) = ConstructorBinder ann (renameQual q1) (renameQual q2) bs
+ 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
+ in Qualified (Just mnSafe) a
+ renameQual q = q
-- |
-- Generate code in the simplified Javascript intermediate representation for a declaration
@@ -120,6 +173,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = do
accessor :: Ident -> JS -> JS
accessor (Ident prop) = accessorString prop
accessor (Op op) = JSIndexer (JSStringLiteral op)
+ accessor (GenIdent _ _) = internalError "GenIdent in accessor"
accessorString :: String -> JS -> JS
accessorString prop | identNeedsEscaping prop = JSIndexer (JSStringLiteral prop)
@@ -129,8 +183,8 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = do
-- Generate code in the simplified Javascript intermediate representation for a value or expression.
--
valueToJs :: Expr Ann -> m JS
- valueToJs (Literal _ l) =
- literalToValueJS l
+ 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) =
@@ -207,7 +261,8 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = do
iife v exprs = JSApp (JSFunction Nothing [] (JSBlock $ exprs ++ [JSReturn $ JSVar v])) []
literalToValueJS :: Literal (Expr Ann) -> m JS
- literalToValueJS (NumericLiteral n) = return $ JSNumericLiteral n
+ 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
@@ -275,10 +330,10 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = do
go _ _ _ = internalError "Invalid arguments to bindersToJs"
failedPatternError :: [String] -> JS
- failedPatternError names = JSUnary JSNew $ JSApp (JSVar "Error") [JSBinary Add (JSStringLiteral errorMessage) (JSArrayLiteral $ zipWith valueError names vals)]
+ failedPatternError names = JSUnary JSNew $ JSApp (JSVar "Error") [JSBinary Add (JSStringLiteral failedPatternMessage) (JSArrayLiteral $ zipWith valueError names vals)]
- errorMessage :: String
- errorMessage = "Failed pattern match" ++ maybe "" (((" at " ++ runModuleName mn ++ " ") ++) . displayStartEndPos) maybeSpan ++ ": "
+ failedPatternMessage :: String
+ failedPatternMessage = "Failed pattern match" ++ maybe "" (((" at " ++ runModuleName mn ++ " ") ++) . displayStartEndPos) maybeSpan ++ ": "
valueError :: String -> JS -> JS
valueError _ l@(JSNumericLiteral _) = l
@@ -359,5 +414,22 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = do
js <- binderToJs elVar done'' binder
return (JSVariableIntroduction elVar (Just (JSIndexer (JSNumericLiteral (Left index)) (JSVar varName))) : js)
-mainCall :: ModuleName -> String -> JS
-mainCall mmi ns = JSApp (JSAccessor C.main (JSAccessor (moduleNameToJs mmi) (JSVar ns))) []
+ -- 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))) =
+ -- 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)) =
+ let minInt = -2147483648
+ maxInt = 2147483647
+ in if i < minInt || i > maxInt
+ then throwError . errorMessage $ IntOutOfRange i "JavaScript" minInt maxInt
+ else return js
+ go other = return other
diff --git a/src/Language/PureScript/CodeGen/JS/AST.hs b/src/Language/PureScript/CodeGen/JS/AST.hs
index a5ec412..3b8236d 100644
--- a/src/Language/PureScript/CodeGen/JS/AST.hs
+++ b/src/Language/PureScript/CodeGen/JS/AST.hs
@@ -1,27 +1,12 @@
------------------------------------------------------------------------------
---
--- Module : Language.PureScript.CodeGen.JS.AST
--- Copyright : (c) Phil Freeman 2013
--- License : MIT
---
--- Maintainer : Phil Freeman <paf31@cantab.net>
--- Stability : experimental
--- Portability :
---
-- |
-- Data types for the intermediate simplified-Javascript AST
--
------------------------------------------------------------------------------
-
-{-# LANGUAGE DeriveDataTypeable #-}
-
module Language.PureScript.CodeGen.JS.AST where
import Prelude ()
import Prelude.Compat
import Control.Monad.Identity
-import Data.Data
import Language.PureScript.Comments
import Language.PureScript.Traversals
@@ -49,7 +34,8 @@ data UnaryOperator
-- |
-- Constructor
--
- | JSNew deriving (Show, Read, Eq, Data, Typeable)
+ | JSNew
+ deriving (Show, Read, Eq)
-- |
-- Built-in binary operators
@@ -130,7 +116,8 @@ data BinaryOperator
-- |
-- Bitwise right shift with zero-fill
--
- | ZeroFillShiftRight deriving (Show, Read, Eq, Data, Typeable)
+ | ZeroFillShiftRight
+ deriving (Show, Read, Eq)
-- |
-- Data type for simplified Javascript expressions
@@ -251,7 +238,8 @@ data JS
-- |
-- Commented Javascript
--
- | JSComment [Comment] JS deriving (Show, Read, Eq, Data, Typeable)
+ | JSComment [Comment] JS
+ deriving (Show, Read, Eq)
--
-- Traversals
diff --git a/src/Language/PureScript/CodeGen/JS/Common.hs b/src/Language/PureScript/CodeGen/JS/Common.hs
index 6ba0e78..8c004b3 100644
--- a/src/Language/PureScript/CodeGen/JS/Common.hs
+++ b/src/Language/PureScript/CodeGen/JS/Common.hs
@@ -1,25 +1,19 @@
------------------------------------------------------------------------------
---
--- Module : Language.PureScript.CodeGen.Common
--- Copyright : (c) Phil Freeman 2013
--- License : MIT
---
--- Maintainer : Phil Freeman <paf31@cantab.net>
--- Stability : experimental
--- Portability :
---
-- |
-- Common code generation utility functions
--
------------------------------------------------------------------------------
-
module Language.PureScript.CodeGen.JS.Common where
import Data.Char
import Data.List (intercalate)
+import Language.PureScript.Crash
import Language.PureScript.Names
+moduleNameToJs :: ModuleName -> String
+moduleNameToJs (ModuleName pns) =
+ let name = intercalate "_" (runProperName `map` pns)
+ in if nameIsJsBuiltIn name then "$$" ++ name else name
+
-- |
-- Convert an Ident into a valid Javascript identifier:
--
@@ -30,9 +24,11 @@ import Language.PureScript.Names
-- * Symbols are prefixed with '$' followed by a symbol name or their ordinal value.
--
identToJs :: Ident -> String
-identToJs (Ident name) | nameIsJsReserved name = "$$" ++ name
-identToJs (Ident name) = concatMap identCharToString name
+identToJs (Ident name)
+ | nameIsJsReserved name || nameIsJsBuiltIn name = "$$" ++ name
+ | otherwise = concatMap identCharToString name
identToJs (Op op) = concatMap identCharToString op
+identToJs (GenIdent _ _) = internalError "GenIdent in identToJs"
-- |
-- Test if a string is a valid JS identifier without escaping.
@@ -75,107 +71,161 @@ identCharToString c = '$' : show (ord c)
--
nameIsJsReserved :: String -> Bool
nameIsJsReserved name =
- name `elem` [ "abstract"
- , "arguments"
- , "boolean"
- , "break"
- , "byte"
- , "case"
- , "catch"
- , "char"
- , "class"
- , "const"
- , "continue"
- , "debugger"
- , "default"
- , "delete"
- , "do"
- , "double"
- , "else"
- , "enum"
- , "eval"
- , "export"
- , "extends"
- , "final"
- , "finally"
- , "float"
- , "for"
- , "function"
- , "goto"
- , "if"
- , "implements"
- , "import"
- , "in"
- , "instanceof"
- , "int"
- , "interface"
- , "let"
- , "long"
- , "native"
- , "new"
- , "null"
- , "package"
- , "private"
- , "protected"
- , "public"
- , "return"
- , "short"
- , "static"
- , "super"
- , "switch"
- , "synchronized"
- , "this"
- , "throw"
- , "throws"
- , "transient"
- , "try"
- , "typeof"
- , "var"
- , "void"
- , "volatile"
- , "while"
- , "with"
- , "yield" ] || properNameIsJsReserved name
-
-moduleNameToJs :: ModuleName -> String
-moduleNameToJs (ModuleName pns) =
- let name = intercalate "_" (runProperName `map` pns)
- in if properNameIsJsReserved name then "$$" ++ name else name
+ name `elem` jsAnyReserved
-- |
--- Checks whether a proper name is reserved in Javascript.
+-- Checks whether a name matches a built-in value in Javascript.
--
-properNameIsJsReserved :: String -> Bool
-properNameIsJsReserved name =
- name `elem` [ "Infinity"
- , "NaN"
- , "Object"
- , "Function"
- , "Boolean"
- , "Error"
- , "EvalError"
- , "InternalError"
- , "RangeError"
- , "ReferenceError"
- , "SyntaxError"
- , "TypeError"
- , "URIError"
- , "Number"
- , "Math"
- , "Date"
- , "String"
- , "RegExp"
- , "Array"
- , "Int8Array"
- , "Uint8Array"
- , "Uint8ClampedArray"
- , "Int16Array"
- , "Uint16Array"
- , "Int32Array"
- , "Uint32Array"
- , "Float32Array"
- , "Float64Array"
- , "ArrayBuffer"
- , "DataView"
- , "JSON"
- , "Intl" ]
+nameIsJsBuiltIn :: String -> Bool
+nameIsJsBuiltIn name =
+ elem name
+ [ "arguments"
+ , "Array"
+ , "ArrayBuffer"
+ , "Boolean"
+ , "DataView"
+ , "Date"
+ , "decodeURI"
+ , "decodeURIComponent"
+ , "encodeURI"
+ , "encodeURIComponent"
+ , "Error"
+ , "escape"
+ , "eval"
+ , "EvalError"
+ , "Float32Array"
+ , "Float64Array"
+ , "Function"
+ , "Infinity"
+ , "Int16Array"
+ , "Int32Array"
+ , "Int8Array"
+ , "Intl"
+ , "isFinite"
+ , "isNaN"
+ , "JSON"
+ , "Map"
+ , "Math"
+ , "NaN"
+ , "Number"
+ , "Object"
+ , "parseFloat"
+ , "parseInt"
+ , "Promise"
+ , "Proxy"
+ , "RangeError"
+ , "ReferenceError"
+ , "Reflect"
+ , "RegExp"
+ , "Set"
+ , "SIMD"
+ , "String"
+ , "Symbol"
+ , "SyntaxError"
+ , "TypeError"
+ , "Uint16Array"
+ , "Uint32Array"
+ , "Uint8Array"
+ , "Uint8ClampedArray"
+ , "undefined"
+ , "unescape"
+ , "URIError"
+ , "WeakMap"
+ , "WeakSet"
+ ]
+
+jsAnyReserved :: [String]
+jsAnyReserved =
+ concat
+ [ jsKeywords
+ , jsSometimesReserved
+ , jsFutureReserved
+ , jsFutureReservedStrict
+ , jsOldReserved
+ , jsLiterals
+ ]
+
+jsKeywords :: [String]
+jsKeywords =
+ [ "break"
+ , "case"
+ , "catch"
+ , "class"
+ , "const"
+ , "continue"
+ , "debugger"
+ , "default"
+ , "delete"
+ , "do"
+ , "else"
+ , "export"
+ , "extends"
+ , "finally"
+ , "for"
+ , "function"
+ , "if"
+ , "import"
+ , "in"
+ , "instanceof"
+ , "new"
+ , "return"
+ , "super"
+ , "switch"
+ , "this"
+ , "throw"
+ , "try"
+ , "typeof"
+ , "var"
+ , "void"
+ , "while"
+ , "with"
+ ]
+
+jsSometimesReserved :: [String]
+jsSometimesReserved =
+ [ "await"
+ , "let"
+ , "static"
+ , "yield"
+ ]
+
+jsFutureReserved :: [String]
+jsFutureReserved =
+ [ "enum" ]
+
+jsFutureReservedStrict :: [String]
+jsFutureReservedStrict =
+ [ "implements"
+ , "interface"
+ , "package"
+ , "private"
+ , "protected"
+ , "public"
+ ]
+
+jsOldReserved :: [String]
+jsOldReserved =
+ [ "abstract"
+ , "boolean"
+ , "byte"
+ , "char"
+ , "double"
+ , "final"
+ , "float"
+ , "goto"
+ , "int"
+ , "long"
+ , "native"
+ , "short"
+ , "synchronized"
+ , "throws"
+ , "transient"
+ , "volatile"
+ ]
+
+jsLiterals :: [String]
+jsLiterals =
+ [ "null"
+ , "true"
+ , "false"
+ ]
diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer.hs b/src/Language/PureScript/CodeGen/JS/Optimizer.hs
index 5e2a38e..0b28e17 100644
--- a/src/Language/PureScript/CodeGen/JS/Optimizer.hs
+++ b/src/Language/PureScript/CodeGen/JS/Optimizer.hs
@@ -1,13 +1,5 @@
------------------------------------------------------------------------------
---
--- Module : Language.PureScript.CodeGen.JS.Optimizer
--- Copyright : (c) Phil Freeman 2013
--- License : MIT
---
--- Maintainer : Phil Freeman <paf31@cantab.net>
--- Stability : experimental
--- Portability :
---
+{-# LANGUAGE FlexibleContexts #-}
+
-- |
-- This module optimizes code in the simplified-Javascript intermediate representation.
--
@@ -29,13 +21,7 @@
--
-- * Inlining primitive Javascript operators
--
------------------------------------------------------------------------------
-
-{-# LANGUAGE FlexibleContexts #-}
-
-module Language.PureScript.CodeGen.JS.Optimizer (
- optimize
-) where
+module Language.PureScript.CodeGen.JS.Optimizer (optimize) where
import Prelude ()
import Prelude.Compat
@@ -65,11 +51,21 @@ optimize js = do
optimize' :: (Monad m, MonadReader Options m, Applicative m, MonadSupply m) => JS -> m JS
optimize' js = do
opts <- ask
- untilFixedPoint (inlineFnComposition . applyAll
+ 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
+ , inlineCommonOperators
+ ]) js
+ untilFixedPoint (return . tidyUp) . tco opts . magicDo opts $ js'
+ where
+ tidyUp :: JS -> JS
+ tidyUp = applyAll
[ collapseNestedBlocks
, collapseNestedIfs
- , tco opts
- , magicDo opts
, removeCodeAfterReturnStatements
, removeUnusedArg
, removeUndefinedApp
@@ -77,11 +73,7 @@ optimize' js = do
, etaConvert
, evaluateIifes
, inlineVariables
- , inlineValues
- , inlineOperator (C.prelude, (C.$)) $ \f x -> JSApp f [x]
- , inlineOperator (C.prelude, (C.#)) $ \x f -> JSApp f [x]
- , inlineOperator (C.dataArrayUnsafe, C.unsafeIndex) $ flip JSIndexer
- , inlineCommonOperators ]) js
+ ]
untilFixedPoint :: (Monad m, Eq a) => (a -> m a) -> a -> m a
untilFixedPoint f = go
diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs
index 1cc24d3..2bbb99a 100644
--- a/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs
+++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs
@@ -1,18 +1,6 @@
------------------------------------------------------------------------------
---
--- Module : Language.PureScript.CodeGen.JS.Optimizer.Common
--- Copyright : (c) Phil Freeman 2013-14
--- License : MIT
---
--- Maintainer : Phil Freeman <paf31@cantab.net>
--- Stability : experimental
--- Portability :
---
-- |
-- Common functions used by the various optimizer phases
--
------------------------------------------------------------------------------
-
module Language.PureScript.CodeGen.JS.Optimizer.Common where
import Data.Maybe (fromMaybe)
@@ -76,3 +64,18 @@ isUpdated var1 = everythingOnJS (||) check
removeFromBlock :: ([JS] -> [JS]) -> JS -> JS
removeFromBlock go (JSBlock sts) = JSBlock (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 _ _ = 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 _ _ = False
+
+isDict' :: [(String, String)] -> JS -> Bool
+isDict' xs js = any (`isDict` js) xs
diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs
index 8b42305..2b5cbd3 100644
--- a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs
+++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs
@@ -1,28 +1,16 @@
------------------------------------------------------------------------------
---
--- Module : Language.PureScript.CodeGen.JS.Optimizer.Inliner
--- Copyright : (c) Phil Freeman 2013-14
--- License : MIT
---
--- Maintainer : Phil Freeman <paf31@cantab.net>
--- Stability : experimental
--- Portability :
---
-- |
-- This module provides basic inlining capabilities
--
------------------------------------------------------------------------------
-
-module Language.PureScript.CodeGen.JS.Optimizer.Inliner (
- inlineVariables,
- inlineValues,
- inlineOperator,
- inlineCommonOperators,
- inlineFnComposition,
- etaConvert,
- unThunk,
- evaluateIifes
-) where
+module Language.PureScript.CodeGen.JS.Optimizer.Inliner
+ ( inlineVariables
+ , inlineCommonValues
+ , inlineOperator
+ , inlineCommonOperators
+ , inlineFnComposition
+ , etaConvert
+ , unThunk
+ , evaluateIifes
+ ) where
import Prelude ()
import Prelude.Compat
@@ -89,30 +77,30 @@ inlineVariables = everywhereOnJS $ removeFromBlock go
go (map (replaceIdent var js) sts)
go (s:sts) = s : go sts
-inlineValues :: JS -> JS
-inlineValues = everywhereOnJS convert
+inlineCommonValues :: JS -> JS
+inlineCommonValues = everywhereOnJS convert
where
convert :: JS -> JS
- convert (JSApp fn [dict]) | isDict semiringNumber dict && isFn fnZero fn = JSNumericLiteral (Left 0)
- | isDict semiringNumber dict && isFn fnOne fn = JSNumericLiteral (Left 1)
- | isDict semiringInt dict && isFn fnZero fn = JSNumericLiteral (Left 0)
- | isDict 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 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 = JSBinary BitwiseOr (JSBinary Add x y) (JSNumericLiteral (Left 0))
- | isDict semiringInt dict && isFn fnMultiply fn = JSBinary BitwiseOr (JSBinary Multiply x y) (JSNumericLiteral (Left 0))
- | isDict moduloSemiringInt dict && isFn fnDivide fn = JSBinary BitwiseOr (JSBinary Divide x y) (JSNumericLiteral (Left 0))
- | isDict ringInt dict && isFn fnSubtract fn = JSBinary BitwiseOr (JSBinary Subtract x y) (JSNumericLiteral (Left 0))
+ | 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 other = other
- fnZero = (C.prelude, C.zero)
- fnOne = (C.prelude, C.one)
- fnBottom = (C.prelude, C.bottom)
- fnTop = (C.prelude, C.top)
- fnAdd = (C.prelude, (C.+))
- fnDivide = (C.prelude, (C./))
- fnMultiply = (C.prelude, (C.*))
- fnSubtract = (C.prelude, (C.-))
+ fnZero = [(C.prelude, C.zero), (C.dataSemiring, C.zero)]
+ fnOne = [(C.prelude, C.one), (C.dataSemiring, C.one)]
+ fnBottom = [(C.prelude, C.bottom), (C.dataBounded, C.bottom)]
+ fnTop = [(C.prelude, C.top), (C.dataBounded, C.top)]
+ fnAdd = [(C.prelude, (C.+)), (C.prelude, (C.add)), (C.dataSemiring, (C.+)), (C.dataSemiring, (C.add))]
+ 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))
inlineOperator :: (String, String) -> (JS -> JS -> JS) -> JS -> JS
inlineOperator (m, op) f = everywhereOnJS convert
@@ -126,43 +114,54 @@ inlineOperator (m, op) f = everywhereOnJS convert
inlineCommonOperators :: JS -> JS
inlineCommonOperators = applyAll $
- [ binary semiringNumber (C.+) Add
- , binary semiringNumber (C.*) Multiply
-
- , binary ringNumber (C.-) Subtract
- , unary ringNumber C.negate Negate
- , binary ringInt (C.-) Subtract
- , unary ringInt C.negate Negate
-
- , binary moduloSemiringNumber (C./) Divide
- , binary moduloSemiringInt C.mod Modulus
-
- , binary eqNumber (C.==) EqualTo
- , binary eqNumber (C./=) NotEqualTo
- , binary eqInt (C.==) EqualTo
- , binary eqInt (C./=) NotEqualTo
- , binary eqString (C.==) EqualTo
- , binary eqString (C./=) NotEqualTo
- , binary eqBoolean (C.==) EqualTo
- , binary eqBoolean (C./=) NotEqualTo
-
- , binary ordNumber (C.<) LessThan
- , binary ordNumber (C.>) GreaterThan
- , binary ordNumber (C.<=) LessThanOrEqualTo
- , binary ordNumber (C.>=) GreaterThanOrEqualTo
- , binary ordInt (C.<) LessThan
- , binary ordInt (C.>) GreaterThan
- , binary ordInt (C.<=) LessThanOrEqualTo
- , binary ordInt (C.>=) GreaterThanOrEqualTo
-
- , binary semigroupString (C.<>) Add
- , binary semigroupString (C.++) Add
-
- , binary booleanAlgebraBoolean (C.&&) And
- , binary booleanAlgebraBoolean (C.||) Or
- , binaryFunction booleanAlgebraBoolean C.conj And
- , binaryFunction booleanAlgebraBoolean C.disj Or
- , unary booleanAlgebraBoolean C.not Not
+ [ binary semiringNumber opAdd Add
+ , binary semiringNumber opMul Multiply
+
+ , binary ringNumber opSub Subtract
+ , unary ringNumber opNegate Negate
+ , binary ringInt opSub Subtract
+ , unary ringInt opNegate Negate
+
+ , binary moduloSemiringNumber opDiv Divide
+ , binary moduloSemiringInt opMod Modulus
+
+ , binary eqNumber opEq EqualTo
+ , binary eqNumber opNotEq NotEqualTo
+ , binary eqInt opEq EqualTo
+ , binary eqInt opNotEq NotEqualTo
+ , binary eqString opEq EqualTo
+ , binary eqString opNotEq NotEqualTo
+ , binary eqChar opEq EqualTo
+ , binary eqChar opNotEq NotEqualTo
+ , binary eqBoolean opEq EqualTo
+ , binary eqBoolean opNotEq NotEqualTo
+
+ , binary ordBoolean opLessThan LessThan
+ , binary ordBoolean opLessThanOrEq LessThanOrEqualTo
+ , binary ordBoolean opGreaterThan GreaterThan
+ , binary ordBoolean opGreaterThanOrEq GreaterThanOrEqualTo
+ , binary ordChar opLessThan LessThan
+ , binary ordChar opLessThanOrEq LessThanOrEqualTo
+ , binary ordChar opGreaterThan GreaterThan
+ , binary ordChar opGreaterThanOrEq GreaterThanOrEqualTo
+ , binary ordInt opLessThan LessThan
+ , binary ordInt opLessThanOrEq LessThanOrEqualTo
+ , binary ordInt opGreaterThan GreaterThan
+ , binary ordInt opGreaterThanOrEq GreaterThanOrEqualTo
+ , binary ordNumber opLessThan LessThan
+ , binary ordNumber opLessThanOrEq LessThanOrEqualTo
+ , binary ordNumber opGreaterThan GreaterThan
+ , binary ordNumber opGreaterThanOrEq GreaterThanOrEqualTo
+ , binary ordString opLessThan LessThan
+ , binary ordString opLessThanOrEq LessThanOrEqualTo
+ , binary ordString opGreaterThan GreaterThan
+ , binary ordString opGreaterThanOrEq GreaterThanOrEqualTo
+
+ , binary semigroupString opAppend Add
+
+ , binary booleanAlgebraBoolean opConj And
+ , binary booleanAlgebraBoolean opDisj Or
+ , unary booleanAlgebraBoolean opNot Not
, binary' C.dataIntBits (C..|.) BitwiseOr
, binary' C.dataIntBits (C..&.) BitwiseAnd
@@ -174,11 +173,11 @@ inlineCommonOperators = applyAll $
] ++
[ fn | i <- [0..10], fn <- [ mkFn i, runFn i ] ]
where
- binary :: (String, String) -> String -> BinaryOperator -> JS -> JS
- binary dict opString op = everywhereOnJS convert
+ binary :: [(String, String)] -> [(String, String)] -> BinaryOperator -> JS -> JS
+ binary dict fns op = everywhereOnJS convert
where
convert :: JS -> JS
- convert (JSApp (JSApp (JSApp fn [dict']) [x]) [y]) | isDict dict dict' && isPreludeFn opString fn = JSBinary op x y
+ convert (JSApp (JSApp (JSApp fn [dict']) [x]) [y]) | isDict' dict dict' && isFn' fns fn = JSBinary op x y
convert other = other
binary' :: String -> String -> BinaryOperator -> JS -> JS
binary' moduleName opString op = everywhereOnJS convert
@@ -186,17 +185,11 @@ inlineCommonOperators = applyAll $
convert :: JS -> JS
convert (JSApp (JSApp fn [x]) [y]) | isFn (moduleName, opString) fn = JSBinary op x y
convert other = other
- binaryFunction :: (String, String) -> String -> BinaryOperator -> JS -> JS
- binaryFunction dict fnName op = everywhereOnJS convert
- where
- convert :: JS -> JS
- convert (JSApp (JSApp (JSApp fn [dict']) [x]) [y]) | isPreludeFn fnName fn && isDict dict dict' = JSBinary op x y
- convert other = other
- unary :: (String, String) -> String -> UnaryOperator -> JS -> JS
- unary dict fnName op = everywhereOnJS convert
+ unary :: [(String, String)] -> [(String, String)] -> UnaryOperator -> JS -> JS
+ unary dicts fns op = everywhereOnJS convert
where
convert :: JS -> JS
- convert (JSApp (JSApp fn [dict']) [x]) | isPreludeFn fnName fn && isDict dict dict' = JSUnary op x
+ convert (JSApp (JSApp fn [dict']) [x]) | isDict' dicts dict' && isFn' fns fn = JSUnary op x
convert other = other
unary' :: String -> String -> UnaryOperator -> JS -> JS
unary' moduleName fnName op = everywhereOnJS convert
@@ -246,71 +239,130 @@ 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]]
- convert (JSApp (JSApp (JSApp fn [dict']) [x]) [y]) | isFnCompose dict' fn = do
- arg <- freshName
- return $ JSFunction Nothing [arg] (JSBlock [JSReturn $ JSApp x [JSApp y [JSVar arg]]])
+ 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])
+ | isFnCompose dict' fn = do
+ arg <- freshName
+ return $ JSFunction Nothing [arg] (JSBlock [JSReturn $ JSApp x [JSApp y [JSVar arg]]])
+ | isFnComposeFlipped dict' fn = do
+ arg <- freshName
+ return $ JSFunction Nothing [arg] (JSBlock [JSReturn $ JSApp y [JSApp x [JSVar arg]]])
convert other = return other
isFnCompose :: JS -> JS -> Bool
- isFnCompose dict' fn = isDict semigroupoidFn dict' && (isPreludeFn (C.<<<) fn || isPreludeFn C.compose fn)
+ isFnCompose dict' fn = isDict' semigroupoidFn dict' && isFn' fnCompose fn
+ isFnComposeFlipped :: JS -> JS -> Bool
+ isFnComposeFlipped dict' fn = isDict' semigroupoidFn dict' && isFn' fnComposeFlipped fn
+ fnCompose :: [(String, String)]
+ fnCompose = [(C.prelude, C.compose), (C.prelude, (C.<<<)), (C.controlSemigroupoid, C.compose)]
+ fnComposeFlipped :: [(String, String)]
+ fnComposeFlipped = [(C.prelude, (C.>>>)), (C.controlSemigroupoid, C.composeFlipped)]
+
+semiringNumber :: [(String, String)]
+semiringNumber = [(C.prelude, C.semiringNumber), (C.dataSemiring, C.semiringNumber)]
+
+semiringInt :: [(String, String)]
+semiringInt = [(C.prelude, C.semiringInt), (C.dataSemiring, C.semiringInt)]
+
+ringNumber :: [(String, String)]
+ringNumber = [(C.prelude, C.ringNumber), (C.dataRing, C.ringNumber)]
+
+ringInt :: [(String, String)]
+ringInt = [(C.prelude, C.ringInt), (C.dataRing, C.ringInt)]
+
+moduloSemiringNumber :: [(String, String)]
+moduloSemiringNumber = [(C.prelude, C.moduloSemiringNumber), (C.dataModuloSemiring, C.moduloSemiringNumber)]
+
+moduloSemiringInt :: [(String, String)]
+moduloSemiringInt = [(C.prelude, C.moduloSemiringInt), (C.dataModuloSemiring, C.moduloSemiringInt)]
+
+eqNumber :: [(String, String)]
+eqNumber = [(C.prelude, C.eqNumber), (C.dataEq, C.eqNumber)]
+
+eqInt :: [(String, String)]
+eqInt = [(C.prelude, C.eqInt), (C.dataEq, C.eqInt)]
+
+eqString :: [(String, String)]
+eqString = [(C.prelude, C.eqString), (C.dataEq, C.eqString)]
+
+eqChar :: [(String, String)]
+eqChar = [(C.prelude, C.eqChar), (C.dataEq, C.eqChar)]
+
+eqBoolean :: [(String, String)]
+eqBoolean = [(C.prelude, C.eqBoolean), (C.dataEq, C.eqBoolean)]
+
+ordBoolean :: [(String, String)]
+ordBoolean = [(C.prelude, C.ordBoolean), (C.dataOrd, C.ordBoolean)]
+
+ordNumber :: [(String, String)]
+ordNumber = [(C.prelude, C.ordNumber), (C.dataOrd, C.ordNumber)]
+
+ordInt :: [(String, String)]
+ordInt = [(C.prelude, C.ordInt), (C.dataOrd, C.ordInt)]
+
+ordString :: [(String, String)]
+ordString = [(C.prelude, C.ordString), (C.dataOrd, C.ordString)]
+
+ordChar :: [(String, String)]
+ordChar = [(C.prelude, C.ordChar), (C.dataOrd, C.ordChar)]
+
+semigroupString :: [(String, String)]
+semigroupString = [(C.prelude, C.semigroupString), (C.dataSemigroup, C.semigroupString)]
-isDict :: (String, String) -> JS -> Bool
-isDict (moduleName, dictName) (JSAccessor x (JSVar y)) = x == dictName && y == moduleName
-isDict _ _ = False
+boundedBoolean :: [(String, String)]
+boundedBoolean = [(C.prelude, C.boundedBoolean), (C.dataBounded, C.boundedBoolean)]
-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 _ _ = False
+booleanAlgebraBoolean :: [(String, String)]
+booleanAlgebraBoolean = [(C.prelude, C.booleanAlgebraBoolean), (C.dataBooleanAlgebra, C.booleanAlgebraBoolean)]
-isPreludeFn :: String -> JS -> Bool
-isPreludeFn fnName = isFn (C.prelude, fnName)
+semigroupoidFn :: [(String, String)]
+semigroupoidFn = [(C.prelude, C.semigroupoidFn), (C.controlSemigroupoid, C.semigroupoidFn)]
-semiringNumber :: (String, String)
-semiringNumber = (C.prelude, C.semiringNumber)
+opAdd :: [(String, String)]
+opAdd = [(C.prelude, (C.+)), (C.prelude, C.add), (C.dataSemiring, C.add)]
-semiringInt :: (String, String)
-semiringInt = (C.prelude, C.semiringInt)
+opMul :: [(String, String)]
+opMul = [(C.prelude, (C.*)), (C.prelude, C.mul), (C.dataSemiring, C.mul)]
-ringNumber :: (String, String)
-ringNumber = (C.prelude, C.ringNumber)
+opEq :: [(String, String)]
+opEq = [(C.prelude, (C.==)), (C.prelude, C.eq), (C.dataEq, C.eq)]
-ringInt :: (String, String)
-ringInt = (C.prelude, C.ringInt)
+opNotEq :: [(String, String)]
+opNotEq = [(C.prelude, (C./=)), (C.dataEq, C.notEq)]
-moduloSemiringNumber :: (String, String)
-moduloSemiringNumber = (C.prelude, C.moduloSemiringNumber)
+opLessThan :: [(String, String)]
+opLessThan = [(C.prelude, (C.<)), (C.dataOrd, C.lessThan)]
-moduloSemiringInt :: (String, String)
-moduloSemiringInt = (C.prelude, C.moduloSemiringInt)
+opLessThanOrEq :: [(String, String)]
+opLessThanOrEq = [(C.prelude, (C.<=)), (C.dataOrd, C.lessThanOrEq)]
-eqNumber :: (String, String)
-eqNumber = (C.prelude, C.eqNumber)
+opGreaterThan :: [(String, String)]
+opGreaterThan = [(C.prelude, (C.>)), (C.dataOrd, C.greaterThan)]
-eqInt :: (String, String)
-eqInt = (C.prelude, C.eqInt)
+opGreaterThanOrEq :: [(String, String)]
+opGreaterThanOrEq = [(C.prelude, (C.>=)), (C.dataOrd, C.greaterThanOrEq)]
-eqString :: (String, String)
-eqString = (C.prelude, C.eqNumber)
+opAppend :: [(String, String)]
+opAppend = [(C.prelude, (C.<>)), (C.prelude, (C.++)), (C.prelude, C.append), (C.dataSemigroup, C.append)]
-eqBoolean :: (String, String)
-eqBoolean = (C.prelude, C.eqNumber)
+opSub :: [(String, String)]
+opSub = [(C.prelude, (C.-)), (C.prelude, C.sub), (C.dataRing, C.sub)]
-ordNumber :: (String, String)
-ordNumber = (C.prelude, C.ordNumber)
+opNegate :: [(String, String)]
+opNegate = [(C.prelude, C.negate), (C.dataRing, C.negate)]
-ordInt :: (String, String)
-ordInt = (C.prelude, C.ordInt)
+opDiv :: [(String, String)]
+opDiv = [(C.prelude, (C./)), (C.prelude, C.div), (C.dataModuloSemiring, C.div)]
-semigroupString :: (String, String)
-semigroupString = (C.prelude, C.semigroupString)
+opMod :: [(String, String)]
+opMod = [(C.prelude, C.mod), (C.dataModuloSemiring, C.mod)]
-boundedBoolean :: (String, String)
-boundedBoolean = (C.prelude, C.boundedBoolean)
+opConj :: [(String, String)]
+opConj = [(C.prelude, (C.&&)), (C.prelude, C.conj), (C.dataBooleanAlgebra, C.conj)]
-booleanAlgebraBoolean :: (String, String)
-booleanAlgebraBoolean = (C.prelude, C.booleanAlgebraBoolean)
+opDisj :: [(String, String)]
+opDisj = [(C.prelude, (C.||)), (C.prelude, C.disj), (C.dataBooleanAlgebra, C.disj)]
-semigroupoidFn :: (String, String)
-semigroupoidFn = (C.prelude, C.semigroupoidFn)
+opNot :: [(String, String)]
+opNot = [(C.prelude, C.not), (C.dataBooleanAlgebra, C.not)]
diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs
index 2f57bc8..fb5eda8 100644
--- a/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs
+++ b/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs
@@ -1,29 +1,14 @@
------------------------------------------------------------------------------
---
--- Module : Language.PureScript.CodeGen.JS.Optimizer.MagicDo
--- Copyright : (c) Phil Freeman 2013-14
--- License : MIT
---
--- Maintainer : Phil Freeman <paf31@cantab.net>
--- Stability : experimental
--- Portability :
---
-- |
-- This module implements the "Magic Do" optimization, which inlines calls to return
-- and bind for the Eff monad, as well as some of its actions.
--
------------------------------------------------------------------------------
-
-module Language.PureScript.CodeGen.JS.Optimizer.MagicDo (
- magicDo
-) where
+module Language.PureScript.CodeGen.JS.Optimizer.MagicDo (magicDo) where
import Data.List (nub)
import Data.Maybe (fromJust, isJust)
import Language.PureScript.CodeGen.JS.AST
-import Language.PureScript.CodeGen.JS.Common
-import Language.PureScript.Names
+import Language.PureScript.CodeGen.JS.Optimizer.Common
import Language.PureScript.Options
import qualified Language.PureScript.Constants as C
@@ -54,9 +39,7 @@ magicDo' = everywhereOnJS undo . everywhereOnJSTopDown convert
fnName = "__do"
-- Desugar monomorphic calls to >>= and return for the Eff monad
convert :: JS -> JS
- -- Desugar return
- convert (JSApp (JSApp ret [val]) []) | isReturn ret = val
- -- Desugar pure
+ -- Desugar pure & return
convert (JSApp (JSApp pure' [val]) []) | isPure pure' = val
-- Desugar >>
convert (JSApp (JSApp bind [m]) [JSFunction Nothing [] (JSBlock js)]) | isBind bind =
@@ -72,33 +55,19 @@ magicDo' = everywhereOnJS undo . everywhereOnJSTopDown convert
JSApp (JSFunction Nothing [] (JSBlock [ JSWhile (JSApp arg1 []) (JSBlock [ JSApp arg2 [] ]), JSReturn $ JSObjectLiteral []])) []
convert other = other
-- Check if an expression represents a monomorphic call to >>= for the Eff monad
- isBind (JSApp bindPoly [effDict]) | isBindPoly bindPoly && isEffDict C.bindEffDictionary effDict = 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 return for the Eff monad
- isReturn (JSApp retPoly [effDict]) | isRetPoly retPoly && isEffDict C.monadEffDictionary effDict = True
- isReturn _ = False
- -- Check if an expression represents a monomorphic call to pure for the Eff applicative
- isPure (JSApp purePoly [effDict]) | isPurePoly purePoly && isEffDict C.applicativeEffDictionary effDict = True
+ -- 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 _ = False
-- Check if an expression represents the polymorphic >>= function
- isBindPoly (JSAccessor prop (JSVar prelude)) = prelude == C.prelude && (prop `elem` map identToJs [Ident C.bind, Op (C.>>=)])
- isBindPoly (JSIndexer (JSStringLiteral bind) (JSVar prelude)) = prelude == C.prelude && (bind `elem` [C.bind, (C.>>=)])
- isBindPoly _ = False
- -- Check if an expression represents the polymorphic return function
- isRetPoly (JSAccessor returnEscaped (JSVar prelude)) = prelude == C.prelude && returnEscaped == C.returnEscaped
- isRetPoly (JSIndexer (JSStringLiteral return') (JSVar prelude)) = prelude == C.prelude && return' == C.return
- isRetPoly _ = False
- -- Check if an expression represents the polymorphic pure function
- isPurePoly (JSAccessor pure' (JSVar prelude)) = prelude == C.prelude && pure' == C.pure'
- isPurePoly (JSIndexer (JSStringLiteral pure') (JSVar prelude)) = prelude == C.prelude && pure' == C.pure'
- isPurePoly _ = False
- -- Check if an expression represents a function in the Ef module
+ 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 _ _ = False
- -- Check if an expression represents the Monad Eff dictionary
- isEffDict name (JSVar ident) | ident == name = True
- isEffDict name (JSAccessor prop (JSVar eff)) = eff == C.eff && prop == name
- isEffDict _ _ = False
+
-- Remove __do function applications which remain after desugaring
undo :: JS -> JS
undo (JSReturn (JSApp (JSFunction (Just ident) [] body) [])) | ident == fnName = body
diff --git a/src/Language/PureScript/Comments.hs b/src/Language/PureScript/Comments.hs
index 351731b..2e72595 100644
--- a/src/Language/PureScript/Comments.hs
+++ b/src/Language/PureScript/Comments.hs
@@ -1,29 +1,15 @@
------------------------------------------------------------------------------
---
--- Module : Language.PureScript.Parser.Comments
--- Copyright : (c) Phil Freeman 2015
--- License : MIT
---
--- Maintainer : Phil Freeman <paf31@cantab.net>
--- Stability : experimental
--- Portability :
---
+{-# LANGUAGE TemplateHaskell #-}
+
-- |
-- Defines the types of source code comments
--
------------------------------------------------------------------------------
-
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE TemplateHaskell #-}
-
module Language.PureScript.Comments where
import Data.Aeson.TH
-import qualified Data.Data as D
data Comment
= LineComment String
| BlockComment String
- deriving (Show, Read, Eq, Ord, D.Data, D.Typeable)
+ deriving (Show, Read, Eq, Ord)
$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Comment)
diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs
index 1614449..573654a 100644
--- a/src/Language/PureScript/Constants.hs
+++ b/src/Language/PureScript/Constants.hs
@@ -1,18 +1,6 @@
------------------------------------------------------------------------------
---
--- Module : Language.PureScript.Constants
--- Copyright : (c) Phil Freeman 2013
--- License : MIT
---
--- Maintainer : Phil Freeman <paf31@cantab.net>
--- Stability : experimental
--- Portability :
---
-- |
-- Various constants which refer to things in the Prelude
--
------------------------------------------------------------------------------
-
module Language.PureScript.Constants where
-- Operators
@@ -20,59 +8,107 @@ module Language.PureScript.Constants where
($) :: String
($) = "$"
+apply :: String
+apply = "apply"
+
(#) :: String
(#) = "#"
+applyFlipped :: String
+applyFlipped = "applyFlipped"
+
(<>) :: String
(<>) = "<>"
(++) :: String
(++) = "++"
+append :: String
+append = "append"
+
(>>=) :: String
(>>=) = ">>="
+bind :: String
+bind = "bind"
+
(+) :: String
(+) = "+"
+add :: String
+add = "add"
+
(-) :: String
(-) = "-"
+sub :: String
+sub = "sub"
+
(*) :: String
(*) = "*"
+mul :: String
+mul = "mul"
+
(/) :: String
(/) = "/"
+div :: String
+div = "div"
+
(%) :: String
(%) = "%"
+mod :: String
+mod = "mod"
+
(<) :: String
(<) = "<"
+lessThan :: String
+lessThan = "lessThan"
+
(>) :: String
(>) = ">"
+greaterThan :: String
+greaterThan = "greaterThan"
+
(<=) :: String
(<=) = "<="
+lessThanOrEq :: String
+lessThanOrEq = "lessThanOrEq"
+
(>=) :: String
(>=) = ">="
+greaterThanOrEq :: String
+greaterThanOrEq = "greaterThanOrEq"
+
(==) :: String
(==) = "=="
+eq :: String
+eq = "eq"
+
(/=) :: String
(/=) = "/="
+notEq :: String
+notEq = "notEq"
+
(&&) :: String
(&&) = "&&"
+conj :: String
+conj = "conj"
+
(||) :: String
(||) = "||"
-bind :: String
-bind = "bind"
+disj :: String
+disj = "disj"
unsafeIndex :: String
unsafeIndex = "unsafeIndex"
@@ -92,6 +128,12 @@ unsafeIndex = "unsafeIndex"
compose :: String
compose = "compose"
+(>>>) :: String
+(>>>) = ">>>"
+
+composeFlipped :: String
+composeFlipped = "composeFlipped"
+
-- Functions
negate :: String
@@ -100,15 +142,6 @@ negate = "negate"
not :: String
not = "not"
-conj :: String
-conj = "conj"
-
-disj :: String
-disj = "disj"
-
-mod :: String
-mod = "mod"
-
shl :: String
shl = "shl"
@@ -211,12 +244,21 @@ moduloSemiringNumber = "moduloSemiringNumber"
moduloSemiringInt :: String
moduloSemiringInt = "moduloSemiringInt"
+ordBoolean :: String
+ordBoolean = "ordBoolean"
+
ordNumber :: String
ordNumber = "ordNumber"
ordInt :: String
ordInt = "ordInt"
+ordString :: String
+ordString = "ordString"
+
+ordChar :: String
+ordChar = "ordChar"
+
eqNumber :: String
eqNumber = "eqNumber"
@@ -226,6 +268,9 @@ eqInt = "eqInt"
eqString :: String
eqString = "eqString"
+eqChar :: String
+eqChar = "eqChar"
+
eqBoolean :: String
eqBoolean = "eqBoolean"
@@ -285,6 +330,39 @@ eff = "Control_Monad_Eff"
st :: String
st = "Control_Monad_ST"
+controlApplicative :: String
+controlApplicative = "Control_Applicative"
+
+controlSemigroupoid :: String
+controlSemigroupoid = "Control_Semigroupoid"
+
+controlBind :: String
+controlBind = "Control_Bind"
+
+dataBounded :: String
+dataBounded = "Data_Bounded"
+
+dataSemigroup :: String
+dataSemigroup = "Data_Semigroup"
+
+dataModuloSemiring :: String
+dataModuloSemiring = "Data_ModuloSemiring"
+
+dataBooleanAlgebra :: String
+dataBooleanAlgebra = "Data_BooleanAlgebra"
+
+dataEq :: String
+dataEq = "Data_Eq"
+
+dataOrd :: String
+dataOrd = "Data_Ord"
+
+dataSemiring :: String
+dataSemiring = "Data_Semiring"
+
+dataRing :: String
+dataRing = "Data_Ring"
+
dataFunction :: String
dataFunction = "Data_Function"
diff --git a/src/Language/PureScript/CoreFn/Binders.hs b/src/Language/PureScript/CoreFn/Binders.hs
index 77303a1..15b833d 100644
--- a/src/Language/PureScript/CoreFn/Binders.hs
+++ b/src/Language/PureScript/CoreFn/Binders.hs
@@ -1,24 +1,10 @@
------------------------------------------------------------------------------
---
--- Module : Language.PureScript.CoreFn.Binders
--- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
--- License : MIT
---
--- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>
--- Stability : experimental
--- Portability :
---
--- | The core functional representation for binders
---
------------------------------------------------------------------------------
-
-{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFunctor #-}
+-- |
+-- The core functional representation for binders
+--
module Language.PureScript.CoreFn.Binders where
-import qualified Data.Data as D
-
import Language.PureScript.CoreFn.Literals
import Language.PureScript.Names
@@ -39,10 +25,11 @@ data Binder a
--
| VarBinder a Ident
-- |
- -- A binder which matches a data constructor (type name, constructor name, binders)
+ -- A binder which matches a data constructor
--
- | ConstructorBinder a (Qualified ProperName) (Qualified ProperName) [Binder a]
+ | ConstructorBinder a (Qualified (ProperName 'TypeName)) (Qualified (ProperName 'ConstructorName)) [Binder a]
-- |
-- A binder which binds its input to an identifier
--
- | NamedBinder a Ident (Binder a) deriving (Show, Read, D.Data, D.Typeable, Functor)
+ | NamedBinder a Ident (Binder a)
+ deriving (Show, Read, Functor)
diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs
index f07e2c2..dbc9717 100644
--- a/src/Language/PureScript/CoreFn/Desugar.hs
+++ b/src/Language/PureScript/CoreFn/Desugar.hs
@@ -1,17 +1,3 @@
------------------------------------------------------------------------------
---
--- Module : Language.PureScript.CoreFn.Desugar
--- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
--- License : MIT (http://opensource.org/licenses/MIT)
---
--- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>
--- Stability : experimental
--- Portability :
---
--- | The AST -> CoreFn desugaring step
---
------------------------------------------------------------------------------
-
module Language.PureScript.CoreFn.Desugar (moduleToCoreFn) where
import Data.Function (on)
@@ -68,6 +54,8 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =
declToCoreFn ss _ (A.DataBindingGroupDeclaration ds) = concatMap (declToCoreFn ss []) ds
declToCoreFn ss com (A.ValueDeclaration name _ _ (Right e)) =
[NonRec name (exprToCoreFn ss com Nothing e)]
+ declToCoreFn ss com (A.FixityDeclaration _ name (Just alias)) =
+ [NonRec (Op name) (Var (ss, com, Nothing, getValueMeta alias) alias)]
declToCoreFn ss _ (A.BindingGroupDeclaration ds) =
[Rec $ map (\(name, _, e) -> (name, exprToCoreFn ss [] Nothing e)) ds]
declToCoreFn ss com (A.TypeClassDeclaration name _ supers members) =
@@ -182,7 +170,7 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =
-- |
-- Gets metadata for data constructors.
--
- getConstructorMeta :: Qualified ProperName -> Meta
+ getConstructorMeta :: Qualified (ProperName 'ConstructorName) -> Meta
getConstructorMeta ctor =
case lookupConstructor env ctor of
(Newtype, _, _, _) -> IsNewtype
@@ -190,9 +178,15 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =
let constructorType = if numConstructors (ctor, dc) == 1 then ProductType else SumType
in IsConstructor constructorType fields
where
- numConstructors :: (Qualified ProperName, (DataDeclType, ProperName, Type, [Ident])) -> Int
+
+ numConstructors
+ :: (Qualified (ProperName 'ConstructorName), (DataDeclType, ProperName 'TypeName, Type, [Ident]))
+ -> Int
numConstructors ty = length $ filter (((==) `on` typeConstructor) ty) $ M.toList $ dataConstructors env
- typeConstructor :: (Qualified ProperName, (DataDeclType, ProperName, Type, [Ident])) -> (ModuleName, ProperName)
+
+ typeConstructor
+ :: (Qualified (ProperName 'ConstructorName), (DataDeclType, ProperName 'TypeName, Type, [Ident]))
+ -> (ModuleName, ProperName 'TypeName)
typeConstructor (Qualified (Just mn') _, (_, tyCtor, _, _)) = (mn', tyCtor)
typeConstructor _ = internalError "Invalid argument to typeConstructor"
@@ -203,9 +197,14 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =
--
findQualModules :: [A.Declaration] -> [ModuleName]
findQualModules decls =
- let (f, _, _, _, _) = everythingOnValues (++) (const []) fqValues fqBinders (const []) (const [])
+ 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 _ = []
+
fqValues :: A.Expr -> [ModuleName]
fqValues (A.Var (Qualified (Just mn) _)) = [mn]
fqValues (A.Constructor (Qualified (Just mn) _)) = [mn]
@@ -219,7 +218,7 @@ findQualModules decls =
-- Desugars import declarations from AST to CoreFn representation.
--
importToCoreFn :: A.Declaration -> Maybe ModuleName
-importToCoreFn (A.ImportDeclaration name _ _) = Just name
+importToCoreFn (A.ImportDeclaration name _ _ _) = Just name
importToCoreFn (A.PositionedDeclaration _ _ d) = importToCoreFn d
importToCoreFn _ = Nothing
@@ -262,5 +261,5 @@ mkTypeClassConstructor ss com supers members =
-- |
-- Converts a ProperName to an Ident.
--
-properToIdent :: ProperName -> Ident
+properToIdent :: ProperName a -> Ident
properToIdent = Ident . runProperName
diff --git a/src/Language/PureScript/CoreFn/Expr.hs b/src/Language/PureScript/CoreFn/Expr.hs
index 39a1006..2445556 100644
--- a/src/Language/PureScript/CoreFn/Expr.hs
+++ b/src/Language/PureScript/CoreFn/Expr.hs
@@ -1,26 +1,12 @@
------------------------------------------------------------------------------
---
--- Module : Language.PureScript.CoreFn.Expr
--- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
--- License : MIT
---
--- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>
--- Stability : experimental
--- Portability :
---
--- | The core functional representation
---
------------------------------------------------------------------------------
-
-{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFunctor #-}
+-- |
+-- The core functional representation
+--
module Language.PureScript.CoreFn.Expr where
import Control.Arrow ((***))
-import qualified Data.Data as D
-
import Language.PureScript.CoreFn.Binders
import Language.PureScript.CoreFn.Literals
import Language.PureScript.Names
@@ -36,7 +22,7 @@ data Expr a
-- |
-- A data constructor (type name, constructor name, field names)
--
- | Constructor a ProperName ProperName [Ident]
+ | Constructor a (ProperName 'TypeName) (ProperName 'ConstructorName) [Ident]
-- |
-- A record property accessor
--
@@ -64,7 +50,8 @@ data Expr a
-- |
-- A let binding
--
- | Let a [Bind a] (Expr a) deriving (Show, Read, D.Data, D.Typeable, Functor)
+ | Let a [Bind a] (Expr a)
+ deriving (Show, Read, Functor)
-- |
-- A let or module binding.
@@ -77,7 +64,8 @@ data Bind a
-- |
-- Mutually recursive binding group for several values
--
- | Rec [(Ident, Expr a)] deriving (Show, Read, D.Data, D.Typeable, Functor)
+ | Rec [(Ident, Expr a)]
+ deriving (Show, Read, Functor)
-- |
-- A guard is just a boolean-valued expression that appears alongside a set of binders
@@ -96,7 +84,8 @@ data CaseAlternative a = CaseAlternative
-- The result expression or a collect of guarded expressions
--
, caseAlternativeResult :: Either [(Guard a, Expr a)] (Expr a)
- } deriving (Show, Read, D.Data, D.Typeable)
+ }
+ deriving (Show, Read)
instance Functor CaseAlternative where
diff --git a/src/Language/PureScript/CoreFn/Literals.hs b/src/Language/PureScript/CoreFn/Literals.hs
index 7f49c0c..cdc71b4 100644
--- a/src/Language/PureScript/CoreFn/Literals.hs
+++ b/src/Language/PureScript/CoreFn/Literals.hs
@@ -1,24 +1,10 @@
------------------------------------------------------------------------------
---
--- Module : Language.PureScript.CoreFn.Literals
--- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
--- License : MIT
---
--- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>
--- Stability : experimental
--- Portability :
---
--- | The core functional representation for literal values.
---
------------------------------------------------------------------------------
-
-{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFunctor #-}
+-- |
+-- The core functional representation for literal values.
+--
module Language.PureScript.CoreFn.Literals where
-import qualified Data.Data as D
-
-- |
-- Data type for literal values. Parameterised so it can be used for Exprs and
-- Binders.
@@ -47,4 +33,5 @@ data Literal a
-- |
-- An object literal
--
- | ObjectLiteral [(String, a)] deriving (Show, Read, D.Data, D.Typeable, Functor)
+ | ObjectLiteral [(String, a)]
+ deriving (Show, Read, Functor)
diff --git a/src/Language/PureScript/CoreFn/Meta.hs b/src/Language/PureScript/CoreFn/Meta.hs
index bbd2abe..91d77a0 100644
--- a/src/Language/PureScript/CoreFn/Meta.hs
+++ b/src/Language/PureScript/CoreFn/Meta.hs
@@ -1,23 +1,8 @@
------------------------------------------------------------------------------
---
--- Module : Language.PureScript.CoreFn.Meta
--- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
--- License : MIT
---
--- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>
--- Stability : experimental
--- Portability :
---
--- | Metadata annotations for core functional representation
+-- |
+-- Metadata annotations for core functional representation
--
------------------------------------------------------------------------------
-
-{-# LANGUAGE DeriveDataTypeable #-}
-
module Language.PureScript.CoreFn.Meta where
-import qualified Data.Data as D
-
import Language.PureScript.Names
-- |
@@ -39,7 +24,8 @@ data Meta
-- |
-- The contained reference is for a foreign member
--
- | IsForeign deriving (Show, Read, D.Data, D.Typeable)
+ | IsForeign
+ deriving (Show, Read)
-- |
-- Data constructor metadata
@@ -52,4 +38,5 @@ data ConstructorType
-- |
-- The constructor is for a type with multiple construcors
--
- | SumType deriving (Show, Read, D.Data, D.Typeable)
+ | SumType
+ deriving (Show, Read)
diff --git a/src/Language/PureScript/CoreFn/Traversals.hs b/src/Language/PureScript/CoreFn/Traversals.hs
index a579168..8b10f67 100644
--- a/src/Language/PureScript/CoreFn/Traversals.hs
+++ b/src/Language/PureScript/CoreFn/Traversals.hs
@@ -40,6 +40,7 @@ everywhereOnValues f g h = (f', g', h')
h' (LiteralBinder a b) = h (LiteralBinder a (handleLiteral h' b))
h' (NamedBinder a name b) = h (NamedBinder a name (h' b))
+ h' (ConstructorBinder a q1 q2 bs) = h (ConstructorBinder a q1 q2 (map h' bs))
h' b = h b
handleCaseAlternative ca =
diff --git a/src/Language/PureScript/Docs/AsMarkdown.hs b/src/Language/PureScript/Docs/AsMarkdown.hs
index 5476489..e0b6e4b 100644
--- a/src/Language/PureScript/Docs/AsMarkdown.hs
+++ b/src/Language/PureScript/Docs/AsMarkdown.hs
@@ -1,10 +1,19 @@
{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE FlexibleContexts #-}
-module Language.PureScript.Docs.AsMarkdown (
- renderModulesAsMarkdown
-) where
+module Language.PureScript.Docs.AsMarkdown
+ ( renderModulesAsMarkdown
+ , Docs
+ , runDocs
+ , modulesAsMarkdown
+ ) where
-import Control.Monad.Writer hiding (First)
+import Prelude ()
+import Prelude.Compat
+
+import Control.Monad (unless, zipWithM_)
+import Control.Monad.Writer (Writer, tell, execWriter)
+import Control.Monad.Error.Class (MonadError)
import Data.Foldable (for_)
import Data.List (partition)
@@ -19,9 +28,14 @@ import qualified Language.PureScript.Docs.Render as Render
-- Take a list of modules and render them all in order, returning a single
-- Markdown-formatted String.
--
-renderModulesAsMarkdown :: [P.Module] -> String
-renderModulesAsMarkdown =
- runDocs . modulesAsMarkdown . map Convert.convertModule
+renderModulesAsMarkdown ::
+ (Functor m, Applicative m,
+ MonadError P.MultipleErrors m) =>
+ P.Env ->
+ [P.Module] ->
+ m String
+renderModulesAsMarkdown env =
+ fmap (runDocs . modulesAsMarkdown) . Convert.convertModules env
modulesAsMarkdown :: [Module] -> Docs
modulesAsMarkdown = mapM_ moduleAsMarkdown
@@ -31,17 +45,23 @@ moduleAsMarkdown Module{..} = do
headerLevel 2 $ "Module " ++ modName
spacer
for_ modComments tell'
- mapM_ declAsMarkdown modDeclarations
+ mapM_ (declAsMarkdown modName) modDeclarations
spacer
+ for_ modReExports $ \(mn, decls) -> do
+ let modName' = P.runModuleName mn
+ headerLevel 3 $ "Re-exported from " ++ modName' ++ ":"
+ spacer
+ mapM_ (declAsMarkdown modName') decls
-declAsMarkdown :: Declaration -> Docs
-declAsMarkdown decl@Declaration{..} = do
+declAsMarkdown :: String -> Declaration -> Docs
+declAsMarkdown mn decl@Declaration{..} = do
+ let options = defaultRenderTypeOptions { currentModule = Just (P.moduleNameFromString mn) }
headerLevel 4 (ticks declTitle)
spacer
let (instances, children) = partition (isChildInstance . cdeclInfo) declChildren
fencedBlock $ do
- tell' (codeToString $ Render.renderDeclaration decl)
+ tell' (codeToString $ Render.renderDeclarationWithOptions options decl)
zipWithM_ (\f c -> tell' (childToString f c)) (First : repeat NotFirst) children
spacer
diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs
index b348291..9d34a45 100644
--- a/src/Language/PureScript/Docs/Convert.hs
+++ b/src/Language/PureScript/Docs/Convert.hs
@@ -2,225 +2,86 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE FlexibleContexts #-}
-- | Functions for converting PureScript ASTs into values of the data types
-- from Language.PureScript.Docs.
module Language.PureScript.Docs.Convert
- ( convertModule
+ ( convertModules
+ , convertModulesInPackage
, collectBookmarks
) where
-import Control.Monad
+import Prelude ()
+import Prelude.Compat
+
+import Control.Monad.Error.Class (MonadError)
+import Control.Arrow ((&&&))
import Control.Category ((>>>))
-import Data.Either
-import Data.Maybe (mapMaybe, isNothing)
-import Data.List (nub, isPrefixOf, isSuffixOf)
+import qualified Data.Map as Map
import qualified Language.PureScript as P
import Language.PureScript.Docs.Types
+import Language.PureScript.Docs.Convert.Single (convertSingleModule, collectBookmarks)
+import Language.PureScript.Docs.Convert.ReExports (updateReExports)
-- |
--- Convert a single Module.
+-- Like convertModules, except that it takes a list of modules, together with
+-- their dependency status, and discards dependency modules in the resulting
+-- documentation.
--
-convertModule :: P.Module -> Module
-convertModule m@(P.Module _ coms moduleName _ _) =
- Module (P.runModuleName moduleName) comments (declarations m)
+convertModulesInPackage ::
+ (Functor m, MonadError P.MultipleErrors m) =>
+ P.Env ->
+ [InPackage P.Module] ->
+ m [Module]
+convertModulesInPackage env modules =
+ go modules
where
- comments = convertComments coms
- declarations =
- P.exportedDeclarations
- >>> mapMaybe (\d -> getDeclarationTitle d >>= convertDeclaration d)
- >>> augmentDeclarations
- >>> map addDefaultFixity
+ localNames =
+ map (P.runModuleName . P.getModuleName) (takeLocals modules)
+ go =
+ map ignorePackage
+ >>> convertModules env
+ >>> fmap (filter ((`elem` localNames) . modName))
--- | The data type for an intermediate stage which we go through during
--- converting.
---
--- In the first pass, we take all top level declarations in the module, and
--- collect other information which will later be used to augment the top level
--- declarations. These two situation correspond to the Right and Left
--- constructors, respectively.
+-- |
+-- Convert a group of modules to the intermediate format, designed for
+-- producing documentation from. It is also necessary to pass an Env containing
+-- imports/exports information about the list of modules, which is needed for
+-- documenting re-exports.
--
--- In the second pass, we go over all of the Left values and augment the
--- relevant declarations, leaving only the augmented Right values.
+-- Preconditions:
--
--- Note that in the Left case, we provide a [String] as well as augment
--- information. The [String] value should be a list of titles of declarations
--- that the augmentation should apply to. For example, for a type instance
--- declaration, that would be any types or type classes mentioned in the
--- instance. For a fixity declaration, it would be just the relevant operator's
--- name.
-type IntermediateDeclaration
- = Either ([String], DeclarationAugment) Declaration
-
--- | Some data which will be used to augment a Declaration in the
--- output.
+-- * 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.
--
--- The AugmentChild constructor allows us to move all children under their
--- respective parents. It is only necessary for type instance declarations,
--- since they appear at the top level in the AST, and since they might need to
--- appear as children in two places (for example, if a data type defined in a
--- module is an instance of a type class also defined in that module).
+-- 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.
--
--- The AugmentFixity constructor allows us to augment operator definitions
--- with their associativity and precedence.
-data DeclarationAugment
- = AugmentChild ChildDeclaration
- | AugmentFixity P.Fixity
+convertModules ::
+ (Functor m, MonadError P.MultipleErrors m) =>
+ P.Env ->
+ [P.Module] ->
+ m [Module]
+convertModules env =
+ P.sortModules >>> fmap (convertSorted env . fst)
--- | Augment top-level declarations; the second pass. See the comments under
--- the type synonym IntermediateDeclaration for more information.
-augmentDeclarations :: [IntermediateDeclaration] -> [Declaration]
-augmentDeclarations (partitionEithers -> (augments, toplevels)) =
- foldl go toplevels augments
- where
- go ds (parentTitles, a) =
- map (\d ->
- if declTitle d `elem` parentTitles
- then augmentWith a d
- else d) ds
-
- augmentWith a d =
- case a of
- AugmentChild child ->
- d { declChildren = declChildren d ++ [child] }
- AugmentFixity fixity ->
- d { declFixity = Just fixity }
-
--- | Add the default operator fixity for operators which do not have associated
--- fixity declarations.
+-- |
+-- Convert a sorted list of modules.
--
--- TODO: This may no longer be necessary after issue 806 is resolved, hopefully
--- in 0.8.
-addDefaultFixity :: Declaration -> Declaration
-addDefaultFixity decl@Declaration{..}
- | isOp declTitle && isNothing declFixity =
- decl { declFixity = Just defaultFixity }
- | otherwise =
- decl
- where
- isOp :: String -> Bool
- isOp str = "(" `isPrefixOf` str && ")" `isSuffixOf` str
- defaultFixity = P.Fixity P.Infixl (-1)
-
-getDeclarationTitle :: P.Declaration -> Maybe String
-getDeclarationTitle (P.TypeDeclaration name _) = Just (P.showIdent name)
-getDeclarationTitle (P.ExternDeclaration name _) = Just (P.showIdent name)
-getDeclarationTitle (P.DataDeclaration _ name _ _) = Just (P.runProperName name)
-getDeclarationTitle (P.ExternDataDeclaration name _) = Just (P.runProperName name)
-getDeclarationTitle (P.TypeSynonymDeclaration name _ _) = Just (P.runProperName name)
-getDeclarationTitle (P.TypeClassDeclaration name _ _ _) = Just (P.runProperName name)
-getDeclarationTitle (P.TypeInstanceDeclaration name _ _ _ _) = Just (P.showIdent name)
-getDeclarationTitle (P.FixityDeclaration _ name) = Just ("(" ++ name ++ ")")
-getDeclarationTitle (P.PositionedDeclaration _ _ d) = getDeclarationTitle d
-getDeclarationTitle _ = Nothing
-
--- | Create a basic Declaration value.
-mkDeclaration :: String -> DeclarationInfo -> Declaration
-mkDeclaration title info =
- Declaration { declTitle = title
- , declComments = Nothing
- , declSourceSpan = Nothing
- , declChildren = []
- , declFixity = Nothing
- , declInfo = info
- }
-
-basicDeclaration :: String -> DeclarationInfo -> Maybe IntermediateDeclaration
-basicDeclaration title info = Just $ Right $ mkDeclaration title info
-
-convertDeclaration :: P.Declaration -> String -> Maybe IntermediateDeclaration
-convertDeclaration (P.TypeDeclaration _ ty) title =
- basicDeclaration title (ValueDeclaration ty)
-convertDeclaration (P.ExternDeclaration _ ty) title =
- basicDeclaration title (ValueDeclaration ty)
-convertDeclaration (P.DataDeclaration dtype _ args ctors) title =
- Just (Right (mkDeclaration title info) { declChildren = children })
- where
- info = DataDeclaration dtype args
- children = map convertCtor ctors
- convertCtor (ctor', tys) =
- ChildDeclaration (P.runProperName ctor') Nothing Nothing (ChildDataConstructor tys)
-convertDeclaration (P.ExternDataDeclaration _ kind') title =
- basicDeclaration title (ExternDataDeclaration kind')
-convertDeclaration (P.TypeSynonymDeclaration _ args ty) title =
- basicDeclaration title (TypeSynonymDeclaration args ty)
-convertDeclaration (P.TypeClassDeclaration _ args implies ds) title =
- Just (Right (mkDeclaration title info) { declChildren = children })
- where
- info = TypeClassDeclaration args implies
- children = map convertClassMember ds
- convertClassMember (P.PositionedDeclaration _ _ d) =
- convertClassMember d
- convertClassMember (P.TypeDeclaration ident' ty) =
- ChildDeclaration (P.showIdent ident') Nothing Nothing (ChildTypeClassMember ty)
- convertClassMember _ =
- P.internalError "convertDeclaration: Invalid argument to convertClassMember."
-convertDeclaration (P.TypeInstanceDeclaration _ constraints className tys _) title =
- Just (Left (classNameString : typeNameStrings, AugmentChild childDecl))
- where
- classNameString = unQual className
- typeNameStrings = nub (concatMap (P.everythingOnTypes (++) extractProperNames) tys)
- unQual x = let (P.Qualified _ y) = x in P.runProperName y
-
- extractProperNames (P.TypeConstructor n) = [unQual n]
- extractProperNames _ = []
-
- childDecl = ChildDeclaration title Nothing Nothing (ChildInstance constraints classApp)
- classApp = foldl P.TypeApp (P.TypeConstructor className) tys
-convertDeclaration (P.FixityDeclaration fixity _) title =
- Just (Left ([title], AugmentFixity fixity))
-convertDeclaration (P.PositionedDeclaration srcSpan com d') title =
- fmap (addComments . addSourceSpan) (convertDeclaration d' title)
- where
- addComments (Right d) =
- Right (d { declComments = convertComments com })
- addComments (Left augment) =
- Left (withAugmentChild (\d -> d { cdeclComments = convertComments com })
- augment)
-
- addSourceSpan (Right d) =
- Right (d { declSourceSpan = Just srcSpan })
- addSourceSpan (Left augment) =
- Left (withAugmentChild (\d -> d { cdeclSourceSpan = Just srcSpan })
- augment)
-
- withAugmentChild f (t, a) =
- case a of
- AugmentChild d -> (t, AugmentChild (f d))
- _ -> (t, a)
-convertDeclaration _ _ = Nothing
-
-convertComments :: [P.Comment] -> Maybe String
-convertComments cs = do
- let raw = concatMap toLines cs
- guard (all hasPipe raw && not (null raw))
- return (go raw)
- where
- go = unlines . map stripPipes
-
- toLines (P.LineComment s) = [s]
- toLines (P.BlockComment s) = lines s
-
- hasPipe s = case dropWhile (== ' ') s of { ('|':_) -> True; _ -> False }
-
- stripPipes = dropPipe . dropWhile (== ' ')
-
- dropPipe ('|':' ':s) = s
- dropPipe ('|':s) = s
- dropPipe s = s
-
--- | Go through a PureScript module and extract a list of Bookmarks; references
--- to data types or values, to be used as a kind of index. These are used for
--- generating links in the HTML documentation, for example.
-collectBookmarks :: InPackage P.Module -> [Bookmark]
-collectBookmarks (Local m) = map Local (collectBookmarks' m)
-collectBookmarks (FromDep pkg m) = map (FromDep pkg) (collectBookmarks' m)
-
-collectBookmarks' :: P.Module -> [(P.ModuleName, String)]
-collectBookmarks' m =
- map (P.getModuleName m, )
- (mapMaybe getDeclarationTitle
- (P.exportedDeclarations m))
+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)
diff --git a/src/Language/PureScript/Docs/Convert/ReExports.hs b/src/Language/PureScript/Docs/Convert/ReExports.hs
new file mode 100644
index 0000000..a42d0e6
--- /dev/null
+++ b/src/Language/PureScript/Docs/Convert/ReExports.hs
@@ -0,0 +1,486 @@
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+module Language.PureScript.Docs.Convert.ReExports
+ ( updateReExports
+ ) where
+
+import Prelude ()
+import Prelude.Compat
+
+import Control.Monad
+import Control.Monad.Trans.State.Strict (execState)
+import Control.Monad.State.Class (MonadState, gets, modify)
+import Control.Monad.Trans.Reader (runReaderT)
+import Control.Monad.Reader.Class (MonadReader, ask)
+import Control.Arrow ((&&&), first, second)
+import Data.Either
+import Data.Maybe (mapMaybe)
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Monoid ((<>))
+
+import qualified Language.PureScript as P
+
+import Language.PureScript.Docs.Types
+
+-- |
+-- Given:
+--
+-- * The Imports/Exports Env
+-- * An order to traverse the modules (which must be topological)
+-- * A map of modules, indexed by their names, which are assumed to not
+-- have their re-exports listed yet
+--
+-- This function adds all the missing re-exports.
+--
+updateReExports ::
+ P.Env ->
+ [P.ModuleName] ->
+ Map P.ModuleName Module ->
+ Map P.ModuleName Module
+updateReExports env order modules =
+ execState action modules
+ where
+ action =
+ void (traverse go order)
+
+ go mn = do
+ mdl <- lookup' mn
+ reExports <- getReExports env mn
+ let mdl' = mdl { modReExports = reExports }
+ modify (Map.insert mn mdl')
+
+ lookup' mn = do
+ v <- gets (Map.lookup mn)
+ case v of
+ Just v' ->
+ pure v'
+ Nothing ->
+ internalError ("Module missing: " ++ P.runModuleName mn)
+
+-- |
+-- Collect all of the re-exported declarations for a single module.
+--
+-- We require that modules have already been sorted (P.sortModules) in order to
+-- ensure that by the time we convert a particular module, all its dependencies
+-- have already been converted.
+--
+getReExports ::
+ (Functor m, Applicative m,
+ MonadState (Map P.ModuleName Module) m) =>
+ P.Env ->
+ P.ModuleName ->
+ m [(P.ModuleName, [Declaration])]
+getReExports env mn =
+ case Map.lookup mn env of
+ Nothing ->
+ internalError ("Module missing: " ++ P.runModuleName mn)
+ Just (_, imports, exports) -> do
+ allExports <- runReaderT (collectDeclarations imports exports) mn
+ pure (filter notLocal allExports)
+
+ where
+ notLocal = (/= mn) . fst
+
+-- |
+-- Assemble a list of declarations re-exported from a particular module, based
+-- on the Imports and Exports value for that module, and by extracting the
+-- declarations from the current state.
+--
+-- This function works by searching through the lists of exported declarations
+-- in the Exports, and looking them up in the associated Imports value to find
+-- the module they were imported from.
+--
+-- Additionally:
+--
+-- * Attempts to move re-exported type class members under their parent
+-- type classes, if possible, or otherwise, "promote" them from
+-- ChildDeclarations to proper Declarations.
+-- * Filters data declarations to ensure that only re-exported data
+-- constructors are listed.
+-- * Filters type class declarations to ensure that only re-exported type
+-- class members are listed.
+--
+collectDeclarations ::
+ (Functor m, Applicative m,
+ MonadState (Map P.ModuleName Module) m,
+ MonadReader P.ModuleName m) =>
+ P.Imports ->
+ P.Exports ->
+ m [(P.ModuleName, [Declaration])]
+collectDeclarations imports exports = do
+ valsAndMembers <- collect lookupValueDeclaration impVals expVals
+ typeClasses <- collect lookupTypeClassDeclaration impTCs expTCs
+ types <- collect lookupTypeDeclaration impTypes expTypes
+
+ (vals, classes) <- handleTypeClassMembers valsAndMembers typeClasses
+
+ let filteredTypes = filterDataConstructors expCtors types
+ let filteredClasses = filterTypeClassMembers (map fst expVals) classes
+
+ pure (Map.toList (Map.unionsWith (<>) [filteredTypes, filteredClasses, vals]))
+
+ where
+ collect lookup' imps exps = do
+ imps' <- traverse (findImport imps) exps
+ Map.fromListWith (<>) <$> traverse (uncurry lookup') imps'
+
+ expVals = P.exportedValues exports
+ impVals = concat (Map.elems (P.importedValues imports))
+
+ expTypes = map (first fst) (P.exportedTypes exports)
+ impTypes = concat (Map.elems (P.importedTypes imports))
+
+ expCtors = concatMap (snd . fst) (P.exportedTypes exports)
+
+ expTCs = P.exportedTypeClasses exports
+ impTCs = concat (Map.elems (P.importedTypeClasses imports))
+
+-- |
+-- Given a list of imported declarations (of a particular kind, ie. type, data,
+-- class, value, etc), and the name of an exported declaration of the same
+-- kind, together with the module it was originally defined in, return a tuple
+-- of:
+--
+-- * the module that exported declaration was imported from (note that
+-- this can be different from the module it was originally defined in, if
+-- it is a re-export),
+-- * that same declaration's name.
+--
+-- This function uses a type variable for names because we want to be able to
+-- instantiate @name@ as both 'P.Ident' and 'P.ProperName'.
+--
+findImport ::
+ (Show name, Eq name, Applicative m, MonadReader P.ModuleName m) =>
+ [(P.Qualified name, P.ModuleName)] ->
+ (name, P.ModuleName) ->
+ m (P.ModuleName, name)
+findImport imps (name, orig) =
+ let
+ matches (qual, mn) = P.disqualify qual == name && mn == orig
+ matching = filter matches imps
+ getQualified (P.Qualified mname _) = mname
+ in
+ case mapMaybe (getQualified . fst) 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.
+ (importedFrom:_) ->
+ pure (importedFrom, name)
+ [] ->
+ internalErrorInModule ("findImport: not found: " ++ show (name, orig))
+
+lookupValueDeclaration ::
+ (Applicative m,
+ MonadState (Map P.ModuleName Module) m,
+ MonadReader P.ModuleName m) =>
+ P.ModuleName ->
+ P.Ident ->
+ m (P.ModuleName, [Either (String, P.Constraint, ChildDeclaration) Declaration])
+lookupValueDeclaration importedFrom ident = do
+ decls <- lookupModuleDeclarations "lookupValueDeclaration" importedFrom
+ let
+ rs =
+ filter (\d -> declTitle d == P.showIdent ident
+ && (isValue d || isAlias d)) decls
+ errOther other =
+ internalErrorInModule
+ ("lookupValueDeclaration: unexpected result:\n" ++
+ "other: " ++ show other ++ "\n" ++
+ "ident: " ++ show ident ++ "\n" ++
+ "decls: " ++ show decls)
+
+ case rs of
+ [r] ->
+ pure (importedFrom, [Right r])
+ [] ->
+ -- It's a type class member.
+ -- Note that we need to filter based on the child declaration info using
+ -- `isTypeClassMember` anyway, because child declarations of type classes
+ -- are not necessarily members; they could also be instances.
+ let
+ allTypeClassChildDecls =
+ decls
+ |> mapMaybe (\d -> (d,) <$> typeClassConstraintFor d)
+ |> concatMap (\(d, constr) ->
+ map (declTitle d, constr,)
+ (declChildren d))
+
+ matchesIdent cdecl =
+ cdeclTitle cdecl == P.showIdent ident
+
+ matchesAndIsTypeClassMember =
+ uncurry (&&) . (matchesIdent &&& isTypeClassMember)
+
+ in
+ case filter (matchesAndIsTypeClassMember . thd) allTypeClassChildDecls of
+ [r'] ->
+ pure (importedFrom, [Left r'])
+ other ->
+ errOther other
+ other -> do
+ errOther other
+
+ where
+ thd :: (a, b, c) -> c
+ thd (_, _, x) = x
+
+-- |
+-- Extract a particular type declaration. For data declarations, constructors
+-- are only included in the output if they are listed in the arguments.
+--
+lookupTypeDeclaration ::
+ (Applicative m,
+ MonadState (Map P.ModuleName Module) m,
+ MonadReader P.ModuleName m) =>
+ P.ModuleName ->
+ P.ProperName 'P.TypeName ->
+ m (P.ModuleName, [Declaration])
+lookupTypeDeclaration importedFrom ty = do
+ decls <- lookupModuleDeclarations "lookupTypeDeclaration" importedFrom
+ let
+ ds = filter (\d -> declTitle d == P.runProperName ty && isType d) decls
+ case ds of
+ [d] ->
+ pure (importedFrom, [d])
+ other ->
+ internalErrorInModule
+ ("lookupTypeDeclaration: unexpected result: " ++ show other)
+
+lookupTypeClassDeclaration ::
+ (Applicative m,
+ MonadState (Map P.ModuleName Module) m,
+ MonadReader P.ModuleName m) =>
+ P.ModuleName ->
+ P.ProperName 'P.ClassName ->
+ m (P.ModuleName, [Declaration])
+lookupTypeClassDeclaration importedFrom tyClass = do
+ decls <- lookupModuleDeclarations "lookupTypeClassDeclaration" importedFrom
+ let
+ ds = filter (\d -> declTitle d == P.runProperName tyClass
+ && isTypeClass d)
+ decls
+ case ds of
+ [d] ->
+ pure (importedFrom, [d])
+ other ->
+ internalErrorInModule
+ ("lookupTypeClassDeclaration: unexpected result: "
+ ++ (unlines . map show) other)
+
+-- |
+-- Get the full list of declarations for a particular module out of the
+-- state, or raise an internal error if it is not there.
+--
+lookupModuleDeclarations ::
+ (Applicative m,
+ MonadState (Map P.ModuleName Module) m,
+ MonadReader P.ModuleName m) =>
+ String ->
+ P.ModuleName ->
+ m [Declaration]
+lookupModuleDeclarations definedIn moduleName = do
+ mmdl <- gets (Map.lookup moduleName)
+ case mmdl of
+ Nothing ->
+ internalErrorInModule
+ (definedIn ++ ": module missing: "
+ ++ P.runModuleName moduleName)
+ Just mdl ->
+ pure (allDeclarations mdl)
+
+handleTypeClassMembers ::
+ (Functor m, Applicative m,
+ MonadReader P.ModuleName m) =>
+ Map P.ModuleName [Either (String, P.Constraint, ChildDeclaration) Declaration] ->
+ Map P.ModuleName [Declaration] ->
+ m (Map P.ModuleName [Declaration], Map P.ModuleName [Declaration])
+handleTypeClassMembers valsAndMembers typeClasses =
+ let
+ moduleEnvs =
+ Map.unionWith (<>)
+ (fmap valsAndMembersToEnv valsAndMembers)
+ (fmap typeClassesToEnv typeClasses)
+ in
+ moduleEnvs
+ |> traverse handleEnv
+ |> fmap splitMap
+
+valsAndMembersToEnv ::
+ [Either (String, P.Constraint, ChildDeclaration) Declaration] -> TypeClassEnv
+valsAndMembersToEnv xs =
+ let (envUnhandledMembers, envValues) = partitionEithers xs
+ envTypeClasses = []
+ in TypeClassEnv{..}
+
+typeClassesToEnv :: [Declaration] -> TypeClassEnv
+typeClassesToEnv classes =
+ TypeClassEnv
+ { envUnhandledMembers = []
+ , envValues = []
+ , envTypeClasses = classes
+ }
+
+-- |
+-- An intermediate data type, used for either moving type class members under
+-- their parent type classes, or promoting them to normal Declaration values
+-- if their parent type class has not been re-exported.
+--
+data TypeClassEnv = TypeClassEnv
+ { -- |
+ -- Type class members which have not yet been dealt with. The String is the
+ -- name of the type class they belong to, and the constraint is used to
+ -- make sure that they have the correct type if they get promoted.
+ --
+ envUnhandledMembers :: [(String, P.Constraint, ChildDeclaration)]
+ -- |
+ -- A list of normal value declarations. Type class members will be added to
+ -- this list if their parent type class is not available.
+ --
+ , envValues :: [Declaration]
+ -- |
+ -- A list of type class declarations. Type class members will be added to
+ -- their parents in this list, if they exist.
+ --
+ , envTypeClasses :: [Declaration]
+ }
+ deriving (Show)
+
+instance Monoid TypeClassEnv where
+ mempty =
+ TypeClassEnv mempty mempty mempty
+ mappend (TypeClassEnv a1 b1 c1)
+ (TypeClassEnv a2 b2 c2) =
+ TypeClassEnv (a1 <> a2) (b1 <> b2) (c1 <> c2)
+
+-- |
+-- Take a TypeClassEnv and handle all of the type class members in it, either
+-- adding them to their parent classes, or promoting them to normal Declaration
+-- values.
+--
+-- Returns a tuple of (values, type classes).
+--
+handleEnv ::
+ (Functor m, Applicative m,
+ MonadReader P.ModuleName m) =>
+ TypeClassEnv ->
+ m ([Declaration], [Declaration])
+handleEnv TypeClassEnv{..} =
+ envUnhandledMembers
+ |> foldM go (envValues, mkMap envTypeClasses)
+ |> fmap (second Map.elems)
+
+ where
+ mkMap =
+ Map.fromList . map (declTitle &&& id)
+
+ go (values, tcs) (title, constraint, childDecl) =
+ case Map.lookup title tcs of
+ Just _ ->
+ -- Leave the state unchanged; if the type class is there, the child
+ -- will be too.
+ pure (values, tcs)
+ Nothing -> do
+ c <- promoteChild constraint childDecl
+ pure (c : values, tcs)
+
+ promoteChild constraint ChildDeclaration{..} =
+ case cdeclInfo of
+ ChildTypeClassMember typ ->
+ pure $ Declaration
+ { declTitle = cdeclTitle
+ , declComments = cdeclComments
+ , declSourceSpan = cdeclSourceSpan
+ , declChildren = []
+ , declFixity = Nothing
+ , declInfo = ValueDeclaration (addConstraint constraint typ)
+ }
+ _ ->
+ internalErrorInModule
+ ("handleEnv: Bad child declaration passed to promoteChild: "
+ ++ cdeclTitle)
+
+ addConstraint constraint =
+ P.quantify . P.moveQuantifiersToFront . P.ConstrainedType [constraint]
+
+splitMap :: (Ord k) => Map k (v1, v2) -> (Map k v1, Map k v2)
+splitMap = foldl go (Map.empty, Map.empty) . Map.toList
+ where
+ go (m1, m2) (k, (v1, v2)) =
+ (Map.insert k v1 m1, Map.insert k v2 m2)
+
+-- |
+-- Given a list of exported constructor names, remove any data constructor
+-- names in the provided Map of declarations which are not in the list.
+--
+filterDataConstructors ::
+ [P.ProperName 'P.ConstructorName] ->
+ Map P.ModuleName [Declaration] ->
+ Map P.ModuleName [Declaration]
+filterDataConstructors =
+ filterExportedChildren isDataConstructor P.runProperName
+
+-- |
+-- Given a list of exported type class member names, remove any data
+-- type class member names in the provided Map of declarations which are not in
+-- the list.
+--
+filterTypeClassMembers ::
+ [P.Ident] ->
+ Map P.ModuleName [Declaration] ->
+ Map P.ModuleName [Declaration]
+filterTypeClassMembers =
+ filterExportedChildren isTypeClassMember P.showIdent
+
+filterExportedChildren ::
+ (Functor f) =>
+ (ChildDeclaration -> Bool) ->
+ (name -> String) ->
+ [name] ->
+ f [Declaration] ->
+ f [Declaration]
+filterExportedChildren isTargetedKind runName expNames =
+ fmap filterDecls
+ where
+ filterDecls =
+ map (filterChildren (\c -> not (isTargetedKind c) ||
+ cdeclTitle c `elem` expNames'))
+
+ expNames' = map runName expNames
+
+allDeclarations :: Module -> [Declaration]
+allDeclarations Module{..} =
+ modDeclarations ++ concatMap snd modReExports
+
+(|>) :: a -> (a -> b) -> b
+x |> f = f x
+
+internalError :: String -> a
+internalError = P.internalError . ("Docs.Convert.ReExports: " ++)
+
+internalErrorInModule ::
+ (MonadReader P.ModuleName m) =>
+ String ->
+ m a
+internalErrorInModule msg = do
+ mn <- ask
+ internalError
+ ("while collecting re-exports for module: " ++ P.runModuleName mn ++
+ ", " ++ msg)
+
+-- |
+-- If the provided Declaration is a TypeClassDeclaration, construct an
+-- appropriate Constraint for use with the types of its members.
+--
+typeClassConstraintFor :: Declaration -> Maybe P.Constraint
+typeClassConstraintFor Declaration{..} =
+ case declInfo of
+ TypeClassDeclaration tyArgs _ ->
+ Just (P.Qualified Nothing (P.ProperName declTitle), mkConstraint tyArgs)
+ _ ->
+ Nothing
+ where
+ mkConstraint = map (P.TypeVar . fst)
diff --git a/src/Language/PureScript/Docs/Convert/Single.hs b/src/Language/PureScript/Docs/Convert/Single.hs
new file mode 100644
index 0000000..ceec9b3
--- /dev/null
+++ b/src/Language/PureScript/Docs/Convert/Single.hs
@@ -0,0 +1,232 @@
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+module Language.PureScript.Docs.Convert.Single
+ ( convertSingleModule
+ , collectBookmarks
+ ) where
+
+import Prelude ()
+import Prelude.Compat
+import Data.Maybe (catMaybes)
+
+import Control.Monad
+import Control.Category ((>>>))
+import Data.Maybe (mapMaybe, isNothing)
+import Data.Either
+import Data.List (nub, isPrefixOf, isSuffixOf)
+
+import qualified Language.PureScript as P
+
+import Language.PureScript.Docs.Types
+
+-- |
+-- Convert a single Module, but ignore re-exports; any re-exported types or
+-- values will not appear in the result.
+--
+convertSingleModule :: P.Module -> Module
+convertSingleModule m@(P.Module _ coms moduleName _ _) =
+ Module (P.runModuleName moduleName) comments (declarations m) []
+ where
+ comments = convertComments coms
+ declarations =
+ P.exportedDeclarations
+ >>> mapMaybe (\d -> getDeclarationTitle d >>= convertDeclaration d)
+ >>> augmentDeclarations
+ >>> map addDefaultFixity
+
+-- | The data type for an intermediate stage which we go through during
+-- converting.
+--
+-- In the first pass, we take all top level declarations in the module, and
+-- collect other information which will later be used to augment the top level
+-- declarations. These two situation correspond to the Right and Left
+-- constructors, respectively.
+--
+-- In the second pass, we go over all of the Left values and augment the
+-- relevant declarations, leaving only the augmented Right values.
+--
+-- Note that in the Left case, we provide a [String] as well as augment
+-- information. The [String] value should be a list of titles of declarations
+-- that the augmentation should apply to. For example, for a type instance
+-- declaration, that would be any types or type classes mentioned in the
+-- instance. For a fixity declaration, it would be just the relevant operator's
+-- name.
+type IntermediateDeclaration
+ = Either ([String], DeclarationAugment) Declaration
+
+-- | Some data which will be used to augment a Declaration in the
+-- output.
+--
+-- The AugmentChild constructor allows us to move all children under their
+-- respective parents. It is only necessary for type instance declarations,
+-- since they appear at the top level in the AST, and since they might need to
+-- appear as children in two places (for example, if a data type defined in a
+-- module is an instance of a type class also defined in that module).
+--
+-- The AugmentFixity constructor allows us to augment operator definitions
+-- with their associativity and precedence.
+data DeclarationAugment
+ = AugmentChild ChildDeclaration
+ | AugmentFixity P.Fixity
+
+-- | Augment top-level declarations; the second pass. See the comments under
+-- the type synonym IntermediateDeclaration for more information.
+augmentDeclarations :: [IntermediateDeclaration] -> [Declaration]
+augmentDeclarations (partitionEithers -> (augments, toplevels)) =
+ foldl go toplevels augments
+ where
+ go ds (parentTitles, a) =
+ map (\d ->
+ if declTitle d `elem` parentTitles
+ then augmentWith a d
+ else d) ds
+
+ augmentWith a d =
+ case a of
+ AugmentChild child ->
+ d { declChildren = declChildren d ++ [child] }
+ AugmentFixity fixity ->
+ d { declFixity = Just fixity }
+
+-- | Add the default operator fixity for operators which do not have associated
+-- fixity declarations.
+--
+-- TODO: This may no longer be necessary after issue 806 is resolved, hopefully
+-- in 0.9.
+addDefaultFixity :: Declaration -> Declaration
+addDefaultFixity decl@Declaration{..}
+ | isOp declTitle && isNothing declFixity =
+ decl { declFixity = Just defaultFixity }
+ | otherwise =
+ decl
+ where
+ isOp :: String -> Bool
+ isOp str = "(" `isPrefixOf` str && ")" `isSuffixOf` str
+ defaultFixity = P.Fixity P.Infixl (-1)
+
+getDeclarationTitle :: P.Declaration -> Maybe String
+getDeclarationTitle (P.TypeDeclaration name _) = Just (P.showIdent name)
+getDeclarationTitle (P.ExternDeclaration name _) = Just (P.showIdent name)
+getDeclarationTitle (P.DataDeclaration _ name _ _) = Just (P.runProperName name)
+getDeclarationTitle (P.ExternDataDeclaration name _) = Just (P.runProperName name)
+getDeclarationTitle (P.TypeSynonymDeclaration name _ _) = Just (P.runProperName name)
+getDeclarationTitle (P.TypeClassDeclaration name _ _ _) = Just (P.runProperName name)
+getDeclarationTitle (P.TypeInstanceDeclaration name _ _ _ _) = Just (P.showIdent name)
+getDeclarationTitle (P.FixityDeclaration _ name _) = Just ("(" ++ name ++ ")")
+getDeclarationTitle (P.PositionedDeclaration _ _ d) = getDeclarationTitle d
+getDeclarationTitle _ = Nothing
+
+-- | Create a basic Declaration value.
+mkDeclaration :: String -> DeclarationInfo -> Declaration
+mkDeclaration title info =
+ Declaration { declTitle = title
+ , declComments = Nothing
+ , declSourceSpan = Nothing
+ , declChildren = []
+ , declFixity = Nothing
+ , declInfo = info
+ }
+
+basicDeclaration :: String -> DeclarationInfo -> Maybe IntermediateDeclaration
+basicDeclaration title info = Just $ Right $ mkDeclaration title info
+
+convertDeclaration :: P.Declaration -> String -> Maybe IntermediateDeclaration
+convertDeclaration (P.TypeDeclaration _ ty) title =
+ basicDeclaration title (ValueDeclaration ty)
+convertDeclaration (P.ExternDeclaration _ ty) title =
+ basicDeclaration title (ValueDeclaration ty)
+convertDeclaration (P.DataDeclaration dtype _ args ctors) title =
+ Just (Right (mkDeclaration title info) { declChildren = children })
+ where
+ info = DataDeclaration dtype args
+ children = map convertCtor ctors
+ convertCtor (ctor', tys) =
+ ChildDeclaration (P.runProperName ctor') Nothing Nothing (ChildDataConstructor tys)
+convertDeclaration (P.ExternDataDeclaration _ kind') title =
+ basicDeclaration title (ExternDataDeclaration kind')
+convertDeclaration (P.TypeSynonymDeclaration _ args ty) title =
+ basicDeclaration title (TypeSynonymDeclaration args ty)
+convertDeclaration (P.TypeClassDeclaration _ args implies ds) title =
+ Just (Right (mkDeclaration title info) { declChildren = children })
+ where
+ info = TypeClassDeclaration args implies
+ children = map convertClassMember ds
+ convertClassMember (P.PositionedDeclaration _ _ d) =
+ convertClassMember d
+ convertClassMember (P.TypeDeclaration ident' ty) =
+ ChildDeclaration (P.showIdent ident') Nothing Nothing (ChildTypeClassMember ty)
+ convertClassMember _ =
+ P.internalError "convertDeclaration: Invalid argument to convertClassMember."
+convertDeclaration (P.TypeInstanceDeclaration _ constraints className tys _) title =
+ Just (Left (classNameString : typeNameStrings, AugmentChild childDecl))
+ where
+ classNameString = unQual className
+ typeNameStrings = nub (concatMap (P.everythingOnTypes (++) extractProperNames) tys)
+ unQual x = let (P.Qualified _ y) = x in P.runProperName y
+
+ extractProperNames (P.TypeConstructor n) = [unQual n]
+ extractProperNames _ = []
+
+ childDecl = ChildDeclaration title Nothing Nothing (ChildInstance constraints classApp)
+ classApp = foldl P.TypeApp (P.TypeConstructor (fmap P.coerceProperName className)) tys
+convertDeclaration (P.FixityDeclaration fixity _ Nothing) title =
+ Just (Left ([title], AugmentFixity fixity))
+convertDeclaration (P.FixityDeclaration fixity _ (Just alias)) title =
+ Just $ Right $ (mkDeclaration title (AliasDeclaration alias fixity)) { declFixity = Just fixity }
+convertDeclaration (P.PositionedDeclaration srcSpan com d') title =
+ fmap (addComments . addSourceSpan) (convertDeclaration d' title)
+ where
+ addComments (Right d) =
+ Right (d { declComments = convertComments com })
+ addComments (Left augment) =
+ Left (withAugmentChild (\d -> d { cdeclComments = convertComments com })
+ augment)
+
+ addSourceSpan (Right d) =
+ Right (d { declSourceSpan = Just srcSpan })
+ addSourceSpan (Left augment) =
+ Left (withAugmentChild (\d -> d { cdeclSourceSpan = Just srcSpan })
+ augment)
+
+ withAugmentChild f (t, a) =
+ case a of
+ AugmentChild d -> (t, AugmentChild (f d))
+ _ -> (t, a)
+convertDeclaration _ _ = Nothing
+
+convertComments :: [P.Comment] -> Maybe String
+convertComments cs = do
+ let raw = concatMap toLines cs
+ let docs = catMaybes (map stripPipe raw)
+ guard (not (null docs))
+ pure (unlines docs)
+
+ where
+ toLines (P.LineComment s) = [s]
+ toLines (P.BlockComment s) = lines s
+
+ stripPipe s' =
+ case dropWhile (== ' ') s' of
+ ('|':' ':s) ->
+ Just s
+ ('|':s) ->
+ Just s
+ _ ->
+ Nothing
+
+-- | Go through a PureScript module and extract a list of Bookmarks; references
+-- to data types or values, to be used as a kind of index. These are used for
+-- generating links in the HTML documentation, for example.
+collectBookmarks :: InPackage P.Module -> [Bookmark]
+collectBookmarks (Local m) = map Local (collectBookmarks' m)
+collectBookmarks (FromDep pkg m) = map (FromDep pkg) (collectBookmarks' m)
+
+collectBookmarks' :: P.Module -> [(P.ModuleName, String)]
+collectBookmarks' m =
+ map (P.getModuleName m, )
+ (mapMaybe getDeclarationTitle
+ (P.exportedDeclarations m))
diff --git a/src/Language/PureScript/Docs/ParseAndDesugar.hs b/src/Language/PureScript/Docs/ParseAndDesugar.hs
index a8b107f..2f0302a 100644
--- a/src/Language/PureScript/Docs/ParseAndDesugar.hs
+++ b/src/Language/PureScript/Docs/ParseAndDesugar.hs
@@ -1,8 +1,8 @@
{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE FlexibleContexts #-}
module Language.PureScript.Docs.ParseAndDesugar
( parseAndDesugar
- , ParseDesugarError(..)
) where
import Prelude ()
@@ -12,7 +12,6 @@ import qualified Data.Map as M
import Control.Arrow (first)
import Control.Monad
-import Control.Monad.Trans.Except
import Control.Monad.Writer.Strict (runWriterT)
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.IO.Class (MonadIO(..))
@@ -24,73 +23,69 @@ import qualified Language.PureScript.Constants as C
import Language.PureScript.Docs.Types
import Language.PureScript.Docs.Convert (collectBookmarks)
-data ParseDesugarError
- = ParseError P.MultipleErrors
- | SortModulesError P.MultipleErrors
- | DesugarError P.MultipleErrors
- deriving (Show)
-
-- |
-- Given:
--
-- * A list of local source files
-- * A list of source files from external dependencies, together with their
-- package names
--- * A callback, taking a list of bookmarks, and a list of desugared modules
--
-- This function does the following:
--
-- * Parse all of the input and dependency source files
--- * Partially desugar all of the resulting modules
+-- * 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
--- * Collect a list of desugared modules from just the input source files (not
--- dependencies)
--- * Call the callback with the bookmarks and desugared module list.
+-- * Return the desugared modules, the bookmarks, and the imports/exports
+-- Env (which is needed for producing documentation).
parseAndDesugar ::
+ (Functor m, Applicative m, MonadError P.MultipleErrors m, MonadIO m) =>
[FilePath]
-> [(PackageName, FilePath)]
- -> ([Bookmark] -> [P.Module] -> IO a)
- -> IO (Either ParseDesugarError a)
-parseAndDesugar inputFiles depsFiles callback = do
+ -> m ([InPackage P.Module], [Bookmark], P.Env)
+parseAndDesugar inputFiles depsFiles = do
inputFiles' <- traverse (parseAs Local) inputFiles
depsFiles' <- traverse (\(pkgName, f) -> parseAs (FromDep pkgName) f) depsFiles
- runExceptT $ do
- ms <- parseFiles (inputFiles' ++ depsFiles')
- ms' <- sortModules (map snd ms)
- (bs, ms'') <- desugarWithBookmarks ms ms'
- liftIO $ callback bs ms''
+ ms <- parseFiles (inputFiles' ++ depsFiles')
+ ms' <- sortModules (map snd ms)
+ desugarWithBookmarks ms ms'
parseFiles ::
+ (MonadError P.MultipleErrors m, MonadIO m) =>
[(FileInfo, FilePath)]
- -> ExceptT ParseDesugarError IO [(FileInfo, P.Module)]
+ -> m [(FileInfo, P.Module)]
parseFiles =
- throwLeft ParseError . P.parseModulesFromFiles fileInfoToString
+ throwLeft . P.parseModulesFromFiles fileInfoToString
sortModules ::
+ (Functor m, MonadError P.MultipleErrors m, MonadIO m) =>
[P.Module]
- -> ExceptT ParseDesugarError IO [P.Module]
+ -> m [P.Module]
sortModules =
- fmap fst . throwLeft SortModulesError . sortModules' . map importPrim
+ 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) =>
[(FileInfo, P.Module)]
-> [P.Module]
- -> ExceptT ParseDesugarError IO ([Bookmark], [P.Module])
+ -> m ([InPackage P.Module], [Bookmark], P.Env)
desugarWithBookmarks msInfo msSorted = do
- msDesugared <- throwLeft DesugarError (desugar msSorted)
+ (env, msDesugared) <- throwLeft (desugar msSorted)
let msDeps = getDepsModuleNames (map (\(fp, m) -> (,m) <$> fp) msInfo)
msPackages = map (addPackage msDeps) msDesugared
bookmarks = concatMap collectBookmarks msPackages
- return (bookmarks, takeLocals msPackages)
+ return (msPackages, bookmarks, env)
-throwLeft :: (MonadError e m) => (l -> e) -> Either l r -> m r
-throwLeft f = either (throwError . f) return
+throwLeft :: (MonadError l m) => Either l r -> m r
+throwLeft = either throwError return
-- | Specifies whether a PureScript source file is considered as:
--
@@ -105,30 +100,27 @@ fileInfoToString :: FileInfo -> FilePath
fileInfoToString (Local fn) = fn
fileInfoToString (FromDep _ fn) = fn
-addDefaultImport :: P.ModuleName -> P.Module -> P.Module
-addDefaultImport toImport m@(P.Module ss coms mn decls exps) =
- if isExistingImport `any` decls || mn == toImport then m
- else P.Module ss coms mn (P.ImportDeclaration toImport P.Implicit Nothing : decls) exps
- where
- isExistingImport (P.ImportDeclaration mn' _ _) | mn' == toImport = True
- isExistingImport (P.PositionedDeclaration _ _ d) = isExistingImport d
- isExistingImport _ = False
-
importPrim :: P.Module -> P.Module
-importPrim = addDefaultImport (P.ModuleName [P.ProperName C.prim])
+importPrim = P.addDefaultImport (P.ModuleName [P.ProperName C.prim])
-desugar :: [P.Module] -> Either P.MultipleErrors [P.Module]
+desugar ::
+ (Functor m, Applicative m, MonadError P.MultipleErrors m) =>
+ [P.Module]
+ -> m (P.Env, [P.Module])
desugar = P.evalSupplyT 0 . desugar'
where
- desugar' :: [P.Module] -> P.SupplyT (Either P.MultipleErrors) [P.Module]
- desugar' = traverse P.desugarDoModule >=> P.desugarCasesModule >=> ignoreWarnings . P.desugarImports []
+ 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'
-parseAs :: (FilePath -> a) -> FilePath -> IO (a, String)
-parseAs g = fmap (first g) . parseFile
+parseAs :: (Functor m, MonadIO m) => (FilePath -> a) -> FilePath -> m (a, String)
+parseAs g = fmap (first g) . liftIO . parseFile
getDepsModuleNames :: [InPackage (FilePath, P.Module)] -> M.Map P.ModuleName PackageName
getDepsModuleNames = foldl go M.empty
diff --git a/src/Language/PureScript/Docs/Render.hs b/src/Language/PureScript/Docs/Render.hs
index 1177391..d954fcc 100644
--- a/src/Language/PureScript/Docs/Render.hs
+++ b/src/Language/PureScript/Docs/Render.hs
@@ -49,7 +49,7 @@ renderDeclarationWithOptions opts Declaration{..} =
[ keywordClass ]
++ maybeToList superclasses
++ [renderType' (typeApp declTitle args)]
- ++ [keywordWhere | any (isTypeClassMember . cdeclInfo) declChildren]
+ ++ [keywordWhere | any isTypeClassMember declChildren]
where
superclasses
@@ -58,11 +58,19 @@ renderDeclarationWithOptions opts Declaration{..} =
syntax "("
<> mintersperse (syntax "," <> sp) (map renderConstraint implies)
<> syntax ")" <> sp <> syntax "<="
+ AliasDeclaration for (P.Fixity associativity precedence) ->
+ [ keywordFixity associativity
+ , syntax $ show precedence
+ , ident $ P.showQualified P.runIdent $ dequalifyCurrentModule for
+ , keyword "as"
+ , ident . tail . init $ declTitle
+ ]
- isTypeClassMember (ChildTypeClassMember _) = True
- isTypeClassMember _ = False
where
renderType' = renderTypeWithOptions opts
+ dequalifyCurrentModule (P.Qualified mn a)
+ | mn == currentModule opts = P.Qualified Nothing a
+ | otherwise = P.Qualified mn a
renderChildDeclaration :: ChildDeclaration -> RenderedCode
renderChildDeclaration = renderChildDeclarationWithOptions defaultRenderTypeOptions
@@ -86,12 +94,12 @@ renderChildDeclarationWithOptions opts ChildDeclaration{..} =
where
renderType' = renderTypeWithOptions opts
-renderConstraint :: (P.Qualified P.ProperName, [P.Type]) -> RenderedCode
+renderConstraint :: P.Constraint -> RenderedCode
renderConstraint = renderConstraintWithOptions defaultRenderTypeOptions
-renderConstraintWithOptions :: RenderTypeOptions -> (P.Qualified P.ProperName, [P.Type]) -> RenderedCode
+renderConstraintWithOptions :: RenderTypeOptions -> P.Constraint -> RenderedCode
renderConstraintWithOptions opts (pn, tys) =
- renderTypeWithOptions opts $ foldl P.TypeApp (P.TypeConstructor pn) tys
+ renderTypeWithOptions opts $ foldl P.TypeApp (P.TypeConstructor (fmap P.coerceProperName pn)) tys
renderConstraints :: [P.Constraint] -> Maybe RenderedCode
renderConstraints = renderConstraintsWithOptions defaultRenderTypeOptions
@@ -108,7 +116,7 @@ renderConstraintsWithOptions opts constraints
mintersperse (syntax "," <> sp)
(map (renderConstraintWithOptions opts) constraints)
-notQualified :: String -> P.Qualified P.ProperName
+notQualified :: String -> P.Qualified (P.ProperName a)
notQualified = P.Qualified Nothing . P.ProperName
typeApp :: String -> [(String, Maybe P.Kind)] -> P.Type
diff --git a/src/Language/PureScript/Docs/RenderedCode/Render.hs b/src/Language/PureScript/Docs/RenderedCode/Render.hs
index 1d6766e..5b04b13 100644
--- a/src/Language/PureScript/Docs/RenderedCode/Render.hs
+++ b/src/Language/PureScript/Docs/RenderedCode/Render.hs
@@ -9,7 +9,7 @@ module Language.PureScript.Docs.RenderedCode.Render (
defaultRenderTypeOptions,
renderTypeWithOptions
) where
-
+
import Prelude ()
import Prelude.Compat
@@ -52,9 +52,10 @@ typeLiterals = mkPattern match
]
where
constraints = mintersperse (syntax "," <> sp) (map renderDep deps)
+ renderDep :: Constraint -> RenderedCode
renderDep (pn, tys) =
- let instApp = foldl TypeApp (TypeConstructor pn) tys
- in renderType instApp
+ let instApp = foldl TypeApp (TypeConstructor (fmap coerceProperName pn)) tys
+ in renderType instApp
match REmpty =
Just (syntax "()")
match row@RCons{} =
@@ -172,10 +173,15 @@ renderType = renderTypeWithOptions defaultRenderTypeOptions
data RenderTypeOptions = RenderTypeOptions
{ prettyPrintObjects :: Bool
+ , currentModule :: Maybe ModuleName
}
defaultRenderTypeOptions :: RenderTypeOptions
-defaultRenderTypeOptions = RenderTypeOptions { prettyPrintObjects = True }
+defaultRenderTypeOptions =
+ RenderTypeOptions
+ { prettyPrintObjects = True
+ , currentModule = Nothing
+ }
renderTypeWithOptions :: RenderTypeOptions -> Type -> RenderedCode
renderTypeWithOptions opts =
diff --git a/src/Language/PureScript/Docs/RenderedCode/Types.hs b/src/Language/PureScript/Docs/RenderedCode/Types.hs
index 8ae8760..307663a 100644
--- a/src/Language/PureScript/Docs/RenderedCode/Types.hs
+++ b/src/Language/PureScript/Docs/RenderedCode/Types.hs
@@ -28,6 +28,7 @@ module Language.PureScript.Docs.RenderedCode.Types
, keywordClass
, keywordInstance
, keywordWhere
+ , keywordFixity
) where
import Prelude ()
@@ -189,3 +190,8 @@ keywordInstance = keyword "instance"
keywordWhere :: RenderedCode
keywordWhere = keyword "where"
+
+keywordFixity :: P.Associativity -> RenderedCode
+keywordFixity P.Infixl = keyword "infixl"
+keywordFixity P.Infixr = keyword "infixr"
+keywordFixity P.Infix = keyword "infix"
diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs
index 15ec473..8d19cfb 100644
--- a/src/Language/PureScript/Docs/Types.hs
+++ b/src/Language/PureScript/Docs/Types.hs
@@ -76,6 +76,8 @@ data Module = Module
{ modName :: String
, modComments :: Maybe String
, modDeclarations :: [Declaration]
+ -- Re-exported values from other modules
+ , modReExports :: [(P.ModuleName, [Declaration])]
}
deriving (Show, Eq, Ord)
@@ -84,7 +86,7 @@ data Declaration = Declaration
, declComments :: Maybe String
, declSourceSpan :: Maybe P.SourceSpan
, declChildren :: [ChildDeclaration]
- , declFixity :: Maybe P.Fixity
+ , declFixity :: Maybe P.Fixity -- TODO: remove in 0.9
, declInfo :: DeclarationInfo
}
deriving (Show, Eq, Ord)
@@ -126,6 +128,12 @@ data DeclarationInfo
-- members are represented as child declarations.
--
| TypeClassDeclaration [(String, Maybe P.Kind)] [P.Constraint]
+
+ -- |
+ -- An operator alias declaration, with the member the alias is for and the
+ -- operator's fixity.
+ --
+ | AliasDeclaration (P.Qualified P.Ident) P.Fixity
deriving (Show, Eq, Ord)
declInfoToString :: DeclarationInfo -> String
@@ -134,6 +142,38 @@ declInfoToString (DataDeclaration _ _) = "data"
declInfoToString (ExternDataDeclaration _) = "externData"
declInfoToString (TypeSynonymDeclaration _ _) = "typeSynonym"
declInfoToString (TypeClassDeclaration _ _) = "typeClass"
+declInfoToString (AliasDeclaration _ _) = "alias"
+
+isTypeClass :: Declaration -> Bool
+isTypeClass Declaration{..} =
+ case declInfo of
+ TypeClassDeclaration{} -> True
+ _ -> False
+
+isValue :: Declaration -> Bool
+isValue Declaration{..} =
+ case declInfo of
+ ValueDeclaration{} -> True
+ _ -> False
+
+isType :: Declaration -> Bool
+isType Declaration{..} =
+ case declInfo of
+ TypeSynonymDeclaration{} -> True
+ DataDeclaration{} -> True
+ ExternDataDeclaration{} -> True
+ _ -> False
+
+isAlias :: Declaration -> Bool
+isAlias Declaration{..} =
+ case declInfo of
+ AliasDeclaration{} -> True
+ _ -> False
+
+-- | Discard any children which do not satisfy the given predicate.
+filterChildren :: (ChildDeclaration -> Bool) -> Declaration -> Declaration
+filterChildren p decl =
+ decl { declChildren = filter p (declChildren decl) }
data ChildDeclaration = ChildDeclaration
{ cdeclTitle :: String
@@ -167,6 +207,18 @@ childDeclInfoToString (ChildInstance _ _) = "instance"
childDeclInfoToString (ChildDataConstructor _) = "dataConstructor"
childDeclInfoToString (ChildTypeClassMember _) = "typeClassMember"
+isTypeClassMember :: ChildDeclaration -> Bool
+isTypeClassMember ChildDeclaration{..} =
+ case cdeclInfo of
+ ChildTypeClassMember{} -> True
+ _ -> False
+
+isDataConstructor :: ChildDeclaration -> Bool
+isDataConstructor ChildDeclaration{..} =
+ case cdeclInfo of
+ ChildDataConstructor{} -> True
+ _ -> False
+
newtype GithubUser
= GithubUser { runGithubUser :: String }
deriving (Show, Eq, Ord)
@@ -297,6 +349,7 @@ asModule =
Module <$> key "name" asString
<*> key "comments" (perhaps asString)
<*> key "declarations" (eachInArray asDeclaration)
+ <*> key "reExports" (eachInArray asReExport)
asDeclaration :: Parse PackageError Declaration
asDeclaration =
@@ -307,9 +360,23 @@ asDeclaration =
<*> key "fixity" (perhaps asFixity)
<*> key "info" asDeclarationInfo
+asReExport :: Parse PackageError (P.ModuleName, [Declaration])
+asReExport =
+ (,) <$> key "moduleName" fromAesonParser
+ <*> key "declarations" (eachInArray asDeclaration)
+
+asInPackage :: Parse BowerError a -> Parse BowerError (InPackage a)
+asInPackage inner =
+ build <$> key "package" (perhaps (withString parsePackageName))
+ <*> key "item" inner
+ where
+ build Nothing = Local
+ build (Just pn) = FromDep pn
+
asFixity :: Parse PackageError P.Fixity
-asFixity = P.Fixity <$> key "associativity" asAssociativity
- <*> key "precedence" asIntegral
+asFixity =
+ P.Fixity <$> key "associativity" asAssociativity
+ <*> key "precedence" asIntegral
parseAssociativity :: String -> Maybe P.Associativity
parseAssociativity str = case str of
@@ -338,6 +405,9 @@ asDeclarationInfo = do
"typeClass" ->
TypeClassDeclaration <$> key "arguments" asTypeArguments
<*> key "superclasses" (eachInArray asConstraint)
+ "alias" ->
+ AliasDeclaration <$> key "for" asQualifiedIdent
+ <*> key "fixity" asFixity
other ->
throwCustomError (InvalidDeclarationType other)
@@ -388,20 +458,19 @@ asConstraint :: Parse PackageError P.Constraint
asConstraint = (,) <$> nth 0 asQualifiedProperName
<*> nth 1 (eachInArray asType)
-asQualifiedProperName :: Parse e (P.Qualified P.ProperName)
+asQualifiedProperName :: Parse e (P.Qualified (P.ProperName a))
asQualifiedProperName = fromAesonParser
+asQualifiedIdent :: Parse e (P.Qualified P.Ident)
+asQualifiedIdent = fromAesonParser
+
asBookmarks :: Parse BowerError [Bookmark]
asBookmarks = eachInArray asBookmark
asBookmark :: Parse BowerError Bookmark
asBookmark =
- build <$> key "package" (perhaps (withString parsePackageName))
- <*> key "item" ((,) <$> nth 0 (P.moduleNameFromString <$> asString)
- <*> nth 1 asString)
- where
- build Nothing = Local
- build (Just pn) = FromDep pn
+ asInPackage ((,) <$> nth 0 (P.moduleNameFromString <$> asString)
+ <*> nth 1 asString)
asResolvedDependencies :: Parse PackageError [(PackageName, Version)]
asResolvedDependencies =
@@ -446,7 +515,12 @@ instance A.ToJSON Module where
A.object [ "name" .= modName
, "comments" .= modComments
, "declarations" .= modDeclarations
+ , "reExports" .= map toObj modReExports
]
+ where
+ toObj (mn, decls) = A.object [ "moduleName" .= mn
+ , "declarations" .= decls
+ ]
instance A.ToJSON Declaration where
toJSON Declaration{..} =
@@ -475,6 +549,7 @@ instance A.ToJSON DeclarationInfo where
ExternDataDeclaration kind -> ["kind" .= kind]
TypeSynonymDeclaration args ty -> ["arguments" .= args, "type" .= ty]
TypeClassDeclaration args super -> ["arguments" .= args, "superclasses" .= super]
+ AliasDeclaration for fixity -> ["for" .= for, "fixity" .= fixity]
instance A.ToJSON ChildDeclarationInfo where
toJSON info = A.object $ "declType" .= childDeclInfoToString info : props
diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs
index 7e54c03..56f48f0 100644
--- a/src/Language/PureScript/Environment.hs
+++ b/src/Language/PureScript/Environment.hs
@@ -1,24 +1,8 @@
------------------------------------------------------------------------------
---
--- Module : Language.PureScript.Environment
--- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
--- License : MIT
---
--- Maintainer : Phil Freeman <paf31@cantab.net>
--- Stability : experimental
--- Portability :
---
--- |
---
------------------------------------------------------------------------------
-
-{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Language.PureScript.Environment where
-import Data.Data
import Data.Maybe (fromMaybe)
import Data.Aeson.TH
import qualified Data.Map as M
@@ -43,30 +27,30 @@ data Environment = Environment {
-- |
-- Type names currently in scope
--
- , types :: M.Map (Qualified ProperName) (Kind, TypeKind)
+ , types :: M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind)
-- |
-- Data constructors currently in scope, along with their associated type
-- constructor name, argument types and return type.
- , dataConstructors :: M.Map (Qualified ProperName) (DataDeclType, ProperName, Type, [Ident])
+ , dataConstructors :: M.Map (Qualified (ProperName 'ConstructorName)) (DataDeclType, ProperName 'TypeName, Type, [Ident])
-- |
-- Type synonyms currently in scope
--
- , typeSynonyms :: M.Map (Qualified ProperName) ([(String, Maybe Kind)], Type)
+ , typeSynonyms :: M.Map (Qualified (ProperName 'TypeName)) ([(String, Maybe Kind)], Type)
-- |
-- Available type class dictionaries
--
- , typeClassDictionaries :: M.Map (Maybe ModuleName) (M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope))
+ , typeClassDictionaries :: M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope))
-- |
-- Type classes
--
- , typeClasses :: M.Map (Qualified ProperName) ([(String, Maybe Kind)], [(Ident, Type)], [Constraint])
+ , typeClasses :: M.Map (Qualified (ProperName 'ClassName)) ([(String, Maybe Kind)], [(Ident, Type)], [Constraint])
} deriving (Show, Read)
-- |
-- The initial environment with no values and only the default javascript types defined
--
initEnvironment :: Environment
-initEnvironment = Environment M.empty primTypes M.empty M.empty M.empty M.empty
+initEnvironment = Environment M.empty primTypes M.empty M.empty M.empty primClasses
-- |
-- The visibility of a name in scope
@@ -98,7 +82,8 @@ data NameKind
-- |
-- A name for member introduced by foreign import
--
- | External deriving (Show, Read, Eq, Data, Typeable)
+ | External
+ deriving (Show, Read, Eq)
-- |
-- The kinds of a type
@@ -107,7 +92,7 @@ data TypeKind
-- |
-- Data type
--
- = DataType [(String, Maybe Kind)] [(ProperName, [Type])]
+ = DataType [(String, Maybe Kind)] [(ProperName 'ConstructorName, [Type])]
-- |
-- Type synonym
--
@@ -124,7 +109,7 @@ data TypeKind
-- A scoped type variable
--
| ScopedTypeVar
- deriving (Show, Read, Eq, Data, Typeable)
+ deriving (Show, Read, Eq)
-- |
-- The type ('data' or 'newtype') of a data type declaration
@@ -137,7 +122,8 @@ data DataDeclType
-- |
-- A newtype constructor
--
- | Newtype deriving (Show, Read, Eq, Ord, Data, Typeable)
+ | Newtype
+ deriving (Show, Read, Eq, Ord)
showDataDeclType :: DataDeclType -> String
showDataDeclType Data = "data"
@@ -156,7 +142,7 @@ instance A.FromJSON DataDeclType where
-- |
-- Construct a ProperName in the Prim module
--
-primName :: String -> Qualified ProperName
+primName :: String -> Qualified (ProperName a)
primName = Qualified (Just $ ModuleName [ProperName C.prim]) . ProperName
-- |
@@ -236,29 +222,44 @@ function :: Type -> Type -> Type
function t1 = TypeApp (TypeApp tyFunction t1)
-- |
--- The primitive types in the external javascript environment with their associated kinds.
+-- The primitive types in the external javascript environment with their
+-- associated kinds. There is also a pseudo `Partial` type that corresponds to
+-- the class with the same name.
+--
+primTypes :: M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind)
+primTypes =
+ M.fromList
+ [ (primName "Function", (FunKind Star (FunKind Star Star), ExternData))
+ , (primName "Array", (FunKind Star Star, ExternData))
+ , (primName "Object", (FunKind (Row Star) Star, ExternData))
+ , (primName "String", (Star, ExternData))
+ , (primName "Char", (Star, ExternData))
+ , (primName "Number", (Star, ExternData))
+ , (primName "Int", (Star, ExternData))
+ , (primName "Boolean", (Star, ExternData))
+ , (primName "Partial", (Star, ExternData))
+ ]
+
+-- |
+-- The primitive class map. This just contains to `Partial` class, used as a
+-- kind of magic constraint for partial functions.
--
-primTypes :: M.Map (Qualified ProperName) (Kind, TypeKind)
-primTypes = M.fromList [ (primName "Function" , (FunKind Star (FunKind Star Star), ExternData))
- , (primName "Array" , (FunKind Star Star, ExternData))
- , (primName "Object" , (FunKind (Row Star) Star, ExternData))
- , (primName "String" , (Star, ExternData))
- , (primName "Char" , (Star, ExternData))
- , (primName "Number" , (Star, ExternData))
- , (primName "Int" , (Star, ExternData))
- , (primName "Boolean" , (Star, ExternData)) ]
+primClasses :: M.Map (Qualified (ProperName 'ClassName)) ([(String, Maybe Kind)], [(Ident, Type)], [Constraint])
+primClasses =
+ M.fromList
+ [ (primName "Partial", ([], [], [])) ]
-- |
-- Finds information about data constructors from the current environment.
--
-lookupConstructor :: Environment -> Qualified ProperName -> (DataDeclType, ProperName, Type, [Ident])
+lookupConstructor :: Environment -> Qualified (ProperName 'ConstructorName) -> (DataDeclType, ProperName 'TypeName, Type, [Ident])
lookupConstructor env ctor =
fromMaybe (internalError "Data constructor not found") $ ctor `M.lookup` dataConstructors env
-- |
-- Checks whether a data constructor is for a newtype.
--
-isNewtypeConstructor :: Environment -> Qualified ProperName -> Bool
+isNewtypeConstructor :: Environment -> Qualified (ProperName 'ConstructorName) -> Bool
isNewtypeConstructor e ctor = case lookupConstructor e ctor of
(Newtype, _, _, _) -> True
(Data, _, _, _) -> False
diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs
index 5c675ed..6487057 100644
--- a/src/Language/PureScript/Errors.hs
+++ b/src/Language/PureScript/Errors.hs
@@ -1,17 +1,3 @@
------------------------------------------------------------------------------
---
--- Module : Language.PureScript.Error
--- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
--- License : MIT (http://opensource.org/licenses/MIT)
---
--- Maintainer : Phil Freeman <paf31@cantab.net>
--- Stability : experimental
--- Portability :
---
--- |
---
------------------------------------------------------------------------------
-
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
@@ -21,9 +7,10 @@ module Language.PureScript.Errors where
import Prelude ()
import Prelude.Compat
+import Data.Ord (comparing)
+import Data.Char (isSpace)
import Data.Either (lefts, rights)
-import Data.List (intercalate, transpose, nub, nubBy)
-import Data.Function (on)
+import Data.List (intercalate, transpose, nub, nubBy, sortBy)
import Data.Foldable (fold)
import qualified Data.Map as M
@@ -32,7 +19,7 @@ import Control.Monad
import Control.Monad.Writer
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.Trans.State.Lazy
-import Control.Arrow (first)
+import Control.Arrow ((&&&))
import Language.PureScript.Crash
import Language.PureScript.AST
@@ -66,64 +53,63 @@ data SimpleErrorMessage
| RedefinedIdent Ident
| OverlappingNamesInLet
| UnknownModule ModuleName
- | UnknownType (Qualified ProperName)
- | UnknownTypeClass (Qualified ProperName)
+ | UnknownType (Qualified (ProperName 'TypeName))
+ | UnknownTypeClass (Qualified (ProperName 'ClassName))
| UnknownValue (Qualified Ident)
- | UnknownDataConstructor (Qualified ProperName) (Maybe (Qualified ProperName))
- | UnknownTypeConstructor (Qualified ProperName)
- | UnknownImportType ModuleName ProperName
- | UnknownExportType ProperName
- | UnknownImportTypeClass ModuleName ProperName
- | UnknownExportTypeClass ProperName
+ | UnknownDataConstructor (Qualified (ProperName 'ConstructorName)) (Maybe (Qualified (ProperName 'ConstructorName)))
+ | UnknownTypeConstructor (Qualified (ProperName 'TypeName))
+ | UnknownImportType ModuleName (ProperName 'TypeName)
+ | UnknownExportType (ProperName 'TypeName)
+ | UnknownImportTypeClass ModuleName (ProperName 'ClassName)
+ | UnknownExportTypeClass (ProperName 'ClassName)
| UnknownImportValue ModuleName Ident
| UnknownExportValue Ident
| UnknownExportModule ModuleName
- | UnknownImportDataConstructor ModuleName ProperName ProperName
- | UnknownExportDataConstructor ProperName ProperName
- | ConflictingImport String ModuleName
- | ConflictingImports String ModuleName ModuleName
- | ConflictingTypeDecls ProperName
- | ConflictingCtorDecls ProperName
- | TypeConflictsWithClass ProperName
- | CtorConflictsWithClass ProperName
- | ClassConflictsWithType ProperName
- | ClassConflictsWithCtor ProperName
+ | UnknownImportDataConstructor ModuleName (ProperName 'TypeName) (ProperName 'ConstructorName)
+ | UnknownExportDataConstructor (ProperName 'TypeName) (ProperName 'ConstructorName)
+ | ScopeConflict String [ModuleName]
+ | ConflictingTypeDecls (ProperName 'TypeName)
+ | ConflictingCtorDecls (ProperName 'ConstructorName)
+ | TypeConflictsWithClass (ProperName 'TypeName)
+ | CtorConflictsWithClass (ProperName 'ConstructorName)
+ | ClassConflictsWithType (ProperName 'ClassName)
+ | ClassConflictsWithCtor (ProperName 'ClassName)
| DuplicateModuleName ModuleName
- | DuplicateClassExport ProperName
+ | DuplicateClassExport (ProperName 'ClassName)
| DuplicateValueExport Ident
| DuplicateTypeArgument String
| InvalidDoBind
| InvalidDoLet
| CycleInDeclaration Ident
- | CycleInTypeSynonym (Maybe ProperName)
+ | CycleInTypeSynonym (Maybe (ProperName 'TypeName))
| CycleInModules [ModuleName]
| NameIsUndefined Ident
- | UndefinedTypeVariable ProperName
- | PartiallyAppliedSynonym (Qualified ProperName)
+ | UndefinedTypeVariable (ProperName 'TypeName)
+ | PartiallyAppliedSynonym (Qualified (ProperName 'TypeName))
| EscapedSkolem (Maybe Expr)
| TypesDoNotUnify Type Type
| KindsDoNotUnify Kind Kind
| ConstrainedTypeUnified Type Type
- | OverlappingInstances (Qualified ProperName) [Type] [Qualified Ident]
- | NoInstanceFound (Qualified ProperName) [Type]
- | PossiblyInfiniteInstance (Qualified ProperName) [Type]
- | CannotDerive (Qualified ProperName) [Type]
- | CannotFindDerivingType ProperName
+ | OverlappingInstances (Qualified (ProperName 'ClassName)) [Type] [Qualified Ident]
+ | NoInstanceFound (Qualified (ProperName 'ClassName)) [Type]
+ | PossiblyInfiniteInstance (Qualified (ProperName 'ClassName)) [Type]
+ | CannotDerive (Qualified (ProperName 'ClassName)) [Type]
+ | CannotFindDerivingType (ProperName 'TypeName)
| DuplicateLabel String (Maybe Expr)
| DuplicateValueDeclaration Ident
| ArgListLengthsDiffer Ident
| OverlappingArgNames (Maybe Ident)
| MissingClassMember Ident
- | ExtraneousClassMember Ident (Qualified ProperName)
+ | ExtraneousClassMember Ident (Qualified (ProperName 'ClassName))
| ExpectedType Type Kind
- | IncorrectConstructorArity (Qualified ProperName)
+ | IncorrectConstructorArity (Qualified (ProperName 'ConstructorName))
| ExprDoesNotHaveType Expr Type
| PropertyIsMissing String
| AdditionalProperty String
| CannotApplyFunction Type Expr
| TypeSynonymInstance
- | OrphanInstance Ident (Qualified ProperName) [Type]
- | InvalidNewtype ProperName
+ | OrphanInstance Ident (Qualified (ProperName 'ClassName)) [Type]
+ | InvalidNewtype (ProperName 'TypeName)
| InvalidInstanceHead Type
| TransitiveExportError DeclarationRef [DeclarationRef]
| ShadowedName Ident
@@ -134,13 +120,28 @@ data SimpleErrorMessage
| NotExhaustivePattern [[Binder]] Bool
| OverlappingPattern [[Binder]] Bool
| IncompleteExhaustivityCheck
- | ClassOperator ProperName Ident
- | MisleadingEmptyTypeImport ModuleName ProperName
+ | ClassOperator (ProperName 'ClassName) Ident
+ | MisleadingEmptyTypeImport ModuleName (ProperName 'TypeName)
| ImportHidingModule ModuleName
| UnusedImport ModuleName
- | UnusedExplicitImport ModuleName [String]
- | UnusedDctorImport ProperName
- | UnusedDctorExplicitImport ProperName [ProperName]
+ | UnusedExplicitImport ModuleName [String] (Maybe ModuleName) [DeclarationRef]
+ | UnusedDctorImport (ProperName 'TypeName)
+ | UnusedDctorExplicitImport (ProperName 'TypeName) [ProperName 'ConstructorName]
+ | DeprecatedOperatorDecl String
+ | DeprecatedQualifiedSyntax ModuleName ModuleName
+ | DeprecatedClassImport ModuleName (ProperName 'ClassName)
+ | DeprecatedClassExport (ProperName 'ClassName)
+ | RedundantUnqualifiedImport ModuleName ImportDeclarationType
+ | DuplicateSelectiveImport ModuleName
+ | DuplicateImport ModuleName ImportDeclarationType (Maybe ModuleName)
+ | DuplicateImportRef String
+ | DuplicateExportRef String
+ | IntOutOfRange Integer String Integer Integer
+ | RedundantEmptyHidingImport ModuleName
+ | ImplicitQualifiedImport ModuleName ModuleName [DeclarationRef]
+ | ImplicitImport ModuleName [DeclarationRef]
+ | HidingImport ModuleName [DeclarationRef]
+ | CaseBinderLengthDiffers Int [Binder]
deriving (Show)
-- | Error message hints, providing more detailed information about failure.
@@ -148,7 +149,7 @@ data ErrorMessageHint
= ErrorUnifyingTypes Type Type
| ErrorInExpression Expr
| ErrorInModule ModuleName
- | ErrorInInstance (Qualified ProperName) [Type]
+ | ErrorInInstance (Qualified (ProperName 'ClassName)) [Type]
| ErrorInSubsumption Type Type
| ErrorCheckingAccessor Expr String
| ErrorCheckingType Expr Type
@@ -156,11 +157,11 @@ data ErrorMessageHint
| ErrorCheckingGuard
| ErrorInferringType Expr
| ErrorInApplication Expr Type Expr
- | ErrorInDataConstructor ProperName
- | ErrorInTypeConstructor ProperName
+ | ErrorInDataConstructor (ProperName 'ConstructorName)
+ | ErrorInTypeConstructor (ProperName 'TypeName)
| ErrorInBindingGroup [Ident]
| ErrorInDataBindingGroup
- | ErrorInTypeSynonym ProperName
+ | ErrorInTypeSynonym (ProperName 'TypeName)
| ErrorInValueDeclaration Ident
| ErrorInTypeDeclaration Ident
| ErrorInForeignImport Ident
@@ -178,6 +179,33 @@ data HintCategory
data ErrorMessage = ErrorMessage [ErrorMessageHint] SimpleErrorMessage deriving (Show)
+newtype ErrorSuggestion = ErrorSuggestion String
+
+-- | Get the source span for an error
+errorSpan :: ErrorMessage -> Maybe SourceSpan
+errorSpan = findHint matchSpan
+ where
+ matchSpan (PositionedError ss) = Just ss
+ matchSpan _ = Nothing
+
+-- | Get the module name for an error
+errorModule :: ErrorMessage -> Maybe ModuleName
+errorModule = findHint matchModule
+ where
+ matchModule (ErrorInModule mn) = Just mn
+ matchModule _ = Nothing
+
+findHint :: (ErrorMessageHint -> Maybe a) -> ErrorMessage -> Maybe a
+findHint f (ErrorMessage hints _) = getLast . foldMap (Last . f) $ hints
+
+-- | Remove the module name and span hints from an error
+stripModuleAndSpan :: ErrorMessage -> ErrorMessage
+stripModuleAndSpan (ErrorMessage hints e) = ErrorMessage (filter (not . shouldStrip) hints) e
+ where
+ shouldStrip (ErrorInModule _) = True
+ shouldStrip (PositionedError _) = True
+ shouldStrip _ = False
+
-- |
-- Get the error code for a particular error type
--
@@ -214,8 +242,7 @@ errorCode em = case unwrapErrorMessage em of
UnknownExportModule{} -> "UnknownExportModule"
UnknownImportDataConstructor{} -> "UnknownImportDataConstructor"
UnknownExportDataConstructor{} -> "UnknownExportDataConstructor"
- ConflictingImport{} -> "ConflictingImport"
- ConflictingImports{} -> "ConflictingImports"
+ ScopeConflict{} -> "ScopeConflict"
ConflictingTypeDecls{} -> "ConflictingTypeDecls"
ConflictingCtorDecls{} -> "ConflictingCtorDecls"
TypeConflictsWithClass{} -> "TypeConflictsWithClass"
@@ -275,7 +302,21 @@ errorCode em = case unwrapErrorMessage em of
UnusedExplicitImport{} -> "UnusedExplicitImport"
UnusedDctorImport{} -> "UnusedDctorImport"
UnusedDctorExplicitImport{} -> "UnusedDctorExplicitImport"
-
+ DeprecatedOperatorDecl{} -> "DeprecatedOperatorDecl"
+ DeprecatedQualifiedSyntax{} -> "DeprecatedQualifiedSyntax"
+ DeprecatedClassImport{} -> "DeprecatedClassImport"
+ DeprecatedClassExport{} -> "DeprecatedClassExport"
+ RedundantUnqualifiedImport{} -> "RedundantUnqualifiedImport"
+ DuplicateSelectiveImport{} -> "DuplicateSelectiveImport"
+ DuplicateImport{} -> "DuplicateImport"
+ DuplicateImportRef{} -> "DuplicateImportRef"
+ DuplicateExportRef{} -> "DuplicateExportRef"
+ IntOutOfRange{} -> "IntOutOfRange"
+ RedundantEmptyHidingImport{} -> "RedundantEmptyHidingImport"
+ ImplicitQualifiedImport{} -> "ImplicitQualifiedImport"
+ ImplicitImport{} -> "ImplicitImport"
+ HidingImport{} -> "HidingImport"
+ CaseBinderLengthDiffers{} -> "CaseBinderLengthDiffers"
-- |
-- A stack trace for an error
@@ -293,7 +334,6 @@ nonEmpty = not . null . runMultipleErrors
errorMessage :: SimpleErrorMessage -> MultipleErrors
errorMessage err = MultipleErrors [ErrorMessage [] err]
-
-- |
-- Create an error set from a single error message
--
@@ -308,11 +348,16 @@ onErrorMessages f = MultipleErrors . map f . runMultipleErrors
addHint :: ErrorMessageHint -> MultipleErrors -> MultipleErrors
addHint hint = onErrorMessages $ \(ErrorMessage hints se) -> ErrorMessage (hint : hints) se
--- | The various types of things which might need to be relabelled in errors messages.
-data LabelType = TypeLabel | SkolemLabel String deriving (Show, Read, Eq, Ord)
-
-- | A map from rigid type variable name/unknown variable pairs to new variables.
-type UnknownMap = M.Map (LabelType, Int) Int
+data TypeMap = TypeMap
+ { umSkolemMap :: M.Map Int (String, Int, Maybe SourceSpan)
+ , umNextSkolem :: Int
+ , umUnknownMap :: M.Map Int Int
+ , umNextUnknown :: Int
+ } deriving Show
+
+defaultUnknownMap :: TypeMap
+defaultUnknownMap = TypeMap M.empty 0 M.empty 0
-- | How critical the issue is
data Level = Error | Warning deriving Show
@@ -323,55 +368,132 @@ data Level = Error | Warning deriving Show
unwrapErrorMessage :: ErrorMessage -> SimpleErrorMessage
unwrapErrorMessage (ErrorMessage _ se) = se
-replaceUnknowns :: Type -> State UnknownMap Type
+replaceUnknowns :: Type -> State TypeMap Type
replaceUnknowns = everywhereOnTypesM replaceTypes
where
- lookupTable :: (LabelType, Int) -> UnknownMap -> (Int, UnknownMap)
- lookupTable x m = case M.lookup x m of
- Nothing -> let i = length (filter (on (==) fst x) (M.keys m)) in (i, M.insert x i m)
- Just i -> (i, m)
-
- replaceTypes :: Type -> State UnknownMap Type
- replaceTypes (TUnknown u) = state $ first TUnknown . lookupTable (TypeLabel, u)
- replaceTypes (Skolem name s sko) = state $ first (flip (Skolem name) sko) . lookupTable (SkolemLabel name, s)
+ replaceTypes :: Type -> State TypeMap Type
+ replaceTypes (TUnknown u) = do
+ m <- get
+ case M.lookup u (umUnknownMap m) of
+ Nothing -> do
+ let u' = umNextUnknown m
+ put $ m { umUnknownMap = M.insert u u' (umUnknownMap m), umNextUnknown = u' + 1 }
+ return (TUnknown u')
+ Just u' -> return (TUnknown u')
+ replaceTypes (Skolem name s sko ss) = do
+ m <- get
+ case M.lookup s (umSkolemMap m) of
+ Nothing -> do
+ let s' = umNextSkolem m
+ put $ m { umSkolemMap = M.insert s (name, s', ss) (umSkolemMap m), umNextSkolem = s' + 1 }
+ return (Skolem name s' sko ss)
+ Just (_, s', _) -> return (Skolem name s' sko ss)
replaceTypes other = return other
onTypesInErrorMessageM :: (Applicative m) => (Type -> m Type) -> ErrorMessage -> m ErrorMessage
onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse gHint hints <*> gSimple simple
where
- gSimple (InfiniteType t) = InfiniteType <$> f t
- gSimple (TypesDoNotUnify t1 t2) = TypesDoNotUnify <$> f t1 <*> f t2
- gSimple (ConstrainedTypeUnified t1 t2) = ConstrainedTypeUnified <$> f t1 <*> f t2
- gSimple (ExprDoesNotHaveType e t) = ExprDoesNotHaveType e <$> f t
- gSimple (CannotApplyFunction t e) = CannotApplyFunction <$> f t <*> pure e
- gSimple (InvalidInstanceHead t) = InvalidInstanceHead <$> f t
- gSimple other = pure other
- gHint (ErrorInSubsumption t1 t2) = ErrorInSubsumption <$> f t1 <*> f t2
- gHint (ErrorUnifyingTypes t1 t2) = ErrorUnifyingTypes <$> f t1 <*> f t2
- gHint (ErrorCheckingType e t) = ErrorCheckingType e <$> f t
- gHint (ErrorCheckingKind t) = ErrorCheckingKind <$> f t
- gHint (ErrorInApplication e1 t1 e2) = ErrorInApplication e1 <$> f t1 <*> pure e2
- gHint other = pure other
+ gSimple (InfiniteType t) = InfiniteType <$> f t
+ gSimple (TypesDoNotUnify t1 t2) = TypesDoNotUnify <$> f t1 <*> f t2
+ gSimple (ConstrainedTypeUnified t1 t2) = ConstrainedTypeUnified <$> f t1 <*> f t2
+ gSimple (ExprDoesNotHaveType e t) = ExprDoesNotHaveType e <$> f t
+ gSimple (CannotApplyFunction t e) = CannotApplyFunction <$> f t <*> pure e
+ gSimple (InvalidInstanceHead t) = InvalidInstanceHead <$> f t
+ gSimple (NoInstanceFound cl ts) = NoInstanceFound cl <$> traverse f ts
+ gSimple (OverlappingInstances cl ts insts) = OverlappingInstances cl <$> traverse f ts <*> pure insts
+ gSimple (PossiblyInfiniteInstance cl ts) = PossiblyInfiniteInstance cl <$> traverse f ts
+ gSimple (CannotDerive cl ts) = CannotDerive cl <$> traverse f ts
+ gSimple (ExpectedType ty k) = ExpectedType <$> f ty <*> pure k
+ gSimple (OrphanInstance nm cl ts) = OrphanInstance nm cl <$> traverse f ts
+ gSimple (WildcardInferredType ty) = WildcardInferredType <$> f ty
+ gSimple (MissingTypeDeclaration nm ty) = MissingTypeDeclaration nm <$> f ty
+
+ gSimple other = pure other
+
+ gHint (ErrorInSubsumption t1 t2) = ErrorInSubsumption <$> f t1 <*> f t2
+ gHint (ErrorUnifyingTypes t1 t2) = ErrorUnifyingTypes <$> f t1 <*> f t2
+ gHint (ErrorCheckingType e t) = ErrorCheckingType e <$> f t
+ gHint (ErrorCheckingKind t) = ErrorCheckingKind <$> f t
+ gHint (ErrorInApplication e1 t1 e2) = ErrorInApplication e1 <$> f t1 <*> pure e2
+ gHint (ErrorInInstance cl ts) = ErrorInInstance cl <$> traverse f ts
+ gHint other = pure other
+
+wikiUri :: ErrorMessage -> String
+wikiUri e = "https://github.com/purescript/purescript/wiki/Error-Code-" ++ errorCode e
+
+-- 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?
+errorSuggestion :: SimpleErrorMessage -> Maybe ErrorSuggestion
+errorSuggestion err = case err of
+ UnusedImport{} -> emptySuggestion
+ RedundantEmptyHidingImport{} -> emptySuggestion
+ DuplicateImport{} -> emptySuggestion
+ RedundantUnqualifiedImport{} -> emptySuggestion
+ DeprecatedQualifiedSyntax name qualName -> suggest $
+ "import " ++ runModuleName name ++ " as " ++ runModuleName qualName
+ UnusedExplicitImport mn _ qual refs -> suggest $ importSuggestion mn refs qual
+ ImplicitImport mn refs -> suggest $ importSuggestion mn refs Nothing
+ ImplicitQualifiedImport mn asModule refs -> suggest $ importSuggestion mn refs (Just asModule)
+ _ -> Nothing
+
+ where
+ emptySuggestion = Just $ ErrorSuggestion ""
+ suggest = Just . ErrorSuggestion
+
+ importSuggestion :: ModuleName -> [ DeclarationRef ] -> Maybe ModuleName -> String
+ importSuggestion mn refs qual =
+ "import " ++ runModuleName mn ++ " (" ++ intercalate ", " (map prettyPrintRef refs) ++ ")" ++ qstr qual
+
+ qstr :: Maybe ModuleName -> String
+ qstr (Just mn) = " as " ++ runModuleName mn
+ qstr Nothing = ""
+
+showSuggestion :: SimpleErrorMessage -> String
+showSuggestion suggestion = case errorSuggestion suggestion of
+ Just (ErrorSuggestion x) -> x
+ _ -> ""
-- |
-- Pretty print a single error, simplifying if necessary
--
-prettyPrintSingleError :: Bool -> Level -> ErrorMessage -> State UnknownMap Box.Box
-prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInErrorMessageM replaceUnknowns (if full then e else simplifyErrorMessage e)
+prettyPrintSingleError :: Bool -> Level -> Bool -> ErrorMessage -> Box.Box
+prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap $ do
+ em <- onTypesInErrorMessageM replaceUnknowns (if full then e else simplifyErrorMessage e)
+ um <- get
+ return (prettyPrintErrorMessage um em)
where
-- Pretty print an ErrorMessage
- prettyPrintErrorMessage :: ErrorMessage -> Box.Box
- prettyPrintErrorMessage (ErrorMessage hints simple) =
+ prettyPrintErrorMessage :: TypeMap -> ErrorMessage -> Box.Box
+ prettyPrintErrorMessage typeMap (ErrorMessage hints simple) =
paras $
[ foldr renderHint (indent (renderSimpleErrorMessage simple)) hints
- , Box.moveDown 1 $ paras [ line $ "See " ++ wikiUri ++ " for more information, "
- , line $ "or to contribute content related to this " ++ levelText ++ "."
- ]
+ ] ++
+ maybe [] (return . Box.moveDown 1) typeInformation ++
+ [ Box.moveDown 1 $ paras [ line $ "See " ++ wikiUri e ++ " for more information, "
+ , line $ "or to contribute content related to this " ++ levelText ++ "."
+ ]
+ | showWiki
]
where
- wikiUri :: String
- wikiUri = "https://github.com/purescript/purescript/wiki/Error-Code-" ++ errorCode e
+ typeInformation :: Maybe Box.Box
+ typeInformation | not (null types) = Just $ Box.hsep 1 Box.left [ line "where", paras types ]
+ | otherwise = Nothing
+ where
+ types :: [Box.Box]
+ types = map skolemInfo (M.elems (umSkolemMap typeMap)) ++
+ map unknownInfo (M.elems (umUnknownMap typeMap))
+
+ skolemInfo :: (String, Int, Maybe SourceSpan) -> Box.Box
+ skolemInfo (name, s, ss) =
+ paras $
+ line (name ++ show s ++ " is a rigid type variable")
+ : foldMap (return . line . (" bound at " ++) . displayStartEndPos) ss
+
+ unknownInfo :: Int -> Box.Box
+ unknownInfo u = line $ "_" ++ show u ++ " is an unknown type"
renderSimpleErrorMessage :: SimpleErrorMessage -> Box.Box
renderSimpleErrorMessage (CannotGetFileInfo path) =
@@ -469,13 +591,10 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError
line $ "Module " ++ runModuleName mn ++ " does not export data constructor " ++ runProperName dcon ++ " for type " ++ runProperName tcon
renderSimpleErrorMessage (UnknownExportDataConstructor tcon dcon) =
line $ "Cannot export data constructor " ++ runProperName dcon ++ " for type " ++ runProperName tcon ++ ", as it has not been declared."
- renderSimpleErrorMessage (ConflictingImport nm mn) =
- paras [ line $ "Cannot declare " ++ show nm ++ ", since another declaration of that name was imported from module " ++ runModuleName mn
- , line $ "Consider hiding " ++ show nm ++ " when importing " ++ runModuleName mn ++ ":"
- , indent . line $ "import " ++ runModuleName mn ++ " hiding (" ++ nm ++ ")"
+ renderSimpleErrorMessage (ScopeConflict nm ms) =
+ paras [ line $ "Conflicting definitions are in scope for " ++ nm ++ " from the following modules:"
+ , indent $ paras $ map (line . runModuleName) ms
]
- renderSimpleErrorMessage (ConflictingImports nm m1 m2) =
- line $ "Conflicting imports for " ++ nm ++ " from modules " ++ runModuleName m1 ++ " and " ++ runModuleName m2
renderSimpleErrorMessage (ConflictingTypeDecls nm) =
line $ "Conflicting type declarations for " ++ runProperName nm
renderSimpleErrorMessage (ConflictingCtorDecls nm) =
@@ -520,12 +639,31 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError
<> foldMap (\expr -> [ line "Relevant expression: "
, indent $ prettyPrintValue valueDepth expr
]) binding
- renderSimpleErrorMessage (TypesDoNotUnify t1 t2)
- = paras [ line "Could not match type"
- , indent $ typeAsBox t1
- , line "with type"
- , indent $ typeAsBox t2
- ]
+ renderSimpleErrorMessage (TypesDoNotUnify u1 u2)
+ = let (sorted1, sorted2) = sortRows u1 u2
+
+ sortRows :: Type -> Type -> (Type, Type)
+ sortRows r1@RCons{} r2@RCons{} = sortRows' (rowToList r1) (rowToList r2)
+ sortRows t1 t2 = (t1, t2)
+
+ -- Put the common labels last
+ sortRows' :: ([(String, Type)], Type) -> ([(String, Type)], Type) -> (Type, Type)
+ sortRows' (s1, r1) (s2, r2) =
+ let common :: [(String, (Type, Type))]
+ common = sortBy (comparing fst) $ [ (name, (t1, t2)) | (name, t1) <- s1, (name', t2) <- s2, name == name' ]
+
+ sd1, sd2 :: [(String, Type)]
+ sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ]
+ sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ]
+ in ( rowFromList (sortBy (comparing fst) sd1 ++ map (fst &&& fst . snd) common, r1)
+ , rowFromList (sortBy (comparing fst) sd2 ++ map (fst &&& snd . snd) common, r2)
+ )
+ in paras [ line "Could not match type"
+ , indent $ typeAsBox sorted1
+ , line "with type"
+ , indent $ typeAsBox sorted2
+ ]
+
renderSimpleErrorMessage (KindsDoNotUnify k1 k2) =
paras [ line "Could not match kind"
, indent $ line $ prettyPrintKind k1
@@ -554,7 +692,16 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError
, indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm)
, Box.vcat Box.left (map typeAtomAsBox ts)
]
+ , paras [ line "The instance head contains unknown type variables. Consider adding a type annotation."
+ | any containsUnknowns ts
+ ]
]
+ where
+ containsUnknowns :: Type -> Bool
+ containsUnknowns = everythingOnTypes (||) go
+ where
+ go TUnknown{} = True
+ go _ = False
renderSimpleErrorMessage (PossiblyInfiniteInstance nm ts) =
paras [ line "Type class instance for"
, indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm)
@@ -634,8 +781,9 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError
, line "All types appearing in instance declarations must be of the form T a_1 .. a_n, where each type a_i is of the same form."
]
renderSimpleErrorMessage (TransitiveExportError x ys) =
- paras $ line ("An export for " ++ prettyPrintExport x ++ " requires the following to also be exported: ")
- : map (line . prettyPrintExport) ys
+ paras [ line $ "An export for " ++ prettyPrintExport x ++ " requires the following to also be exported: "
+ , indent $ paras $ map (line . prettyPrintExport) ys
+ ]
renderSimpleErrorMessage (ShadowedName nm) =
line $ "Name '" ++ showIdent nm ++ "' was shadowed."
renderSimpleErrorMessage (ShadowedTypeVar tv) =
@@ -666,9 +814,12 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError
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"
- , Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs))
- ] ++
- [ line "..." | not b ]
+ , 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))
@@ -681,9 +832,11 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError
renderSimpleErrorMessage (UnusedImport name) =
line $ "The import of module " ++ runModuleName name ++ " is redundant"
- renderSimpleErrorMessage (UnusedExplicitImport name names) =
- paras [ line $ "The import of module " ++ runModuleName name ++ " contains the following unused references:"
- , indent $ paras $ map line names ]
+ 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:"
+ , indent $ line $ showSuggestion msg ]
renderSimpleErrorMessage (UnusedDctorImport name) =
line $ "The import of type " ++ runProperName name ++ " includes data constructors but only the type is used"
@@ -692,6 +845,80 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError
paras [ line $ "The import of type " ++ runProperName name ++ " includes the following unused data constructors:"
, indent $ paras $ map (line .runProperName) names ]
+ renderSimpleErrorMessage (DeprecatedOperatorDecl name) =
+ 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."
+ ]
+
+ renderSimpleErrorMessage (DeprecatedQualifiedSyntax name qualName) =
+ 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."
+ ]
+
+ renderSimpleErrorMessage (DeprecatedClassImport mn name) =
+ paras [ line $ "Class import from " ++ runModuleName mn ++ " 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."
+ ]
+
+ renderSimpleErrorMessage (DeprecatedClassExport name) =
+ 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."
+ ]
+
+ renderSimpleErrorMessage (RedundantUnqualifiedImport name imp) =
+ line $ "Import of " ++ prettyPrintImport name imp Nothing ++ " is redundant due to a whole-module import"
+
+ renderSimpleErrorMessage (DuplicateSelectiveImport name) =
+ line $ "There is an existing import of " ++ runModuleName name ++ ", consider merging the import lists"
+
+ renderSimpleErrorMessage (DuplicateImport name imp qual) =
+ line $ "Duplicate import of " ++ prettyPrintImport name imp qual
+
+ renderSimpleErrorMessage (DuplicateImportRef ref) =
+ line $ "Import list contains multiple references to " ++ ref
+
+ renderSimpleErrorMessage (DuplicateExportRef ref) =
+ line $ "Export list contains multiple references to " ++ ref
+
+ renderSimpleErrorMessage (IntOutOfRange value backend lo hi) =
+ paras [ line $ "Integer value " ++ show value ++ " is out of range for the " ++ backend ++ " backend."
+ , line $ "Acceptable values fall within the range " ++ show lo ++ " to " ++ show hi ++ " (inclusive)." ]
+
+ renderSimpleErrorMessage (RedundantEmptyHidingImport mn) =
+ line $ "The import for module " ++ runModuleName mn ++ " is redundant as all members have been explicitly hidden."
+
+ renderSimpleErrorMessage msg@(ImplicitQualifiedImport importedModule asModule _) =
+ paras [ line $ "Module " ++ runModuleName importedModule ++ " was imported as " ++ runModuleName asModule ++ " with unspecified imports."
+ , line $ "As there are multiple modules being imported as " ++ runModuleName asModule ++ ", consider using the explicit form:"
+ , indent $ line $ showSuggestion msg
+ ]
+
+ renderSimpleErrorMessage msg@(ImplicitImport mn _) =
+ paras [ line $ "Module " ++ runModuleName mn ++ " has unspecified imports, consider using the explicit form: "
+ , indent $ line $ showSuggestion msg
+ ]
+
+ renderSimpleErrorMessage (HidingImport mn refs) =
+ paras [ line $ "Module " ++ runModuleName mn ++ " has unspecified imports, consider using the inclusive form: "
+ , indent $ line $ "import " ++ runModuleName mn ++ " (" ++ intercalate ", " (map prettyPrintRef refs) ++ ")"
+ ]
+
+ 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") ++ "." ]
+
renderHint :: ErrorMessageHint -> Box.Box -> Box.Box
renderHint (ErrorUnifyingTypes t1 t2) detail =
paras [ detail
@@ -820,22 +1047,13 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError
paras :: [Box.Box] -> Box.Box
paras = Box.vcat Box.left
- -- Pretty print and export declaration
- prettyPrintExport :: DeclarationRef -> String
- prettyPrintExport (TypeRef pn _) = runProperName pn
- prettyPrintExport (ValueRef ident) = showIdent ident
- prettyPrintExport (TypeClassRef pn) = runProperName pn
- prettyPrintExport (TypeInstanceRef ident) = showIdent ident
- prettyPrintExport (ModuleRef name) = "module " ++ runModuleName name
- prettyPrintExport (PositionedDeclarationRef _ _ ref) = prettyPrintExport ref
-
-- | Simplify an error message
simplifyErrorMessage :: ErrorMessage -> ErrorMessage
simplifyErrorMessage (ErrorMessage hints simple) = ErrorMessage (simplifyHints hints) simple
where
-- Take the last instance of each "hint category"
simplifyHints :: [ErrorMessageHint] -> [ErrorMessageHint]
- simplifyHints = reverse . nubBy categoriesEqual . reverse
+ simplifyHints = reverse . nubBy categoriesEqual . stripRedudantHints simple . reverse
-- Don't remove hints in the "other" category
categoriesEqual :: ErrorMessageHint -> ErrorMessageHint -> Bool
@@ -845,6 +1063,30 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError
(_, OtherHint) -> False
(c1, c2) -> c1 == c2
+ -- | See https://github.com/purescript/purescript/issues/1802
+ stripRedudantHints :: SimpleErrorMessage -> [ErrorMessageHint] -> [ErrorMessageHint]
+ stripRedudantHints CannotApplyFunction{} = stripFirst isApplicationHint
+ where
+ isApplicationHint ErrorInApplication{} = True
+ isApplicationHint _ = False
+ stripRedudantHints ExprDoesNotHaveType{} = stripFirst isCheckHint
+ where
+ isCheckHint ErrorCheckingType{} = True
+ isCheckHint _ = False
+ stripRedudantHints TypesDoNotUnify{} = stripFirst isUnifyHint
+ where
+ isUnifyHint ErrorUnifyingTypes{} = True
+ isUnifyHint _ = False
+ stripRedudantHints _ = id
+
+ stripFirst :: (ErrorMessageHint -> Bool) -> [ErrorMessageHint] -> [ErrorMessageHint]
+ stripFirst p (PositionedError pos : hs) = PositionedError pos : stripFirst p hs
+ stripFirst p (ErrorInModule mn : hs) = ErrorInModule mn : stripFirst p hs
+ stripFirst p (hint : hs)
+ | p hint = hs
+ | otherwise = hint : hs
+ stripFirst _ [] = []
+
hintCategory :: ErrorMessageHint -> HintCategory
hintCategory ErrorCheckingType{} = ExprHint
hintCategory ErrorInferringType{} = ExprHint
@@ -852,9 +1094,34 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError
hintCategory ErrorUnifyingTypes{} = CheckHint
hintCategory ErrorInSubsumption{} = CheckHint
hintCategory ErrorInApplication{} = CheckHint
+ hintCategory ErrorCheckingKind{} = CheckHint
hintCategory PositionedError{} = PositionHint
hintCategory _ = OtherHint
+-- Pretty print and export declaration
+prettyPrintExport :: DeclarationRef -> String
+prettyPrintExport (TypeRef pn _) = runProperName pn
+prettyPrintExport ref = prettyPrintRef ref
+
+prettyPrintImport :: ModuleName -> ImportDeclarationType -> Maybe ModuleName -> String
+prettyPrintImport mn idt qual =
+ let i = case idt of
+ Implicit -> runModuleName mn
+ Explicit refs -> runModuleName mn ++ " (" ++ intercalate ", " (map prettyPrintRef refs) ++ ")"
+ Hiding refs -> runModuleName mn ++ " hiding (" ++ intercalate "," (map prettyPrintRef refs) ++ ")"
+ in i ++ maybe "" (\q -> " as " ++ runModuleName q) qual
+
+prettyPrintRef :: DeclarationRef -> String
+prettyPrintRef (TypeRef pn Nothing) = runProperName pn ++ "(..)"
+prettyPrintRef (TypeRef pn (Just [])) = runProperName pn
+prettyPrintRef (TypeRef pn (Just dctors)) = runProperName pn ++ "(" ++ intercalate ", " (map runProperName dctors) ++ ")"
+prettyPrintRef (ValueRef ident) = showIdent ident
+prettyPrintRef (TypeClassRef pn) = "class " ++ runProperName pn
+prettyPrintRef (ProperRef name) = name
+prettyPrintRef (TypeInstanceRef ident) = showIdent ident
+prettyPrintRef (ModuleRef name) = "module " ++ runModuleName name
+prettyPrintRef (PositionedDeclarationRef _ _ ref) = prettyPrintExport ref
+
-- |
-- Pretty print multiple errors
--
@@ -869,22 +1136,21 @@ prettyPrintMultipleWarnings full = renderBox . prettyPrintMultipleWarningsBox fu
-- | Pretty print warnings as a Box
prettyPrintMultipleWarningsBox :: Bool -> MultipleErrors -> Box.Box
-prettyPrintMultipleWarningsBox full = flip evalState M.empty . prettyPrintMultipleErrorsWith Warning "Warning found:" "Warning" full
+prettyPrintMultipleWarningsBox full = prettyPrintMultipleErrorsWith Warning "Warning found:" "Warning" full
-- | Pretty print errors as a Box
prettyPrintMultipleErrorsBox :: Bool -> MultipleErrors -> Box.Box
-prettyPrintMultipleErrorsBox full = flip evalState M.empty . prettyPrintMultipleErrorsWith Error "Error found:" "Error" full
-
-prettyPrintMultipleErrorsWith :: Level -> String -> String -> Bool -> MultipleErrors -> State UnknownMap Box.Box
-prettyPrintMultipleErrorsWith level intro _ full (MultipleErrors [e]) = do
- result <- prettyPrintSingleError full level e
- return $
- Box.vcat Box.left [ Box.text intro
- , result
- ]
-prettyPrintMultipleErrorsWith level _ intro full (MultipleErrors es) = do
- result <- forM es $ prettyPrintSingleError full level
- return $ Box.vsep 1 Box.left $ concat $ zipWith withIntro [1 :: Int ..] result
+prettyPrintMultipleErrorsBox full = prettyPrintMultipleErrorsWith Error "Error found:" "Error" full
+
+prettyPrintMultipleErrorsWith :: Level -> String -> String -> Bool -> MultipleErrors -> Box.Box
+prettyPrintMultipleErrorsWith level intro _ full (MultipleErrors [e]) =
+ let result = prettyPrintSingleError full level True e
+ in Box.vcat Box.left [ Box.text intro
+ , result
+ ]
+prettyPrintMultipleErrorsWith level _ intro full (MultipleErrors es) =
+ let result = map (prettyPrintSingleError full level True) es
+ in Box.vsep 1 Box.left $ concat $ zipWith withIntro [1 :: Int ..] result
where
withIntro i err = [ Box.text (intro ++ " " ++ show i ++ " of " ++ show (length es) ++ ":")
, Box.moveRight 2 err
@@ -946,9 +1212,15 @@ line :: String -> Box.Box
line = Box.text
renderBox :: Box.Box -> String
-renderBox = unlines . map trimEnd . lines . Box.render
+renderBox = unlines
+ . map (dropWhileEnd isSpace)
+ . dropWhile whiteSpace
+ . dropWhileEnd whiteSpace
+ . lines
+ . Box.render
where
- trimEnd = reverse . dropWhile (== ' ') . reverse
+ dropWhileEnd p = reverse . dropWhile p . reverse
+ whiteSpace = all isSpace
-- |
-- Rethrow an error with a more detailed error message in the case of failure
diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs
index 036a748..5bdc304 100644
--- a/src/Language/PureScript/Externs.hs
+++ b/src/Language/PureScript/Externs.hs
@@ -1,22 +1,10 @@
------------------------------------------------------------------------------
---
--- Module : Language.PureScript.Externs
--- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
--- License : MIT (http://opensource.org/licenses/MIT)
---
--- Maintainer : Phil Freeman <paf31@cantab.net>
--- Stability : experimental
--- Portability :
---
--- |
--- This module generates code for \"externs\" files, i.e. files containing only foreign import declarations.
---
------------------------------------------------------------------------------
-
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE TemplateHaskell #-}
+-- |
+-- This module generates code for \"externs\" files, i.e. files containing only foreign import declarations.
+--
module Language.PureScript.Externs
( ExternsFile(..)
, ExternsImport(..)
@@ -84,27 +72,29 @@ data ExternsFixity = ExternsFixity
, efPrecedence :: Precedence
-- | The operator symbol
, efOperator :: String
+ -- | The value the operator is an alias for
+ , efAlias :: Maybe (Qualified Ident)
} deriving (Show, Read)
-- | A type or value declaration appearing in an externs file
data ExternsDeclaration =
-- | A type declaration
EDType
- { edTypeName :: ProperName
+ { edTypeName :: ProperName 'TypeName
, edTypeKind :: Kind
, edTypeDeclarationKind :: TypeKind
}
-- | A type synonym
| EDTypeSynonym
- { edTypeSynonymName :: ProperName
+ { edTypeSynonymName :: ProperName 'TypeName
, edTypeSynonymArguments :: [(String, Maybe Kind)]
, edTypeSynonymType :: Type
}
-- | A data construtor
| EDDataConstructor
- { edDataCtorName :: ProperName
+ { edDataCtorName :: ProperName 'ConstructorName
, edDataCtorOrigin :: DataDeclType
- , edDataCtorTypeCtor :: ProperName
+ , edDataCtorTypeCtor :: ProperName 'TypeName
, edDataCtorType :: Type
, edDataCtorFields :: [Ident]
}
@@ -115,14 +105,14 @@ data ExternsDeclaration =
}
-- | A type class declaration
| EDClass
- { edClassName :: ProperName
+ { edClassName :: ProperName 'ClassName
, edClassTypeArguments :: [(String, Maybe Kind)]
, edClassMembers :: [(Ident, Type)]
, edClassConstraints :: [Constraint]
}
-- | An instance declaration
| EDInstance
- { edInstanceClassName :: Qualified ProperName
+ { edInstanceClassName :: Qualified (ProperName 'ClassName)
, edInstanceName :: Ident
, edInstanceTypes :: [Type]
, edInstanceConstraints :: Maybe [Constraint]
@@ -163,7 +153,7 @@ moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..}
efDeclarations = concatMap toExternsDeclaration efExports
fixityDecl :: Declaration -> Maybe ExternsFixity
- fixityDecl (FixityDeclaration (Fixity assoc prec) op) = fmap (const (ExternsFixity assoc prec op)) (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
@@ -173,7 +163,7 @@ moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..}
fixityDecl _ = Nothing
importDecl :: Declaration -> Maybe ExternsImport
- importDecl (ImportDeclaration m mt qmn) = Just (ExternsImport m mt qmn)
+ importDecl (ImportDeclaration m mt qmn _) = Just (ExternsImport m mt qmn)
importDecl (PositionedDeclaration _ _ d) = importDecl d
importDecl _ = Nothing
@@ -188,7 +178,7 @@ moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..}
Just (kind, tk@(DataType _ tys)) ->
EDType pn kind tk : [ EDDataConstructor dctor dty pn ty args
| dctor <- fromMaybe (map fst tys) dctors
- , (dty, _, ty, args) <- maybeToList (M.lookup (Qualified (Just mn) dctor) (dataConstructors env))
+ , (dty, _, ty, args) <- maybeToList (Qualified (Just mn) dctor `M.lookup` dataConstructors env)
]
_ -> internalError "toExternsDeclaration: Invalid input"
toExternsDeclaration (ValueRef ident)
@@ -196,10 +186,10 @@ moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..}
= [ EDValue ident ty ]
toExternsDeclaration (TypeClassRef className)
| Just (args, members, implies) <- Qualified (Just mn) className `M.lookup` typeClasses env
- , Just (kind, TypeSynonym) <- M.lookup (Qualified (Just mn) className) (types env)
- , Just (_, synTy) <- Qualified (Just mn) className `M.lookup` typeSynonyms env
- = [ EDType className kind TypeSynonym
- , EDTypeSynonym className args synTy
+ , Just (kind, TypeSynonym) <- Qualified (Just mn) (coerceProperName className) `M.lookup` types env
+ , Just (_, synTy) <- Qualified (Just mn) (coerceProperName className) `M.lookup` typeSynonyms env
+ = [ EDType (coerceProperName className) kind TypeSynonym
+ , EDTypeSynonym (coerceProperName className) args synTy
, EDClass className args members implies
]
toExternsDeclaration (TypeInstanceRef ident)
diff --git a/src/Language/PureScript/Kinds.hs b/src/Language/PureScript/Kinds.hs
index bf37e48..c19c773 100644
--- a/src/Language/PureScript/Kinds.hs
+++ b/src/Language/PureScript/Kinds.hs
@@ -1,18 +1,3 @@
------------------------------------------------------------------------------
---
--- Module : Language.PureScript.Kinds
--- Copyright : (c) Phil Freeman 2013
--- License : MIT
---
--- Maintainer : Phil Freeman <paf31@cantab.net>
--- Stability : experimental
--- Portability :
---
--- |
---
------------------------------------------------------------------------------
-
-{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE TemplateHaskell #-}
module Language.PureScript.Kinds where
@@ -20,7 +5,6 @@ module Language.PureScript.Kinds where
import Prelude ()
import Prelude.Compat
-import Data.Data
import qualified Data.Aeson.TH as A
-- |
@@ -46,7 +30,8 @@ data Kind
-- |
-- Function kinds
--
- | FunKind Kind Kind deriving (Show, Read, Eq, Ord, Data, Typeable)
+ | FunKind Kind Kind
+ deriving (Show, Read, Eq, Ord)
$(A.deriveJSON A.defaultOptions ''Kind)
diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs
index 10991c8..8ab4649 100644
--- a/src/Language/PureScript/Linter.hs
+++ b/src/Language/PureScript/Linter.hs
@@ -1,26 +1,16 @@
------------------------------------------------------------------------------
---
--- Module : Language.PureScript.Linter
--- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
--- License : MIT (http://opensource.org/licenses/MIT)
---
--- Maintainer : Phil Freeman <paf31@cantab.net>
--- Stability : experimental
--- Portability :
---
--- | This module implements a simple linting pass on the PureScript AST.
---
------------------------------------------------------------------------------
-
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE PatternGuards #-}
+-- |
+-- This module implements a simple linting pass on the PureScript AST.
+--
module Language.PureScript.Linter (lint, module L) where
import Prelude ()
import Prelude.Compat
-import Data.List (mapAccumL, nub, (\\))
+import Data.List (nub, (\\))
import Data.Maybe (mapMaybe)
import Data.Monoid
@@ -54,43 +44,47 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl
getDeclIdent _ = Nothing
lintDeclaration :: Declaration -> m ()
- lintDeclaration d =
- let (f, _, _, _, _) = everythingWithContextOnValues moduleNames mempty mappend stepD stepE stepB def def
-
- f' :: Declaration -> MultipleErrors
- f' (PositionedDeclaration pos _ dec) = addHint (PositionedError pos) (f' dec)
- f' dec@(ValueDeclaration name _ _ _) = addHint (ErrorInValueDeclaration name) (f dec <> checkTypeVarsInDecl dec)
- f' (TypeDeclaration name ty) = addHint (ErrorInTypeDeclaration name) (checkTypeVars ty)
- f' dec = f dec <> checkTypeVarsInDecl dec
-
- in tell (f' d)
+ lintDeclaration = tell . f
where
- def s _ = (s, mempty)
+ (warningsInDecl, _, _, _, _) = everythingWithScope stepD stepE stepB (\_ _ -> mempty) stepDo
- stepD :: S.Set Ident -> Declaration -> (S.Set Ident, MultipleErrors)
- stepD s (TypeClassDeclaration name _ _ decls) = (s, foldr go mempty decls)
+ f :: Declaration -> MultipleErrors
+ f (PositionedDeclaration pos _ dec) = addHint (PositionedError pos) (f dec)
+ f dec@(ValueDeclaration name _ _ _) = addHint (ErrorInValueDeclaration name) (warningsInDecl moduleNames dec <> checkTypeVarsInDecl dec)
+ f (TypeDeclaration name ty) = addHint (ErrorInTypeDeclaration name) (checkTypeVars ty)
+ f dec = warningsInDecl moduleNames dec <> checkTypeVarsInDecl dec
+
+ stepD :: S.Set Ident -> Declaration -> MultipleErrors
+ stepD _ (ValueDeclaration (Op name) _ _ _) = errorMessage (DeprecatedOperatorDecl name)
+ stepD _ (TypeClassDeclaration _ _ _ decls) = foldMap go decls
+ where
+ go :: Declaration -> MultipleErrors
+ go (PositionedDeclaration _ _ d') = go d'
+ go (TypeDeclaration (Op name) _) = errorMessage (DeprecatedOperatorDecl name)
+ go _ = mempty
+ stepD _ _ = mempty
+
+ stepE :: S.Set Ident -> Expr -> MultipleErrors
+ stepE s (Abs (Left name) _) | name `S.member` s = errorMessage (ShadowedName name)
+ stepE s (Let ds' _) = foldMap go ds'
+ where
+ go d | Just i <- getDeclIdent d
+ , i `S.member` s = errorMessage (ShadowedName i)
+ | otherwise = mempty
+ stepE _ _ = mempty
+
+ stepB :: S.Set Ident -> Binder -> MultipleErrors
+ stepB s (VarBinder name) | name `S.member` s = errorMessage (ShadowedName name)
+ stepB s (NamedBinder name _) | name `S.member` s = errorMessage (ShadowedName name)
+ stepB _ _ = mempty
+
+ stepDo :: S.Set Ident -> DoNotationElement -> MultipleErrors
+ stepDo s (DoNotationLet ds') = foldMap go ds'
where
- go :: Declaration -> MultipleErrors -> MultipleErrors
- go (PositionedDeclaration _ _ d') errs = go d' errs
- go (TypeDeclaration op@(Op _) _) errs = errorMessage (ClassOperator name op) <> errs
- go _ errs = errs
- stepD s _ = (s, mempty)
-
- stepE :: S.Set Ident -> Expr -> (S.Set Ident, MultipleErrors)
- stepE s (Abs (Left name) _) = bindName s name
- stepE s (Let ds' _) =
- case mapAccumL bindName s (nub (mapMaybe getDeclIdent ds')) of
- (s', es) -> (s', mconcat es)
- stepE s _ = (s, mempty)
-
- stepB :: S.Set Ident -> Binder -> (S.Set Ident, MultipleErrors)
- stepB s (VarBinder name) = bindName s name
- stepB s (NamedBinder name _) = bindName s name
- stepB s (TypedBinder _ b) = stepB s b
- stepB s _ = (s, mempty)
-
- bindName :: S.Set Ident -> Ident -> (S.Set Ident, MultipleErrors)
- bindName = bind ShadowedName
+ go d | Just i <- getDeclIdent d
+ , i `S.member` s = errorMessage (ShadowedName i)
+ | otherwise = mempty
+ stepDo _ _ = mempty
checkTypeVarsInDecl :: Declaration -> MultipleErrors
checkTypeVarsInDecl d = let (f, _, _, _, _) = accumTypes checkTypeVars in f d
diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs
index f36cc21..b28905b 100644
--- a/src/Language/PureScript/Linter/Exhaustive.hs
+++ b/src/Language/PureScript/Linter/Exhaustive.hs
@@ -1,28 +1,13 @@
------------------------------------------------------------------------------
---
--- Module : Language.PureScript.Exhaustive
--- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
--- License : MIT (http://opensource.org/licenses/MIT)
---
--- Maintainer : Phil Freeman <paf31@cantab.net>
--- Stability : experimental
--- Portability :
---
--- |
--- | Module for exhaustivity checking over pattern matching definitions
--- | The algorithm analyses the clauses of a definition one by one from top
--- | to bottom, where in each step it has the cases already missing (uncovered),
--- | and it generates the new set of missing cases.
---
------------------------------------------------------------------------------
-
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
-module Language.PureScript.Linter.Exhaustive
- ( checkExhaustive
- , checkExhaustiveModule
- ) where
+-- |
+-- Module for exhaustivity checking over pattern matching definitions
+-- The algorithm analyses the clauses of a definition one by one from top
+-- to bottom, where in each step it has the cases already missing (uncovered),
+-- and it generates the new set of missing cases.
+--
+module Language.PureScript.Linter.Exhaustive (checkExhaustiveModule) where
import Prelude ()
import Prelude.Compat
@@ -46,18 +31,22 @@ import Language.PureScript.Kinds
import Language.PureScript.Types as P
import Language.PureScript.Errors
--- | There are two modes of failure for the redudancy check:
+-- | There are two modes of failure for the redundancy check:
--
--- 1. Exhaustivity was incomeplete due to too many cases, so we couldn't determine redundancy.
+-- 1. Exhaustivity was incomplete due to too many cases, so we couldn't determine redundancy.
-- 2. We didn't attempt to determine redundancy for a binder, e.g. an integer binder.
--
-- We want to warn the user in the first case.
-data RedudancyError = Incomplete | Unknown
+data RedundancyError = Incomplete | Unknown
-- |
-- Qualifies a propername from a given qualified propername and a default module name
--
-qualifyName :: a -> ModuleName -> Qualified a -> Qualified a
+qualifyName
+ :: (ProperName a)
+ -> ModuleName
+ -> Qualified (ProperName b)
+ -> Qualified (ProperName a)
qualifyName n defmn qn = Qualified (Just mn) n
where
(mn, _) = qualify defmn qn
@@ -68,31 +57,28 @@ qualifyName n defmn qn = Qualified (Just mn) n
-- where: - ProperName is the name of the constructor (for example, "Nothing" in Maybe)
-- - [Type] is the list of arguments, if it has (for example, "Just" has [TypeVar "a"])
--
-getConstructors :: Environment -> ModuleName -> Qualified ProperName -> [(ProperName, [Type])]
+getConstructors :: Environment -> ModuleName -> Qualified (ProperName 'ConstructorName) -> [(ProperName 'ConstructorName, [Type])]
getConstructors env defmn n = extractConstructors lnte
where
- qpn :: Qualified ProperName
- qpn = getConsDataName n
-
- getConsDataName :: Qualified ProperName -> Qualified ProperName
- getConsDataName con = qualifyName nm defmn con
- where
- nm = case getConsInfo con of
- Nothing -> error $ "Constructor " ++ showQualified runProperName con ++ " not in the scope of the current environment in getConsDataName."
- Just (_, pm, _, _) -> pm
- getConsInfo :: Qualified ProperName -> Maybe (DataDeclType, ProperName, Type, [Ident])
- getConsInfo con = M.lookup con dce
- where
- dce :: M.Map (Qualified ProperName) (DataDeclType, ProperName, Type, [Ident])
- dce = dataConstructors env
+ extractConstructors :: Maybe (Kind, TypeKind) -> [(ProperName 'ConstructorName, [Type])]
+ extractConstructors (Just (_, DataType _ pt)) = pt
+ extractConstructors _ = internalError "Data name not in the scope of the current environment in extractConstructors"
lnte :: Maybe (Kind, TypeKind)
lnte = M.lookup qpn (types env)
- extractConstructors :: Maybe (Kind, TypeKind) -> [(ProperName, [Type])]
- extractConstructors (Just (_, DataType _ pt)) = pt
- extractConstructors _ = internalError "Data name not in the scope of the current environment in extractConstructors"
+ qpn :: Qualified (ProperName 'TypeName)
+ qpn = getConsDataName n
+
+ getConsDataName :: Qualified (ProperName 'ConstructorName) -> Qualified (ProperName 'TypeName)
+ getConsDataName con =
+ case getConsInfo con of
+ Nothing -> internalError $ "Constructor " ++ showQualified runProperName con ++ " not in the scope of the current environment in getConsDataName."
+ Just (_, pm, _, _) -> qualifyName pm defmn con
+
+ getConsInfo :: Qualified (ProperName 'ConstructorName) -> Maybe (DataDeclType, ProperName 'TypeName, Type, [Ident])
+ getConsInfo con = M.lookup con (dataConstructors env)
-- |
-- Replicates a wildcard binder
@@ -120,7 +106,7 @@ genericMerge f bsl@((s, b):bs) bsr@((s', b'):bs')
-- Find the uncovered set between two binders:
-- the first binder is the case we are trying to cover, the second one is the matching binder
--
-missingCasesSingle :: Environment -> ModuleName -> Binder -> Binder -> ([Binder], Either RedudancyError Bool)
+missingCasesSingle :: Environment -> ModuleName -> Binder -> Binder -> ([Binder], Either RedundancyError Bool)
missingCasesSingle _ _ _ NullBinder = ([], return True)
missingCasesSingle _ _ _ (VarBinder _) = ([], return True)
missingCasesSingle env mn (VarBinder _) b = missingCasesSingle env mn NullBinder b
@@ -189,7 +175,7 @@ missingCasesSingle _ _ b _ = ([b], Left Unknown)
-- redundant or not, but uncovered at least. If we use `y` instead, we'll need to have a redundancy checker
-- (which ought to be available soon), or increase the complexity of the algorithm.
--
-missingCasesMultiple :: Environment -> ModuleName -> [Binder] -> [Binder] -> ([[Binder]], Either RedudancyError Bool)
+missingCasesMultiple :: Environment -> ModuleName -> [Binder] -> [Binder] -> ([[Binder]], Either RedundancyError Bool)
missingCasesMultiple env mn = go
where
go [] [] = ([], pure True)
@@ -217,16 +203,17 @@ isExhaustiveGuard (Left gs) = not . null $ filter (\(g, _) -> isOtherwise g) gs
isOtherwise :: Expr -> Bool
isOtherwise (TypedValue _ (BooleanLiteral True) _) = True
isOtherwise (TypedValue _ (Var (Qualified (Just (ModuleName [ProperName "Prelude"])) (Ident "otherwise"))) _) = True
+ isOtherwise (TypedValue _ (Var (Qualified (Just (ModuleName [ProperName "Data", ProperName "Boolean"])) (Ident "otherwise"))) _) = True
isOtherwise _ = False
isExhaustiveGuard (Right _) = True
-- |
-- Returns the uncovered set of case alternatives
--
-missingCases :: Environment -> ModuleName -> [Binder] -> CaseAlternative -> ([[Binder]], Either RedudancyError Bool)
+missingCases :: Environment -> ModuleName -> [Binder] -> CaseAlternative -> ([[Binder]], Either RedundancyError Bool)
missingCases env mn uncovered ca = missingCasesMultiple env mn uncovered (caseAlternativeBinders ca)
-missingAlternative :: Environment -> ModuleName -> CaseAlternative -> [Binder] -> ([[Binder]], Either RedudancyError Bool)
+missingAlternative :: Environment -> ModuleName -> CaseAlternative -> [Binder] -> ([[Binder]], Either RedundancyError Bool)
missingAlternative env mn ca uncovered
| isExhaustiveGuard (caseAlternativeResult ca) = mcases
| otherwise = ([uncovered], snd mcases)
@@ -239,16 +226,16 @@ missingAlternative env mn ca uncovered
-- it partitions that set with the new uncovered cases, until it consumes the whole set of clauses.
-- Then, returns the uncovered set of case alternatives.
--
-checkExhaustive :: forall m. (MonadWriter MultipleErrors m) => Environment -> ModuleName -> Int -> [CaseAlternative] -> m ()
-checkExhaustive env mn numArgs cas = makeResult . first nub $ foldl' step ([initialize numArgs], (pure True, [])) cas
+checkExhaustive :: forall m. (MonadWriter MultipleErrors m) => Bool -> Environment -> ModuleName -> Int -> [CaseAlternative] -> m ()
+checkExhaustive hasConstraint env mn numArgs cas = makeResult . first nub $ foldl' step ([initialize numArgs], (pure True, [])) cas
where
- step :: ([[Binder]], (Either RedudancyError Bool, [[Binder]])) -> CaseAlternative -> ([[Binder]], (Either RedudancyError Bool, [[Binder]]))
+ step :: ([[Binder]], (Either RedundancyError Bool, [[Binder]])) -> CaseAlternative -> ([[Binder]], (Either RedundancyError Bool, [[Binder]]))
step (uncovered, (nec, redundant)) ca =
let (missed, pr) = unzip (map (missingAlternative env mn ca) uncovered)
(missed', approx) = splitAt 10000 (nub (concat missed))
- cond = liftA2 (&&) (or <$> sequenceA pr) nec
+ cond = or <$> sequenceA pr
in (missed', ( if null approx
- then cond
+ then liftA2 (&&) cond nec
else Left Incomplete
, if either (const True) id cond
then redundant
@@ -256,15 +243,15 @@ checkExhaustive env mn numArgs cas = makeResult . first nub $ foldl' step ([init
)
)
- makeResult :: ([[Binder]], (Either RedudancyError Bool, [[Binder]])) -> m ()
+ makeResult :: ([[Binder]], (Either RedundancyError Bool, [[Binder]])) -> m ()
makeResult (bss, (rr, bss')) =
- do unless (null bss) tellExhaustive
+ do unless (hasConstraint || null bss) tellNonExhaustive
unless (null bss') tellRedundant
case rr of
- Left Incomplete -> tellIncomplete
+ Left Incomplete -> unless hasConstraint tellIncomplete
_ -> return ()
where
- tellExhaustive = tell . errorMessage . uncurry NotExhaustivePattern . second null . splitAt 5 $ bss
+ tellNonExhaustive = tell . errorMessage . uncurry NotExhaustivePattern . second null . splitAt 5 $ bss
tellRedundant = tell . errorMessage . uncurry OverlappingPattern . second null . splitAt 5 $ bss'
tellIncomplete = tell . errorMessage $ IncompleteExhaustivityCheck
@@ -279,29 +266,43 @@ checkExhaustiveDecls env mn = mapM_ onDecl
where
convert :: (Ident, NameKind, Expr) -> Declaration
convert (name, nk, e) = ValueDeclaration name nk [] (Right e)
- onDecl (ValueDeclaration name _ _ (Right e)) = censor (addHint (ErrorInValueDeclaration name)) (onExpr e)
+ onDecl (ValueDeclaration name _ _ (Right e)) = censor (addHint (ErrorInValueDeclaration name)) (onExpr False e)
onDecl (PositionedDeclaration pos _ dec) = censor (addHint (PositionedError pos)) (onDecl dec)
onDecl _ = return ()
- onExpr :: Expr -> m ()
- onExpr (UnaryMinus e) = onExpr e
- onExpr (ArrayLiteral es) = mapM_ onExpr es
- onExpr (ObjectLiteral es) = mapM_ (onExpr . snd) es
- onExpr (TypeClassDictionaryConstructorApp _ e) = onExpr e
- onExpr (Accessor _ e) = onExpr e
- onExpr (ObjectUpdate o es) = onExpr o >> mapM_ (onExpr . snd) es
- onExpr (Abs _ e) = onExpr e
- onExpr (App e1 e2) = onExpr e1 >> onExpr e2
- onExpr (IfThenElse e1 e2 e3) = onExpr e1 >> onExpr e2 >> onExpr e3
- onExpr (Case es cas) = checkExhaustive env mn (length es) cas >> mapM_ onExpr es >> mapM_ onCaseAlternative cas
- onExpr (TypedValue _ e _) = onExpr e
- onExpr (Let ds e) = mapM_ onDecl ds >> onExpr e
- onExpr (PositionedValue pos _ e) = censor (addHint (PositionedError pos)) (onExpr e)
- onExpr _ = return ()
-
- onCaseAlternative :: CaseAlternative -> m ()
- onCaseAlternative (CaseAlternative _ (Left es)) = mapM_ (\(e, g) -> onExpr e >> onExpr g) es
- onCaseAlternative (CaseAlternative _ (Right e)) = onExpr e
+ onExpr :: Bool -> Expr -> m ()
+ onExpr isP (UnaryMinus e) = onExpr isP e
+ onExpr isP (ArrayLiteral es) = mapM_ (onExpr isP) es
+ onExpr isP (ObjectLiteral es) = mapM_ (onExpr isP . snd) es
+ onExpr isP (TypeClassDictionaryConstructorApp _ e) = onExpr isP e
+ onExpr isP (Accessor _ e) = onExpr isP e
+ onExpr isP (ObjectUpdate o es) = onExpr isP o >> mapM_ (onExpr isP . snd) es
+ onExpr isP (Abs _ e) = onExpr isP e
+ onExpr isP (App e1 e2) = onExpr isP e1 >> onExpr isP e2
+ onExpr isP (IfThenElse e1 e2 e3) = onExpr isP e1 >> onExpr isP e2 >> onExpr isP e3
+ onExpr isP (Case es cas) = checkExhaustive isP env mn (length es) cas >> mapM_ (onExpr isP) es >> mapM_ (onCaseAlternative isP) cas
+ onExpr isP (TypedValue _ e ty) = onExpr (isP || hasPartialConstraint ty) e
+ onExpr isP (Let ds e) = mapM_ onDecl ds >> onExpr isP e
+ onExpr isP (PositionedValue pos _ e) = censor (addHint (PositionedError pos)) (onExpr isP e)
+ onExpr _ _ = return ()
+
+ onCaseAlternative :: Bool -> CaseAlternative -> m ()
+ onCaseAlternative isP (CaseAlternative _ (Left es)) = mapM_ (\(e, g) -> onExpr isP e >> onExpr isP g) es
+ onCaseAlternative isP (CaseAlternative _ (Right e)) = onExpr isP e
+
+ hasPartialConstraint :: Type -> Bool
+ hasPartialConstraint (ConstrainedType cs _) = any (go . fst) cs
+ where
+ go :: Qualified (ProperName 'ClassName) -> Bool
+ go qname
+ | qname == partialClass = True
+ | otherwise =
+ case qname `M.lookup` typeClasses env of
+ Just ([], _, cs') -> any (go . fst) cs'
+ _ -> False
+ partialClass :: Qualified (ProperName 'ClassName)
+ partialClass = primName "Partial"
+ hasPartialConstraint _ = False
-- |
-- Exhaustivity checking over a single module
diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs
index 01f195a..6ac06e9 100644
--- a/src/Language/PureScript/Linter/Imports.hs
+++ b/src/Language/PureScript/Linter/Imports.hs
@@ -1,21 +1,27 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
-module Language.PureScript.Linter.Imports (findUnusedImports, Name(..), UsedImports()) where
+module Language.PureScript.Linter.Imports
+ ( lintImports
+ , Name(..)
+ , UsedImports()
+ ) where
import Prelude ()
import Prelude.Compat
-import qualified Data.Map as M
-import Data.Maybe (mapMaybe)
-import Data.List ((\\), find, intersect)
+import Control.Monad (unless, when)
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.Writer.Class
-import Control.Monad(unless,when)
+
import Data.Foldable (forM_)
+import Data.List ((\\), find, intersect, nub)
+import Data.Maybe (mapMaybe)
+import qualified Data.Map as M
import Language.PureScript.AST.Declarations
import Language.PureScript.AST.SourcePos
+import Language.PureScript.Crash
import Language.PureScript.Names as P
import Language.PureScript.Errors
@@ -25,88 +31,273 @@ import Language.PureScript.Sugar.Names.Imports
import qualified Language.PureScript.Constants as C
-- | Imported name used in some type or expression.
-data Name = IdentName (Qualified Ident) | IsProperName (Qualified ProperName) | DctorName (Qualified ProperName)
+data Name
+ = IdentName (Qualified Ident)
+ | TyName (Qualified (ProperName 'TypeName))
+ | DctorName (Qualified (ProperName 'ConstructorName))
+ | TyClassName (Qualified (ProperName 'ClassName))
+ deriving (Eq, Show)
+
+getIdentName :: Maybe ModuleName -> Name -> Maybe Ident
+getIdentName q (IdentName (Qualified q' name)) | q == q' = Just name
+getIdentName _ _ = Nothing
+
+getTypeName :: Maybe ModuleName -> Name -> Maybe (ProperName 'TypeName)
+getTypeName q (TyName (Qualified q' name)) | q == q' = Just name
+getTypeName _ _ = Nothing
+
+getClassName :: Maybe ModuleName -> Name -> Maybe (ProperName 'ClassName)
+getClassName q (TyClassName (Qualified q' name)) | q == q' = Just name
+getClassName _ _ = Nothing
-- | Map of module name to list of imported names from that module which have been used.
type UsedImports = M.Map ModuleName [Name]
-- |
--- Find and warn on any unused import statements (qualified or unqualified)
--- or references in an explicit import list.
+-- Find and warn on:
+--
+-- * Unused import statements (qualified or unqualified)
+--
+-- * Unused references in an explicit import list
--
-findUnusedImports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Module -> Env -> UsedImports -> m ()
-findUnusedImports (Module _ _ _ mdecls mexports) env usedImps = do
- imps <- findImports mdecls
- forM_ (M.toAscList imps) $ \(mni, decls) -> unless (mni `elem` alwaysUsedModules) $
- forM_ decls $ \(ss, declType, qualifierName) ->
- censor (onErrorMessages $ addModuleLocError ss) $ unless (qnameUsed qualifierName) $
- let names = sugarNames mni ++ M.findWithDefault [] mni usedImps
- usedNames = mapMaybe (matchName (typeForDCtor mni) qualifierName) names
- usedDctors = mapMaybe (matchDctor qualifierName) names
- in case declType of
- Implicit -> when (null usedNames) $ tell $ errorMessage $ UnusedImport mni
- Explicit declrefs -> do
- let idents = mapMaybe runDeclRef declrefs
- let diff = idents \\ usedNames
- case (length diff, length idents) of
- (0, _) -> return ()
- (n, m) | n == m -> tell $ errorMessage $ UnusedImport mni
- _ -> tell $ errorMessage $ UnusedExplicitImport mni diff
-
- -- If we've not already warned a type is unused, check its data constructors
- forM_ (mapMaybe getTypeRef declrefs) $ \(tn, c) -> do
- let allCtors = dctorsForType mni tn
- when (runProperName tn `elem` usedNames) $ case (c, null $ usedDctors `intersect` allCtors) of
- (Nothing, True) -> tell $ errorMessage $ UnusedDctorImport tn
- (Just (_:_), True) -> tell $ errorMessage $ UnusedDctorImport tn
- (Just ctors, _) ->
- let ddiff = ctors \\ usedDctors
- in unless (null ddiff) $ tell $ errorMessage $ UnusedDctorExplicitImport tn ddiff
- _ -> return ()
- return ()
-
- _ -> return ()
+-- * Implicit imports of modules
+--
+-- * Implicit imports into a virtual module (unless the virtual module only has
+-- members from one module imported)
+--
+-- * Imports using `hiding` (this is another form of implicit importing)
+--
+lintImports
+ :: forall m
+ . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+ => Module
+ -> Env
+ -> UsedImports
+ -> m ()
+lintImports (Module _ _ mn mdecls mexports) env usedImps = do
+
+ let scope = maybe nullImports (\(_, imps, _) -> imps) (M.lookup mn env)
+ usedImps' = foldr (elaborateUsed scope) usedImps exportedModules
+
+ imps <- M.toAscList <$> findImports mdecls
+
+ forM_ imps $ \(mni, decls) ->
+ unless (isPrim mni) $ do
+ forM_ decls $ \(ss, declType, qualifierName) ->
+ censor (onErrorMessages $ addModuleLocError ss) $ do
+ let names = nub $ M.findWithDefault [] mni usedImps'
+ lintImportDecl env mni qualifierName names declType
+
+ forM_ (M.toAscList (byQual imps)) $ \(mnq, entries) -> do
+ let mnis = nub $ map (\(_, _, mni) -> mni) entries
+ unless (length mnis == 1) $ do
+ let implicits = filter (\(_, declType, _) -> not $ isExplicit declType) entries
+ forM_ implicits $ \(ss, _, mni) ->
+ censor (onErrorMessages $ addModuleLocError ss) $ do
+ let names = nub $ M.findWithDefault [] mni usedImps'
+ usedRefs = findUsedRefs env mni (Just mnq) names
+ unless (null usedRefs) $
+ tell $ errorMessage $ ImplicitQualifiedImport mni mnq usedRefs
+
+ return ()
+
where
- sugarNames :: ModuleName -> [ Name ]
- sugarNames (ModuleName [ProperName n]) | n == C.prelude = [ IdentName $ Qualified Nothing (Ident C.bind) ]
- sugarNames _ = []
- -- rely on exports being elaborated by this point
- alwaysUsedModules :: [ ModuleName ]
- alwaysUsedModules = ModuleName [ProperName C.prim] : maybe [] (mapMaybe isExport) mexports
+ -- Checks whether a module is the Prim module - used to suppress any checks
+ -- made, as Prim is always implicitly imported.
+ isPrim :: ModuleName -> Bool
+ isPrim = (== ModuleName [ProperName C.prim])
+
+ -- Creates a map of virtual modules mapped to all the declarations that
+ -- import to that module, with the corresponding source span, import type,
+ -- and module being imported
+ byQual
+ :: [(ModuleName, [(Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)])]
+ -> M.Map ModuleName [(Maybe SourceSpan, ImportDeclarationType, ModuleName)]
+ byQual = foldr goImp M.empty
where
- isExport (ModuleRef mn) = Just mn
- isExport _ = Nothing
+ goImp (mni, xs) acc = foldr (goDecl mni) acc xs
+ goDecl mni (ss, declType, Just qmn) acc =
+ let entry = (ss, declType, mni)
+ in M.alter (Just . maybe [entry] (entry :)) qmn acc
+ goDecl _ _ acc = acc
- qnameUsed :: Maybe ModuleName -> Bool
- qnameUsed (Just qn) = qn `elem` alwaysUsedModules
- qnameUsed Nothing = False
+ -- The list of modules that are being re-exported by the current module. Any
+ -- module that appears in this list is always considered to be used.
+ exportedModules :: [ModuleName]
+ exportedModules = nub $ maybe [] (mapMaybe extractModule) mexports
+ where
+ extractModule (PositionedDeclarationRef _ _ r) = extractModule r
+ extractModule (ModuleRef mne) = Just mne
+ extractModule _ = Nothing
+
+ -- Elaborates the UsedImports to include values from modules that are being
+ -- re-exported. This ensures explicit export hints are printed for modules
+ -- that are implicitly exported and then re-exported.
+ elaborateUsed :: Imports -> ModuleName -> UsedImports -> UsedImports
+ elaborateUsed scope mne used =
+ let classes = extractByQual mne (importedTypeClasses scope) TyClassName
+ types = extractByQual mne (importedTypes scope) TyName
+ dctors = extractByQual mne (importedDataConstructors scope) DctorName
+ values = extractByQual mne (importedValues scope) IdentName
+ in foldr go used (classes ++ types ++ dctors ++ values)
+ where
+ go :: (ModuleName, Name) -> UsedImports -> UsedImports
+ go (q, name) acc = M.alter (Just . maybe [name] (name :)) q acc
+
+ extractByQual
+ :: (Eq a)
+ => ModuleName
+ -> M.Map (Qualified a) [(Qualified a, ModuleName)]
+ -> (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
+ Qualified (Just mn') name -> Just (mn', toName $ Qualified mnq name)
+ _ -> internalError "unqualified name in extractByQual"
+ go _ = Nothing
+
+lintImportDecl
+ :: forall m
+ . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+ => Env
+ -> ModuleName
+ -> Maybe ModuleName
+ -> [Name]
+ -> ImportDeclarationType
+ -> m ()
+lintImportDecl env mni qualifierName names declType =
+ case declType of
+ Implicit -> case qualifierName of
+ Nothing -> checkImplicit ImplicitImport
+ Just q ->
+ let usedModuleNames = mapMaybe extractQualName names
+ in unless (q `elem` usedModuleNames) unused
+ Hiding _ -> checkImplicit HidingImport
+ Explicit [] -> unused
+ Explicit declrefs -> checkExplicit declrefs
+
+ where
+
+ checkImplicit
+ :: (ModuleName -> [DeclarationRef] -> SimpleErrorMessage)
+ -> m ()
+ checkImplicit warning =
+ if null allRefs
+ then unused
+ else tell $ errorMessage $ warning mni allRefs
+
+ checkExplicit
+ :: [DeclarationRef]
+ -> m ()
+ checkExplicit declrefs = do
+ let idents = nub (mapMaybe runDeclRef declrefs)
+ dctors = mapMaybe (matchDctor qualifierName) names
+ usedNames = mapMaybe (matchName (typeForDCtor mni) qualifierName) names
+ diff = idents \\ usedNames
+ case (length diff, length idents) of
+ (0, _) -> return ()
+ (n, m) | n == m -> unused
+ _ -> tell $ errorMessage $ UnusedExplicitImport mni diff qualifierName allRefs
- dtys :: ModuleName -> [((ProperName, [ProperName]), ModuleName)]
+ -- If we've not already warned a type is unused, check its data constructors
+ forM_ (mapMaybe getTypeRef declrefs) $ \(tn, c) -> do
+ let allCtors = dctorsForType mni tn
+ when (runProperName tn `elem` usedNames) $ case (c, dctors `intersect` allCtors) of
+ (_, []) | c /= Just [] ->
+ tell $ errorMessage $ UnusedDctorImport tn
+ (Just ctors, dctors') ->
+ let ddiff = ctors \\ dctors'
+ in unless (null ddiff) $ tell $ errorMessage $ UnusedDctorExplicitImport tn ddiff
+ _ -> return ()
+ return ()
+
+ unused :: m ()
+ unused = tell $ errorMessage $ UnusedImport mni
+
+ allRefs :: [DeclarationRef]
+ allRefs = findUsedRefs env mni qualifierName names
+
+ dtys
+ :: ModuleName
+ -> [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]
dtys mn = maybe [] exportedTypes $ envModuleExports <$> mn `M.lookup` env
- dctorsForType :: ModuleName -> ProperName -> [ProperName]
+ dctorsForType
+ :: ModuleName
+ -> ProperName 'TypeName
+ -> [ProperName 'ConstructorName]
dctorsForType mn tn =
maybe [] getDctors (find matches $ dtys mn)
where
matches ((ty, _),_) = ty == tn
getDctors ((_,ctors),_) = ctors
- typeForDCtor :: ModuleName -> ProperName -> Maybe ProperName
+ typeForDCtor
+ :: ModuleName
+ -> ProperName 'ConstructorName
+ -> Maybe (ProperName 'TypeName)
typeForDCtor mn pn =
getTy <$> find matches (dtys mn)
where
matches ((_, ctors), _) = pn `elem` ctors
getTy ((ty, _), _) = ty
+findUsedRefs :: Env -> ModuleName -> Maybe ModuleName -> [Name] -> [DeclarationRef]
+findUsedRefs env mni qualifierName names =
+ let
+ classRefs = TypeClassRef <$> mapMaybe (getClassName qualifierName) names
+ valueRefs = ValueRef <$> mapMaybe (getIdentName qualifierName) names
+ types = mapMaybe (getTypeName qualifierName) names
+ dctors = mapMaybe (matchDctor qualifierName) names
+ typesWithDctors = reconstructTypeRefs dctors
+ typesWithoutDctors = filter (`M.notMember` typesWithDctors) types
+ typesRefs
+ = map (flip TypeRef (Just [])) typesWithoutDctors
+ ++ map (\(ty, ds) -> TypeRef ty (Just ds)) (M.toList typesWithDctors)
+ in classRefs ++ typesRefs ++ valueRefs
+
+ where
-matchName :: (ProperName -> Maybe ProperName) -> Maybe ModuleName -> Name -> Maybe String
+ reconstructTypeRefs
+ :: [ProperName 'ConstructorName]
+ -> M.Map (ProperName 'TypeName) [ProperName 'ConstructorName]
+ reconstructTypeRefs = foldr accumDctors M.empty
+ where
+ accumDctors dctor = M.alter (Just . maybe [dctor] (dctor :)) (findTypeForDctor mni dctor)
+
+ findTypeForDctor
+ :: ModuleName
+ -> ProperName 'ConstructorName
+ -> ProperName 'TypeName
+ findTypeForDctor mn dctor =
+ case mn `M.lookup` env of
+ Just (_, _, exps) ->
+ case find (elem dctor . snd . fst) (exportedTypes exps) of
+ Just ((ty, _), _) -> ty
+ Nothing -> internalError $ "missing type for data constructor " ++ runProperName dctor ++ " in findTypeForDctor"
+ Nothing -> internalError $ "missing module " ++ runModuleName mn ++ " in findTypeForDctor"
+
+matchName
+ :: (ProperName 'ConstructorName -> Maybe (ProperName 'TypeName))
+ -> Maybe ModuleName
+ -> Name
+ -> Maybe String
matchName _ qual (IdentName (Qualified q x)) | q == qual = Just $ showIdent x
-matchName _ qual (IsProperName (Qualified q x)) | q == qual = Just $ runProperName x
+matchName _ qual (TyName (Qualified q x)) | q == qual = Just $ runProperName x
+matchName _ qual (TyClassName (Qualified q x)) | q == qual = Just $ runProperName x
matchName lookupDc qual (DctorName (Qualified q x)) | q == qual = runProperName <$> lookupDc x
matchName _ _ _ = Nothing
-matchDctor :: Maybe ModuleName -> Name -> Maybe ProperName
+extractQualName :: Name -> Maybe ModuleName
+extractQualName (IdentName (Qualified q _)) = q
+extractQualName (TyName (Qualified q _)) = q
+extractQualName (TyClassName (Qualified q _)) = q
+extractQualName (DctorName (Qualified q _)) = q
+
+matchDctor :: Maybe ModuleName -> Name -> Maybe (ProperName 'ConstructorName)
matchDctor qual (DctorName (Qualified q x)) | q == qual = Just x
matchDctor _ _ = Nothing
@@ -114,9 +305,12 @@ runDeclRef :: DeclarationRef -> Maybe String
runDeclRef (PositionedDeclarationRef _ _ ref) = runDeclRef ref
runDeclRef (ValueRef ident) = Just $ showIdent ident
runDeclRef (TypeRef pn _) = Just $ runProperName pn
+runDeclRef (TypeClassRef pn) = Just $ runProperName pn
runDeclRef _ = Nothing
-getTypeRef :: DeclarationRef -> Maybe (ProperName, Maybe [ProperName])
+getTypeRef
+ :: DeclarationRef
+ -> Maybe (ProperName 'TypeName, Maybe [ProperName 'ConstructorName])
getTypeRef (PositionedDeclarationRef _ _ ref) = getTypeRef ref
getTypeRef (TypeRef pn x) = Just (pn, x)
getTypeRef _ = Nothing
diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs
index 4888ca6..cf9898d 100644
--- a/src/Language/PureScript/Make.hs
+++ b/src/Language/PureScript/Make.hs
@@ -1,18 +1,3 @@
------------------------------------------------------------------------------
---
--- Module : Make
--- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
--- License : MIT (http://opensource.org/licenses/MIT)
---
--- Maintainer : Phil Freeman <paf31@cantab.net>
--- Stability : experimental
--- Portability :
---
--- |
---
------------------------------------------------------------------------------
-
-{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TupleSections #-}
@@ -63,6 +48,7 @@ import Data.Traversable (for)
import Data.Version (showVersion)
import Data.Aeson (encode, decode)
import qualified Data.ByteString.Lazy as B
+import qualified Data.ByteString.UTF8 as BU8
import qualified Data.Set as S
import qualified Data.Map as M
@@ -70,6 +56,7 @@ import System.Directory
(doesFileExist, getModificationTime, createDirectoryIfMissing)
import System.FilePath ((</>), takeDirectory)
import System.IO.Error (tryIOError)
+import System.IO.UTF8 (readUTF8File, writeUTF8File)
import Language.PureScript.Crash
import Language.PureScript.AST
@@ -123,7 +110,7 @@ data MakeActions m = MakeActions {
-- |
-- Read the externs file for a module as a string and also return the actual
-- path for the file.
- , readExterns :: ModuleName -> m (FilePath, B.ByteString)
+ , readExterns :: ModuleName -> m (FilePath, Externs)
-- |
-- Run the code generator for the module and write any required output files.
--
@@ -137,7 +124,7 @@ data MakeActions m = MakeActions {
-- |
-- Generated code for an externs file.
--
-type Externs = B.ByteString
+type Externs = String
-- |
-- Determines when to rebuild a module
@@ -223,15 +210,16 @@ make MakeActions{..} ms = do
progress $ CompilingModule moduleName
let env = foldl' (flip applyExternsFileToEnvironment) initEnvironment externs
lint m
- ([desugared], nextVar) <- runSupplyT 0 $ desugar externs [m]
- (checked@(Module ss coms _ elaborated exps), env') <- runCheck' env $ typeCheckModule desugared
+ ((checked@(Module ss coms _ elaborated exps), env'), nextVar) <- runSupplyT 0 $ do
+ [desugared] <- desugar externs [m]
+ runCheck' env $ typeCheckModule desugared
checkExhaustiveModule env' checked
regrouped <- createBindingGroups moduleName . collapseBindingGroups $ elaborated
let mod' = Module ss coms moduleName regrouped exps
corefn = CF.moduleToCoreFn env' mod'
[renamed] = renameInModules [corefn]
exts = moduleToExternsFile mod' env'
- evalSupplyT nextVar $ codegen renamed env' $ encode exts
+ evalSupplyT nextVar . codegen renamed env' . BU8.toString . B.toStrict . encode $ exts
return exts
markComplete (Just (warnings, exts)) Nothing
@@ -258,24 +246,12 @@ make MakeActions{..} ms = do
shouldExist (Just t) = t
shouldExist _ = internalError "make: dependency should already have been built."
- decodeExterns :: B.ByteString -> Maybe ExternsFile
+ decodeExterns :: Externs -> Maybe ExternsFile
decodeExterns bs = do
- externs <- decode bs
+ externs <- decode (fromString bs)
guard $ efVersion externs == showVersion Paths.version
return externs
--- |
--- Add an import declaration for a module if it does not already explicitly import it.
---
-addDefaultImport :: ModuleName -> Module -> Module
-addDefaultImport toImport m@(Module ss coms mn decls exps) =
- if isExistingImport `any` decls || mn == toImport then m
- else Module ss coms mn (ImportDeclaration toImport Implicit Nothing : decls) exps
- where
- isExistingImport (ImportDeclaration mn' _ _) | mn' == toImport = True
- isExistingImport (PositionedDeclaration _ _ d) = isExistingImport d
- isExistingImport _ = False
-
importPrim :: Module -> Module
importPrim = addDefaultImport (ModuleName [ProperName C.prim])
@@ -335,7 +311,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
externsFile = outputDir </> filePath </> "externs.json"
min <$> getTimestamp jsFile <*> getTimestamp externsFile
- readExterns :: ModuleName -> Make (FilePath, B.ByteString)
+ readExterns :: ModuleName -> Make (FilePath, Externs)
readExterns mn = do
let path = outputDir </> runModuleName mn </> "externs.json"
(path, ) <$> readTextFile path
@@ -371,13 +347,13 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
exists <- doesFileExist path
traverse (const $ getModificationTime path) $ guard exists
- readTextFile :: FilePath -> Make B.ByteString
- readTextFile path = makeIO (const (ErrorMessage [] $ CannotReadFile path)) $ B.readFile path
+ readTextFile :: FilePath -> Make String
+ readTextFile path = makeIO (const (ErrorMessage [] $ CannotReadFile path)) $ readUTF8File path
- writeTextFile :: FilePath -> B.ByteString -> Make ()
+ writeTextFile :: FilePath -> String -> Make ()
writeTextFile path text = makeIO (const (ErrorMessage [] $ CannotWriteFile path)) $ do
mkdirp path
- B.writeFile path text
+ writeUTF8File path text
where
mkdirp :: FilePath -> IO ()
mkdirp = createDirectoryIfMissing True . takeDirectory
diff --git a/src/Language/PureScript/ModuleDependencies.hs b/src/Language/PureScript/ModuleDependencies.hs
index 9e22c65..b1f3e84 100644
--- a/src/Language/PureScript/ModuleDependencies.hs
+++ b/src/Language/PureScript/ModuleDependencies.hs
@@ -23,7 +23,7 @@ import Control.Monad.Error.Class (MonadError(..))
import Data.Graph
import Data.List (nub)
-import Data.Maybe (fromMaybe, mapMaybe)
+import Data.Maybe (fromMaybe)
import Language.PureScript.Crash
import Language.PureScript.AST
@@ -54,21 +54,24 @@ sortModules ms = do
-- Calculate a list of used modules based on explicit imports and qualified names
--
usedModules :: Declaration -> [ModuleName]
-usedModules = let (f, _, _, _, _) = everythingOnValues (++) forDecls forValues (const []) (const []) (const []) in nub . f
+usedModules d =
+ let (f, _, _, _, _) = everythingOnValues (++) forDecls forValues (const []) (const []) (const [])
+ (g, _, _, _, _) = accumTypes (everythingOnTypes (++) forTypes)
+ in nub (f d ++ g d)
where
forDecls :: Declaration -> [ModuleName]
- forDecls (ImportDeclaration mn _ _) = [mn]
+ forDecls (ImportDeclaration mn _ _ _) = [mn]
+ forDecls (FixityDeclaration _ _ (Just (Qualified (Just mn) _))) = [mn]
+ forDecls (TypeInstanceDeclaration _ _ (Qualified (Just mn) _) _ _) = [mn]
forDecls _ = []
forValues :: Expr -> [ModuleName]
forValues (Var (Qualified (Just mn) _)) = [mn]
forValues (Constructor (Qualified (Just mn) _)) = [mn]
- forValues (TypedValue _ _ ty) = forTypes ty
forValues _ = []
forTypes :: Type -> [ModuleName]
forTypes (TypeConstructor (Qualified (Just mn) _)) = [mn]
- forTypes (ConstrainedType cs _) = mapMaybe (\(Qualified mn _, _) -> mn) cs
forTypes _ = []
-- |
diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs
index 1b003d2..99a55c7 100644
--- a/src/Language/PureScript/Names.hs
+++ b/src/Language/PureScript/Names.hs
@@ -1,31 +1,19 @@
------------------------------------------------------------------------------
---
--- Module : Language.PureScript.Names
--- Copyright : (c) Phil Freeman 2013
--- License : MIT
---
--- Maintainer : Phil Freeman <paf31@cantab.net>
--- Stability : experimental
--- Portability :
---
--- |
--- Data types for names
---
------------------------------------------------------------------------------
-
-{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE GADTs #-}
+{-# LANGUAGE EmptyDataDecls #-}
+{-# LANGUAGE KindSignatures #-}
+-- |
+-- Data types for names
+--
module Language.PureScript.Names where
+import Control.Monad (liftM)
+import Control.Monad.Supply.Class
+
import Data.List
-import Data.Data
-import Data.List.Split (splitOn)
+import Data.Aeson
import Data.Aeson.TH
-import qualified Data.Aeson as A
-import qualified Data.Text as T
-- |
-- Names for value identifiers
@@ -38,25 +26,59 @@ data Ident
-- |
-- A symbolic name for an infix operator
--
- | Op String deriving (Show, Read, Eq, Ord, Data, Typeable)
+ | Op String
+ -- |
+ -- A generated name for an identifier
+ --
+ | GenIdent (Maybe String) Integer
+ deriving (Show, Read, Eq, Ord)
runIdent :: Ident -> String
runIdent (Ident i) = i
runIdent (Op op) = op
+runIdent (GenIdent Nothing n) = "$" ++ show n
+runIdent (GenIdent (Just name) n) = "$" ++ name ++ show n
showIdent :: Ident -> String
-showIdent (Ident i) = i
showIdent (Op op) = '(' : op ++ ")"
+showIdent i = runIdent i
+
+freshIdent :: (MonadSupply m) => String -> m Ident
+freshIdent name = liftM (GenIdent (Just name)) fresh
+
+freshIdent' :: (MonadSupply m) => m Ident
+freshIdent' = liftM (GenIdent Nothing) fresh
-- |
-- Proper names, i.e. capitalized names for e.g. module names, type//data constructors.
--
-newtype ProperName = ProperName { runProperName :: String } deriving (Show, Read, Eq, Ord, Data, Typeable)
+newtype ProperName (a :: ProperNameType) = ProperName { runProperName :: String }
+ deriving (Show, Read, Eq, Ord)
+
+instance ToJSON (ProperName a) where
+ toJSON = toJSON . runProperName
+
+instance FromJSON (ProperName a) where
+ parseJSON = fmap ProperName . parseJSON
+
+-- |
+-- The closed set of proper name types.
+--
+data ProperNameType = TypeName | ConstructorName | ClassName | Namespace
+
+-- |
+-- Coerces a ProperName from one ProperNameType to another. This should be used
+-- with care, and is primarily used to convert ClassNames into TypeNames after
+-- classes have been desugared.
+--
+coerceProperName :: ProperName a -> ProperName b
+coerceProperName = ProperName . runProperName
-- |
-- Module names
--
-newtype ModuleName = ModuleName [ProperName] deriving (Show, Read, Eq, Ord, Data, Typeable)
+newtype ModuleName = ModuleName [ProperName 'Namespace]
+ deriving (Show, Read, Eq, Ord)
runModuleName :: ModuleName -> String
runModuleName (ModuleName pns) = intercalate "." (runProperName `map` pns)
@@ -72,25 +94,13 @@ moduleNameFromString = ModuleName . splitProperNames
-- |
-- A qualified name, i.e. a name with an optional module name
--
-data Qualified a = Qualified (Maybe ModuleName) a deriving (Show, Read, Eq, Ord, Data, Typeable, Functor)
+data Qualified a = Qualified (Maybe ModuleName) a
+ deriving (Show, Read, Eq, Ord, Functor)
showQualified :: (a -> String) -> Qualified a -> String
showQualified f (Qualified Nothing a) = f a
showQualified f (Qualified (Just name) a) = runModuleName name ++ "." ++ f a
-instance (a ~ ProperName) => A.ToJSON (Qualified a) where
- toJSON = A.toJSON . showQualified runProperName
-
-instance (a ~ ProperName) => A.FromJSON (Qualified a) where
- parseJSON =
- A.withText "Qualified ProperName" $ \str ->
- return $ case reverse (splitOn "." (T.unpack str)) of
- [name] -> Qualified Nothing (ProperName name)
- (name:rest) -> Qualified (Just (reconstructModuleName rest)) (ProperName name)
- _ -> Qualified Nothing (ProperName "")
- where
- reconstructModuleName = moduleNameFromString . intercalate "." . reverse
-
-- |
-- Provide a default module name, if a name is unqualified
--
@@ -111,10 +121,23 @@ disqualify (Qualified _ a) = a
-- |
-- Checks whether a qualified value is actually qualified with a module reference
--
+isQualified :: Qualified a -> Bool
+isQualified (Qualified Nothing _) = False
+isQualified _ = True
+
+-- |
+-- Checks whether a qualified value is not actually qualified with a module reference
+--
isUnqualified :: Qualified a -> Bool
-isUnqualified (Qualified Nothing _) = True
-isUnqualified _ = False
+isUnqualified = not . isQualified
+
+-- |
+-- Checks whether a qualified value is qualified with a particular module
+--
+isQualifiedWith :: ModuleName -> Qualified a -> Bool
+isQualifiedWith mn (Qualified (Just mn') _) = mn == mn'
+isQualifiedWith _ _ = False
+$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Qualified)
$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Ident)
-$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ProperName)
$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ModuleName)
diff --git a/src/Language/PureScript/Parser/Common.hs b/src/Language/PureScript/Parser/Common.hs
index 2460e40..1088834 100644
--- a/src/Language/PureScript/Parser/Common.hs
+++ b/src/Language/PureScript/Parser/Common.hs
@@ -1,20 +1,8 @@
------------------------------------------------------------------------------
---
--- Module : Language.PureScript.Parser.Common
--- Copyright : (c) Phil Freeman 2013
--- License : MIT
---
--- Maintainer : Phil Freeman <paf31@cantab.net>
--- Stability : experimental
--- Portability :
---
+{-# LANGUAGE FlexibleContexts #-}
+
-- |
-- Constants, and utility functions to be used when parsing
--
------------------------------------------------------------------------------
-
-{-# LANGUAGE FlexibleContexts #-}
-
module Language.PureScript.Parser.Common where
import Control.Applicative
@@ -27,12 +15,7 @@ import Language.PureScript.Names
import qualified Text.Parsec as P
-featureWasRemoved :: String -> TokenParser a
-featureWasRemoved err = do
- pos <- P.getPosition
- error $ "It looks like you are trying to use a feature from a previous version of the compiler:\n" ++ err ++ "\nat " ++ show pos
-
-properName :: TokenParser ProperName
+properName :: TokenParser (ProperName a)
properName = ProperName <$> uname
-- |
diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs
index c48c472..0a5e004 100644
--- a/src/Language/PureScript/Parser/Declarations.hs
+++ b/src/Language/PureScript/Parser/Declarations.hs
@@ -1,22 +1,10 @@
------------------------------------------------------------------------------
---
--- Module : Language.PureScript.Parser.Declarations
--- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
--- License : MIT (http://opensource.org/licenses/MIT)
---
--- Maintainer : Phil Freeman <paf31@cantab.net>
--- Stability : experimental
--- Portability :
---
--- |
--- Parsers for module definitions and declarations
---
------------------------------------------------------------------------------
-
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
+-- |
+-- Parsers for module definitions and declarations
+--
module Language.PureScript.Parser.Declarations (
parseDeclaration,
parseModule,
@@ -45,6 +33,7 @@ import Language.PureScript.Environment
import Language.PureScript.Errors
import Language.PureScript.Kinds
import Language.PureScript.Names
+import Language.PureScript.Types
import Language.PureScript.Parser.Common
import Language.PureScript.Parser.Kinds
import Language.PureScript.Parser.Lexer
@@ -87,7 +76,7 @@ parseTypeDeclaration =
parseTypeSynonymDeclaration :: TokenParser Declaration
parseTypeSynonymDeclaration =
- TypeSynonymDeclaration <$> (P.try (reserved "type") *> indented *> properName)
+ TypeSynonymDeclaration <$> (reserved "type" *> indented *> properName)
<*> many (indented *> kindedIdent)
<*> (indented *> equals *> noWildcards parsePolyType)
@@ -113,21 +102,18 @@ parseValueDeclaration = do
return $ maybe value (`Let` value) whereClause
parseExternDeclaration :: TokenParser Declaration
-parseExternDeclaration = P.try (reserved "foreign") *> indented *> reserved "import" *> indented *>
- (ExternDataDeclaration <$> (P.try (reserved "data") *> indented *> properName)
+parseExternDeclaration = reserved "foreign" *> indented *> reserved "import" *> indented *>
+ (ExternDataDeclaration <$> (reserved "data" *> indented *> properName)
<*> (indented *> doubleColon *> parseKind)
<|> (do ident <- parseIdent
- -- TODO: add a wiki page link with migration info
- -- TODO: remove this deprecation warning in 0.8
- _ <- P.optional $ stringLiteral *> featureWasRemoved "Inline foreign string literals are no longer supported."
ty <- indented *> doubleColon *> noWildcards parsePolyType
return $ ExternDeclaration ident ty))
parseAssociativity :: TokenParser Associativity
parseAssociativity =
- (P.try (reserved "infixl") >> return Infixl) <|>
- (P.try (reserved "infixr") >> return Infixr) <|>
- (P.try (reserved "infix") >> return Infix)
+ (reserved "infixl" *> return Infixl) <|>
+ (reserved "infixr" *> return Infixr) <|>
+ (reserved "infix" *> return Infix)
parseFixity :: TokenParser Fixity
parseFixity = Fixity <$> parseAssociativity <*> (indented *> natural)
@@ -136,15 +122,16 @@ parseFixityDeclaration :: TokenParser Declaration
parseFixityDeclaration = do
fixity <- parseFixity
indented
+ alias <- P.optionMaybe $ parseQualified (Ident <$> identifier) <* reserved "as"
name <- symbol
- return $ FixityDeclaration fixity name
+ return $ FixityDeclaration fixity name alias
parseImportDeclaration :: TokenParser Declaration
parseImportDeclaration = do
- (mn, declType, asQ) <- parseImportDeclaration'
- return $ ImportDeclaration mn declType asQ
+ (mn, declType, asQ, isOldSyntax) <- parseImportDeclaration'
+ return $ ImportDeclaration mn declType asQ isOldSyntax
-parseImportDeclaration' :: TokenParser (ModuleName, ImportDeclarationType, Maybe ModuleName)
+parseImportDeclaration' :: TokenParser (ModuleName, ImportDeclarationType, Maybe ModuleName, Bool)
parseImportDeclaration' = do
reserved "import"
indented
@@ -152,16 +139,9 @@ parseImportDeclaration' = do
where
stdImport = do
moduleName' <- moduleName
- suffixHiding moduleName' <|> suffixQualifyingList moduleName'
- where
- suffixHiding mn = do
- reserved "hiding"
- declType <- qualifyingList Hiding
- return (mn, declType, Nothing)
- suffixQualifyingList mn = do
- declType <- qualifyingList Explicit
- qName <- P.optionMaybe qualifiedName
- return (mn, declType, qName)
+ declType <- reserved "hiding" *> qualifyingList Hiding <|> qualifyingList Explicit
+ qName <- P.optionMaybe qualifiedName
+ return (moduleName', declType, qName, False)
qualifiedName = reserved "as" *> moduleName
qualImport = do
reserved "qualified"
@@ -169,33 +149,30 @@ parseImportDeclaration' = do
moduleName' <- moduleName
declType <- qualifyingList Explicit
qName <- qualifiedName
- return (moduleName', declType, Just qName)
+ return (moduleName', declType, Just qName, True)
qualifyingList expectedType = do
- idents <- P.optionMaybe $ indented *> parens (commaSep parseDeclarationRef)
- return $ fromMaybe Implicit (expectedType <$> idents)
-
+ declType <- P.optionMaybe (expectedType <$> (indented *> parens (commaSep parseDeclarationRef)))
+ return $ fromMaybe Implicit declType
parseDeclarationRef :: TokenParser DeclarationRef
parseDeclarationRef =
- parseModuleRef <|>
withSourceSpan PositionedDeclarationRef
- (ValueRef <$> parseIdent
- <|> do name <- properName
- dctors <- P.optionMaybe $ parens (symbol' ".." *> pure Nothing <|> Just <$> commaSep properName)
- return $ maybe (TypeClassRef name) (TypeRef name) dctors
- )
+ $ (ValueRef <$> parseIdent)
+ <|> parseProperRef
+ <|> (TypeClassRef <$> (reserved "class" *> properName))
+ <|> (ModuleRef <$> (indented *> reserved "module" *> moduleName))
where
- parseModuleRef :: TokenParser DeclarationRef
- parseModuleRef = do
- name <- indented *> reserved "module" *> moduleName
- return $ ModuleRef name
+ parseProperRef = do
+ name <- properName
+ dctors <- P.optionMaybe $ parens (symbol' ".." *> pure Nothing <|> Just <$> commaSep properName)
+ return $ maybe (ProperRef (runProperName name)) (TypeRef name) dctors
parseTypeClassDeclaration :: TokenParser Declaration
parseTypeClassDeclaration = do
reserved "class"
- implies <- P.option [] $ do
+ implies <- P.option [] . P.try $ do
indented
- implies <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many (noWildcards parseTypeAtom)))
+ implies <- (return <$> parseConstraint) <|> parens (commaSep1 parseConstraint)
lfatArrow
return implies
className <- indented *> properName
@@ -204,13 +181,17 @@ parseTypeClassDeclaration = do
indented *> reserved "where"
indented *> mark (P.many (same *> positioned parseTypeDeclaration))
return $ TypeClassDeclaration className idents implies members
+ where
+
+parseConstraint :: TokenParser Constraint
+parseConstraint = (,) <$> parseQualified properName <*> P.many (noWildcards parseTypeAtom)
parseInstanceDeclaration :: TokenParser (TypeInstanceBody -> Declaration)
parseInstanceDeclaration = do
reserved "instance"
name <- parseIdent <* indented <* doubleColon
- deps <- P.optionMaybe $ do
- deps <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many (noWildcards parseTypeAtom)))
+ deps <- P.optionMaybe $ P.try $ do
+ deps <- (return <$> parseConstraint) <|> parens (commaSep1 parseConstraint)
indented
rfatArrow
return deps
@@ -341,12 +322,13 @@ parseIdentifierAndValue =
return (name, b)
<|> (,) <$> (C.indented *> stringLiteral) <*> rest
where
- rest = C.indented *> colon *> C.indented *> val
- val = (Just <$> parseValue) <|> (underscore *> pure Nothing)
+ rest = C.indented *> colon *> C.indented *> val
+ val = P.try (Just <$> parseValue) <|> (underscore *> pure Nothing)
parseAbs :: TokenParser Expr
parseAbs = do
symbol' "\\"
+ -- TODO: remove this 'try' after operator aliases are finished (0.9)
args <- P.many1 (C.indented *> (Abs <$> (Left <$> P.try C.parseIdent <|> Right <$> parseBinderNoParens)))
C.indented *> rarrow
value <- parseValue
@@ -362,11 +344,11 @@ parseConstructor :: TokenParser Expr
parseConstructor = Constructor <$> C.parseQualified C.properName
parseCase :: TokenParser Expr
-parseCase = Case <$> P.between (P.try (reserved "case")) (C.indented *> reserved "of") (return <$> parseValue)
+parseCase = Case <$> P.between (reserved "case") (C.indented *> reserved "of") (commaSep1 parseValue)
<*> (C.indented *> C.mark (P.many1 (C.same *> C.mark parseCaseAlternative)))
parseCaseAlternative :: TokenParser CaseAlternative
-parseCaseAlternative = CaseAlternative <$> (return <$> parseBinder)
+parseCaseAlternative = CaseAlternative <$> (commaSep1 parseBinder)
<*> (Left <$> (C.indented *>
P.many1 ((,) <$> parseGuard
<*> (indented *> rarrow *> parseValue)
@@ -391,23 +373,25 @@ parseLet = do
parseValueAtom :: TokenParser Expr
parseValueAtom = P.choice
- [ P.try parseNumericLiteral
- , P.try parseCharLiteral
- , P.try parseStringLiteral
- , P.try parseBooleanLiteral
- , parseArrayLiteral
- , P.try parseObjectLiteral
- , P.try parseObjectGetter
- , parseAbs
- , P.try parseConstructor
- , P.try parseVar
- , parseCase
- , parseIfThenElse
- , parseDo
- , parseLet
- , P.try $ Parens <$> parens parseValue
- , parseOperatorSection
- , P.try parseObjectUpdaterWildcard ]
+ [ parseNumericLiteral
+ , parseCharLiteral
+ , parseStringLiteral
+ , parseBooleanLiteral
+ , parseArrayLiteral
+ , P.try parseObjectLiteral
+ , P.try parseObjectGetter
+ , parseAbs
+ , P.try parseConstructor
+ , P.try parseVar
+ , parseCase
+ , parseIfThenElse
+ , parseDo
+ , parseLet
+ , P.try $ Parens <$> parens parseValue
+ , parseOperatorSection
+ -- TODO: combine this with parseObjectGetter
+ , parseObjectUpdaterWildcard
+ ]
-- |
-- Parse an expression in backticks or an operator
@@ -443,13 +427,14 @@ parseDoNotationLet :: TokenParser DoNotationElement
parseDoNotationLet = DoNotationLet <$> (reserved "let" *> C.indented *> C.mark (P.many1 (C.same *> parseLocalDeclaration)))
parseDoNotationBind :: TokenParser DoNotationElement
-parseDoNotationBind = DoNotationBind <$> parseBinder <*> (C.indented *> larrow *> parseValue)
+parseDoNotationBind = DoNotationBind <$> P.try (parseBinder <* C.indented <* larrow) <*> parseValue
parseDoNotationElement :: TokenParser DoNotationElement
parseDoNotationElement = P.choice
- [ P.try parseDoNotationBind
+ [ parseDoNotationBind
, parseDoNotationLet
- , P.try (DoNotationValue <$> parseValue) ]
+ , DoNotationValue <$> parseValue
+ ]
parseObjectGetter :: TokenParser Expr
parseObjectGetter = ObjectGetter <$> (underscore *> C.indented *> dot *> C.indented *> (lname <|> stringLiteral))
@@ -459,7 +444,8 @@ indexersAndAccessors :: TokenParser Expr
indexersAndAccessors = C.buildPostfixParser postfixTable parseValueAtom
where
postfixTable = [ parseAccessor
- , P.try . parseUpdaterBody . Just ]
+ , P.try . parseUpdaterBody . Just
+ ]
-- |
-- Parse a value
@@ -471,9 +457,9 @@ parseValue = withSourceSpan PositionedValue
$ indexersAndAccessors) P.<?> "expression"
where
postfixTable = [ \v -> P.try (flip App <$> (C.indented *> indexersAndAccessors)) <*> pure v
- , \v -> flip (TypedValue True) <$> (P.try (C.indented *> doubleColon) *> parsePolyType) <*> pure v
+ , \v -> flip (TypedValue True) <$> (C.indented *> doubleColon *> parsePolyType) <*> pure v
]
- operators = [ [ P.Prefix (P.try (C.indented *> symbol' "-") >> return UnaryMinus)
+ operators = [ [ P.Prefix (C.indented *> symbol' "-" *> return UnaryMinus)
]
, [ P.Infix (P.try (C.indented *> parseInfixExpr P.<?> "infix expression") >>= \ident ->
return (BinaryNoParens ident)) P.AssocRight
@@ -503,9 +489,6 @@ parseNumberBinder = NumberBinder <$> (sign <*> number)
<|> (symbol' "+" >> return id)
<|> return id
-parseVarBinder :: TokenParser Binder
-parseVarBinder = VarBinder <$> C.parseIdent
-
parseNullaryConstructorBinder :: TokenParser Binder
parseNullaryConstructorBinder = ConstructorBinder <$> C.parseQualified C.properName <*> pure []
@@ -518,9 +501,13 @@ parseObjectBinder = ObjectBinder <$> braces (commaSep (C.indented *> parseIdenti
parseArrayBinder :: TokenParser Binder
parseArrayBinder = squares $ ArrayBinder <$> commaSep (C.indented *> parseBinder)
-parseNamedBinder :: TokenParser Binder
-parseNamedBinder = NamedBinder <$> (C.parseIdent <* C.indented <* at)
- <*> (C.indented *> parseBinder)
+parseVarOrNamedBinder :: TokenParser Binder
+parseVarOrNamedBinder = do
+ -- TODO: once operator aliases are finalized in 0.9, this 'try' won't be needed
+ -- any more since identifiers in binders won't be 'Op's.
+ name <- P.try C.parseIdent
+ let parseNamedBinder = NamedBinder name <$> (at *> C.indented *> parseBinder)
+ parseNamedBinder <|> return (VarBinder name)
parseNullBinder :: TokenParser Binder
parseNullBinder = underscore *> return NullBinder
@@ -538,43 +525,41 @@ parseIdentifierAndBinder =
-- Parse a binder
--
parseBinder :: TokenParser Binder
-parseBinder = withSourceSpan PositionedBinder (P.buildExpressionParser operators (buildPostfixParser postfixTable parseBinderAtom))
+parseBinder = withSourceSpan PositionedBinder (buildPostfixParser postfixTable parseBinderAtom)
where
- -- TODO: remove this deprecation warning in 0.8
- operators = [ [ P.Infix (P.try $ C.indented *> colon *> featureWasRemoved "Cons binders are no longer supported. Consider using purescript-lists or purescript-sequences instead.") P.AssocRight ] ]
-- TODO: parsePolyType when adding support for polymorphic types
- postfixTable = [ \b -> flip TypedBinder b <$> (P.try (indented *> doubleColon) *> parseType)
+ postfixTable = [ \b -> flip TypedBinder b <$> (indented *> doubleColon *> parseType)
]
parseBinderAtom :: TokenParser Binder
- parseBinderAtom = P.choice (map P.try
+ parseBinderAtom = P.choice
[ parseNullBinder
, parseCharBinder
, parseStringBinder
, parseBooleanBinder
, parseNumberBinder
- , parseNamedBinder
- , parseVarBinder
+ , parseVarOrNamedBinder
, parseConstructorBinder
, parseObjectBinder
, parseArrayBinder
- , parens parseBinder ]) P.<?> "binder"
+ , parens parseBinder
+ ] P.<?> "binder"
-- |
-- Parse a binder as it would appear in a top level declaration
--
parseBinderNoParens :: TokenParser Binder
-parseBinderNoParens = P.choice (map P.try
- [ parseNullBinder
- , parseCharBinder
- , parseStringBinder
- , parseBooleanBinder
- , parseNumberBinder
- , parseNamedBinder
- , parseVarBinder
- , parseNullaryConstructorBinder
- , parseObjectBinder
- , parseArrayBinder
- , parens parseBinder ]) P.<?> "binder"
+parseBinderNoParens = P.choice
+ [ parseNullBinder
+ , parseCharBinder
+ , parseStringBinder
+ , parseBooleanBinder
+ , parseNumberBinder
+ , parseVarOrNamedBinder
+ , parseNullaryConstructorBinder
+ , parseObjectBinder
+ , parseArrayBinder
+ , parens parseBinder
+ ] P.<?> "binder"
-- |
-- Parse a guard
diff --git a/src/Language/PureScript/Parser/Kinds.hs b/src/Language/PureScript/Parser/Kinds.hs
index 83e62da..ef67827 100644
--- a/src/Language/PureScript/Parser/Kinds.hs
+++ b/src/Language/PureScript/Parser/Kinds.hs
@@ -33,10 +33,11 @@ parseBang :: TokenParser Kind
parseBang = const Bang <$> symbol' "!"
parseTypeAtom :: TokenParser Kind
-parseTypeAtom = indented *> P.choice (map P.try
+parseTypeAtom = indented *> P.choice
[ parseStar
, parseBang
- , parens parseKind ])
+ , parens parseKind
+ ]
-- |
-- Parse a kind
--
@@ -44,4 +45,4 @@ parseKind :: TokenParser Kind
parseKind = P.buildExpressionParser operators parseTypeAtom P.<?> "kind"
where
operators = [ [ P.Prefix (symbol' "#" >> return Row) ]
- , [ P.Infix (P.try rarrow >> return FunKind) P.AssocRight ] ]
+ , [ P.Infix (rarrow >> return FunKind) P.AssocRight ] ]
diff --git a/src/Language/PureScript/Parser/Lexer.hs b/src/Language/PureScript/Parser/Lexer.hs
index acdb940..4cabc01 100644
--- a/src/Language/PureScript/Parser/Lexer.hs
+++ b/src/Language/PureScript/Parser/Lexer.hs
@@ -67,13 +67,13 @@ module Language.PureScript.Parser.Lexer
, natural
, reservedPsNames
, reservedTypeNames
- , opChars
+ , isSymbolChar
)
where
import Prelude hiding (lex)
-import Data.Char (isSpace)
+import Data.Char (isSpace, isAscii, isSymbol)
import Control.Monad (void, guard)
import Data.Functor.Identity
@@ -185,10 +185,15 @@ parsePositionedToken = P.try $ do
parseToken :: P.Parsec String u Token
parseToken = P.choice
[ P.try $ P.string "<-" *> P.notFollowedBy symbolChar *> pure LArrow
+ , P.try $ P.string "←" *> P.notFollowedBy symbolChar *> pure LArrow
, P.try $ P.string "<=" *> P.notFollowedBy symbolChar *> pure LFatArrow
+ , P.try $ P.string "⇐" *> P.notFollowedBy symbolChar *> pure LFatArrow
, P.try $ P.string "->" *> P.notFollowedBy symbolChar *> pure RArrow
+ , P.try $ P.string "β†’" *> P.notFollowedBy symbolChar *> pure RArrow
, P.try $ P.string "=>" *> P.notFollowedBy symbolChar *> pure RFatArrow
+ , P.try $ P.string "β‡’" *> P.notFollowedBy symbolChar *> pure RFatArrow
, P.try $ P.string "::" *> P.notFollowedBy symbolChar *> pure DoubleColon
+ , P.try $ P.string "∷" *> P.notFollowedBy symbolChar *> pure DoubleColon
, P.try $ P.char '(' *> pure LParen
, P.try $ P.char ')' *> pure RParen
, P.try $ P.char '{' *> pure LBrace
@@ -233,7 +238,7 @@ parseToken = P.choice
uidentLetter = P.alphaNum <|> P.char '_'
symbolChar :: P.Parsec String u Char
- symbolChar = P.oneOf opChars
+ symbolChar = P.satisfy isSymbolChar
parseCharLiteral :: P.Parsec String u Char
parseCharLiteral = PT.charLiteral tokenParser
@@ -411,6 +416,7 @@ reserved :: String -> TokenParser ()
reserved s = token go P.<?> show s
where
go (LName s') | s == s' = Just ()
+ go (Symbol s') | s == s' = Just ()
go _ = Nothing
uname :: TokenParser String
@@ -516,5 +522,5 @@ reservedTypeNames = [ "forall", "where" ]
-- |
-- The characters allowed for use in operators
--
-opChars :: [Char]
-opChars = ":!#$%&*+./<=>?@\\^|-~"
+isSymbolChar :: Char -> Bool
+isSymbolChar c = (c `elem` ":!#$%&*+./<=>?@\\^|-~") || (not (isAscii c) && isSymbol c)
diff --git a/src/Language/PureScript/Parser/Types.hs b/src/Language/PureScript/Parser/Types.hs
index 7cd1602..ca14aa5 100644
--- a/src/Language/PureScript/Parser/Types.hs
+++ b/src/Language/PureScript/Parser/Types.hs
@@ -1,18 +1,3 @@
------------------------------------------------------------------------------
---
--- Module : Language.PureScript.Parser.Types
--- Copyright : (c) Phil Freeman 2013
--- License : MIT
---
--- Maintainer : Phil Freeman <paf31@cantab.net>
--- Stability : experimental
--- Portability :
---
--- |
--- Parsers for types
---
------------------------------------------------------------------------------
-
module Language.PureScript.Parser.Types (
parseType,
parsePolyType,
@@ -32,19 +17,8 @@ import Language.PureScript.Environment
import qualified Text.Parsec as P
import qualified Text.Parsec.Expr as P
--- TODO: remove these deprecation warnings in 0.8
-parseArray :: TokenParser Type
-parseArray = do
- _ <- squares $ return tyArray
- featureWasRemoved "Array notation is no longer supported. Use Array instead of []."
-
-parseArrayOf :: TokenParser Type
-parseArrayOf = do
- _ <- squares $ TypeApp tyArray <$> parseType
- featureWasRemoved "Array notation is no longer supported. Use Array _ instead of [_]."
-
parseFunction :: TokenParser Type
-parseFunction = parens $ rarrow >> return tyFunction
+parseFunction = parens rarrow >> return tyFunction
parseObject :: TokenParser Type
parseObject = braces $ TypeApp tyObject <$> parseRow
@@ -62,45 +36,48 @@ parseTypeConstructor :: TokenParser Type
parseTypeConstructor = TypeConstructor <$> parseQualified properName
parseForAll :: TokenParser Type
-parseForAll = mkForAll <$> (P.try (reserved "forall") *> P.many1 (indented *> identifier) <* indented <* dot)
+parseForAll = mkForAll <$> ((reserved "forall" <|> reserved "βˆ€") *> P.many1 (indented *> identifier) <* indented <* dot)
<*> parseType
-- |
-- Parse a type as it appears in e.g. a data constructor
--
parseTypeAtom :: TokenParser Type
-parseTypeAtom = indented *> P.choice (map P.try
- [ parseArray
- , parseArrayOf
- , parseFunction
+parseTypeAtom = indented *> P.choice
+ [ P.try parseConstrainedType
+ , P.try parseFunction
, parseObject
, parseTypeWildcard
+ , parseForAll
, parseTypeVariable
, parseTypeConstructor
- , parseForAll
- , parens parseRow
- , parseConstrainedType
+ -- This try is needed due to some unfortunate ambiguities between rows and kinded types
+ , P.try (parens parseRow)
, parens parsePolyType
- ])
+ ]
parseConstrainedType :: TokenParser Type
parseConstrainedType = do
- constraints <- parens . commaSep1 $ do
- className <- parseQualified properName
- indented
- ty <- P.many parseTypeAtom
- return (className, ty)
+ constraints <- P.try (return <$> parseConstraint) <|> parens (commaSep1 parseConstraint)
_ <- rfatArrow
indented
ty <- parseType
return $ ConstrainedType constraints ty
+ where
+ parseConstraint = do
+ className <- parseQualified properName
+ indented
+ ty <- P.many parseTypeAtom
+ return (className, ty)
+
parseAnyType :: TokenParser Type
parseAnyType = P.buildExpressionParser operators (buildPostfixParser postfixTable parseTypeAtom) P.<?> "type"
where
operators = [ [ P.Infix (return TypeApp) P.AssocLeft ]
- , [ P.Infix (rarrow >> return function) P.AssocRight ] ]
- postfixTable = [ \t -> KindedType t <$> (P.try (indented *> doubleColon) *> parseKind)
+ , [ P.Infix (rarrow >> return function) P.AssocRight ]
+ ]
+ postfixTable = [ \t -> KindedType t <$> (indented *> doubleColon *> parseKind)
]
-- |
diff --git a/src/Language/PureScript/Pretty/Common.hs b/src/Language/PureScript/Pretty/Common.hs
index ce6fc33..59b5451 100644
--- a/src/Language/PureScript/Pretty/Common.hs
+++ b/src/Language/PureScript/Pretty/Common.hs
@@ -18,7 +18,7 @@ module Language.PureScript.Pretty.Common where
import Control.Monad.State
import Data.List (intercalate)
-import Language.PureScript.Parser.Lexer (reservedPsNames, opChars)
+import Language.PureScript.Parser.Lexer (reservedPsNames, isSymbolChar)
import Text.PrettyPrint.Boxes
@@ -68,7 +68,7 @@ prettyPrintMany f xs = do
--
prettyPrintObjectKey :: String -> String
prettyPrintObjectKey s | s `elem` reservedPsNames = show s
- | any (`elem` opChars) s = show s
+ | any isSymbolChar s = show s
| otherwise = s
-- | Place a box before another, vertically when the first box takes up multiple lines.
diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs
index 717e610..1d14bdb 100644
--- a/src/Language/PureScript/Pretty/Types.hs
+++ b/src/Language/PureScript/Pretty/Types.hs
@@ -1,26 +1,14 @@
------------------------------------------------------------------------------
---
--- Module : Language.PureScript.Pretty.Types
--- Copyright : (c) Phil Freeman 2013
--- License : MIT
---
--- Maintainer : Phil Freeman <paf31@cantab.net>
--- Stability : experimental
--- Portability :
---
-- |
-- Pretty printer for Types
--
------------------------------------------------------------------------------
-
-module Language.PureScript.Pretty.Types (
- typeAsBox,
- prettyPrintType,
- typeAtomAsBox,
- prettyPrintTypeAtom,
- prettyPrintRowWith,
- prettyPrintRow
-) where
+module Language.PureScript.Pretty.Types
+ ( typeAsBox
+ , prettyPrintType
+ , typeAtomAsBox
+ , prettyPrintTypeAtom
+ , prettyPrintRowWith
+ , prettyPrintRow
+ ) where
import Data.Maybe (fromMaybe)
@@ -45,16 +33,16 @@ typeLiterals = mkPattern match
match (PrettyPrintObject row) = Just $ prettyPrintRowWith '{' '}' row
match (TypeConstructor ctor) = Just $ text $ runProperName $ disqualify ctor
match (TUnknown u) = Just $ text $ '_' : show u
- match (Skolem name s _) = Just $ text $ name ++ show s
+ match (Skolem name s _ _) = Just $ text $ name ++ show s
match REmpty = Just $ text "()"
match row@RCons{} = Just $ prettyPrintRowWith '(' ')' row
match _ = Nothing
-constraintsAsBox :: [(Qualified ProperName, [Type])] -> Box -> Box
+constraintsAsBox :: [Constraint] -> Box -> Box
constraintsAsBox [(pn, tys)] ty = text "(" <> constraintAsBox pn tys <> text ") => " <> ty
constraintsAsBox xs ty = vcat left (zipWith (\i (pn, tys) -> text (if i == 0 then "( " else ", ") <> constraintAsBox pn tys) [0 :: Int ..] xs) `before` (text ") => " <> ty)
-constraintAsBox :: Qualified ProperName -> [Type] -> Box
+constraintAsBox :: Qualified (ProperName a) -> [Type] -> Box
constraintAsBox pn tys = hsep 1 left (text (runProperName (disqualify pn)) : map typeAtomAsBox tys)
-- |
@@ -79,7 +67,7 @@ prettyPrintRowWith open close = uncurry listToBox . toList []
toList :: [(String, Type)] -> Type -> ([(String, Type)], Type)
toList tys (RCons name ty row) = toList ((name, ty):tys) row
- toList tys r = (tys, r)
+ toList tys r = (reverse tys, r)
prettyPrintRow :: Type -> String
prettyPrintRow = render . prettyPrintRowWith '(' ')'
@@ -121,21 +109,27 @@ constrained = mkPattern match
match _ = Nothing
matchTypeAtom :: Pattern () Type Box
-matchTypeAtom = typeLiterals <+> fmap ((`before` text ")") . (text "(" <>)) matchType
+matchTypeAtom = typeLiterals <+> fmap ((`before` (text ")")) . (text "(" <>)) matchType
matchType :: Pattern () Type Box
matchType = buildPrettyPrinter operators matchTypeAtom
where
operators :: OperatorTable () Type Box
operators =
- OperatorTable [ [ AssocL typeApp $ \f x -> f `beforeWithSpace` x ]
- , [ AssocR appliedFunction $ \arg ret -> (arg <> text " ") `before` (text "-> " <> ret)
- ]
+ OperatorTable [ [ AssocL typeApp $ \f x -> keepSingleLinesOr (moveRight 2) f x ]
+ , [ AssocR appliedFunction $ \arg ret -> keepSingleLinesOr id arg (text "-> " <> ret) ]
, [ Wrap constrained $ \deps ty -> constraintsAsBox deps ty ]
- , [ Wrap forall_ $ \idents ty -> text ("forall " ++ unwords idents ++ ". ") <> ty ]
- , [ Wrap kinded $ \k ty -> ty `before` text (" :: " ++ prettyPrintKind k) ]
+ , [ Wrap forall_ $ \idents ty -> keepSingleLinesOr (moveRight 2) (text ("forall " ++ unwords idents ++ ".")) ty ]
+ , [ Wrap kinded $ \k ty -> keepSingleLinesOr (moveRight 2) ty (text (":: " ++ prettyPrintKind k)) ]
]
+ -- If both boxes span a single line, keep them on the same line, or else
+ -- use the specified function to modify the second box, then combine vertically.
+ keepSingleLinesOr :: (Box -> Box) -> Box -> Box -> Box
+ keepSingleLinesOr f b1 b2
+ | rows b1 > 1 || rows b2 > 1 = vcat left [ b1, f b2 ]
+ | otherwise = hcat top [ b1, text " ", b2]
+
forall_ :: Pattern () Type ([String], Type)
forall_ = mkPattern match
where
diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs
index 3064bc2..9ef9a0c 100644
--- a/src/Language/PureScript/Pretty/Values.hs
+++ b/src/Language/PureScript/Pretty/Values.hs
@@ -160,6 +160,7 @@ prettyPrintBinderAtom (ArrayBinder bs) =
++ " ]"
prettyPrintBinderAtom (NamedBinder ident binder) = showIdent ident ++ "@" ++ prettyPrintBinder binder
prettyPrintBinderAtom (PositionedBinder _ _ binder) = prettyPrintBinderAtom binder
+prettyPrintBinderAtom (TypedBinder _ binder) = prettyPrintBinderAtom binder
prettyPrintBinderAtom b = parens (prettyPrintBinder b)
-- |
diff --git a/src/Language/PureScript/Publish.hs b/src/Language/PureScript/Publish.hs
index 904607e..210504f 100644
--- a/src/Language/PureScript/Publish.hs
+++ b/src/Language/PureScript/Publish.hs
@@ -146,11 +146,20 @@ preparePackage' opts = do
getModulesAndBookmarks :: PrepareM ([D.Bookmark], [D.Module])
getModulesAndBookmarks = do
(inputFiles, depsFiles) <- liftIO getInputAndDepsFiles
- liftIO (D.parseAndDesugar inputFiles depsFiles renderModules)
- >>= either (userError . ParseAndDesugarError) return
+ (modules', bookmarks, env) <- parseAndDesugar inputFiles depsFiles
+
+ case runExcept (D.convertModulesInPackage env modules') of
+ Right modules -> return (bookmarks, modules)
+ Left err -> userError (CompileError err)
+
where
- renderModules bookmarks modules =
- return (bookmarks, map D.convertModule modules)
+ parseAndDesugar inputFiles depsFiles = do
+ r <- liftIO . runExceptT $ D.parseAndDesugar inputFiles depsFiles
+ case r of
+ Right r' ->
+ return r'
+ Left err ->
+ userError (CompileError err)
data TreeStatus = Clean | Dirty deriving (Show, Read, Eq, Ord, Enum)
@@ -196,8 +205,7 @@ getBowerInfo = either (userError . BadRepositoryField) return . tryExtract
maybe (Left NotOnGithub) Right (extractGithub repositoryUrl)
extractGithub :: String -> Maybe (D.GithubUser, D.GithubRepo)
-extractGithub =
- stripPrefix "git://github.com/"
+extractGithub = stripGitHubPrefixes
>>> fmap (splitOn "/")
>=> takeTwo
>>> fmap (D.GithubUser *** (D.GithubRepo . dropDotGit))
@@ -207,6 +215,15 @@ extractGithub =
takeTwo [x, y] = Just (x, y)
takeTwo _ = Nothing
+ stripGitHubPrefixes :: String -> Maybe String
+ stripGitHubPrefixes = stripPrefixes [ "git://github.com/"
+ , "https://github.com/"
+ , "git@github.com:"
+ ]
+
+ stripPrefixes :: [String] -> String -> Maybe String
+ stripPrefixes prefixes str = msum $ (`stripPrefix` str) <$> prefixes
+
dropDotGit :: String -> String
dropDotGit str
| ".git" `isSuffixOf` str = take (length str - 4) str
diff --git a/src/Language/PureScript/Publish/ErrorsWarnings.hs b/src/Language/PureScript/Publish/ErrorsWarnings.hs
index c001de8..baec5aa 100644
--- a/src/Language/PureScript/Publish/ErrorsWarnings.hs
+++ b/src/Language/PureScript/Publish/ErrorsWarnings.hs
@@ -33,7 +33,6 @@ import Web.Bower.PackageMeta (BowerError, PackageName, runPackageName, showBower
import qualified Web.Bower.PackageMeta as Bower
import qualified Language.PureScript as P
-import qualified Language.PureScript.Docs as D
import Language.PureScript.Publish.BoxesHelpers
@@ -61,7 +60,7 @@ data UserError
| AmbiguousVersions [Version] -- Invariant: should contain at least two elements
| BadRepositoryField RepositoryFieldError
| MissingDependencies (NonEmpty PackageName)
- | ParseAndDesugarError D.ParseDesugarError
+ | CompileError P.MultipleErrors
| DirtyWorkingTree
deriving (Show)
@@ -188,19 +187,9 @@ displayUserError e = case e of
[ "Please install ", them, " first, by running `bower install`."
])
]
- ParseAndDesugarError (D.ParseError err) ->
+ CompileError err ->
vcat
- [ para "Parse error:"
- , indented (P.prettyPrintMultipleErrorsBox False err)
- ]
- ParseAndDesugarError (D.SortModulesError err) ->
- vcat
- [ para "Error in sortModules:"
- , indented (P.prettyPrintMultipleErrorsBox False err)
- ]
- ParseAndDesugarError (D.DesugarError err) ->
- vcat
- [ para "Error while desugaring:"
+ [ para "Compile error:"
, indented (P.prettyPrintMultipleErrorsBox False err)
]
DirtyWorkingTree ->
diff --git a/src/Language/PureScript/Renamer.hs b/src/Language/PureScript/Renamer.hs
index c651bfc..f497b92 100644
--- a/src/Language/PureScript/Renamer.hs
+++ b/src/Language/PureScript/Renamer.hs
@@ -1,22 +1,9 @@
------------------------------------------------------------------------------
------------------------------------------------------------------------------
---
--- Module : Language.PureScript.Renamer
--- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
--- License : MIT
---
--- Maintainer : Phil Freeman <paf31@cantab.net>
--- Stability : experimental
--- Portability :
---
--- |
--- Renaming pass that prevents shadowing of local identifiers.
---
------------------------------------------------------------------------------
-
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
+-- |
+-- Renaming pass that prevents shadowing of local identifiers.
+--
module Language.PureScript.Renamer (renameInModules) where
import Prelude ()
@@ -25,6 +12,7 @@ import Prelude.Compat
import Control.Monad.State
import Data.List (find)
+import Data.Maybe (fromJust, fromMaybe)
import qualified Data.Map as M
import qualified Data.Set as S
@@ -76,19 +64,29 @@ newScope x = do
-- unique name is generated and stored.
--
updateScope :: Ident -> Rename Ident
-updateScope i@(Ident name) | name == C.__unused = return i
-updateScope name = do
- scope <- get
- name' <- if name `S.member` rsUsedNames scope
- then do
- let newNames = [ Ident (runIdent name ++ "_" ++ show (i :: Int)) | i <- [1..] ]
- Just newName = find (`S.notMember` rsUsedNames scope) newNames
- return newName
- else return name
- modify $ \s -> s { rsBoundNames = M.insert name name' (rsBoundNames s)
- , rsUsedNames = S.insert name' (rsUsedNames s)
- }
- return name'
+updateScope ident =
+ case ident of
+ Ident name | name == C.__unused -> return ident
+ GenIdent name _ -> go ident $ Ident (fromMaybe "v" name)
+ _ -> go ident ident
+ where
+ go :: Ident -> Ident -> Rename Ident
+ go keyName baseName = do
+ scope <- get
+ let usedNames = rsUsedNames scope
+ name' =
+ if baseName `S.member` usedNames
+ then getNewName usedNames baseName
+ else baseName
+ modify $ \s -> s { rsBoundNames = M.insert keyName name' (rsBoundNames s)
+ , rsUsedNames = S.insert name' (rsUsedNames s)
+ }
+ return name'
+ getNewName :: S.Set Ident -> Ident -> Ident
+ getNewName usedNames name =
+ fromJust $ find
+ (`S.notMember` usedNames)
+ [ Ident (runIdent name ++ show (i :: Int)) | i <- [1..] ]
-- |
-- Finds the new name to use for an ident.
diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs
index ff6c03f..3949673 100644
--- a/src/Language/PureScript/Sugar/BindingGroups.hs
+++ b/src/Language/PureScript/Sugar/BindingGroups.hs
@@ -1,60 +1,61 @@
------------------------------------------------------------------------------
---
--- Module : Language.PureScript.BindingGroups
--- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
--- License : MIT (http://opensource.org/licenses/MIT)
---
--- Maintainer : Phil Freeman <paf31@cantab.net>
--- Stability : experimental
--- Portability :
---
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE LambdaCase #-}
+
-- |
-- This module implements the desugaring pass which creates binding groups from sets of
-- mutually-recursive value declarations and mutually-recursive type declarations.
--
------------------------------------------------------------------------------
-
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-
-module Language.PureScript.Sugar.BindingGroups (
- createBindingGroups,
- createBindingGroupsModule,
- collapseBindingGroups,
- collapseBindingGroupsModule
-) where
+module Language.PureScript.Sugar.BindingGroups
+ ( createBindingGroups
+ , createBindingGroupsModule
+ , collapseBindingGroups
+ , collapseBindingGroupsModule
+ ) where
import Prelude ()
import Prelude.Compat
-import Data.Graph
-import Data.List (nub, intersect)
-import Data.Maybe (isJust, mapMaybe)
import Control.Monad ((<=<))
import Control.Monad.Error.Class (MonadError(..))
+import Data.Graph
+import Data.List (nub, intersect)
+import Data.Maybe (isJust, mapMaybe)
import qualified Data.Set as S
-import Language.PureScript.Crash
import Language.PureScript.AST
-import Language.PureScript.Names
-import Language.PureScript.Types
+import Language.PureScript.Crash
import Language.PureScript.Environment
import Language.PureScript.Errors
+import Language.PureScript.Names
+import Language.PureScript.Types
-- |
-- Replace all sets of mutually-recursive declarations in a module with binding groups
--
-createBindingGroupsModule :: (Functor m, Applicative m, MonadError MultipleErrors m) => [Module] -> m [Module]
-createBindingGroupsModule = mapM $ \(Module ss coms name ds exps) -> Module ss coms name <$> createBindingGroups name ds <*> pure exps
+createBindingGroupsModule
+ :: (Functor m, Applicative m, MonadError MultipleErrors m)
+ => [Module]
+ -> m [Module]
+createBindingGroupsModule =
+ mapM $ \(Module ss coms name ds exps) ->
+ Module ss coms name <$> createBindingGroups name ds <*> pure exps
-- |
-- Collapse all binding groups in a module to individual declarations
--
collapseBindingGroupsModule :: [Module] -> [Module]
-collapseBindingGroupsModule = map $ \(Module ss coms name ds exps) -> Module ss coms name (collapseBindingGroups ds) exps
-
-createBindingGroups :: forall m. (Functor m, Applicative m, MonadError MultipleErrors m) => ModuleName -> [Declaration] -> m [Declaration]
+collapseBindingGroupsModule =
+ map $ \(Module ss coms name ds exps) ->
+ Module ss coms name (collapseBindingGroups ds) exps
+
+createBindingGroups
+ :: forall m
+ . (Functor m, Applicative m, MonadError MultipleErrors m)
+ => ModuleName
+ -> [Declaration]
+ -> m [Declaration]
createBindingGroups moduleName = mapM f <=< handleDecls
where
@@ -71,8 +72,8 @@ createBindingGroups moduleName = mapM f <=< handleDecls
handleDecls ds = do
let values = filter isValueDecl ds
dataDecls = filter isDataDecl ds
- allProperNames = map getProperName dataDecls
- dataVerts = map (\d -> (d, getProperName d, usedProperNames moduleName d `intersect` allProperNames)) dataDecls
+ allProperNames = map getTypeName dataDecls
+ dataVerts = map (\d -> (d, getTypeName d, usedTypeNames moduleName d `intersect` allProperNames)) dataDecls
dataBindingGroupDecls <- parU (stronglyConnComp dataVerts) toDataBindingGroup
let allIdents = map getIdent values
valueVerts = map (\d -> (d, getIdent d, usedIdents moduleName d `intersect` allIdents)) values
@@ -90,11 +91,15 @@ createBindingGroups moduleName = mapM f <=< handleDecls
-- Collapse all binding groups to individual declarations
--
collapseBindingGroups :: [Declaration] -> [Declaration]
-collapseBindingGroups = let (f, _, _) = everywhereOnValues id collapseBindingGroupsForValue id in map f . concatMap go
+collapseBindingGroups =
+ let (f, _, _) = everywhereOnValues id collapseBindingGroupsForValue id
+ in map f . concatMap go
where
go (DataBindingGroupDeclaration ds) = ds
- go (BindingGroupDeclaration ds) = map (\(ident, nameKind, val) -> ValueDeclaration ident nameKind [] (Right val)) ds
- go (PositionedDeclaration pos com d) = map (PositionedDeclaration pos com) $ go d
+ go (BindingGroupDeclaration ds) =
+ map (\(ident, nameKind, val) -> ValueDeclaration ident nameKind [] (Right val)) ds
+ go (PositionedDeclaration pos com d) =
+ map (PositionedDeclaration pos com) $ go d
go other = [other]
collapseBindingGroupsForValue :: Expr -> Expr
@@ -102,20 +107,23 @@ collapseBindingGroupsForValue (Let ds val) = Let (collapseBindingGroups ds) val
collapseBindingGroupsForValue other = other
usedIdents :: ModuleName -> Declaration -> [Ident]
-usedIdents moduleName =
- let (f, _, _, _, _) = everythingWithContextOnValues S.empty [] (++) def usedNamesE usedNamesB def def
- in nub . f
+usedIdents moduleName = nub . usedIdents' S.empty . getValue
where
- def s _ = (s, [])
+ def _ _ = []
- usedNamesE :: S.Set Ident -> Expr -> (S.Set Ident, [Ident])
- usedNamesE scope (Var (Qualified Nothing name)) | name `S.notMember` scope = (scope, [name])
- usedNamesE scope (Var (Qualified (Just moduleName') name)) | moduleName == moduleName' && name `S.notMember` scope = (scope, [name])
- usedNamesE scope (Abs (Left name) _) = (name `S.insert` scope, [])
- usedNamesE scope _ = (scope, [])
+ getValue (ValueDeclaration _ _ [] (Right val)) = val
+ getValue ValueDeclaration{} = internalError "Binders should have been desugared"
+ getValue (PositionedDeclaration _ _ d) = getValue d
+ getValue _ = internalError "Expected ValueDeclaration"
+
+ (_, usedIdents', _, _, _) = everythingWithScope def usedNamesE def def def
- usedNamesB :: S.Set Ident -> Binder -> (S.Set Ident, [Ident])
- usedNamesB scope binder = (scope `S.union` S.fromList (binderNames binder), [])
+ usedNamesE :: S.Set Ident -> Expr -> [Ident]
+ usedNamesE scope (Var (Qualified Nothing name))
+ | name `S.notMember` scope = [name]
+ usedNamesE scope (Var (Qualified (Just moduleName') name))
+ | moduleName == moduleName' && name `S.notMember` scope = [name]
+ usedNamesE _ _ = []
usedImmediateIdents :: ModuleName -> Declaration -> [Ident]
usedImmediateIdents moduleName =
@@ -126,21 +134,24 @@ usedImmediateIdents moduleName =
usedNamesE :: Bool -> Expr -> (Bool, [Ident])
usedNamesE True (Var (Qualified Nothing name)) = (True, [name])
- usedNamesE True (Var (Qualified (Just moduleName') name)) | moduleName == moduleName' = (True, [name])
+ usedNamesE True (Var (Qualified (Just moduleName') name))
+ | moduleName == moduleName' = (True, [name])
usedNamesE True (Abs _ _) = (False, [])
usedNamesE scope _ = (scope, [])
-usedProperNames :: ModuleName -> Declaration -> [ProperName]
-usedProperNames moduleName =
+usedTypeNames :: ModuleName -> Declaration -> [ProperName 'TypeName]
+usedTypeNames moduleName =
let (f, _, _, _, _) = accumTypes (everythingOnTypes (++) usedNames)
in nub . f
where
- usedNames :: Type -> [ProperName]
- usedNames (ConstrainedType constraints _) = flip mapMaybe constraints $ \qual ->
- case qual of
- (Qualified (Just moduleName') name, _) | moduleName == moduleName' -> Just name
+ usedNames :: Type -> [ProperName 'TypeName]
+ usedNames (ConstrainedType constraints _) =
+ flip mapMaybe constraints $ \case
+ (Qualified (Just moduleName') name, _)
+ | moduleName == moduleName' -> Just (coerceProperName name)
_ -> Nothing
- usedNames (TypeConstructor (Qualified (Just moduleName') name)) | moduleName == moduleName' = [name]
+ usedNames (TypeConstructor (Qualified (Just moduleName') name))
+ | moduleName == moduleName' = [name]
usedNames _ = []
getIdent :: Declaration -> Ident
@@ -148,17 +159,22 @@ getIdent (ValueDeclaration ident _ _ _) = ident
getIdent (PositionedDeclaration _ _ d) = getIdent d
getIdent _ = internalError "Expected ValueDeclaration"
-getProperName :: Declaration -> ProperName
-getProperName (DataDeclaration _ pn _ _) = pn
-getProperName (TypeSynonymDeclaration pn _ _) = pn
-getProperName (PositionedDeclaration _ _ d) = getProperName d
-getProperName _ = internalError "Expected DataDeclaration"
+getTypeName :: Declaration -> ProperName 'TypeName
+getTypeName (DataDeclaration _ pn _ _) = pn
+getTypeName (TypeSynonymDeclaration pn _ _) = pn
+getTypeName (PositionedDeclaration _ _ d) = getTypeName d
+getTypeName _ = internalError "Expected DataDeclaration"
-- |
-- Convert a group of mutually-recursive dependencies into a BindingGroupDeclaration (or simple ValueDeclaration).
--
--
-toBindingGroup :: forall m. (Functor m, MonadError MultipleErrors m) => ModuleName -> SCC Declaration -> m Declaration
+toBindingGroup
+ :: forall m
+ . (Functor m, MonadError MultipleErrors m)
+ => ModuleName
+ -> SCC Declaration
+ -> m Declaration
toBindingGroup _ (AcyclicSCC d) = return d
toBindingGroup moduleName (CyclicSCC ds') =
-- Once we have a mutually-recursive group of declarations, we need to sort
@@ -187,7 +203,10 @@ toBindingGroup moduleName (CyclicSCC ds') =
cycleError (ValueDeclaration n _ _ (Right _)) = errorMessage $ CycleInDeclaration n
cycleError _ = internalError "cycleError: Expected ValueDeclaration"
-toDataBindingGroup :: (MonadError MultipleErrors m) => SCC Declaration -> m Declaration
+toDataBindingGroup
+ :: MonadError MultipleErrors m
+ => SCC Declaration
+ -> m Declaration
toDataBindingGroup (AcyclicSCC d) = return d
toDataBindingGroup (CyclicSCC [d]) = case isTypeSynonym d of
Just pn -> throwError . errorMessage $ CycleInTypeSynonym (Just pn)
@@ -196,7 +215,7 @@ toDataBindingGroup (CyclicSCC ds')
| all (isJust . isTypeSynonym) ds' = throwError . errorMessage $ CycleInTypeSynonym Nothing
| otherwise = return $ DataBindingGroupDeclaration ds'
-isTypeSynonym :: Declaration -> Maybe ProperName
+isTypeSynonym :: Declaration -> Maybe (ProperName 'TypeName)
isTypeSynonym (TypeSynonymDeclaration pn _ _) = Just pn
isTypeSynonym (PositionedDeclaration _ _ d) = isTypeSynonym d
isTypeSynonym _ = Nothing
diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs
index 8380d4c..da646f6 100644
--- a/src/Language/PureScript/Sugar/CaseDeclarations.hs
+++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs
@@ -1,22 +1,10 @@
------------------------------------------------------------------------------
---
--- Module : Language.PureScript.CaseDeclarations
--- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
--- License : MIT (http://opensource.org/licenses/MIT)
---
--- Maintainer : Phil Freeman <paf31@cantab.net>
--- Stability : experimental
--- Portability :
---
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
-- |
-- This module implements the desugaring pass which replaces top-level binders with
-- case expressions.
--
------------------------------------------------------------------------------
-
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-
module Language.PureScript.Sugar.CaseDeclarations (
desugarCases,
desugarCasesModule
@@ -26,8 +14,8 @@ import Prelude ()
import Prelude.Compat
import Language.PureScript.Crash
-import Data.Maybe (catMaybes)
-import Data.List (nub, groupBy)
+import Data.Maybe (catMaybes, mapMaybe)
+import Data.List (nub, groupBy, foldl1')
import Control.Monad ((<=<), forM, replicateM, join, unless)
import Control.Monad.Error.Class (MonadError(..))
@@ -51,26 +39,54 @@ isLeft (Right _) = False
desugarCasesModule :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Module] -> m [Module]
desugarCasesModule ms = forM ms $ \(Module ss coms name ds exps) ->
rethrow (addHint (ErrorInModule name)) $
- Module ss coms name <$> (desugarCases <=< desugarAbs $ ds) <*> pure exps
+ Module ss coms name <$> (desugarCases <=< desugarAbs <=< validateCases $ ds) <*> pure exps
-desugarAbs :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]
+-- |
+-- Validates that case head and binder lengths match.
+--
+validateCases :: forall m. (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]
+validateCases = flip parU f
+ where
+ (f, _, _) = everywhereOnValuesM return validate return
+
+ validate :: Expr -> m Expr
+ validate c@(Case vs alts) = do
+ let l = length vs
+ alts' = filter ((l /=) . length . caseAlternativeBinders) alts
+ unless (null alts') $
+ throwError . MultipleErrors $ fmap (altError l) (caseAlternativeBinders <$> alts')
+ return c
+ validate other = return other
+
+ altError :: Int -> [Binder] -> ErrorMessage
+ altError l bs = withPosition pos $ ErrorMessage [] $ CaseBinderLengthDiffers l bs
+ where
+ pos = foldl1' widenSpan (mapMaybe positionedBinder bs)
+
+ widenSpan (SourceSpan n start end) (SourceSpan _ start' end') =
+ SourceSpan n (min start start') (max end end')
+
+ positionedBinder (PositionedBinder p _ _) = Just p
+ positionedBinder _ = Nothing
+
+desugarAbs :: forall m. (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]
desugarAbs = flip parU f
where
(f, _, _) = everywhereOnValuesM return replace return
- replace :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Expr -> m Expr
+ replace :: Expr -> m Expr
replace (Abs (Right binder) val) = do
- ident <- Ident <$> freshName
+ ident <- freshIdent'
return $ Abs (Left ident) $ Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] (Right val)]
replace other = return other
-- |
-- Replace all top-level binders with case expressions.
--
-desugarCases :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]
+desugarCases :: forall m. (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]
desugarCases = desugarRest <=< fmap join . flip parU toDecls . groupBy inSameGroup
where
- desugarRest :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]
+ desugarRest :: [Declaration] -> m [Declaration]
desugarRest (TypeInstanceDeclaration name constraints className tys ds : rest) =
(:) <$> (TypeInstanceDeclaration name constraints className tys <$> traverseTypeInstanceBody desugarCases ds) <*> desugarRest rest
desugarRest (ValueDeclaration name nameKind bs result : rest) =
@@ -108,7 +124,7 @@ toDecls [ValueDeclaration ident nameKind bs (Right val)] | all isVarBinder bs =
isVarBinder _ = False
fromVarBinder :: Binder -> m Ident
- fromVarBinder NullBinder = Ident <$> freshName
+ fromVarBinder NullBinder = freshIdent'
fromVarBinder (VarBinder name) = return name
fromVarBinder (PositionedBinder _ _ b) = fromVarBinder b
fromVarBinder (TypedBinder _ b) = fromVarBinder b
@@ -134,24 +150,21 @@ toTuple _ = internalError "Not a value declaration"
makeCaseDeclaration :: forall m. (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Ident -> [([Binder], Either [(Guard, Expr)] Expr)] -> m Declaration
makeCaseDeclaration ident alternatives = do
let namedArgs = map findName . fst <$> alternatives
- argNames = map join $ foldl1 resolveNames namedArgs
+ argNames = foldl1 resolveNames namedArgs
args <- if allUnique (catMaybes argNames)
then mapM argName argNames
- else replicateM (length argNames) (Ident <$> freshName)
+ else replicateM (length argNames) freshIdent'
let vars = map (Var . Qualified Nothing) args
binders = [ CaseAlternative bs result | (bs, result) <- alternatives ]
value = foldr (Abs . Left) (Case vars binders) args
return $ ValueDeclaration ident Public [] (Right value)
where
-- We will construct a table of potential names.
- -- VarBinders will become Just (Just _) which is a potential name.
- -- NullBinder will become Just Nothing, which indicates that we may
- -- have to generate a name.
- -- Everything else becomes Nothing, which indicates that we definitely
+ -- VarBinders will become Just _ which is a potential name.
+ -- Everything else becomes Nothing, which indicates that we
-- have to generate a name.
- findName :: Binder -> Maybe (Maybe Ident)
- findName NullBinder = Just Nothing
- findName (VarBinder name) = Just (Just name)
+ findName :: Binder -> Maybe Ident
+ findName (VarBinder name) = Just name
findName (PositionedBinder _ _ binder) = findName binder
findName _ = Nothing
@@ -162,25 +175,17 @@ makeCaseDeclaration ident alternatives = do
argName :: Maybe Ident -> m Ident
argName (Just name) = return name
- argName _ = do
- name <- freshName
- return (Ident name)
+ argName _ = freshIdent'
-- Combine two lists of potential names from two case alternatives
-- by zipping correspoding columns.
- resolveNames :: [Maybe (Maybe Ident)] ->
- [Maybe (Maybe Ident)] ->
- [Maybe (Maybe Ident)]
+ resolveNames :: [Maybe Ident] -> [Maybe Ident] -> [Maybe Ident]
resolveNames = zipWith resolveName
-- Resolve a pair of names. VarBinder beats NullBinder, and everything
-- else results in Nothing.
- resolveName :: Maybe (Maybe Ident) ->
- Maybe (Maybe Ident) ->
- Maybe (Maybe Ident)
- resolveName (Just (Just a)) (Just (Just b))
- | a == b = Just (Just a)
+ resolveName :: Maybe Ident -> Maybe Ident -> Maybe Ident
+ resolveName (Just a) (Just b)
+ | a == b = Just a
| otherwise = Nothing
- resolveName (Just Nothing) a = a
- resolveName a (Just Nothing) = a
resolveName _ _ = Nothing
diff --git a/src/Language/PureScript/Sugar/DoNotation.hs b/src/Language/PureScript/Sugar/DoNotation.hs
index c91012a..e175bbe 100644
--- a/src/Language/PureScript/Sugar/DoNotation.hs
+++ b/src/Language/PureScript/Sugar/DoNotation.hs
@@ -1,22 +1,10 @@
------------------------------------------------------------------------------
---
--- Module : Language.PureScript.Sugar.DoNotation
--- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
--- License : MIT (http://opensource.org/licenses/MIT)
---
--- Maintainer : Phil Freeman <paf31@cantab.net>
--- Stability : experimental
--- Portability :
---
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
-- |
-- This module implements the desugaring pass which replaces do-notation statements with
-- appropriate calls to bind from the Prelude.Monad type class.
--
------------------------------------------------------------------------------
-
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-
module Language.PureScript.Sugar.DoNotation (
desugarDoModule
) where
@@ -68,7 +56,7 @@ desugarDo d =
return $ App (App bind val) (Abs (Left ident) rest')
go (DoNotationBind binder val : rest) = do
rest' <- go rest
- ident <- Ident <$> freshName
+ ident <- freshIdent'
return $ App (App bind val) (Abs (Left ident) (Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] (Right rest')]))
go [DoNotationLet _] = throwError . errorMessage $ InvalidDoLet
go (DoNotationLet ds : rest) = do
diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs
index 2cf496b..5e75fc9 100644
--- a/src/Language/PureScript/Sugar/Names.hs
+++ b/src/Language/PureScript/Sugar/Names.hs
@@ -1,21 +1,15 @@
------------------------------------------------------------------------------
---
--- Module : Language.PureScript.Sugar.Names
--- License : MIT (http://opensource.org/licenses/MIT)
---
--- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>
--- Stability : experimental
--- Portability :
---
--- |
---
------------------------------------------------------------------------------
-
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
-module Language.PureScript.Sugar.Names (desugarImports) where
+module Language.PureScript.Sugar.Names
+ ( desugarImports
+ , desugarImportsWithEnv
+ , Env
+ , Imports(..)
+ , Exports(..)
+ ) where
import Prelude ()
import Prelude.Compat
@@ -29,6 +23,7 @@ import Control.Monad.Writer (MonadWriter(..), censor)
import Control.Monad.State.Lazy
import qualified Data.Map as M
+import qualified Data.Set as S
import Language.PureScript.Crash
import Language.PureScript.AST
@@ -47,10 +42,20 @@ import Language.PureScript.Linter.Imports
-- modules should be topologically sorted beforehand.
--
desugarImports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module]
-desugarImports externs modules = do
+desugarImports externs modules =
+ fmap snd (desugarImportsWithEnv externs modules)
+
+desugarImportsWithEnv
+ :: forall m
+ . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+ => [ExternsFile]
+ -> [Module]
+ -> m (Env, [Module])
+desugarImportsWithEnv externs modules = do
env <- silence $ foldM externsEnv primEnv externs
- env' <- foldM updateEnv env modules
- traverse (renameInModule' env') modules
+ modules' <- traverse updateExportRefs modules
+ (modules'', env') <- foldM updateEnv ([], env) modules'
+ (env',) <$> traverse (renameInModule' env') modules''
where
silence :: m a -> m a
silence = censor (const mempty)
@@ -62,22 +67,22 @@ desugarImports externs modules = do
ss = internalModuleSourceSpan "<Externs>"
env' = M.insert efModuleName (ss, nullImports, members) env
fromEFImport (ExternsImport mn mt qmn) = (mn, [(Nothing, mt, qmn)])
- imps <- foldM (resolveModuleImport efModuleName env') nullImports (map fromEFImport efImports)
+ imps <- foldM (resolveModuleImport env') nullImports (map fromEFImport efImports)
exps <- resolveExports env' efModuleName imps members efExports
return $ M.insert efModuleName (ss, imps, exps) env
where
- exportedTypes :: [((ProperName, [ProperName]), ModuleName)]
+ exportedTypes :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]
exportedTypes = mapMaybe toExportedType efExports
where
toExportedType (TypeRef tyCon dctors) = Just ((tyCon, fromMaybe (mapMaybe forTyCon efDeclarations) dctors), efModuleName)
where
- forTyCon :: ExternsDeclaration -> Maybe ProperName
+ forTyCon :: ExternsDeclaration -> Maybe (ProperName 'ConstructorName)
forTyCon (EDDataConstructor pn _ tNm _ _) | tNm == tyCon = Just pn
forTyCon _ = Nothing
toExportedType (PositionedDeclarationRef _ _ r) = toExportedType r
toExportedType _ = Nothing
- exportedTypeClasses :: [(ProperName, ModuleName)]
+ exportedTypeClasses :: [(ProperName 'ClassName, ModuleName)]
exportedTypeClasses = mapMaybe toExportedTypeClass efExports
where
toExportedTypeClass (TypeClassRef className) = Just (className, efModuleName)
@@ -90,24 +95,24 @@ desugarImports externs modules = do
toExportedValue (PositionedDeclarationRef _ _ r) = toExportedValue r
toExportedValue _ = Nothing
- updateEnv :: Env -> Module -> m Env
- updateEnv env m@(Module ss _ mn _ refs) =
+ updateEnv :: ([Module], Env) -> Module -> m ([Module], Env)
+ updateEnv (ms, env) m@(Module ss _ mn _ refs) =
case mn `M.lookup` env of
Just m' -> throwError . errorMessage $ RedefinedModule mn [envModuleSourceSpan m', ss]
Nothing -> do
members <- findExportable m
let env' = M.insert mn (ss, nullImports, members) env
- imps <- resolveImports env' m
+ (m', imps) <- resolveImports env' m
exps <- maybe (return members) (resolveExports env' mn imps members) refs
- return $ M.insert mn (ss, imps, exps) env
+ return (m' : ms, M.insert mn (ss, imps, exps) env)
renameInModule' :: Env -> Module -> m Module
renameInModule' env m@(Module _ _ mn _ _) =
warnAndRethrow (addHint (ErrorInModule mn)) $ do
let (_, imps, exps) = fromMaybe (internalError "Module is missing in renameInModule'") $ M.lookup mn env
(m', used) <- flip runStateT M.empty $ renameInModule env imps (elaborateExports exps m)
- findUnusedImports m env used
- return $ elaborateImports imps m'
+ lintImports m env used
+ return m'
-- |
-- Make all exports for a module explicit. This may still effect modules that
@@ -128,34 +133,26 @@ elaborateExports exps (Module ss coms mn decls refs) =
my f = fst `map` filter ((== mn) . snd) (f exps)
-- |
--- Add `import X ()` for any modules where there are only fully qualified references to members.
--- This ensures transitive instances are included when using a member from a module.
---
-elaborateImports :: Imports -> Module -> Module
-elaborateImports imps (Module ss coms mn decls exps) = Module ss coms mn decls' exps
- where
- decls' :: [Declaration]
- decls' =
- let (f, _, _, _, _) = everythingOnValues (++) (const []) fqValues (const []) (const []) (const [])
- in mkImport `map` nub (f `concatMap` decls) ++ decls
- fqValues :: Expr -> [ModuleName]
- fqValues (Var (Qualified (Just mn') _)) | mn' `notElem` importedModules imps = [mn']
- fqValues _ = []
- mkImport :: ModuleName -> Declaration
- mkImport mn' = ImportDeclaration mn' (Explicit []) Nothing
-
--- |
-- Replaces all local names with qualified names within a module and checks that all existing
-- qualified names are valid.
--
-renameInModule :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadState UsedImports m) => Env -> Imports -> Module -> m Module
+renameInModule
+ :: forall m
+ . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadState UsedImports m)
+ => Env
+ -> Imports
+ -> Module
+ -> m Module
renameInModule env imports (Module ss coms mn decls exps) =
Module ss coms mn <$> parU decls go <*> pure exps
where
(go, _, _, _, _) = everywhereWithContextOnValuesM (Nothing, []) updateDecl updateValue updateBinder updateCase defS
- updateDecl :: (Maybe SourceSpan, [Ident]) -> Declaration -> m ((Maybe SourceSpan, [Ident]), Declaration)
+ updateDecl
+ :: (Maybe SourceSpan, [Ident])
+ -> Declaration
+ -> m ((Maybe SourceSpan, [Ident]), Declaration)
updateDecl (_, bound) d@(PositionedDeclaration pos _ _) =
return ((Just pos, bound), d)
updateDecl (pos, bound) (DataDeclaration dtype name args dctors) =
@@ -170,9 +167,14 @@ renameInModule env imports (Module ss coms mn decls exps) =
(,) (pos, bound) <$> (TypeDeclaration name <$> updateTypesEverywhere pos ty)
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)
updateDecl s d = return (s, d)
- --
- updateValue :: (Maybe SourceSpan, [Ident]) -> Expr -> m ((Maybe SourceSpan, [Ident]), Expr)
+
+ updateValue
+ :: (Maybe SourceSpan, [Ident])
+ -> Expr
+ -> m ((Maybe SourceSpan, [Ident]), Expr)
updateValue (_, bound) v@(PositionedValue pos' _ _) =
return ((Just pos', bound), v)
updateValue (pos, bound) (Abs (Left arg) val') =
@@ -192,8 +194,11 @@ renameInModule env imports (Module ss coms mn decls exps) =
updateValue s@(pos, _) (TypedValue check val ty) =
(,) s <$> (TypedValue check val <$> updateTypesEverywhere pos ty)
updateValue s v = return (s, v)
- --
- updateBinder :: (Maybe SourceSpan, [Ident]) -> Binder -> m ((Maybe SourceSpan, [Ident]), Binder)
+
+ updateBinder
+ :: (Maybe SourceSpan, [Ident])
+ -> Binder
+ -> m ((Maybe SourceSpan, [Ident]), Binder)
updateBinder (_, bound) v@(PositionedBinder pos _ _) =
return ((Just pos, bound), v)
updateBinder s@(pos, _) (ConstructorBinder name b) =
@@ -204,8 +209,11 @@ renameInModule env imports (Module ss coms mn decls exps) =
return (s', TypedBinder t' b')
updateBinder s v =
return (s, v)
- --
- updateCase :: (Maybe SourceSpan, [Ident]) -> CaseAlternative -> m ((Maybe SourceSpan, [Ident]), CaseAlternative)
+
+ updateCase
+ :: (Maybe SourceSpan, [Ident])
+ -> CaseAlternative
+ -> m ((Maybe SourceSpan, [Ident]), CaseAlternative)
updateCase (pos, bound) c@(CaseAlternative bs _) =
return ((pos, concatMap binderNames bs ++ bound), c)
@@ -225,17 +233,26 @@ renameInModule env imports (Module ss coms mn decls exps) =
updateConstraints :: Maybe SourceSpan -> [Constraint] -> m [Constraint]
updateConstraints pos = traverse (\(name, ts) -> (,) <$> updateClassName name pos <*> traverse (updateTypesEverywhere pos) ts)
- updateTypeName :: Qualified ProperName -> Maybe SourceSpan -> m (Qualified ProperName)
- updateTypeName = update UnknownType (importedTypes imports) (resolveType . exportedTypes) IsProperName
+ updateTypeName
+ :: Qualified (ProperName 'TypeName)
+ -> Maybe SourceSpan
+ -> m (Qualified (ProperName 'TypeName))
+ updateTypeName = update UnknownType (importedTypes imports) (resolveType . exportedTypes) TyName (("type " ++) . runProperName)
- updateDataConstructorName :: Qualified ProperName -> Maybe SourceSpan -> m (Qualified ProperName)
- updateDataConstructorName = update (flip UnknownDataConstructor Nothing) (importedDataConstructors imports) (resolveDctor . exportedTypes) DctorName
+ updateDataConstructorName
+ :: Qualified (ProperName 'ConstructorName)
+ -> Maybe SourceSpan
+ -> m (Qualified (ProperName 'ConstructorName))
+ updateDataConstructorName = update (flip UnknownDataConstructor Nothing) (importedDataConstructors imports) (resolveDctor . exportedTypes) DctorName (("data constructor " ++) . runProperName)
- updateClassName :: Qualified ProperName -> Maybe SourceSpan -> m (Qualified ProperName)
- updateClassName = update UnknownTypeClass (importedTypeClasses imports) (resolve . exportedTypeClasses) IsProperName
+ updateClassName
+ :: Qualified (ProperName 'ClassName)
+ -> Maybe SourceSpan
+ -> m (Qualified (ProperName 'ClassName))
+ updateClassName = update UnknownTypeClass (importedTypeClasses imports) (resolve . exportedTypeClasses) TyClassName (("class " ++) . runProperName)
- updateValueName :: Qualified Ident -> Maybe SourceSpan -> m (Qualified Ident)
- updateValueName = update UnknownValue (importedValues imports) (resolve . exportedValues) IdentName
+ updateValueName :: Qualified Ident -> Maybe SourceSpan -> m (Qualified Ident)
+ updateValueName = update UnknownValue (importedValues imports) (resolve . exportedValues) IdentName (("value " ++) . runIdent)
-- Used when performing an update to qualify values and classes with their
-- module of original definition.
@@ -244,54 +261,98 @@ renameInModule env imports (Module ss coms mn decls exps) =
-- Used when performing an update to qualify types with their module of
-- original definition.
- resolveType :: [((ProperName, [ProperName]), ModuleName)] -> ProperName -> Maybe (Qualified ProperName)
+ resolveType
+ :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]
+ -> ProperName 'TypeName
+ -> Maybe (Qualified (ProperName 'TypeName))
resolveType tys name = mkQualified name . snd <$> find ((== name) . fst . fst) tys
-- Used when performing an update to qualify data constructors with their
-- module of original definition.
- resolveDctor :: [((ProperName, [ProperName]), ModuleName)] -> ProperName -> Maybe (Qualified ProperName)
+ resolveDctor
+ :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]
+ -> ProperName 'ConstructorName
+ -> Maybe (Qualified (ProperName 'ConstructorName))
resolveDctor tys name = mkQualified name . snd <$> find (elem name . snd . fst) tys
-- Update names so unqualified references become qualified, and locally
-- qualified references are replaced with their canoncial qualified names
-- (e.g. M.Map -> Data.Map.Map).
- update :: (Ord a) => (Qualified a -> SimpleErrorMessage)
- -> M.Map (Qualified a) (Qualified a, ModuleName)
- -> (Exports -> a -> Maybe (Qualified a))
- -> (Qualified a -> Name)
- -> Qualified a
- -> Maybe SourceSpan
- -> m (Qualified a)
- update unknown imps getE toName qname@(Qualified mn' name) pos = positioned $
+ update
+ :: (Ord a, Show a)
+ => (Qualified a -> SimpleErrorMessage)
+ -> M.Map (Qualified a) [(Qualified a, ModuleName)]
+ -> (Exports -> a -> Maybe (Qualified a))
+ -> (Qualified a -> Name)
+ -> (a -> String)
+ -> Qualified a
+ -> Maybe SourceSpan
+ -> m (Qualified a)
+ update unknown imps getE toName render qname@(Qualified mn' name) pos = positioned $
case (M.lookup qname imps, mn') of
+
-- We found the name in our imports, so we return the name for it,
-- qualifying with the name of the module it was originally defined in
-- rather than the module we're importing from, to handle the case of
- -- re-exports.
- (Just (qn, mnOrig), _) -> do
- case qn of
- Qualified (Just mnNew) _ ->
- modify $ \result -> M.insert mnNew (maybe [toName qname] (toName qname :) (mnNew `M.lookup` result)) result
- _ -> return ()
+ -- 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
+ modify $ \result -> M.insert mnNew (maybe [toName qname] (toName qname :) (mnNew `M.lookup` result)) result
return $ Qualified (Just mnOrig) name
+
-- If the name wasn't found in our imports but was qualified then we need
-- to check whether it's a failed import from a "pseudo" module (created
-- by qualified importing). If that's not the case, then we just need to
-- check it refers to a symbol in another module.
(Nothing, Just mn'') -> do
- when (isExplicitQualModule mn'') . throwError . errorMessage $ unknown qname
- modExports <- getExports mn''
- maybe (throwError . errorMessage $ unknown qname) return (getE modExports name)
+ case M.lookup mn'' env of
+ Nothing
+ | mn'' `S.member` importedVirtualModules imports -> throwUnknown
+ | otherwise -> throwError . errorMessage $ UnknownModule mn''
+ Just env' -> maybe throwUnknown return (getE (envModuleExports env') name)
+
-- If neither of the above cases are true then it's an undefined or
-- unimported symbol.
- _ -> throwError . errorMessage $ unknown qname
+ _ -> throwUnknown
+
where
- isExplicitQualModule :: ModuleName -> Bool
- isExplicitQualModule = flip elem $ mapMaybe (\(Qualified q _) -> q) (M.keys imps)
positioned err = case pos of
Nothing -> err
Just pos' -> rethrowWithPosition pos' err
+ throwUnknown = throwError . errorMessage $ unknown qname
- -- Gets the exports for a module, or an error message if the module doesn't exist
- getExports :: ModuleName -> m Exports
- getExports mn' = maybe (throwError . errorMessage $ UnknownModule mn') (return . envModuleExports) $ M.lookup mn' env
+-- |
+-- Replaces `ProperRef` export values with a `TypeRef` or `TypeClassRef`
+-- depending on what is availble within the module. Warns when a `ProperRef`
+-- desugars into a `TypeClassRef`.
+--
+updateExportRefs
+ :: forall m
+ . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+ => Module
+ -> m Module
+updateExportRefs (Module ss coms mn decls exps) =
+ Module ss coms mn decls <$> traverse (traverse updateRef) exps
+ where
+
+ updateRef :: DeclarationRef -> m DeclarationRef
+ updateRef (ProperRef name)
+ | ProperName name `elem` classNames = do
+ tell . errorMessage . DeprecatedClassExport $ ProperName name
+ return . TypeClassRef $ ProperName name
+ -- Fall through case here - assume it's a type if it's not a class.
+ -- If it's a reference to something that doesn't actually exist it will
+ -- be picked up elsewhere
+ | otherwise = return $ TypeRef (ProperName name) (Just [])
+ updateRef (PositionedDeclarationRef pos com ref) =
+ warnWithPosition pos $ PositionedDeclarationRef pos com <$> updateRef ref
+ updateRef other = return other
+
+ classNames :: [ProperName 'ClassName]
+ classNames = mapMaybe go decls
+ where
+ go (PositionedDeclaration _ _ d) = go d
+ go (TypeClassDeclaration name _ _ _) = Just name
+ go _ = Nothing
diff --git a/src/Language/PureScript/Sugar/Names/Env.hs b/src/Language/PureScript/Sugar/Names/Env.hs
index 62f8514..6820ac5 100644
--- a/src/Language/PureScript/Sugar/Names/Env.hs
+++ b/src/Language/PureScript/Sugar/Names/Env.hs
@@ -1,17 +1,5 @@
------------------------------------------------------------------------------
---
--- Module : Language.PureScript.Sugar.Names.Env
--- License : MIT (http://opensource.org/licenses/MIT)
---
--- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>
--- Stability : experimental
--- Portability :
---
--- |
---
------------------------------------------------------------------------------
-
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
module Language.PureScript.Sugar.Names.Env
( Imports(..)
@@ -26,14 +14,21 @@ module Language.PureScript.Sugar.Names.Env
, exportType
, exportTypeClass
, exportValue
+ , getExports
+ , checkImportConflicts
) where
+import Data.Function (on)
+import Data.List (groupBy, sortBy, nub)
+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 Language.PureScript.AST
+import Language.PureScript.Crash
import Language.PureScript.Names
import Language.PureScript.Environment
import Language.PureScript.Errors
@@ -46,30 +41,35 @@ data Imports = Imports
-- |
-- Local names for types within a module mapped to to their qualified names
--
- importedTypes :: M.Map (Qualified ProperName) (Qualified ProperName, ModuleName)
+ importedTypes :: M.Map (Qualified (ProperName 'TypeName)) [(Qualified (ProperName 'TypeName), ModuleName)]
-- |
-- Local names for data constructors within a module mapped to to their qualified names
--
- , importedDataConstructors :: M.Map (Qualified ProperName) (Qualified ProperName, ModuleName)
+ , importedDataConstructors :: M.Map (Qualified (ProperName 'ConstructorName)) [(Qualified (ProperName 'ConstructorName), ModuleName)]
-- |
-- Local names for classes within a module mapped to to their qualified names
--
- , importedTypeClasses :: M.Map (Qualified ProperName) (Qualified ProperName, ModuleName)
+ , importedTypeClasses :: M.Map (Qualified (ProperName 'ClassName)) [(Qualified (ProperName 'ClassName), ModuleName)]
-- |
-- 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) [(Qualified Ident, ModuleName)]
-- |
- -- The list of modules that have been imported into the current scope.
+ -- The modules that have been imported into the current scope.
--
- , importedModules :: [ModuleName]
+ , importedModules :: S.Set ModuleName
+ -- |
+ -- The names of "virtual" modules that come into existence when "import as"
+ -- is used.
+ --
+ , importedVirtualModules :: S.Set ModuleName
} deriving (Show, Read)
-- |
-- An empty 'Imports' value.
--
nullImports :: Imports
-nullImports = Imports M.empty M.empty M.empty M.empty []
+nullImports = Imports M.empty M.empty M.empty M.empty S.empty S.empty
-- |
-- The exported declarations from a module.
@@ -80,12 +80,12 @@ data Exports = Exports
-- The types exported from each module along with the module they originally
-- came from.
--
- exportedTypes :: [((ProperName, [ProperName]), ModuleName)]
+ exportedTypes :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]
-- |
-- The classes exported from each module along with the module they originally
-- came from.
--
- , exportedTypeClasses :: [(ProperName, ModuleName)]
+ , exportedTypeClasses :: [(ProperName 'ClassName, ModuleName)]
-- |
-- The values exported from each module along with the module they originally
-- came from.
@@ -128,9 +128,10 @@ envModuleExports (_, _, exps) = exps
-- The exported types from the @Prim@ module
--
primExports :: Exports
-primExports = Exports (mkTypeEntry `map` M.keys primTypes) [] []
+primExports = Exports (mkTypeEntry `map` M.keys primTypes) (mkClassEntry `map` M.keys primClasses) []
where
- mkTypeEntry (Qualified _ name) = ((name, []), ModuleName [ProperName "Prim"])
+ mkTypeEntry (Qualified mn name) = ((name, []), fromJust mn)
+ mkClassEntry (Qualified mn name) = (name, fromJust mn)
-- | Environment which only contains the Prim module.
primEnv :: Env
@@ -142,27 +143,28 @@ primEnv = M.singleton
-- Safely adds a type and its data constructors to some exports, returning an
-- error if a conflict occurs.
--
-exportType :: (MonadError MultipleErrors m) => Exports -> ProperName -> [ProperName] -> ModuleName -> m Exports
+exportType :: (MonadError MultipleErrors m) => Exports -> ProperName 'TypeName -> [ProperName 'ConstructorName] -> ModuleName -> m Exports
exportType exps name dctors mn = do
- let exTypes = exportedTypes exps
+ let exTypes' = exportedTypes exps
+ let exTypes = filter ((/= mn) . snd) exTypes'
let exDctors = (snd . fst) `concatMap` exTypes
let exClasses = exportedTypeClasses exps
- when (any (\((name', _), _) -> name == name') exTypes) $ throwConflictError ConflictingTypeDecls name
- when (any ((== name) . fst) exClasses) $ throwConflictError TypeConflictsWithClass name
+ when (any ((== name) . fst . fst) exTypes) $ throwConflictError ConflictingTypeDecls name
+ when (any ((== coerceProperName name) . fst) exClasses) $ throwConflictError TypeConflictsWithClass name
forM_ dctors $ \dctor -> do
when (dctor `elem` exDctors) $ throwConflictError ConflictingCtorDecls dctor
- when (any ((== dctor) . fst) exClasses) $ throwConflictError CtorConflictsWithClass dctor
- return $ exps { exportedTypes = ((name, dctors), mn) : exTypes }
+ when (any ((== coerceProperName dctor) . fst) exClasses) $ throwConflictError CtorConflictsWithClass dctor
+ return $ exps { exportedTypes = nub $ ((name, dctors), mn) : exTypes' }
-- |
-- Safely adds a class to some exports, returning an error if a conflict occurs.
--
-exportTypeClass :: (MonadError MultipleErrors m) => Exports -> ProperName -> ModuleName -> m Exports
+exportTypeClass :: (MonadError MultipleErrors m) => Exports -> ProperName 'ClassName -> ModuleName -> m Exports
exportTypeClass exps name mn = do
let exTypes = exportedTypes exps
let exDctors = (snd . fst) `concatMap` exTypes
- when (any (\((name', _), _) -> name == name') exTypes) $ throwConflictError ClassConflictsWithType name
- when (name `elem` exDctors) $ throwConflictError ClassConflictsWithCtor name
+ when (any ((== coerceProperName name) . fst . fst) exTypes) $ throwConflictError ClassConflictsWithType name
+ when (coerceProperName name `elem` exDctors) $ throwConflictError ClassConflictsWithCtor name
classes <- addExport DuplicateClassExport name mn (exportedTypeClasses exps)
return $ exps { exportedTypeClasses = classes }
@@ -180,12 +182,39 @@ exportValue exps name mn = do
--
addExport :: (MonadError MultipleErrors m, Eq a) => (a -> SimpleErrorMessage) -> a -> ModuleName -> [(a, ModuleName)] -> m [(a, ModuleName)]
addExport what name mn exports =
- if any ((== name) . fst) exports
+ if any (\(name', mn') -> name == name' && mn /= mn') exports
then throwConflictError what name
- else return $ (name, mn) : exports
+ else return $ nub $ (name, mn) : exports
-- |
-- Raises an error for when there is more than one definition for something.
--
throwConflictError :: (MonadError MultipleErrors m) => (a -> SimpleErrorMessage) -> a -> m b
throwConflictError conflict = throwError . errorMessage . conflict
+
+-- Gets the exports for a module, or an error message if the module doesn't exist
+getExports :: (MonadError MultipleErrors m) => Env -> ModuleName -> m Exports
+getExports env mn = maybe (throwError . errorMessage $ UnknownModule mn) (return . envModuleExports) $ M.lookup mn env
+
+-- |
+-- When reading a value from the imports, check that there are no conflicts in
+-- scope.
+--
+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
+ in
+ if length byOrig > 1
+ then throwError . errorMessage $ ScopeConflict (render' (fst . head $ xs)) (map (getQual . fst . head) byOrig)
+ else return ()
+ where
+ getQual :: Qualified a -> ModuleName
+ getQual (Qualified (Just mn) _) = mn
+ getQual _ = internalError "unexpected unqualified name in checkImportConflicts"
+ render' :: Qualified a -> String
+ render' (Qualified _ a) = render a
diff --git a/src/Language/PureScript/Sugar/Names/Exports.hs b/src/Language/PureScript/Sugar/Names/Exports.hs
index 7b82792..6b1e68e 100644
--- a/src/Language/PureScript/Sugar/Names/Exports.hs
+++ b/src/Language/PureScript/Sugar/Names/Exports.hs
@@ -1,20 +1,8 @@
------------------------------------------------------------------------------
---
--- Module : Language.PureScript.Sugar.Names.Exports
--- License : MIT (http://opensource.org/licenses/MIT)
---
--- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>
--- Stability : experimental
--- Portability :
---
--- |
---
------------------------------------------------------------------------------
-
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE LambdaCase #-}
module Language.PureScript.Sugar.Names.Exports
( findExportable
@@ -29,6 +17,7 @@ import Data.Maybe (fromMaybe, mapMaybe)
import Data.Foldable (traverse_)
import Control.Monad
+import Control.Monad.Writer.Class (MonadWriter(..))
import Control.Monad.Error.Class (MonadError(..))
import qualified Data.Map as M
@@ -58,6 +47,7 @@ findExportable (Module _ _ mn ds _) =
updateExports exps (TypeSynonymDeclaration tn _ _) = exportType exps tn [] mn
updateExports exps (ExternDataDeclaration tn _) = exportType exps tn [] mn
updateExports exps (ValueDeclaration name _ _ _) = exportValue exps name mn
+ updateExports exps (FixityDeclaration _ name (Just _)) = exportValue exps (Op name) mn
updateExports exps (ExternDeclaration name _) = exportValue exps name mn
updateExports exps (PositionedDeclaration pos _ d) = rethrowWithPosition pos $ updateExports exps d
updateExports exps _ = return exps
@@ -66,14 +56,31 @@ findExportable (Module _ _ mn ds _) =
-- Resolves the exports for a module, filtering out members that have not been
-- exported and elaborating re-exports of other modules.
--
-resolveExports :: forall m. (Applicative m, MonadError MultipleErrors m) => Env -> ModuleName -> Imports -> Exports -> [DeclarationRef] -> m Exports
+resolveExports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Env -> ModuleName -> Imports -> Exports -> [DeclarationRef] -> m Exports
resolveExports env mn imps exps refs =
rethrow (addHint (ErrorInModule mn)) $ do
filtered <- filterModule mn exps refs
+ let (dupeRefs, dupeDctors) = findDuplicateRefs refs
+ warnDupeRefs dupeRefs
+ warnDupeDctors dupeDctors
foldM elaborateModuleExports filtered refs
where
+ warnDupeRefs :: [DeclarationRef] -> m ()
+ warnDupeRefs = traverse_ $ \case
+ TypeRef name _ -> warnDupe $ "type " ++ runProperName name
+ ValueRef name -> warnDupe $ "value " ++ runIdent name
+ TypeClassRef name -> warnDupe $ "class " ++ runProperName name
+ ModuleRef name -> warnDupe $ "module " ++ runModuleName name
+ _ -> return ()
+
+ warnDupeDctors :: [ProperName 'ConstructorName] -> m ()
+ warnDupeDctors = traverse_ (warnDupe . ("data constructor " ++) . runProperName)
+
+ warnDupe :: String -> m ()
+ warnDupe ref = tell . errorMessage $ DuplicateExportRef ref
+
-- Takes the current module's imports, the accumulated list of exports, and a
-- `DeclarationRef` for an explicit export. When the ref refers to another
-- module, export anything from the imports that matches for that module.
@@ -91,20 +98,30 @@ resolveExports env mn imps exps refs =
let isPseudo = isPseudoModule name
when (not isPseudo && not (isImportedModule name)) $
throwError . errorMessage . UnknownExportModule $ name
- let reTypes = extract isPseudo name (importedTypes imps)
- let reDctors = extract isPseudo name (importedDataConstructors imps)
- let reClasses = extract isPseudo name (importedTypeClasses imps)
- let reValues = extract isPseudo name (importedValues imps)
+ reTypes <- extract isPseudo name (("type " ++) . runProperName) (importedTypes imps)
+ reDctors <- extract isPseudo name (("data constructor " ++) . runProperName) (importedDataConstructors imps)
+ reClasses <- extract isPseudo name (("class " ++) . runProperName) (importedTypeClasses imps)
+ reValues <- extract isPseudo name (("value " ++) . runIdent) (importedValues imps)
result' <- foldM (\exps' ((tctor, dctors), mn') -> exportType exps' tctor dctors mn') result (resolveTypeExports reTypes reDctors)
result'' <- foldM (uncurry . exportTypeClass) result' (map resolveClass reClasses)
foldM (uncurry . exportValue) result'' (map resolveValue reValues)
elaborateModuleExports result _ = return result
-- 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 of the
- extract :: Bool -> ModuleName -> M.Map (Qualified a) (Qualified a, ModuleName) -> [Qualified a]
- extract True name = map fst . M.elems . M.filterWithKey (\k _ -> eqQual name k)
- extract False name = map fst . M.elems . M.filter (eqQual name . fst)
+ -- boolean is true the values are filtered by the qualification
+ extract
+ :: (Ord a)
+ => Bool
+ -> ModuleName
+ -> (a -> String)
+ -> M.Map (Qualified a) [(Qualified a, ModuleName)]
+ -> m [Qualified a]
+ extract useQual name render = fmap (map (fst . 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
+ return isMatch
-- Check whether a module name refers to a "pseudo module" that came into
-- existence in an import scope due to importing one or more modules as
@@ -116,7 +133,7 @@ resolveExports env mn imps exps refs =
-- function to either extract the keys or values. We test the keys to see if a
-- value being re-exported belongs to a qualified module, and we test the
-- values if that fails to see whether the value has been imported at all.
- testQuals :: (forall a. M.Map (Qualified a) (Qualified a, ModuleName) -> [Qualified a]) -> ModuleName -> Bool
+ testQuals :: (forall a b. M.Map (Qualified a) b -> [Qualified a]) -> ModuleName -> Bool
testQuals f mn' = any (eqQual mn') (f (importedTypes imps))
|| any (eqQual mn') (f (importedDataConstructors imps))
|| any (eqQual mn') (f (importedTypeClasses imps))
@@ -134,21 +151,26 @@ resolveExports env mn imps exps refs =
-- Constructs a list of types with their data constructors and the original
-- module they were defined in from a list of type and data constructor names.
- resolveTypeExports :: [Qualified ProperName] -> [Qualified ProperName] -> [((ProperName, [ProperName]), ModuleName)]
+ resolveTypeExports
+ :: [Qualified (ProperName 'TypeName)]
+ -> [Qualified (ProperName 'ConstructorName)]
+ -> [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]
resolveTypeExports tctors dctors = map go tctors
where
- go :: Qualified ProperName -> ((ProperName, [ProperName]), ModuleName)
+ go
+ :: Qualified (ProperName 'TypeName)
+ -> ((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)
go (Qualified (Just mn'') name) = fromMaybe (internalError "Missing value in resolveTypeExports") $ do
exps' <- envModuleExports <$> mn'' `M.lookup` env
((_, dctors'), mnOrig) <- find (\((name', _), _) -> name == name') (exportedTypes exps')
- let relevantDctors = mapMaybe (\(Qualified mn''' dctor) -> if mn''' == Just mnOrig then Just dctor else Nothing) dctors
+ let relevantDctors = mapMaybe (\(Qualified mn''' dctor) -> if mn''' == Just mn'' then Just dctor else Nothing) dctors
return ((name, intersect relevantDctors dctors'), mnOrig)
go (Qualified Nothing _) = internalError "Unqualified value in resolveTypeExports"
-- Looks up an imported class and re-qualifies it with the original module it
-- came from.
- resolveClass :: Qualified ProperName -> (ProperName, ModuleName)
+ resolveClass :: Qualified (ProperName 'ClassName) -> (ProperName 'ClassName, ModuleName)
resolveClass className = splitQual $ fromMaybe (internalError "Missing value in resolveClass") $
resolve exportedTypeClasses className
@@ -175,7 +197,13 @@ resolveExports env mn imps exps refs =
-- Filters the full list of exportable values, types, and classes for a module
-- based on a list of export declaration references.
--
-filterModule :: forall m. (Applicative m, MonadError MultipleErrors m) => ModuleName -> Exports -> [DeclarationRef] -> m Exports
+filterModule
+ :: forall m
+ . (Applicative m, MonadError MultipleErrors m)
+ => ModuleName
+ -> Exports
+ -> [DeclarationRef]
+ -> m Exports
filterModule mn exps refs = do
types <- foldM (filterTypes $ exportedTypes exps) [] refs
values <- foldM (filterValues $ exportedValues exps) [] refs
@@ -189,7 +217,11 @@ filterModule mn exps refs = do
-- explicit export. When the ref refers to a type in the list of exportable
-- values, the type and specified data constructors are included in the
-- result.
- filterTypes :: [((ProperName, [ProperName]), ModuleName)] -> [((ProperName, [ProperName]), ModuleName)] -> DeclarationRef -> m [((ProperName, [ProperName]), ModuleName)]
+ filterTypes
+ :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]
+ -> [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]
+ -> DeclarationRef
+ -> m [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]
filterTypes exps' result (PositionedDeclarationRef pos _ r) =
rethrowWithPosition pos $ filterTypes exps' result r
filterTypes exps' result (TypeRef name expDcons) =
@@ -204,7 +236,11 @@ filterModule mn exps refs = do
-- Ensures a data constructor is exportable for a given type. Takes a type
-- name, a list of exportable data constructors for the type, and the name of
-- the data constructor to check.
- checkDcon :: ProperName -> [ProperName] -> ProperName -> m ()
+ checkDcon
+ :: ProperName 'TypeName
+ -> [ProperName 'ConstructorName]
+ -> ProperName 'ConstructorName
+ -> m ()
checkDcon tcon exps' name =
unless (name `elem` exps') $
throwError . errorMessage $ UnknownExportDataConstructor tcon name
@@ -213,7 +249,11 @@ filterModule mn exps refs = do
-- filtered exports, and a `DeclarationRef` for an explicit export. When the
-- ref refers to a class in the list of exportable classes, the class is
-- included in the result.
- filterClasses :: [(ProperName, ModuleName)] -> [(ProperName, ModuleName)] -> DeclarationRef -> m [(ProperName, ModuleName)]
+ filterClasses
+ :: [(ProperName 'ClassName, ModuleName)]
+ -> [(ProperName 'ClassName, ModuleName)]
+ -> DeclarationRef
+ -> m [(ProperName 'ClassName, ModuleName)]
filterClasses exps' result (PositionedDeclarationRef pos _ r) =
rethrowWithPosition pos $ filterClasses exps' result r
filterClasses exps' result (TypeClassRef name) =
diff --git a/src/Language/PureScript/Sugar/Names/Imports.hs b/src/Language/PureScript/Sugar/Names/Imports.hs
index 70d61b2..886c8fc 100644
--- a/src/Language/PureScript/Sugar/Names/Imports.hs
+++ b/src/Language/PureScript/Sugar/Names/Imports.hs
@@ -1,19 +1,7 @@
------------------------------------------------------------------------------
---
--- Module : Language.PureScript.Sugar.Names.Imports
--- License : MIT (http://opensource.org/licenses/MIT)
---
--- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>
--- Stability : experimental
--- Portability :
---
--- |
---
------------------------------------------------------------------------------
-
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE LambdaCase #-}
module Language.PureScript.Sugar.Names.Imports
( resolveImports
@@ -24,16 +12,18 @@ module Language.PureScript.Sugar.Names.Imports
import Prelude ()
import Prelude.Compat
-import Data.List (find)
-import Data.Maybe (fromMaybe, isNothing)
-import Data.Foldable (traverse_)
+import Data.List (find, delete, (\\))
+import Data.Maybe (fromMaybe, isJust, isNothing, fromJust)
+import Data.Foldable (traverse_, for_)
+import Data.Traversable (for)
import Control.Arrow (first)
import Control.Monad
import Control.Monad.Error.Class (MonadError(..))
-import Control.Monad.Writer (MonadWriter(..), censor)
+import Control.Monad.Writer (MonadWriter(..))
import qualified Data.Map as M
+import qualified Data.Set as S
import Language.PureScript.Crash
import Language.PureScript.AST
@@ -45,46 +35,145 @@ import Language.PureScript.Sugar.Names.Env
-- Finds the imports within a module, mapping the imported module name to an optional set of
-- explicitly imported declarations.
--
-findImports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [Declaration] -> m (M.Map ModuleName [(Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)])
+findImports
+ :: forall m
+ . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+ => [Declaration]
+ -> m (M.Map ModuleName [(Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)])
findImports = foldM (go Nothing) M.empty
where
- go pos result (ImportDeclaration mn typ qual) = do
- checkImportRefType typ
+ go pos result (ImportDeclaration mn typ qual isOldSyntax) = do
+ when isOldSyntax . tell . errorMessage $ DeprecatedQualifiedSyntax mn (fromJust qual)
let imp = (pos, typ, qual)
return $ M.insert mn (maybe [imp] (imp :) (mn `M.lookup` result)) result
- go _ result (PositionedDeclaration pos _ d) = rethrowWithPosition pos $ go (Just pos) result d
+ go _ result (PositionedDeclaration pos _ d) = warnAndRethrowWithPosition pos $ go (Just pos) result d
go _ result _ = return result
- -- Ensure that classes don't appear in an `import X hiding (...)`
- checkImportRefType :: ImportDeclarationType -> m ()
- checkImportRefType (Hiding refs) = traverse_ checkImportRef refs
- checkImportRefType _ = return ()
- checkImportRef :: DeclarationRef -> m ()
- checkImportRef (ModuleRef name) = throwError . errorMessage $ ImportHidingModule name
- checkImportRef _ = return ()
+type ImportDef = (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)
-- |
-- Constructs a set of imports for a module.
--
-resolveImports :: (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Env -> Module -> m Imports
-resolveImports env (Module _ _ currentModule decls _) =
- censor (addHint (ErrorInModule currentModule)) $ do
- scope <- M.insert currentModule [(Nothing, Implicit, Nothing)] <$> findImports decls
- foldM (resolveModuleImport currentModule env) nullImports (M.toList scope)
+resolveImports
+ :: forall m
+ . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+ => Env
+ -> Module
+ -> m (Module, Imports)
+resolveImports env (Module ss coms currentModule decls exps) =
+ warnAndRethrow (addHint (ErrorInModule currentModule)) $ do
+
+ decls' <- traverse updateImportRef decls
+ imports <- findImports decls'
+
+ for_ (M.toList imports) $ \(mn, imps) -> do
+
+ -- Better ordering for the warnings: the list is in last-import-first
+ -- order, but we want the first appearence of an import to be the primary,
+ -- and warnings to appear for later imports
+ let imps' = reverse imps
+
+ warned <- foldM (checkDuplicateImports mn) [] (selfCartesianSubset imps')
+
+ let unqual = filter (\(_, _, q) -> isJust q) (imps' \\ warned)
+
+ warned' <- (warned ++) <$>
+ if (length unqual < 2)
+ then return []
+ else case find (\(_, typ, _) -> isImplicit typ) unqual of
+ Just i ->
+ for (delete i unqual) $ \i'@(pos, typ, _) -> do
+ warn pos $ RedundantUnqualifiedImport mn typ
+ return i'
+ Nothing ->
+ for (tail unqual) $ \i@(pos, _, _) -> do
+ warn pos $ DuplicateSelectiveImport mn
+ return i
+
+ for_ (imps' \\ warned') $ \(pos, typ, _) ->
+ let (dupeRefs, dupeDctors) = findDuplicateRefs $ case typ of
+ Explicit refs -> refs
+ Hiding refs -> refs
+ _ -> []
+ in warnDupeRefs pos dupeRefs >> warnDupeDctors pos dupeDctors
+
+ return ()
+
+ let scope = M.insert currentModule [(Nothing, Implicit, Nothing)] imports
+ resolved <- foldM (resolveModuleImport env) nullImports (M.toList scope)
+ return (Module ss coms currentModule decls' exps, resolved)
+
+ where
+ selfCartesianSubset :: [a] -> [(a, a)]
+ selfCartesianSubset (x : xs) = [(x, y) | y <- xs] ++ selfCartesianSubset xs
+ selfCartesianSubset [] = []
+
+ checkDuplicateImports :: ModuleName -> [ImportDef] -> (ImportDef, ImportDef) -> m [ImportDef]
+ checkDuplicateImports mn xs ((_, t1, q1), (pos, t2, q2)) =
+ if (t1 == t2 && q1 == q2)
+ then do
+ warn pos $ DuplicateImport mn t2 q2
+ return $ (pos, t2, q2) : xs
+ else return xs
+
+ warnDupeRefs :: Maybe SourceSpan -> [DeclarationRef] -> m ()
+ warnDupeRefs pos = traverse_ $ \case
+ TypeRef name _ -> warnDupe pos $ "type " ++ runProperName name
+ ValueRef name -> warnDupe pos $ "value " ++ runIdent name
+ TypeClassRef name -> warnDupe pos $ "class " ++ runProperName name
+ ModuleRef name -> warnDupe pos $ "module " ++ runModuleName name
+ _ -> return ()
+
+ warnDupeDctors :: Maybe SourceSpan -> [ProperName 'ConstructorName] -> m ()
+ warnDupeDctors pos = traverse_ (warnDupe pos . ("data constructor " ++) . runProperName)
+
+ warnDupe :: Maybe SourceSpan -> String -> m ()
+ warnDupe pos ref = warn pos $ DuplicateImportRef ref
+
+ warn :: Maybe SourceSpan -> SimpleErrorMessage -> m ()
+ warn pos msg = maybe id warnWithPosition pos $ tell . errorMessage $ msg
+
+ updateImportRef :: Declaration -> m Declaration
+ updateImportRef (PositionedDeclaration pos com d) =
+ warnAndRethrowWithPosition pos $ PositionedDeclaration pos com <$> updateImportRef d
+ updateImportRef (ImportDeclaration mn typ qual isOldSyntax) = do
+ modExports <- getExports env mn
+ typ' <- case typ of
+ Implicit -> return Implicit
+ Explicit refs -> Explicit <$> updateProperRef mn modExports `traverse` refs
+ Hiding refs -> Hiding <$> updateProperRef mn modExports `traverse` refs
+ return $ ImportDeclaration mn typ' qual isOldSyntax
+ updateImportRef other = return other
+
+ updateProperRef :: ModuleName -> Exports -> DeclarationRef -> m DeclarationRef
+ updateProperRef importModule modExports (ProperRef name) =
+ if ProperName name `elem` (fst `map` exportedTypeClasses modExports)
+ then do
+ tell . errorMessage $ DeprecatedClassImport importModule (ProperName name)
+ return . TypeClassRef $ ProperName name
+ else return $ TypeRef (ProperName name) (Just [])
+ updateProperRef importModule modExports (PositionedDeclarationRef pos com ref) =
+ PositionedDeclarationRef pos com <$> updateProperRef importModule modExports ref
+ updateProperRef _ _ other = return other
-- | Constructs a set of imports for a single module import.
-resolveModuleImport ::
- forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
- ModuleName -> Env -> Imports ->
- (ModuleName, [(Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)]) ->
- m Imports
-resolveModuleImport currentModule env ie (mn, imps) = foldM go ie imps
+resolveModuleImport
+ :: forall m
+ . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+ => Env
+ -> Imports
+ -> (ModuleName, [(Maybe SourceSpan, 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 ie' (pos, typ, impQual) = do
modExports <- positioned $ maybe (throwError . errorMessage $ UnknownModule mn) (return . envModuleExports) $ mn `M.lookup` env
- let ie'' = ie' { importedModules = mn : importedModules ie' }
- positioned $ resolveImport currentModule mn modExports ie'' impQual typ
+ let virtualModules = importedVirtualModules ie'
+ ie'' = ie' { importedModules = S.insert mn (importedModules ie')
+ , importedVirtualModules = maybe virtualModules (`S.insert` virtualModules) impQual
+ }
+ positioned $ resolveImport mn modExports ie'' impQual typ
where
positioned err = case pos of
Nothing -> err
@@ -93,19 +182,34 @@ resolveModuleImport currentModule env ie (mn, imps) = foldM go ie imps
-- |
-- Extends the local environment for a module by resolving an import of another module.
--
-resolveImport :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => ModuleName -> ModuleName -> Exports -> Imports -> Maybe ModuleName -> ImportDeclarationType -> m Imports
-resolveImport currentModule importModule exps imps impQual =
- resolveByType
+resolveImport
+ :: forall m
+ . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+ => ModuleName
+ -> Exports
+ -> Imports
+ -> Maybe ModuleName
+ -> ImportDeclarationType
+ -> m Imports
+resolveImport importModule exps imps impQual = resolveByType
where
resolveByType :: ImportDeclarationType -> m Imports
resolveByType Implicit = importAll importExplicit
- resolveByType (Explicit explImports) = checkRefs explImports >> foldM importExplicit imps explImports
- resolveByType (Hiding hiddenImports) = checkRefs hiddenImports >> importAll (importNonHidden hiddenImports)
+ resolveByType (Explicit refs) = checkRefs False refs >> foldM importExplicit imps refs
+ resolveByType (Hiding refs) = do
+ imps' <- checkRefs True refs >> importAll (importNonHidden refs)
+ let isEmptyImport
+ = M.null (importedTypes imps')
+ && M.null (importedDataConstructors imps')
+ && M.null (importedTypeClasses imps')
+ && M.null (importedValues imps')
+ when isEmptyImport $ tell . errorMessage $ RedundantEmptyHidingImport importModule
+ return imps'
-- Check that a 'DeclarationRef' refers to an importable symbol
- checkRefs :: [DeclarationRef] -> m ()
- checkRefs = traverse_ check
+ checkRefs :: Bool -> [DeclarationRef] -> m ()
+ checkRefs isHiding = traverse_ check
where
check (PositionedDeclarationRef pos _ r) =
rethrowWithPosition pos $ check r
@@ -117,18 +221,27 @@ resolveImport currentModule importModule exps imps impQual =
maybe (return ()) (traverse_ $ checkDctorExists name allDctors) dctors
check (TypeClassRef name) =
checkImportExists UnknownImportTypeClass (fst `map` exportedTypeClasses exps) name
- --check (ModuleRef name) =
- -- checkImportExists (const UnknownModule) (exportedModules exps) name
- check _ = internalError "Invalid argument to checkRefs"
+ check (ModuleRef name) | isHiding =
+ throwError . errorMessage $ ImportHidingModule name
+ check r = internalError $ "Invalid argument to checkRefs: " ++ show r
-- Check that an explicitly imported item exists in the module it is being imported from
- checkImportExists :: (Eq a) => (ModuleName -> a -> SimpleErrorMessage) -> [a] -> a -> m ()
+ checkImportExists
+ :: Eq a
+ => (ModuleName -> a -> SimpleErrorMessage)
+ -> [a]
+ -> a
+ -> m ()
checkImportExists unknown exports item =
when (item `notElem` exports) $ throwError . errorMessage $ unknown importModule item
-- Ensure that an explicitly imported data constructor exists for the type it is being imported
-- from
- checkDctorExists :: ProperName -> [ProperName] -> ProperName -> m ()
+ checkDctorExists
+ :: ProperName 'TypeName
+ -> [ProperName 'ConstructorName]
+ -> ProperName 'ConstructorName
+ -> m ()
checkDctorExists tcon = checkImportExists (flip UnknownImportDataConstructor tcon)
importNonHidden :: [DeclarationRef] -> Imports -> DeclarationRef -> m Imports
@@ -160,55 +273,38 @@ resolveImport currentModule importModule exps imps impQual =
importExplicit imp (PositionedDeclarationRef pos _ r) =
warnAndRethrowWithPosition pos $ importExplicit imp r
importExplicit imp (ValueRef name) = do
- values' <- updateImports (importedValues imp) showIdent (exportedValues exps) name
+ let values' = updateImports (importedValues imp) (exportedValues exps) name
return $ imp { importedValues = values' }
importExplicit imp (TypeRef name dctors) = do
- types' <- updateImports (importedTypes imp) runProperName (first fst `map` exportedTypes exps) name
- let exportedDctors :: [(ProperName, ModuleName)]
+ let types' = updateImports (importedTypes imp) (first fst `map` exportedTypes exps) name
+ let exportedDctors :: [(ProperName 'ConstructorName, ModuleName)]
exportedDctors = allExportedDataConstructors name
- dctorNames :: [ProperName]
+ dctorNames :: [ProperName 'ConstructorName]
dctorNames = fst `map` exportedDctors
maybe (return ()) (traverse_ $ checkDctorExists name dctorNames) dctors
when (null dctorNames && isNothing dctors) . tell . errorMessage $ MisleadingEmptyTypeImport importModule name
- dctors' <- foldM (\m -> updateImports m runProperName exportedDctors) (importedDataConstructors imp) (fromMaybe dctorNames dctors)
+ let dctors' = foldl (\m -> updateImports m exportedDctors) (importedDataConstructors imp) (fromMaybe dctorNames dctors)
return $ imp { importedTypes = types', importedDataConstructors = dctors' }
importExplicit imp (TypeClassRef name) = do
- typeClasses' <- updateImports (importedTypeClasses imp) runProperName (exportedTypeClasses exps) name
+ let typeClasses' = updateImports (importedTypeClasses imp) (exportedTypeClasses exps) name
return $ imp { importedTypeClasses = typeClasses' }
importExplicit _ _ = internalError "Invalid argument to importExplicit"
-- Find all exported data constructors for a given type
- allExportedDataConstructors :: ProperName -> [(ProperName, ModuleName)]
+ allExportedDataConstructors :: ProperName 'TypeName -> [(ProperName 'ConstructorName, ModuleName)]
allExportedDataConstructors name =
case find ((== name) . fst . fst) (exportedTypes exps) of
Nothing -> internalError "Invalid state in allExportedDataConstructors"
Just ((_, dctors), mn) -> map (, mn) dctors
- -- Add something to the Imports if it does not already exist there
- updateImports :: (Ord a) => M.Map (Qualified a) (Qualified a, ModuleName)
- -> (a -> String)
- -> [(a, ModuleName)]
- -> a
- -> m (M.Map (Qualified a) (Qualified a, ModuleName))
- updateImports imps' render exps' name = case M.lookup (Qualified impQual name) imps' of
-
- -- If the name is not already present add it to the list, after looking up
- -- where it was originally defined
- Nothing ->
- let mnOrig = fromMaybe (internalError "Invalid state in updateImports") (name `lookup` exps')
- in return $ M.insert (Qualified impQual name) (Qualified (Just importModule) name, mnOrig) imps'
-
- -- If the name already is present check whether it's a duplicate import
- -- before rejecting it. For example, if module A defines X, and module B
- -- re-exports A, importing A and B in C should not result in a "conflicting
- -- import for `x`" error
- Just (Qualified (Just mn) _, mnOrig)
- | mnOrig == fromMaybe (internalError "Invalid state in updateImports") (name `lookup` exps') -> return imps'
- | otherwise -> throwError . errorMessage $ err
- where
- err = if currentModule `elem` [mn, importModule]
- then ConflictingImport (render name) importModule
- else ConflictingImports (render name) mn importModule
-
- Just (Qualified Nothing _, _) ->
- internalError "Invalid state in updateImports"
+ -- Add something to an import resolution list
+ updateImports
+ :: (Ord a)
+ => M.Map (Qualified a) [(Qualified a, ModuleName)]
+ -> [(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'
diff --git a/src/Language/PureScript/Sugar/ObjectWildcards.hs b/src/Language/PureScript/Sugar/ObjectWildcards.hs
index a68331e..136e892 100644
--- a/src/Language/PureScript/Sugar/ObjectWildcards.hs
+++ b/src/Language/PureScript/Sugar/ObjectWildcards.hs
@@ -1,17 +1,3 @@
------------------------------------------------------------------------------
---
--- Module : Language.PureScript.Sugar.ObjectWildcards
--- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
--- License : MIT (http://opensource.org/licenses/MIT)
---
--- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>
--- Stability : experimental
--- Portability :
---
--- |
---
------------------------------------------------------------------------------
-
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
@@ -44,10 +30,10 @@ desugarObjectConstructors (Module ss coms mn ds exts) = Module ss coms mn <$> ma
desugarExpr (ObjectConstructor ps) = wrapLambda ObjectLiteral ps
desugarExpr (ObjectUpdater (Just obj) ps) = wrapLambda (ObjectUpdate obj) ps
desugarExpr (ObjectUpdater Nothing ps) = do
- obj <- Ident <$> freshName
+ obj <- freshIdent'
Abs (Left obj) <$> wrapLambda (ObjectUpdate (Var (Qualified Nothing obj))) ps
desugarExpr (ObjectGetter prop) = do
- arg <- Ident <$> freshName
+ arg <- freshIdent'
return $ Abs (Left arg) (Accessor prop (Var (Qualified Nothing arg)))
desugarExpr e = return e
@@ -63,5 +49,5 @@ desugarObjectConstructors (Module ss coms mn ds exts) = Module ss coms mn <$> ma
mkProp :: (String, Maybe Expr) -> m (Maybe Ident, (String, Expr))
mkProp (name, Just e) = return (Nothing, (name, e))
mkProp (name, Nothing) = do
- arg <- Ident <$> freshName
+ arg <- freshIdent'
return (Just arg, (name, Var (Qualified Nothing arg)))
diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs
index 5934b9f..4d401fa 100644
--- a/src/Language/PureScript/Sugar/Operators.hs
+++ b/src/Language/PureScript/Sugar/Operators.hs
@@ -1,13 +1,9 @@
------------------------------------------------------------------------------
---
--- Module : Language.PureScript.Sugar.Operators
--- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
--- License : MIT (http://opensource.org/licenses/MIT)
---
--- Maintainer : Phil Freeman <paf31@cantab.net>
--- Stability : experimental
--- Portability :
---
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TupleSections #-}
+
-- |
-- This module implements the desugaring pass which reapplies binary operators based
-- on their fixity data and removes explicit parentheses.
@@ -15,13 +11,6 @@
-- The value parser ignores fixity data when parsing binary operator applications, so
-- it is necessary to reorder them here.
--
------------------------------------------------------------------------------
-
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE RecordWildCards #-}
-
module Language.PureScript.Sugar.Operators (
rebracket,
removeSignedLiterals,
@@ -44,6 +33,8 @@ import Control.Monad.Supply.Class
import Data.Function (on)
import Data.Functor.Identity
import Data.List (groupBy, sortBy)
+import Data.Maybe (mapMaybe, fromMaybe)
+import qualified Data.Map as M
import qualified Text.Parsec as P
import qualified Text.Parsec.Pos as P
@@ -57,9 +48,23 @@ import qualified Language.PureScript.Constants as C
rebracket :: (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
- traverse (rebracketModule opTable) 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'
+
+ where
+
+ makeLookupEntry :: (Qualified Ident, SourceSpan, Fixity, Maybe (Qualified Ident)) -> Maybe (Qualified Ident, Qualified Ident)
+ 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
+ where
+ (f', _, _) = everywhereOnValues id go id
+ go (Var name) = Var $ fromMaybe name (name `M.lookup` aliased)
+ go other = other
removeSignedLiterals :: Module -> Module
removeSignedLiterals (Module ss coms mn ds exts) = Module ss coms mn (map f' ds) exts
@@ -82,17 +87,18 @@ removeParens =
go (Parens val) = val
go val = val
-externsFixities :: ExternsFile -> [(Qualified Ident, SourceSpan, Fixity)]
+externsFixities :: ExternsFile -> [(Qualified Ident, SourceSpan, Fixity, Maybe (Qualified Ident))]
externsFixities ExternsFile{..} =
- [ (Qualified (Just efModuleName) (Op op), internalModuleSourceSpan "", Fixity assoc prec)
- | ExternsFixity assoc prec op <- efFixities
- ]
+ [ (Qualified (Just efModuleName) (Op op), internalModuleSourceSpan "", Fixity assoc prec, alias)
+ | ExternsFixity assoc prec op alias <- efFixities
+ ]
-collectFixities :: Module -> [(Qualified Ident, SourceSpan, Fixity)]
+collectFixities :: Module -> [(Qualified Ident, SourceSpan, Fixity, Maybe (Qualified Ident))]
collectFixities (Module _ _ moduleName ds _) = concatMap collect ds
where
- collect :: Declaration -> [(Qualified Ident, SourceSpan, Fixity)]
- collect (PositionedDeclaration pos _ (FixityDeclaration fixity name)) = [(Qualified (Just moduleName) (Op name), pos, fixity)]
+ collect :: Declaration -> [(Qualified Ident, SourceSpan, Fixity, Maybe (Qualified Ident))]
+ collect (PositionedDeclaration pos _ (FixityDeclaration fixity name alias)) =
+ [(Qualified (Just moduleName) (Op name), pos, fixity, alias)]
collect FixityDeclaration{} = internalError "Fixity without srcpos info"
collect _ = []
@@ -172,6 +178,6 @@ desugarOperatorSections (Module ss coms mn ds exts) = Module ss coms mn <$> trav
goExpr :: Expr -> m Expr
goExpr (OperatorSection op (Left val)) = return $ App op val
goExpr (OperatorSection op (Right val)) = do
- arg <- Ident <$> freshName
+ arg <- freshIdent'
return $ Abs (Left arg) $ App (App op (Var (Qualified Nothing arg))) val
goExpr other = return other
diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs
index 44300e3..03a7324 100644
--- a/src/Language/PureScript/Sugar/TypeClasses.hs
+++ b/src/Language/PureScript/Sugar/TypeClasses.hs
@@ -1,22 +1,11 @@
------------------------------------------------------------------------------
---
--- Module : Language.PureScript.Sugar.TypeClasses
--- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
--- License : MIT (http://opensource.org/licenses/MIT)
---
--- Maintainer : Phil Freeman <paf31@cantab.net>
--- Stability : experimental
--- Portability :
---
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
-- |
-- This module implements the desugaring pass which creates type synonyms for type class dictionaries
-- and dictionary expressions for type class instances.
--
------------------------------------------------------------------------------
-
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE RecordWildCards #-}
-
module Language.PureScript.Sugar.TypeClasses
( desugarTypeClasses
, typeClassMemberName
@@ -47,7 +36,7 @@ import Data.Maybe (catMaybes, mapMaybe, isJust)
import qualified Data.Map as M
-type MemberMap = M.Map (ModuleName, ProperName) ([(String, Maybe Kind)], [Constraint], [Declaration])
+type MemberMap = M.Map (ModuleName, ProperName 'ClassName) ([(String, Maybe Kind)], [Constraint], [Declaration])
type Desugar = StateT MemberMap
@@ -55,17 +44,27 @@ type Desugar = StateT MemberMap
-- Add type synonym declarations for type class dictionary types, and value declarations for type class
-- instance dictionary expressions.
--
-desugarTypeClasses :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module]
+desugarTypeClasses
+ :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m)
+ => [ExternsFile]
+ -> [Module]
+ -> m [Module]
desugarTypeClasses externs = flip evalStateT initialState . traverse desugarModule
where
initialState :: MemberMap
initialState = M.fromList (externs >>= \ExternsFile{..} -> mapMaybe (fromExternsDecl efModuleName) efDeclarations)
- fromExternsDecl :: ModuleName -> ExternsDeclaration -> Maybe ((ModuleName, ProperName), ([(String, Maybe Kind)], [Constraint], [Declaration]))
+ fromExternsDecl
+ :: ModuleName
+ -> ExternsDeclaration
+ -> Maybe ((ModuleName, ProperName 'ClassName), ([(String, Maybe Kind)], [Constraint], [Declaration]))
fromExternsDecl mn (EDClass name args members implies) = Just ((mn, name), (args, implies, map (uncurry TypeDeclaration) members))
fromExternsDecl _ _ = Nothing
-desugarModule :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Module -> Desugar m Module
+desugarModule
+ :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m)
+ => Module
+ -> Desugar m Module
desugarModule (Module ss coms name decls (Just exps)) = do
(newExpss, declss) <- unzip <$> parU (sortBy classesFirst decls) (desugarDecl name exps)
return $ Module ss coms name (concat declss) $ Just (exps ++ catMaybes newExpss)
@@ -171,7 +170,12 @@ desugarModule _ = internalError "Exports should have been elaborated in name des
-- return new Sub(fooString, "");
-- };
-}
-desugarDecl :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => ModuleName -> [DeclarationRef] -> Declaration -> Desugar m (Maybe DeclarationRef, [Declaration])
+desugarDecl
+ :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m)
+ => ModuleName
+ -> [DeclarationRef]
+ -> Declaration
+ -> Desugar m (Maybe DeclarationRef, [Declaration])
desugarDecl mn exps = go
where
go d@(TypeClassDeclaration name args implies members) = do
@@ -187,48 +191,60 @@ desugarDecl mn exps = go
return (dr, map (PositionedDeclaration pos com) ds)
go other = return (Nothing, [other])
- expRef :: Ident -> Qualified ProperName -> [Type] -> Maybe DeclarationRef
+ expRef :: Ident -> Qualified (ProperName 'ClassName) -> [Type] -> Maybe DeclarationRef
expRef name className tys
| isExportedClass className && all isExportedType (getConstructors `concatMap` tys) = Just $ TypeInstanceRef name
| otherwise = Nothing
- isExportedClass :: Qualified ProperName -> Bool
+ isExportedClass :: Qualified (ProperName 'ClassName) -> Bool
isExportedClass = isExported (elem . TypeClassRef)
- isExportedType :: Qualified ProperName -> Bool
+ isExportedType :: Qualified (ProperName 'TypeName) -> Bool
isExportedType = isExported $ \pn -> isJust . find (matchesTypeRef pn)
- isExported :: (ProperName -> [DeclarationRef] -> Bool) -> Qualified ProperName -> Bool
+ isExported
+ :: (ProperName a -> [DeclarationRef] -> Bool)
+ -> Qualified (ProperName a)
+ -> Bool
isExported test (Qualified (Just mn') pn) = mn /= mn' || test pn exps
isExported _ _ = internalError "Names should have been qualified in name desugaring"
- matchesTypeRef :: ProperName -> DeclarationRef -> Bool
+ matchesTypeRef :: ProperName 'TypeName -> DeclarationRef -> Bool
matchesTypeRef pn (TypeRef pn' _) = pn == pn'
matchesTypeRef _ _ = False
- getConstructors :: Type -> [Qualified ProperName]
+ getConstructors :: Type -> [Qualified (ProperName 'TypeName)]
getConstructors = everythingOnTypes (++) getConstructor
-
- getConstructor :: Type -> [Qualified ProperName]
- getConstructor (TypeConstructor tcname) = [tcname]
- getConstructor _ = []
+ where
+ getConstructor (TypeConstructor tcname) = [tcname]
+ getConstructor _ = []
memberToNameAndType :: Declaration -> (Ident, Type)
memberToNameAndType (TypeDeclaration ident ty) = (ident, ty)
memberToNameAndType (PositionedDeclaration _ _ d) = memberToNameAndType d
memberToNameAndType _ = internalError "Invalid declaration in type class definition"
-typeClassDictionaryDeclaration :: ProperName -> [(String, Maybe Kind)] -> [Constraint] -> [Declaration] -> Declaration
+typeClassDictionaryDeclaration
+ :: ProperName 'ClassName
+ -> [(String, Maybe Kind)]
+ -> [Constraint]
+ -> [Declaration]
+ -> Declaration
typeClassDictionaryDeclaration name args implies members =
let superclassTypes = superClassDictionaryNames implies `zip`
- [ function unit (foldl TypeApp (TypeConstructor superclass) tyArgs)
+ [ function unit (foldl TypeApp (TypeConstructor (fmap coerceProperName superclass)) tyArgs)
| (superclass, tyArgs) <- implies
]
members' = map (first runIdent . memberToNameAndType) members
mtys = members' ++ superclassTypes
- in TypeSynonymDeclaration name args (TypeApp tyObject $ rowFromList (mtys, REmpty))
-
-typeClassMemberToDictionaryAccessor :: ModuleName -> ProperName -> [(String, Maybe Kind)] -> Declaration -> Declaration
+ in TypeSynonymDeclaration (coerceProperName name) args (TypeApp tyObject $ rowFromList (mtys, REmpty))
+
+typeClassMemberToDictionaryAccessor
+ :: ModuleName
+ -> ProperName 'ClassName
+ -> [(String, Maybe Kind)]
+ -> Declaration
+ -> Declaration
typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) =
let className = Qualified (Just mn) name
in ValueDeclaration ident Private [] $ Right $
@@ -241,7 +257,16 @@ typeClassMemberToDictionaryAccessor _ _ _ _ = internalError "Invalid declaration
unit :: Type
unit = TypeApp tyObject REmpty
-typeInstanceDictionaryDeclaration :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Ident -> ModuleName -> [Constraint] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar m Declaration
+typeInstanceDictionaryDeclaration
+ :: forall m
+ . (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m)
+ => Ident
+ -> ModuleName
+ -> [Constraint]
+ -> Qualified (ProperName 'ClassName)
+ -> [Type]
+ -> [Declaration]
+ -> Desugar m Declaration
typeInstanceDictionaryDeclaration name mn deps className tys decls =
rethrow (addHint (ErrorInInstance className tys)) $ do
m <- get
@@ -273,7 +298,7 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =
]
let props = ObjectLiteral (members ++ superclasses)
- dictTy = foldl TypeApp (TypeConstructor className) tys
+ dictTy = foldl TypeApp (TypeConstructor (fmap coerceProperName className)) tys
constrainedTy = quantify (if null deps then dictTy else ConstrainedType deps dictTy)
dict = TypeClassDictionaryConstructorApp className props
result = ValueDeclaration name Private [] (Right (TypedValue True dict constrainedTy))
@@ -287,7 +312,7 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =
declName (TypeDeclaration ident _) = Just ident
declName _ = Nothing
- memberToValue :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [(Ident, Type)] -> Declaration -> Desugar m Expr
+ memberToValue :: [(Ident, Type)] -> Declaration -> Desugar m Expr
memberToValue tys' (ValueDeclaration ident _ [] (Right val)) = do
_ <- maybe (throwError . errorMessage $ ExtraneousClassMember ident className) return $ lookup ident tys'
return val
diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs
index 08840f6..d011a35 100644
--- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs
+++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs
@@ -1,18 +1,3 @@
------------------------------------------------------------------------------
---
--- Module : Language.PureScript.Sugar.TypeClasses.Deriving
--- Copyright : (c) Gershom Bazerman 2015
--- License : MIT (http://opensource.org/licenses/MIT)
---
--- Maintainer : Phil Freeman <paf31@cantab.net>
--- Stability : experimental
--- Portability :
---
--- |
--- This module implements the generic deriving elaboration that takes place during desugaring.
---
------------------------------------------------------------------------------
-
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
@@ -20,9 +5,10 @@
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
-module Language.PureScript.Sugar.TypeClasses.Deriving (
- deriveInstances
-) where
+-- |
+-- This module implements the generic deriving elaboration that takes place during desugaring.
+--
+module Language.PureScript.Sugar.TypeClasses.Deriving (deriveInstances) where
import Prelude ()
import Prelude.Compat
@@ -31,8 +17,9 @@ import Data.List (foldl', find, sortBy)
import Data.Maybe (fromMaybe)
import Data.Ord (comparing)
+import Control.Arrow (second)
import Control.Monad (replicateM)
-import Control.Monad.Supply.Class (MonadSupply, freshName)
+import Control.Monad.Supply.Class (MonadSupply)
import Control.Monad.Error.Class (MonadError(..))
import Language.PureScript.Crash
@@ -44,12 +31,20 @@ import Language.PureScript.Types
import qualified Language.PureScript.Constants as C
-- | Elaborates deriving instance declarations by code generation.
-deriveInstances :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadSupply m) => Module -> m Module
+deriveInstances
+ :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadSupply m)
+ => Module
+ -> m Module
deriveInstances (Module ss coms mn ds exts) = Module ss coms mn <$> mapM (deriveInstance mn ds) ds <*> pure exts
-- | Takes a declaration, and if the declaration is a deriving TypeInstanceDeclaration,
-- elaborates that into an instance declaration via code generation.
-deriveInstance :: (Functor m, MonadError MultipleErrors m, MonadSupply m) => ModuleName -> [Declaration] -> Declaration -> m Declaration
+deriveInstance
+ :: (Functor m, MonadError MultipleErrors m, MonadSupply m)
+ => ModuleName
+ -> [Declaration]
+ -> Declaration
+ -> m Declaration
deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@[ty] DerivedInstance)
| className == Qualified (Just dataGeneric) (ProperName C.generic)
, Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor ty
@@ -60,12 +55,14 @@ deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance)
deriveInstance mn ds (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> deriveInstance mn ds d
deriveInstance _ _ e = return e
-unwrapTypeConstructor :: Type -> Maybe (Qualified ProperName, [Type])
-unwrapTypeConstructor (TypeConstructor tyCon) = Just (tyCon, [])
-unwrapTypeConstructor (TypeApp ty arg) = do
- (tyCon, args) <- unwrapTypeConstructor ty
- return (tyCon, arg : args)
-unwrapTypeConstructor _ = Nothing
+unwrapTypeConstructor :: Type -> Maybe (Qualified (ProperName 'TypeName), [Type])
+unwrapTypeConstructor = fmap (second reverse) . go
+ where
+ go (TypeConstructor tyCon) = Just (tyCon, [])
+ go (TypeApp ty arg) = do
+ (tyCon, args) <- go ty
+ return (tyCon, arg : args)
+ go _ = Nothing
dataGeneric :: ModuleName
dataGeneric = ModuleName [ ProperName "Data", ProperName "Generic" ]
@@ -76,7 +73,13 @@ dataMaybe = ModuleName [ ProperName "Data", ProperName "Maybe" ]
typesProxy :: ModuleName
typesProxy = ModuleName [ ProperName "Type", ProperName "Proxy" ]
-deriveGeneric :: (Functor m, MonadError MultipleErrors m, MonadSupply m) => ModuleName -> [Declaration] -> ProperName -> [Type] -> m [Declaration]
+deriveGeneric
+ :: (Functor m, MonadError MultipleErrors m, MonadSupply m)
+ => ModuleName
+ -> [Declaration]
+ -> ProperName 'TypeName
+ -> [Type]
+ -> m [Declaration]
deriveGeneric mn ds tyConNm args = do
tyCon <- findTypeDecl tyConNm ds
toSpine <- mkSpineFunction mn tyCon
@@ -87,7 +90,11 @@ deriveGeneric mn ds tyConNm args = do
, ValueDeclaration (Ident C.toSignature) Public [] (Right toSignature)
]
-findTypeDecl :: (Functor m, MonadError MultipleErrors m) => ProperName -> [Declaration] -> m Declaration
+findTypeDecl
+ :: (Functor m, MonadError MultipleErrors m)
+ => ProperName 'TypeName
+ -> [Declaration]
+ -> m Declaration
findTypeDecl tyConNm = maybe (throwError . errorMessage $ CannotFindDerivingType tyConNm) return . find isTypeDecl
where
isTypeDecl :: Declaration -> Bool
@@ -104,9 +111,9 @@ mkSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> mapM mkCtorCl
recordConstructor :: Expr -> Expr
recordConstructor = App (Constructor (Qualified (Just dataGeneric) (ProperName "SRecord")))
- mkCtorClause :: (ProperName, [Type]) -> m CaseAlternative
+ mkCtorClause :: (ProperName 'ConstructorName, [Type]) -> m CaseAlternative
mkCtorClause (ctorName, tys) = do
- idents <- replicateM (length tys) (fmap Ident freshName)
+ idents <- replicateM (length tys) freshIdent'
return $ CaseAlternative [ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)] (Right (caseResult idents))
where
caseResult idents =
@@ -137,10 +144,12 @@ mkSignatureFunction mn (DataDeclaration _ name tyArgs args) classArgs = lamNull
proxy :: Type -> Type
proxy = TypeApp (TypeConstructor (Qualified (Just typesProxy) (ProperName "Proxy")))
- mkProdClause :: (ProperName, [Type]) -> Expr
- mkProdClause (ctorName, tys) = ObjectLiteral [ ("sigConstructor", StringLiteral (showQualified runProperName (Qualified (Just mn) ctorName)))
- , ("sigValues", ArrayLiteral . map (mkProductSignature . instantiate) $ tys)
- ]
+ 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 =
@@ -170,9 +179,9 @@ mkFromSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> (addCatch
recordBinder :: [Binder] -> Binder
recordBinder = ConstructorBinder (Qualified (Just dataGeneric) (ProperName "SRecord"))
- mkAlternative :: (ProperName, [Type]) -> m CaseAlternative
+ mkAlternative :: (ProperName 'ConstructorName, [Type]) -> m CaseAlternative
mkAlternative (ctorName, tys) = do
- idents <- replicateM (length tys) (fmap Ident freshName)
+ 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))
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
index 70a89c8..21401ba 100644
--- a/src/Language/PureScript/TypeChecker.hs
+++ b/src/Language/PureScript/TypeChecker.hs
@@ -1,22 +1,10 @@
------------------------------------------------------------------------------
---
--- Module : Language.PureScript.TypeChecker
--- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
--- License : MIT (http://opensource.org/licenses/MIT)
---
--- Maintainer : Phil Freeman <paf31@cantab.net>
--- Stability : experimental
--- Portability :
---
--- |
--- The top-level type checker, which checks all declarations in a module.
---
------------------------------------------------------------------------------
-
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
+-- |
+-- The top-level type checker, which checks all declarations in a module.
+--
module Language.PureScript.TypeChecker (
module T,
typeCheckModule
@@ -37,6 +25,7 @@ import Data.Foldable (for_, traverse_)
import qualified Data.Map as M
import Control.Monad (when, unless, void, forM, forM_)
+import Control.Monad.Supply.Class (MonadSupply)
import Control.Monad.State.Class (MonadState(..), modify)
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.Writer.Class (MonadWriter(..))
@@ -50,15 +39,15 @@ import Language.PureScript.TypeClassDictionaries
import Language.PureScript.Environment
import Language.PureScript.Errors
-addDataType ::
- (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
- ModuleName ->
- DataDeclType ->
- ProperName ->
- [(String, Maybe Kind)] ->
- [(ProperName, [Type])] ->
- Kind ->
- m ()
+addDataType
+ :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+ => ModuleName
+ -> DataDeclType
+ -> ProperName 'TypeName
+ -> [(String, Maybe Kind)]
+ -> [(ProperName 'ConstructorName, [Type])]
+ -> Kind
+ -> m ()
addDataType moduleName dtype name args dctors ctorKind = do
env <- getEnv
putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (ctorKind, DataType args dctors) (types env) }
@@ -66,15 +55,15 @@ addDataType moduleName dtype name args dctors ctorKind = do
warnAndRethrow (addHint (ErrorInDataConstructor dctor)) $
addDataConstructor moduleName dtype name (map fst args) dctor tys
-addDataConstructor ::
- (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
- ModuleName ->
- DataDeclType ->
- ProperName ->
- [String] ->
- ProperName ->
- [Type] ->
- m ()
+addDataConstructor
+ :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+ => ModuleName
+ -> DataDeclType
+ -> ProperName 'TypeName
+ -> [String]
+ -> ProperName 'ConstructorName
+ -> [Type]
+ -> m ()
addDataConstructor moduleName dtype name args dctor tys = do
env <- getEnv
traverse_ checkTypeSynonyms tys
@@ -84,50 +73,50 @@ addDataConstructor moduleName dtype name args dctor tys = do
let fields = [Ident ("value" ++ show n) | n <- [0..(length tys - 1)]]
putEnv $ env { dataConstructors = M.insert (Qualified (Just moduleName) dctor) (dtype, name, polyType, fields) (dataConstructors env) }
-addTypeSynonym ::
- (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
- ModuleName ->
- ProperName ->
- [(String, Maybe Kind)] ->
- Type ->
- Kind ->
- m ()
+addTypeSynonym
+ :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+ => ModuleName
+ -> ProperName 'TypeName
+ -> [(String, Maybe Kind)]
+ -> Type
+ -> Kind
+ -> m ()
addTypeSynonym moduleName name args ty kind = do
env <- getEnv
checkTypeSynonyms ty
putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (kind, TypeSynonym) (types env)
, typeSynonyms = M.insert (Qualified (Just moduleName) name) (args, ty) (typeSynonyms env) }
-valueIsNotDefined ::
- (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
- ModuleName ->
- Ident ->
- m ()
+valueIsNotDefined
+ :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+ => ModuleName
+ -> Ident
+ -> m ()
valueIsNotDefined moduleName name = do
env <- getEnv
case M.lookup (moduleName, name) (names env) of
Just _ -> throwError . errorMessage $ RedefinedIdent name
Nothing -> return ()
-addValue ::
- (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
- ModuleName ->
- Ident ->
- Type ->
- NameKind ->
- m ()
+addValue
+ :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+ => ModuleName
+ -> Ident
+ -> Type
+ -> NameKind
+ -> m ()
addValue moduleName name ty nameKind = do
env <- getEnv
putEnv (env { names = M.insert (moduleName, name) (ty, nameKind, Defined) (names env) })
-addTypeClass ::
- (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
- ModuleName ->
- ProperName ->
- [(String, Maybe Kind)] ->
- [Constraint] ->
- [Declaration] ->
- m ()
+addTypeClass
+ :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+ => ModuleName
+ -> ProperName 'ClassName
+ -> [(String, Maybe Kind)]
+ -> [Constraint]
+ -> [Declaration]
+ -> m ()
addTypeClass moduleName pn args implies ds =
let members = map toPair ds in
modify $ \st -> st { checkEnv = (checkEnv st) { typeClasses = M.insert (Qualified (Just moduleName) pn) (args, members, implies) (typeClasses . checkEnv $ st) } }
@@ -136,30 +125,30 @@ addTypeClass moduleName pn args implies ds =
toPair (PositionedDeclaration _ _ d) = toPair d
toPair _ = internalError "Invalid declaration in TypeClassDeclaration"
-addTypeClassDictionaries ::
- (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
- Maybe ModuleName ->
- M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope) ->
- m ()
+addTypeClassDictionaries
+ :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+ => Maybe ModuleName
+ -> M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope)
+ -> m ()
addTypeClassDictionaries mn entries =
modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = insertState st } }
where insertState st = M.insertWith (M.unionWith M.union) mn entries (typeClassDictionaries . checkEnv $ st)
-checkDuplicateTypeArguments ::
- (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
- [String] ->
- m ()
+checkDuplicateTypeArguments
+ :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+ => [String]
+ -> m ()
checkDuplicateTypeArguments args = for_ firstDup $ \dup ->
throwError . errorMessage $ DuplicateTypeArgument dup
where
firstDup :: Maybe String
firstDup = listToMaybe $ args \\ nub args
-checkTypeClassInstance ::
- (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
- ModuleName ->
- Type ->
- m ()
+checkTypeClassInstance
+ :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+ => ModuleName
+ -> Type
+ -> m ()
checkTypeClassInstance _ (TypeVar _) = return ()
checkTypeClassInstance _ (TypeConstructor ctor) = do
env <- getEnv
@@ -171,10 +160,10 @@ checkTypeClassInstance _ ty = throwError . errorMessage $ InvalidInstanceHead ty
-- |
-- Check that type synonyms are fully-applied in a type
--
-checkTypeSynonyms ::
- (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
- Type ->
- m ()
+checkTypeSynonyms
+ :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+ => Type
+ -> m ()
checkTypeSynonyms = void . replaceAllTypeSynonyms
-- |
@@ -190,13 +179,14 @@ checkTypeSynonyms = void . replaceAllTypeSynonyms
--
-- * Process module imports
--
-typeCheckAll :: forall m.
- (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
- ModuleName ->
- [DeclarationRef] ->
- [Declaration] ->
- m [Declaration]
-typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkOrphanFixities ds
+typeCheckAll
+ :: forall m
+ . (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+ => ModuleName
+ -> [DeclarationRef]
+ -> [Declaration]
+ -> m [Declaration]
+typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds
where
go :: Declaration -> m Declaration
go (DataDeclaration dtype name args dctors) = do
@@ -208,7 +198,7 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkOrphanFixities d
addDataType moduleName dtype name args' dctors ctorKind
return $ DataDeclaration dtype name args dctors
where
- checkNewtype :: [(ProperName, [Type])] -> m ()
+ checkNewtype :: [(ProperName 'ConstructorName, [Type])] -> m ()
checkNewtype [(_, [_])] = return ()
checkNewtype [(_, _)] = throwError . errorMessage $ InvalidNewtype name
checkNewtype _ = throwError . errorMessage $ InvalidNewtype name
@@ -290,13 +280,16 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkOrphanFixities d
go (PositionedDeclaration pos com d) =
warnAndRethrowWithPosition pos $ PositionedDeclaration pos com <$> go d
- checkOrphanFixities :: Declaration -> m ()
- checkOrphanFixities (FixityDeclaration _ name) = do
+ checkFixities :: Declaration -> m ()
+ checkFixities (FixityDeclaration _ name (Just alias)) = do
+ ty <- lookupVariable moduleName alias
+ addValue moduleName (Op name) ty Public
+ checkFixities (FixityDeclaration _ name _) = do
env <- getEnv
guardWith (errorMessage (OrphanFixityDeclaration name)) $ M.member (moduleName, Op name) $ names env
- checkOrphanFixities (PositionedDeclaration pos _ d) =
- warnAndRethrowWithPosition pos $ checkOrphanFixities d
- checkOrphanFixities _ = return ()
+ checkFixities (PositionedDeclaration pos _ d) =
+ warnAndRethrowWithPosition pos $ checkFixities d
+ checkFixities _ = return ()
checkInstanceMembers :: [Declaration] -> m [Declaration]
checkInstanceMembers instDecls = do
@@ -316,7 +309,7 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkOrphanFixities d
| otherwise = firstDuplicate xs
firstDuplicate _ = Nothing
- checkOrphanInstance :: Ident -> Qualified ProperName -> [Type] -> m ()
+ checkOrphanInstance :: Ident -> Qualified (ProperName 'ClassName) -> [Type] -> m ()
checkOrphanInstance dictName className@(Qualified (Just mn') _) tys'
| moduleName == mn' || any checkType tys' = return ()
| otherwise = throwError . errorMessage $ OrphanInstance dictName className tys'
@@ -343,10 +336,11 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkOrphanFixities d
-- Type check an entire module and ensure all types and classes defined within the module that are
-- required by exported members are also exported.
--
-typeCheckModule :: forall m.
- (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
- Module ->
- m Module
+typeCheckModule
+ :: forall m
+ . (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+ => Module
+ -> m Module
typeCheckModule (Module _ _ _ _ Nothing) = internalError "exports should have been elaborated"
typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint (ErrorInModule mn)) $ do
modify (\s -> s { checkCurrentModule = Just mn })
@@ -355,6 +349,7 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint
checkTypesAreExported e
checkClassMembersAreExported e
checkClassesAreExported e
+ checkNonAliasesAreExported e
return $ Module ss coms mn decls' (Just exps)
where
@@ -410,7 +405,7 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint
where
go (ConstrainedType cs _) = mapMaybe (fmap TypeClassRef . extractCurrentModuleClass . fst) cs
go _ = []
- extractCurrentModuleClass :: Qualified ProperName -> Maybe ProperName
+ extractCurrentModuleClass :: Qualified (ProperName 'ClassName) -> Maybe (ProperName 'ClassName)
extractCurrentModuleClass (Qualified (Just mn') name) | mn == mn' = Just name
extractCurrentModuleClass _ = Nothing
@@ -429,3 +424,18 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint
extractMemberName (TypeDeclaration memberName _) = memberName
extractMemberName _ = internalError "Unexpected declaration in typeclass member list"
checkClassMembersAreExported _ = return ()
+
+ checkNonAliasesAreExported :: DeclarationRef -> m ()
+ checkNonAliasesAreExported dr@(ValueRef (Op name)) =
+ case listToMaybe (mapMaybe getAlias decls) of
+ Just alias ->
+ when (not $ any (== ValueRef alias) exps) $
+ throwError . errorMessage $ TransitiveExportError dr [ValueRef alias]
+ _ -> return ()
+ where
+ getAlias :: Declaration -> Maybe Ident
+ getAlias (PositionedDeclaration _ _ d) = getAlias d
+ getAlias (FixityDeclaration _ name' (Just (Qualified (Just mn') alias)))
+ | mn == mn' && name == name' = Just alias
+ getAlias _ = Nothing
+ checkNonAliasesAreExported _ = return ()
diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs
index c290f0f..48d878a 100644
--- a/src/Language/PureScript/TypeChecker/Entailment.hs
+++ b/src/Language/PureScript/TypeChecker/Entailment.hs
@@ -1,24 +1,10 @@
------------------------------------------------------------------------------
---
--- Module : Language.PureScript.TypeChecker.Entailment
--- Copyright : (c) Phil Freeman 2013
--- License : MIT
---
--- Maintainer : Phil Freeman <paf31@cantab.net>
--- Stability : experimental
--- Portability :
---
--- |
--- Type class entailment
---
------------------------------------------------------------------------------
-
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
-module Language.PureScript.TypeChecker.Entailment (
- entails
-) where
+-- |
+-- Type class entailment
+--
+module Language.PureScript.TypeChecker.Entailment (entails) where
import Prelude ()
import Prelude.Compat
@@ -46,15 +32,16 @@ import qualified Language.PureScript.Constants as C
-- Check that the current set of type class dictionaries entail the specified type class goal, and, if so,
-- return a type class dictionary reference.
--
-entails :: forall m.
- (Functor m, Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
- ModuleName ->
- M.Map (Maybe ModuleName) (M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope)) ->
- Constraint ->
- m Expr
+entails
+ :: forall m
+ . (Functor m, Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+ => ModuleName
+ -> M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope))
+ -> Constraint
+ -> m Expr
entails moduleName context = solve
where
- forClassName :: Qualified ProperName -> [Type] -> [TypeClassDictionaryInScope]
+ forClassName :: Qualified (ProperName 'ClassName) -> [Type] -> [TypeClassDictionaryInScope]
forClassName cn@(Qualified (Just mn) _) tys = concatMap (findDicts cn) (Nothing : Just mn : map Just (mapMaybe ctorModules tys))
forClassName _ _ = internalError "forClassName: expected qualified class name"
@@ -64,7 +51,7 @@ entails moduleName context = solve
ctorModules (TypeApp ty _) = ctorModules ty
ctorModules _ = Nothing
- findDicts :: Qualified ProperName -> Maybe ModuleName -> [TypeClassDictionaryInScope]
+ findDicts :: Qualified (ProperName 'ClassName) -> Maybe ModuleName -> [TypeClassDictionaryInScope]
findDicts cn = maybe [] M.elems . (>>= M.lookup cn) . flip M.lookup context
solve :: Constraint -> m Expr
@@ -72,7 +59,7 @@ entails moduleName context = solve
dict <- go 0 className tys
return $ dictionaryValueToValue dict
where
- go :: Int -> Qualified ProperName -> [Type] -> m DictionaryValue
+ go :: Int -> Qualified (ProperName 'ClassName) -> [Type] -> m DictionaryValue
go work className' tys' | work > 1000 = throwError . errorMessage $ PossiblyInfiniteInstance className' tys'
go work className' tys' = do
let instances = do
@@ -147,7 +134,7 @@ entails moduleName context = solve
-- and return a substitution from type variables to types which makes the type heads unify.
--
typeHeadsAreEqual :: ModuleName -> Type -> Type -> Maybe [(String, Type)]
-typeHeadsAreEqual _ (Skolem _ s1 _) (Skolem _ s2 _) | s1 == s2 = Just []
+typeHeadsAreEqual _ (Skolem _ s1 _ _) (Skolem _ s2 _ _) | s1 == s2 = Just []
typeHeadsAreEqual _ t (TypeVar v) = Just [(v, t)]
typeHeadsAreEqual _ (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = Just []
typeHeadsAreEqual m (TypeApp h1 t1) (TypeApp h2 t2) = (++) <$> typeHeadsAreEqual m h1 h2
@@ -164,12 +151,12 @@ typeHeadsAreEqual m r1@RCons{} r2@RCons{} =
<*> go sd1 r1' sd2 r2'
where
go :: [(String, Type)] -> Type -> [(String, Type)] -> Type -> Maybe [(String, Type)]
- go [] REmpty [] REmpty = Just []
- go [] (TUnknown _) _ _ = Just []
- go [] (TypeVar v1) [] (TypeVar v2) | v1 == v2 = Just []
- go [] (Skolem _ s1 _) [] (Skolem _ s2 _) | s1 == s2 = Just []
- go sd r [] (TypeVar v) = Just [(v, rowFromList (sd, r))]
- go _ _ _ _ = Nothing
+ go [] REmpty [] REmpty = Just []
+ go [] (TUnknown _) _ _ = Just []
+ go [] (TypeVar v1) [] (TypeVar v2) | v1 == v2 = Just []
+ go [] (Skolem _ s1 _ _) [] (Skolem _ s2 _ _) | s1 == s2 = Just []
+ go sd r [] (TypeVar v) = Just [(v, rowFromList (sd, r))]
+ go _ _ _ _ = Nothing
typeHeadsAreEqual _ _ _ = Nothing
-- |
diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs
index 37872f2..ae3325b 100644
--- a/src/Language/PureScript/TypeChecker/Kinds.hs
+++ b/src/Language/PureScript/TypeChecker/Kinds.hs
@@ -1,18 +1,3 @@
------------------------------------------------------------------------------
---
--- Module : Language.PureScript.TypeChecker.Kinds
--- Copyright : (c) Phil Freeman 2013
--- License : MIT
---
--- Maintainer : Phil Freeman <paf31@cantab.net>
--- Stability : experimental
--- Portability :
---
--- |
--- This module implements the kind checker
---
------------------------------------------------------------------------------
-
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
@@ -20,12 +5,15 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RankNTypes #-}
-module Language.PureScript.TypeChecker.Kinds (
- kindOf,
- kindOfWithScopedVars,
- kindsOf,
- kindsOfAll
-) where
+-- |
+-- This module implements the kind checker
+--
+module Language.PureScript.TypeChecker.Kinds
+ ( kindOf
+ , kindOfWithScopedVars
+ , kindsOf
+ , kindsOfAll
+ ) where
import Prelude ()
import Prelude.Compat
@@ -54,7 +42,11 @@ freshKind = do
return $ KUnknown k
-- | Update the substitution to solve a kind constraint
-solveKind :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Int -> Kind -> m ()
+solveKind
+ :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m)
+ => Int
+ -> Kind
+ -> m ()
solveKind u k = do
occursCheck u k
modify $ \cs -> cs { checkSubstitution =
@@ -75,7 +67,11 @@ substituteKind sub = everywhereOnKinds go
go other = other
-- | Make sure that an unknown does not occur in a kind
-occursCheck :: (Functor m, Applicative m, MonadError MultipleErrors m) => Int -> Kind -> m ()
+occursCheck
+ :: (Functor m, Applicative m, MonadError MultipleErrors m)
+ => Int
+ -> Kind
+ -> m ()
occursCheck _ KUnknown{} = return ()
occursCheck u k = void $ everywhereOnKindsM go k
where
@@ -83,7 +79,11 @@ occursCheck u k = void $ everywhereOnKindsM go k
go other = return other
-- | Unify two kinds
-unifyKinds :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Kind -> Kind -> m ()
+unifyKinds
+ :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m)
+ => Kind
+ -> Kind
+ -> m ()
unifyKinds k1 k2 = do
sub <- gets checkSubstitution
go (substituteKind sub k1) (substituteKind sub k2)
@@ -100,10 +100,10 @@ unifyKinds k1 k2 = do
go k1' k2' = throwError . errorMessage $ KindsDoNotUnify k1' k2'
-- | Infer the kind of a single type
-kindOf ::
- (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m) =>
- Type ->
- m Kind
+kindOf
+ :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m)
+ => Type
+ -> m Kind
kindOf ty = fst <$> kindOfWithScopedVars ty
-- | Infer the kind of a single type, returning the kinds of any scoped type variables
@@ -120,14 +120,14 @@ kindOfWithScopedVars ty =
)
-- | Infer the kind of a type constructor with a collection of arguments and a collection of associated data constructors
-kindsOf ::
- (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m) =>
- Bool ->
- ModuleName ->
- ProperName ->
- [(String, Maybe Kind)] ->
- [Type] ->
- m Kind
+kindsOf
+ :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m)
+ => Bool
+ -> ModuleName
+ -> ProperName 'TypeName
+ -> [(String, Maybe Kind)]
+ -> [Type]
+ -> m Kind
kindsOf isData moduleName name args ts = fmap tidyUp . liftUnify $ do
tyCon <- freshKind
kargs <- replicateM (length args) freshKind
@@ -138,23 +138,23 @@ kindsOf isData moduleName name args ts = fmap tidyUp . liftUnify $ do
where
tidyUp (k, sub) = starIfUnknown $ substituteKind sub k
-freshKindVar ::
- (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) =>
- (String, Maybe Kind) ->
- Kind ->
- m (ProperName, Kind)
+freshKindVar
+ :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m)
+ => (String, Maybe Kind)
+ -> Kind
+ -> m (ProperName 'TypeName, Kind)
freshKindVar (arg, Nothing) kind = return (ProperName arg, kind)
freshKindVar (arg, Just kind') kind = do
unifyKinds kind kind'
return (ProperName arg, kind')
-- | Simultaneously infer the kinds of several mutually recursive type constructors
-kindsOfAll ::
- (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m) =>
- ModuleName ->
- [(ProperName, [(String, Maybe Kind)], Type)] ->
- [(ProperName, [(String, Maybe Kind)], [Type])] ->
- m ([Kind], [Kind])
+kindsOfAll
+ :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m)
+ => ModuleName
+ -> [(ProperName 'TypeName, [(String, Maybe Kind)], Type)]
+ -> [(ProperName 'TypeName, [(String, Maybe Kind)], [Type])]
+ -> m ([Kind], [Kind])
kindsOfAll moduleName syns tys = fmap tidyUp . liftUnify $ do
synVars <- replicateM (length syns) freshKind
let dict = zipWith (\(name, _, _) var -> (name, var)) syns synVars
@@ -177,7 +177,13 @@ kindsOfAll moduleName syns tys = fmap tidyUp . liftUnify $ do
tidyUp ((ks1, ks2), sub) = (map (starIfUnknown . substituteKind sub) ks1, map (starIfUnknown . substituteKind sub) ks2)
-- | Solve the set of kind constraints associated with the data constructors for a type constructor
-solveTypes :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Bool -> [Type] -> [Kind] -> Kind -> m Kind
+solveTypes
+ :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m)
+ => Bool
+ -> [Type]
+ -> [Kind]
+ -> Kind
+ -> m Kind
solveTypes isData ts kargs tyCon = do
ks <- traverse (fmap fst . infer) ts
when isData $ do
@@ -195,10 +201,17 @@ starIfUnknown (FunKind k1 k2) = FunKind (starIfUnknown k1) (starIfUnknown k2)
starIfUnknown k = k
-- | Infer a kind for a type
-infer :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Type -> m (Kind, [(String, Kind)])
+infer
+ :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m)
+ => Type
+ -> m (Kind, [(String, Kind)])
infer ty = rethrow (addHint (ErrorCheckingKind ty)) $ infer' ty
-infer' :: forall m. (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Type -> m (Kind, [(String, Kind)])
+infer'
+ :: forall m
+ . (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m)
+ => Type
+ -> m (Kind, [(String, Kind)])
infer' (ForAll ident ty _) = do
k1 <- freshKind
Just moduleName <- checkCurrentModule <$> get
@@ -226,7 +239,7 @@ infer' other = (, []) <$> go other
go (TypeVar v) = do
Just moduleName <- checkCurrentModule <$> get
lookupTypeVariable moduleName (Qualified Nothing (ProperName v))
- go (Skolem v _ _) = do
+ go (Skolem v _ _ _) = do
Just moduleName <- checkCurrentModule <$> get
lookupTypeVariable moduleName (Qualified Nothing (ProperName v))
go (TypeConstructor v) = do
@@ -250,7 +263,7 @@ infer' other = (, []) <$> go other
return $ Row k1
go (ConstrainedType deps ty) = do
forM_ deps $ \(className, tys) -> do
- k <- go $ foldl TypeApp (TypeConstructor className) tys
+ k <- go $ foldl TypeApp (TypeConstructor (fmap coerceProperName className)) tys
unifyKinds k Star
k <- go ty
unifyKinds k Star
diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs
index 97eea4c..752e9be 100644
--- a/src/Language/PureScript/TypeChecker/Monad.hs
+++ b/src/Language/PureScript/TypeChecker/Monad.hs
@@ -1,18 +1,3 @@
------------------------------------------------------------------------------
---
--- Module : Language.PureScript.TypeChecker.Monad
--- Copyright : (c) Phil Freeman 2013
--- License : MIT
---
--- Maintainer : Phil Freeman <paf31@cantab.net>
--- Stability : experimental
--- Portability :
---
--- |
--- Monads for type checking and type inference and associated data types
---
------------------------------------------------------------------------------
-
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RankNTypes #-}
@@ -20,6 +5,9 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
+-- |
+-- Monads for type checking and type inference and associated data types
+--
module Language.PureScript.TypeChecker.Monad where
import Prelude ()
@@ -57,20 +45,23 @@ data CheckState = CheckState
, checkNextKind :: Int -- ^ The next kind unification variable
, checkNextSkolem :: Int -- ^ The next skolem variable
, checkNextSkolemScope :: Int -- ^ The next skolem scope constant
- , checkNextDictName :: Int -- ^ The next type class dictionary name
, checkCurrentModule :: Maybe ModuleName -- ^ The current module
, checkSubstitution :: Substitution -- ^ The current substitution
}
-- | Create an empty @CheckState@
emptyCheckState :: Environment -> CheckState
-emptyCheckState env = CheckState env 0 0 0 0 0 Nothing emptySubstitution
+emptyCheckState env = CheckState env 0 0 0 0 Nothing emptySubstitution
-- | Unification variables
type Unknown = Int
-- | Temporarily bind a collection of names to values
-bindNames :: (MonadState CheckState m) => M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility) -> m a -> m a
+bindNames
+ :: MonadState CheckState m
+ => M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility)
+ -> m a
+ -> m a
bindNames newNames action = do
orig <- get
modify $ \st -> st { checkEnv = (checkEnv st) { names = newNames `M.union` (names . checkEnv $ st) } }
@@ -79,7 +70,11 @@ bindNames newNames action = do
return a
-- | Temporarily bind a collection of names to types
-bindTypes :: (MonadState CheckState m) => M.Map (Qualified ProperName) (Kind, TypeKind) -> m a -> m a
+bindTypes
+ :: MonadState CheckState m
+ => M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind)
+ -> m a
+ -> m a
bindTypes newNames action = do
orig <- get
modify $ \st -> st { checkEnv = (checkEnv st) { types = newNames `M.union` (types . checkEnv $ st) } }
@@ -88,7 +83,12 @@ bindTypes newNames action = do
return a
-- | Temporarily bind a collection of names to types
-withScopedTypeVars :: (Functor m, Applicative m, MonadState CheckState m, MonadWriter MultipleErrors m) => ModuleName -> [(String, Kind)] -> m a -> m a
+withScopedTypeVars
+ :: (Functor m, Applicative m, MonadState CheckState m, MonadWriter MultipleErrors m)
+ => ModuleName
+ -> [(String, Kind)]
+ -> m a
+ -> m a
withScopedTypeVars mn ks ma = do
orig <- get
forM_ ks $ \(name, _) ->
@@ -97,7 +97,11 @@ withScopedTypeVars mn ks ma = do
bindTypes (M.fromList (map (\(name, k) -> (Qualified (Just mn) (ProperName name), (k, ScopedTypeVar))) ks)) ma
-- | Temporarily make a collection of type class dictionaries available
-withTypeClassDictionaries :: (MonadState CheckState m) => [TypeClassDictionaryInScope] -> m a -> m a
+withTypeClassDictionaries
+ :: MonadState CheckState m
+ => [TypeClassDictionaryInScope]
+ -> m a
+ -> m a
withTypeClassDictionaries entries action = do
orig <- get
let mentries = M.fromListWith (M.unionWith M.union) [ (mn, M.singleton className (M.singleton (tcdName entry) entry)) | entry@TypeClassDictionaryInScope{ tcdName = Qualified mn _, tcdClassName = className } <- entries ]
@@ -107,25 +111,35 @@ withTypeClassDictionaries entries action = do
return a
-- | Get the currently available map of type class dictionaries
-getTypeClassDictionaries ::
- (Functor m, MonadState CheckState m) =>
- m (M.Map (Maybe ModuleName) (M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope)))
+getTypeClassDictionaries
+ :: (Functor m, MonadState CheckState m)
+ => m (M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope)))
getTypeClassDictionaries = typeClassDictionaries . checkEnv <$> get
-- | Lookup type class dictionaries in a module.
-lookupTypeClassDictionaries ::
- (Functor m, MonadState CheckState m) =>
- Maybe ModuleName ->
- m (M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope))
+lookupTypeClassDictionaries
+ :: (Functor m, MonadState CheckState m)
+ => Maybe ModuleName
+ -> m (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope))
lookupTypeClassDictionaries mn = fromMaybe M.empty . M.lookup mn . typeClassDictionaries . checkEnv <$> get
-- | Temporarily bind a collection of names to local variables
-bindLocalVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(Ident, Type, NameVisibility)] -> m a -> m a
+bindLocalVariables
+ :: (Functor m, MonadState CheckState m)
+ => ModuleName
+ -> [(Ident, Type, NameVisibility)]
+ -> m a
+ -> m a
bindLocalVariables moduleName bindings =
bindNames (M.fromList $ flip map bindings $ \(name, ty, visibility) -> ((moduleName, name), (ty, Private, visibility)))
-- | Temporarily bind a collection of names to local type variables
-bindLocalTypeVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(ProperName, Kind)] -> m a -> m a
+bindLocalTypeVariables
+ :: (Functor m, MonadState CheckState m)
+ => ModuleName
+ -> [(ProperName 'TypeName, Kind)]
+ -> m a
+ -> m a
bindLocalTypeVariables moduleName bindings =
bindTypes (M.fromList $ flip map bindings $ \(pn, kind) -> (Qualified (Just moduleName) pn, (kind, LocalTypeVariable)))
@@ -146,7 +160,11 @@ preservingNames action = do
return a
-- | Lookup the type of a value by name in the @Environment@
-lookupVariable :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m Type
+lookupVariable
+ :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m)
+ => ModuleName
+ -> Qualified Ident
+ -> m Type
lookupVariable currentModule (Qualified moduleName var) = do
env <- getEnv
case M.lookup (fromMaybe currentModule moduleName, var) (names env) of
@@ -154,7 +172,11 @@ lookupVariable currentModule (Qualified moduleName var) = do
Just (ty, _, _) -> return ty
-- | Lookup the visibility of a value by name in the @Environment@
-getVisibility :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m NameVisibility
+getVisibility
+ :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m)
+ => ModuleName
+ -> Qualified Ident
+ -> m NameVisibility
getVisibility currentModule (Qualified moduleName var) = do
env <- getEnv
case M.lookup (fromMaybe currentModule moduleName, var) (names env) of
@@ -162,7 +184,11 @@ getVisibility currentModule (Qualified moduleName var) = do
Just (_, _, vis) -> return vis
-- | Assert that a name is visible
-checkVisibility :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m ()
+checkVisibility
+ :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m)
+ => ModuleName
+ -> Qualified Ident
+ -> m ()
checkVisibility currentModule name@(Qualified _ var) = do
vis <- getVisibility currentModule name
case vis of
@@ -170,7 +196,11 @@ checkVisibility currentModule name@(Qualified _ var) = do
_ -> return ()
-- | Lookup the kind of a type by name in the @Environment@
-lookupTypeVariable :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified ProperName -> m Kind
+lookupTypeVariable
+ :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m)
+ => ModuleName
+ -> Qualified (ProperName 'TypeName)
+ -> m Kind
lookupTypeVariable currentModule (Qualified moduleName name) = do
env <- getEnv
case M.lookup (Qualified (Just $ fromMaybe currentModule moduleName) name) (types env) of
@@ -202,13 +232,6 @@ guardWith :: (MonadError e m) => e -> Bool -> m ()
guardWith _ True = return ()
guardWith e False = throwError e
--- | Generate new type class dictionary name
-freshDictionaryName :: (Functor m, MonadState CheckState m) => m Int
-freshDictionaryName = do
- n <- checkNextDictName <$> get
- modify $ \s -> s { checkNextDictName = succ (checkNextDictName s) }
- return n
-
-- | Run a computation in the substitution monad, generating a return value and the final substitution.
liftUnify ::
(Functor m, MonadState CheckState m, MonadWriter MultipleErrors m, MonadError MultipleErrors m) =>
diff --git a/src/Language/PureScript/TypeChecker/Skolems.hs b/src/Language/PureScript/TypeChecker/Skolems.hs
index a5c0514..a345c08 100644
--- a/src/Language/PureScript/TypeChecker/Skolems.hs
+++ b/src/Language/PureScript/TypeChecker/Skolems.hs
@@ -71,30 +71,30 @@ newSkolemScope = do
-- |
-- Skolemize a type variable by replacing its instances with fresh skolem constants
--
-skolemize :: String -> Int -> SkolemScope -> Type -> Type
-skolemize ident sko scope = replaceTypeVars ident (Skolem ident sko scope)
+skolemize :: String -> Int -> SkolemScope -> Maybe SourceSpan -> Type -> Type
+skolemize ident sko scope ss = replaceTypeVars ident (Skolem ident sko scope ss)
-- |
-- This function has one purpose - to skolemize type variables appearing in a
-- SuperClassDictionary placeholder. These type variables are somewhat unique since they are the
-- only example of scoped type variables.
--
-skolemizeTypesInValue :: String -> Int -> SkolemScope -> Expr -> Expr
-skolemizeTypesInValue ident sko scope =
+skolemizeTypesInValue :: String -> Int -> SkolemScope -> Maybe SourceSpan -> Expr -> Expr
+skolemizeTypesInValue ident sko scope ss =
let
(_, f, _, _, _) = everywhereWithContextOnValuesM [] defS onExpr onBinder defS defS
in runIdentity . f
where
onExpr :: [String] -> Expr -> Identity ([String], Expr)
onExpr sco (SuperClassDictionary c ts)
- | ident `notElem` sco = return (sco, SuperClassDictionary c (map (skolemize ident sko scope) ts))
+ | ident `notElem` sco = return (sco, SuperClassDictionary c (map (skolemize ident sko scope ss) ts))
onExpr sco (TypedValue check val ty)
- | ident `notElem` sco = return (sco ++ peelTypeVars ty, TypedValue check val (skolemize ident sko scope ty))
+ | ident `notElem` sco = return (sco ++ peelTypeVars ty, TypedValue check val (skolemize ident sko scope ss ty))
onExpr sco other = return (sco, other)
onBinder :: [String] -> Binder -> Identity ([String], Binder)
onBinder sco (TypedBinder ty b)
- | ident `notElem` sco = return (sco ++ peelTypeVars ty, TypedBinder (skolemize ident sko scope ty) b)
+ | ident `notElem` sco = return (sco ++ peelTypeVars ty, TypedBinder (skolemize ident sko scope ss ty) b)
onBinder sco other = return (sco, other)
peelTypeVars :: Type -> [String]
@@ -129,7 +129,7 @@ skolemEscapeCheck root@TypedValue{} =
collectSkolems :: Type -> [SkolemScope]
collectSkolems = nub . everythingOnTypes (++) collect
where
- collect (Skolem _ _ scope) = [scope]
+ collect (Skolem _ _ scope _) = [scope]
collect _ = []
go scos _ = (scos, [])
findBindingScope :: SkolemScope -> Maybe Expr
diff --git a/src/Language/PureScript/TypeChecker/Subsumption.hs b/src/Language/PureScript/TypeChecker/Subsumption.hs
index 7e4d9af..023642e 100644
--- a/src/Language/PureScript/TypeChecker/Subsumption.hs
+++ b/src/Language/PureScript/TypeChecker/Subsumption.hs
@@ -55,7 +55,7 @@ subsumes' val ty1 (ForAll ident ty2 sco) =
case sco of
Just sco' -> do
sko <- newSkolemConstant
- let sk = skolemize ident sko sco' ty2
+ let sk = skolemize ident sko sco' Nothing ty2
subsumes val ty1 sk
Nothing -> internalError "subsumes: unspecified skolem scope"
subsumes' val (TypeApp (TypeApp f1 arg1) ret1) (TypeApp (TypeApp f2 arg2) ret2) | f1 == tyFunction && f2 == tyFunction = do
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index ef4d4e1..fbeb321 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -1,23 +1,11 @@
------------------------------------------------------------------------------
---
--- Module : Language.PureScript.TypeChecker.Types
--- Copyright : (c) Phil Freeman 2013
--- License : MIT
---
--- Maintainer : Phil Freeman <paf31@cantab.net>
--- Stability : experimental
--- Portability :
---
--- |
--- This module implements the type checker
---
------------------------------------------------------------------------------
-
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
+-- |
+-- This module implements the type checker
+--
module Language.PureScript.TypeChecker.Types (
typesOf
) where
@@ -48,6 +36,7 @@ import qualified Data.Map as M
import Control.Monad
import Control.Monad.State.Class (MonadState(..), gets)
+import Control.Monad.Supply.Class (MonadSupply)
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.Writer.Class (MonadWriter(..))
@@ -72,7 +61,7 @@ import Language.PureScript.Types
-- | Infer the types of multiple mutually-recursive values, and return elaborated values including
-- type class dictionaries and type annotations.
typesOf ::
- (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
+ (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
ModuleName ->
[(Ident, Expr)] ->
m [(Ident, (Expr, Type))]
@@ -129,7 +118,7 @@ typeDictionaryForBindingGroup moduleName vals = do
return (untyped, typed, dict, untypedDict)
checkTypedBindingGroupElement ::
- (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
+ (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
ModuleName ->
(Ident, (Expr, Type, Bool)) ->
TypeData ->
@@ -148,7 +137,7 @@ checkTypedBindingGroupElement mn (ident, (val', ty, checkType)) dict = do
return (ident, (val'', ty''))
typeForBindingGroupElement ::
- (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
+ (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
Bool ->
(Ident, Expr) ->
TypeData ->
@@ -213,20 +202,19 @@ instantiatePolyTypeWithUnknowns val (ForAll ident ty _) = do
instantiatePolyTypeWithUnknowns val ty'
instantiatePolyTypeWithUnknowns val (ConstrainedType constraints ty) = do
dicts <- getTypeClassDictionaries
- (_, ty') <- instantiatePolyTypeWithUnknowns (internalError "Types under a constraint cannot themselves be constrained") ty
- return (foldl App val (map (flip TypeClassDictionary dicts) constraints), ty')
+ instantiatePolyTypeWithUnknowns (foldl App val (map (flip TypeClassDictionary dicts) constraints)) ty
instantiatePolyTypeWithUnknowns val ty = return (val, ty)
-- | Infer a type for a value, rethrowing any error to provide a more useful error message
infer ::
- (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
+ (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
Expr ->
m Expr
infer val = rethrow (addHint (ErrorInferringType val)) $ infer' val
-- | Infer a type for a value
infer' ::
- (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
+ (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
Expr ->
m Expr
infer' v@(NumericLiteral (Left _)) = return $ TypedValue True v tyInt
@@ -313,7 +301,7 @@ infer' (PositionedValue pos _ val) = warnAndRethrowWithPosition pos $ infer' val
infer' _ = internalError "Invalid argument to infer"
inferLetBinding ::
- (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
+ (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
[Declaration] ->
[Declaration] ->
Expr ->
@@ -407,9 +395,9 @@ inferBinder val (PositionedBinder pos _ binder) =
-- change the definition of `binderRequiresMonotype`,
-- and use `kindOfWithScopedVars`.
inferBinder val (TypedBinder ty binder) = do
+ kind <- kindOf ty
+ checkTypeKind ty kind
ty1 <- replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty
- kind <- kindOf ty1
- checkTypeKind ty1 kind
unifyTypes val ty1
inferBinder val binder
@@ -424,7 +412,7 @@ binderRequiresMonotype _ = True
-- | Instantiate polytypes only when necessitated by a binder.
instantiateForBinders ::
- (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
+ (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
[Expr] ->
[CaseAlternative] ->
m ([Expr], [Type])
@@ -441,7 +429,7 @@ instantiateForBinders vals cas = unzip <$> zipWithM (\val inst -> do
-- Check the types of the return values in a set of binders in a case statement
--
checkBinders ::
- (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
+ (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
[Type] ->
Type ->
[CaseAlternative] ->
@@ -471,7 +459,7 @@ checkBinders nvals ret (CaseAlternative binders result : bs) = do
-- Check the type of a value, rethrowing errors to provide a better error message
--
check ::
- (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
+ (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
Expr ->
Type ->
m Expr
@@ -480,29 +468,36 @@ check val ty = rethrow (addHint (ErrorCheckingType val ty)) $ check' val ty
-- |
-- Check the type of a value
--
-check' :: forall m.
- (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
- Expr ->
- Type ->
- m Expr
+check'
+ :: forall m
+ . (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+ => Expr
+ -> Type
+ -> m Expr
check' val (ForAll ident ty _) = do
scope <- newSkolemScope
sko <- newSkolemConstant
- let sk = skolemize ident sko scope ty
- let skVal = skolemizeTypesInValue ident sko scope val
+ let ss = case val of
+ PositionedValue pos _ _ -> Just pos
+ _ -> Nothing
+ sk = skolemize ident sko scope ss ty
+ skVal = skolemizeTypesInValue ident sko scope ss val
val' <- check skVal sk
return $ TypedValue True val' (ForAll ident ty (Just scope))
check' val t@(ConstrainedType constraints ty) = do
- dictNames <- forM constraints $ \(Qualified _ (ProperName className), _) -> do
- n <- freshDictionaryName
- return $ Ident $ "__dict_" ++ className ++ "_" ++ show n
+ dictNames <- forM constraints $ \(Qualified _ (ProperName className), _) ->
+ freshIdent ("dict" ++ className)
dicts <- join <$> zipWithM (newDictionaries []) (map (Qualified Nothing) dictNames) constraints
val' <- withBindingGroupVisible $ withTypeClassDictionaries dicts $ check val ty
return $ TypedValue True (foldr (Abs . Left) val' dictNames) t
where
-- | Add a dictionary for the constraint to the scope, and dictionaries
-- for all implied superclass instances.
- newDictionaries :: [(Qualified ProperName, Integer)] -> Qualified Ident -> (Qualified ProperName, [Type]) -> m [TypeClassDictionaryInScope]
+ newDictionaries
+ :: [(Qualified (ProperName 'ClassName), Integer)]
+ -> Qualified Ident
+ -> (Qualified (ProperName 'ClassName), [Type])
+ -> m [TypeClassDictionaryInScope]
newDictionaries path name (className, instanceTy) = do
tcs <- gets (typeClasses . checkEnv)
let (args, _, superclasses) = fromMaybe (internalError "newDictionaries: type class lookup failed") $ M.lookup className tcs
@@ -637,7 +632,7 @@ check' val ty = do
-- The @lax@ parameter controls whether or not every record member has to be provided. For object updates, this is not the case.
--
checkProperties ::
- (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
+ (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
Expr ->
[(String, Expr)] ->
Type ->
@@ -669,7 +664,7 @@ checkProperties expr ps row lax = let (ts, r') = rowToList row in go ps ts r' wh
-- | Check the type of a function application, rethrowing errors to provide a better error message
checkFunctionApplication ::
- (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
+ (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
Expr ->
Type ->
Expr ->
@@ -681,7 +676,7 @@ checkFunctionApplication fn fnTy arg ret = rethrow (addHint (ErrorInApplication
-- | Check the type of a function application
checkFunctionApplication' ::
- (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
+ (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
Expr ->
Type ->
Expr ->
diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs
index 241c52e..92d7b7f 100644
--- a/src/Language/PureScript/TypeChecker/Unify.hs
+++ b/src/Language/PureScript/TypeChecker/Unify.hs
@@ -105,13 +105,13 @@ unifyTypes t1 t2 = do
case (sc1, sc2) of
(Just sc1', Just sc2') -> do
sko <- newSkolemConstant
- let sk1 = skolemize ident1 sko sc1' ty1
- let sk2 = skolemize ident2 sko sc2' ty2
+ let sk1 = skolemize ident1 sko sc1' Nothing ty1
+ let sk2 = skolemize ident2 sko sc2' Nothing ty2
sk1 `unifyTypes` sk2
_ -> internalError "unifyTypes: unspecified skolem scope"
unifyTypes' (ForAll ident ty1 (Just sc)) ty2 = do
sko <- newSkolemConstant
- let sk = skolemize ident sko sc ty1
+ let sk = skolemize ident sko sc Nothing ty1
sk `unifyTypes` ty2
unifyTypes' ForAll{} _ = internalError "unifyTypes: unspecified skolem scope"
unifyTypes' ty f@ForAll{} = f `unifyTypes` ty
@@ -121,7 +121,7 @@ unifyTypes t1 t2 = do
unifyTypes' (TypeApp t3 t4) (TypeApp t5 t6) = do
t3 `unifyTypes` t5
t4 `unifyTypes` t6
- unifyTypes' (Skolem _ s1 _) (Skolem _ s2 _) | s1 == s2 = return ()
+ unifyTypes' (Skolem _ s1 _ _) (Skolem _ s2 _ _) | s1 == s2 = return ()
unifyTypes' (KindedType ty1 _) ty2 = ty1 `unifyTypes` ty2
unifyTypes' ty1 (KindedType ty2 _) = ty1 `unifyTypes` ty2
unifyTypes' r1@RCons{} r2 = unifyRows r1 r2
@@ -162,15 +162,15 @@ unifyRows r1 r2 =
solveType u2 (rowFromList (sd1, rest))
unifyRows' [] REmpty [] REmpty = return ()
unifyRows' [] (TypeVar v1) [] (TypeVar v2) | v1 == v2 = return ()
- unifyRows' [] (Skolem _ s1 _) [] (Skolem _ s2 _) | s1 == s2 = return ()
- unifyRows' sd3 r3 sd4 r4 = throwError . errorMessage $ TypesDoNotUnify (rowFromList (sd3, r3)) (rowFromList (sd4, r4))
+ unifyRows' [] (Skolem _ s1 _ _) [] (Skolem _ s2 _ _) | s1 == s2 = return ()
+ unifyRows' _ _ _ _ = throwError . errorMessage $ TypesDoNotUnify r1 r2
-- |
-- Check that two types unify
--
unifiesWith :: Type -> Type -> Bool
unifiesWith (TUnknown u1) (TUnknown u2) | u1 == u2 = True
-unifiesWith (Skolem _ s1 _) (Skolem _ s2 _) | s1 == s2 = True
+unifiesWith (Skolem _ s1 _ _) (Skolem _ s2 _ _) | s1 == s2 = True
unifiesWith (TypeVar v1) (TypeVar v2) | v1 == v2 = True
unifiesWith (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = True
unifiesWith (TypeApp h1 t1) (TypeApp h2 t2) = h1 `unifiesWith` h2 && t1 `unifiesWith` t2
@@ -187,7 +187,7 @@ unifiesWith r1@RCons{} r2@RCons{} =
go :: [(String, Type)] -> Type -> [(String, Type)] -> Type -> Bool
go [] REmpty [] REmpty = True
go [] (TypeVar v1) [] (TypeVar v2) = v1 == v2
- go [] (Skolem _ s1 _) [] (Skolem _ s2 _) = s1 == s2
+ go [] (Skolem _ s1 _ _) [] (Skolem _ s2 _ _) = s1 == s2
go [] (TUnknown _) _ _ = True
go _ _ [] (TUnknown _) = True
go _ (TUnknown _) _ (TUnknown _) = True
diff --git a/src/Language/PureScript/TypeClassDictionaries.hs b/src/Language/PureScript/TypeClassDictionaries.hs
index 6c0ccd5..19ac046 100644
--- a/src/Language/PureScript/TypeClassDictionaries.hs
+++ b/src/Language/PureScript/TypeClassDictionaries.hs
@@ -1,23 +1,5 @@
------------------------------------------------------------------------------
---
--- Module : Language.PureScript.TypeClassDictionaries
--- Copyright : (c) 2014 Phil Freeman
--- License : MIT
---
--- Maintainer : Phil Freeman <paf31@cantab.net>
--- Stability : experimental
--- Portability :
---
--- |
---
------------------------------------------------------------------------------
-
-{-# LANGUAGE DeriveDataTypeable #-}
-
module Language.PureScript.TypeClassDictionaries where
-import Data.Data
-
import Language.PureScript.Names
import Language.PureScript.Types
@@ -29,14 +11,15 @@ data TypeClassDictionaryInScope
-- | The identifier with which the dictionary can be accessed at runtime
tcdName :: Qualified Ident
-- | How to obtain this instance via superclass relationships
- , tcdPath :: [(Qualified ProperName, Integer)]
+ , tcdPath :: [(Qualified (ProperName 'ClassName), Integer)]
-- | The name of the type class to which this type class instance applies
- , tcdClassName :: Qualified ProperName
+ , tcdClassName :: Qualified (ProperName 'ClassName)
-- | The types to which this type class instance applies
, tcdInstanceTypes :: [Type]
-- | Type class dependencies which must be satisfied to construct this dictionary
, tcdDependencies :: Maybe [Constraint]
- } deriving (Show, Read, Data, Typeable)
+ }
+ deriving (Show, Read)
-- |
-- A simplified representation of expressions which are used to represent type
@@ -58,5 +41,5 @@ data DictionaryValue
-- |
-- A subclass dictionary
--
- | SubclassDictionaryValue DictionaryValue (Qualified ProperName) Integer
+ | SubclassDictionaryValue DictionaryValue (Qualified (ProperName 'ClassName)) Integer
deriving (Show, Read, Ord, Eq)
diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs
index 940a5c3..f2505ed 100644
--- a/src/Language/PureScript/Types.hs
+++ b/src/Language/PureScript/Types.hs
@@ -1,28 +1,14 @@
------------------------------------------------------------------------------
---
--- Module : Language.PureScript.Types
--- Copyright : (c) Phil Freeman 2013
--- License : MIT
---
--- Maintainer : Phil Freeman <paf31@cantab.net>
--- Stability : experimental
--- Portability :
---
--- |
--- Data types for types
---
------------------------------------------------------------------------------
-
-{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
+-- |
+-- Data types for types
+--
module Language.PureScript.Types where
import Prelude ()
import Prelude.Compat
-import Data.Data
import Data.List (nub)
import Data.Maybe (fromMaybe)
import qualified Data.Aeson as A
@@ -34,11 +20,13 @@ import Control.Monad ((<=<))
import Language.PureScript.Names
import Language.PureScript.Kinds
import Language.PureScript.Traversals
+import Language.PureScript.AST.SourcePos
-- |
-- An identifier for the scope of a skolem variable
--
-newtype SkolemScope = SkolemScope { runSkolemScope :: Int } deriving (Show, Read, Eq, Ord, Data, Typeable, A.ToJSON, A.FromJSON)
+newtype SkolemScope = SkolemScope { runSkolemScope :: Int }
+ deriving (Show, Read, Eq, Ord, A.ToJSON, A.FromJSON)
-- |
-- The type of types
@@ -59,7 +47,7 @@ data Type
-- |
-- A type constructor
--
- | TypeConstructor (Qualified ProperName)
+ | TypeConstructor (Qualified (ProperName 'TypeName))
-- |
-- A type application
--
@@ -75,7 +63,7 @@ data Type
-- |
-- A skolem constant
--
- | Skolem String Int SkolemScope
+ | Skolem String Int SkolemScope (Maybe SourceSpan)
-- |
-- An empty row
--
@@ -100,12 +88,13 @@ data Type
-- |
-- A placeholder used in pretty printing
--
- | PrettyPrintForAll [String] Type deriving (Show, Read,Eq, Ord, Data, Typeable)
+ | PrettyPrintForAll [String] Type
+ deriving (Show, Read, Eq, Ord)
-- |
-- A typeclass constraint
--
-type Constraint = (Qualified ProperName, [Type])
+type Constraint = (Qualified (ProperName 'ClassName), [Type])
$(A.deriveJSON A.defaultOptions ''Type)
diff --git a/src/System/IO/UTF8.hs b/src/System/IO/UTF8.hs
index d2b8ff9..2352d39 100644
--- a/src/System/IO/UTF8.hs
+++ b/src/System/IO/UTF8.hs
@@ -1,9 +1,25 @@
module System.IO.UTF8
+
where
-import System.IO (hGetContents, hSetEncoding, openFile, utf8, IOMode (..))
+
+import System.IO ( IOMode(..)
+ , hGetContents
+ , hSetEncoding
+ , hClose
+ , hPutStr
+ , openFile
+ , utf8
+ )
readUTF8File :: FilePath -> IO String
readUTF8File inFile = do
- h <- openFile inFile ReadMode
- hSetEncoding h utf8
- hGetContents h
+ h <- openFile inFile ReadMode
+ hSetEncoding h utf8
+ hGetContents h
+
+writeUTF8File :: FilePath -> String -> IO ()
+writeUTF8File inFile text = do
+ h <- openFile inFile WriteMode
+ hSetEncoding h utf8
+ hPutStr h text
+ hClose h
diff --git a/tests/Main.hs b/tests/Main.hs
index 1b5c834..9433b19 100644
--- a/tests/Main.hs
+++ b/tests/Main.hs
@@ -30,6 +30,7 @@
-- -- @shouldFailWith TypesDoNotUnify
-- -- @shouldFailWith TypesDoNotUnify
-- -- @shouldFailWith TransitiveExportError
+--
module Main (main) where
@@ -39,6 +40,7 @@ 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)
@@ -68,6 +70,8 @@ import qualified System.FilePath.Glob as Glob
import Text.Parsec (ParseError)
import TestsSetup
+import TestPscPublish
+import qualified TestDocs
modulesDir :: FilePath
modulesDir = ".test_modules" </> "node_modules"
@@ -171,6 +175,23 @@ assertDoesNotCompile inputFiles foreigns = do
main :: IO ()
main = do
+ heading "Main compiler test suite"
+ testCompiler
+ heading "Documentation test suite"
+ TestDocs.main
+ -- heading "psc-publish test suite"
+ -- testPscPublish
+
+ where
+ heading msg = do
+ putStrLn ""
+ putStrLn $ replicate 79 '#'
+ putStrLn $ "# " ++ msg
+ putStrLn $ replicate 79 '#'
+ putStrLn ""
+
+testCompiler :: IO ()
+testCompiler = do
fetchSupportCode
cwd <- getCurrentDirectory
@@ -195,7 +216,7 @@ main = do
assertDoesNotCompile (supportPurs ++ [failing </> inputFile]) foreigns
if null failures
- then exitSuccess
+ then pure ()
else do
putStrLn "Failures:"
forM_ failures $ \(fp, err) ->
@@ -203,6 +224,11 @@ main = do
in putStrLn $ fp' ++ ": " ++ err
exitFailure
+testPscPublish :: IO ()
+testPscPublish = do
+ testPackage "tests/support/prelude"
+
+
supportModules :: [String]
supportModules =
[ "Control.Monad.Eff.Class"
diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs
new file mode 100644
index 0000000..477cc13
--- /dev/null
+++ b/tests/TestDocs.hs
@@ -0,0 +1,232 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE DataKinds #-}
+
+module TestDocs where
+
+import Prelude ()
+import Prelude.Compat
+
+import Data.Version (Version(..))
+
+import Control.Monad hiding (forM_)
+import Control.Applicative
+import Control.Arrow
+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
+
+publishOpts :: Publish.PublishOptions
+publishOpts = Publish.defaultPublishOptions
+ { Publish.publishGetVersion = return testVersion
+ , Publish.publishWorkingTreeDirty = return ()
+ }
+ where testVersion = ("v999.0.0", Version [999,0,0] [])
+
+main :: IO ()
+main = do
+ TestPscPublish.pushd "examples/docs" $ do
+ Docs.Package{..} <- Publish.preparePackage publishOpts
+ forM_ testCases $ \(mn, pragmas) ->
+ let mdl = takeJust ("module not found in docs: " ++ mn)
+ (find ((==) mn . Docs.modName) pkgModules)
+ in forM_ pragmas (flip runAssertionIO mdl)
+
+takeJust :: String -> Maybe a -> a
+takeJust msg = maybe (error msg) id
+
+data Assertion
+ -- | Assert that a particular declaration is documented with the given
+ -- children
+ = ShouldBeDocumented P.ModuleName String [String]
+ -- | Assert that a particular declaration is not documented
+ | ShouldNotBeDocumented P.ModuleName String
+ -- | Assert that a particular declaration exists, but without a particular
+ -- child.
+ | ChildShouldNotBeDocumented P.ModuleName String String
+ -- | Assert that a particular declaration has a particular type class
+ -- constraint.
+ | ShouldBeConstrained P.ModuleName String String
+ deriving (Show)
+
+data AssertionFailure
+ -- | A declaration was not documented, but should have been
+ = NotDocumented P.ModuleName String
+ -- | A child declaration was not documented, but should have been
+ | ChildrenNotDocumented P.ModuleName String [String]
+ -- | A declaration was documented, but should not have been
+ | Documented P.ModuleName String
+ -- | A child declaration was documented, but should not have been
+ | ChildDocumented P.ModuleName String String
+ -- | A constraint was missing.
+ | ConstraintMissing P.ModuleName String String
+ -- | A declaration had the wrong "type" (ie, value, type, type class)
+ -- Fields: declaration title, expected "type", actual "type".
+ | WrongDeclarationType P.ModuleName String String String
+ deriving (Show)
+
+data AssertionResult
+ = Pass
+ | Fail AssertionFailure
+ deriving (Show)
+
+runAssertion :: Assertion -> Docs.Module -> AssertionResult
+runAssertion assertion Docs.Module{..} =
+ case assertion of
+ ShouldBeDocumented mn decl children ->
+ case findChildren decl (declarationsFor mn) of
+ Nothing ->
+ Fail (NotDocumented mn decl)
+ Just actualChildren ->
+ case children \\ actualChildren of
+ [] -> Pass
+ cs -> Fail (ChildrenNotDocumented mn decl cs)
+
+ ShouldNotBeDocumented mn decl ->
+ case findChildren decl (declarationsFor mn) of
+ Just _ ->
+ Fail (Documented mn decl)
+ Nothing ->
+ Pass
+
+ ChildShouldNotBeDocumented mn decl child ->
+ case findChildren decl (declarationsFor mn) of
+ Just children ->
+ if child `elem` children
+ then Fail (ChildDocumented mn decl child)
+ else Pass
+ Nothing ->
+ Fail (NotDocumented mn decl)
+
+ ShouldBeConstrained mn decl tyClass ->
+ case find ((==) decl . Docs.declTitle) (declarationsFor mn) of
+ Nothing ->
+ Fail (NotDocumented mn decl)
+ Just Docs.Declaration{..} ->
+ case declInfo of
+ Docs.ValueDeclaration ty ->
+ if checkConstrained ty tyClass
+ then Pass
+ else Fail (ConstraintMissing mn decl tyClass)
+ _ ->
+ Fail (WrongDeclarationType mn decl "value"
+ (Docs.declInfoToString declInfo))
+
+ where
+ declarationsFor mn =
+ if P.runModuleName mn == modName
+ then modDeclarations
+ else fromMaybe [] (lookup mn modReExports)
+
+ findChildren title =
+ fmap childrenTitles . find ((==) title . Docs.declTitle)
+
+ childrenTitles = map Docs.cdeclTitle . Docs.declChildren
+
+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
+ -- anyway.
+ case ty of
+ P.ConstrainedType cs _ | any (matches tyClass) cs ->
+ True
+ P.ForAll _ ty' _ ->
+ checkConstrained ty' tyClass
+ _ ->
+ False
+ where
+ matches className =
+ (==) className . P.runProperName . P.disqualify . fst
+
+runAssertionIO :: Assertion -> Docs.Module -> IO ()
+runAssertionIO assertion mdl = do
+ putStrLn ("In " ++ Docs.modName mdl ++ ": " ++ show assertion)
+ case runAssertion assertion mdl of
+ Pass -> pure ()
+ fail -> do
+ putStrLn (show fail)
+ exitFailure
+
+testCases :: [(String, [Assertion])]
+testCases =
+ [ ("Example",
+ [ -- From dependencies
+ ShouldBeDocumented (n "Prelude") "Unit" []
+ , ShouldNotBeDocumented (n "Prelude") "unit"
+
+ -- From local files
+ , ShouldBeDocumented (n "Example2") "one" []
+ , ShouldNotBeDocumented (n "Example2") "two"
+ ])
+ , ("Example2",
+ [ ShouldBeDocumented (n "Example2") "one" []
+ , ShouldBeDocumented (n "Example2") "two" []
+ ])
+
+ , ("UTF8",
+ [ ShouldBeDocumented (n "UTF8") "thing" []
+ ])
+
+ , ("Transitive1",
+ [ ShouldBeDocumented (n "Transitive2") "transitive3" []
+ ])
+
+ , ("NotAllCtors",
+ [ ShouldBeDocumented (n "Prelude") "Boolean2" ["True"]
+ , ChildShouldNotBeDocumented (n "Prelude") "Boolean2" "False"
+ ])
+
+ , ("DuplicateNames",
+ [ ShouldBeDocumented (n "Prelude") "Unit" []
+ , ShouldBeDocumented (n "DuplicateNames") "unit" []
+ , ShouldNotBeDocumented (n "Prelude") "unit"
+ ])
+
+ , ("MultiVirtual",
+ [ ShouldBeDocumented (n "MultiVirtual1") "foo" []
+ , ShouldBeDocumented (n "MultiVirtual2") "bar" []
+ , ShouldBeDocumented (n "MultiVirtual2") "baz" []
+ ])
+
+ , ("Clash",
+ [ ShouldBeDocumented (n "Clash1") "value" []
+ , ShouldBeDocumented (n "Clash1") "Type" []
+ , ShouldBeDocumented (n "Clash1") "TypeClass" ["typeClassMember"]
+ ])
+
+ , ("SolitaryTypeClassMember",
+ [ ShouldBeDocumented (n "SomeTypeClass") "member" []
+ , ShouldNotBeDocumented (n "SomeTypeClass") "SomeClass"
+ , ShouldBeConstrained (n "SomeTypeClass") "member" "SomeClass"
+ ])
+
+ , ("ReExportedTypeClass",
+ [ ShouldBeDocumented (n "SomeTypeClass") "SomeClass" ["member"]
+ ])
+
+ , ("TypeClassWithoutMembers",
+ [ ShouldBeDocumented (n "Intermediate") "SomeClass" []
+ , ChildShouldNotBeDocumented (n "Intermediate") "SomeClass" "member"
+ ])
+
+ -- Remove this after 0.9.
+ , ("OldOperators",
+ [ ShouldBeDocumented (n "OldOperators2") "(>>)" []
+ ])
+
+ , ("NewOperators",
+ [ ShouldBeDocumented (n "NewOperators2") "(>>>)" []
+ ])
+ ]
+
+ where
+ n = P.moduleNameFromString
diff --git a/tests/TestPscPublish.hs b/tests/TestPscPublish.hs
new file mode 100644
index 0000000..657105d
--- /dev/null
+++ b/tests/TestPscPublish.hs
@@ -0,0 +1,65 @@
+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
+{-# OPTIONS_GHC -fno-warn-unused-imports #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module TestPscPublish where
+
+import Control.Monad
+import Control.Applicative
+import Control.Exception
+import System.Process
+import System.Directory
+import System.IO
+import System.Exit
+import qualified Data.ByteString.Lazy as BL
+import Data.ByteString.Lazy (ByteString)
+import qualified Data.Aeson as A
+import Data.Aeson.BetterErrors
+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
+
+data TestResult
+ = ParseFailed String
+ | Mismatch ByteString ByteString -- ^ encoding before, encoding after
+ | Pass ByteString
+ deriving (Show, Read)
+
+roundTrip :: UploadedPackage -> TestResult
+roundTrip pkg =
+ let before = A.encode pkg
+ in case A.eitherDecode before of
+ Left err -> ParseFailed err
+ Right parsed -> do
+ let after = A.encode (parsed :: UploadedPackage)
+ if before == after
+ then Pass before
+ else Mismatch before after
+
+testRunOptions :: PublishOptions
+testRunOptions = defaultPublishOptions
+ { publishGetVersion = return testVersion
+ }
+ where testVersion = ("v999.0.0", Version [999,0,0] [])
+
+-- | Given a directory which contains a package, produce JSON from it, and then
+-- | attempt to parse it again, and ensure that it doesn't change.
+testPackage :: String -> IO ()
+testPackage dir = do
+ pushd dir $ do
+ r <- roundTrip <$> preparePackage testRunOptions
+ case r of
+ Pass _ -> pure ()
+ other -> do
+ putStrLn ("psc-publish tests failed on " ++ dir ++ ":")
+ putStrLn (show other)
+ exitFailure
diff --git a/tests/support/bower.json b/tests/support/bower.json
index 9d1b7d2..c29e6e8 100644
--- a/tests/support/bower.json
+++ b/tests/support/bower.json
@@ -2,7 +2,7 @@
"name": "purescript-test-suite-support",
"dependencies": {
"purescript-eff": "0.1.0",
- "purescript-prelude": "0.1.1",
+ "purescript-prelude": "0.1.3",
"purescript-assert": "0.1.1",
"purescript-st": "0.1.0",
"purescript-console": "0.1.0",