summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--CONTRIBUTING.md18
-rw-r--r--CONTRIBUTORS.md197
-rw-r--r--LICENSE248
-rw-r--r--README.md2
-rw-r--r--app/Command/Bundle.hs (renamed from psc-bundle/Main.hs)102
-rw-r--r--app/Command/Compile.hs (renamed from psc/Main.hs)152
-rw-r--r--app/Command/Docs.hs (renamed from psc-docs/Main.hs)153
-rw-r--r--app/Command/Docs/Ctags.hs (renamed from psc-docs/Ctags.hs)6
-rw-r--r--app/Command/Docs/Etags.hs (renamed from psc-docs/Etags.hs)4
-rw-r--r--app/Command/Docs/Html.hs181
-rw-r--r--app/Command/Docs/Tags.hs (renamed from psc-docs/Tags.hs)4
-rw-r--r--app/Command/Hierarchy.hs (renamed from hierarchy/Main.hs)48
-rw-r--r--app/Command/Ide.hs (renamed from psc-ide-server/Main.hs)158
-rw-r--r--app/Command/Publish.hs52
-rw-r--r--app/Command/REPL.hs (renamed from psci/Main.hs)84
-rw-r--r--app/Main.hs64
-rw-r--r--app/Version.hs23
-rw-r--r--app/static/index.html (renamed from psci/static/index.html)0
-rw-r--r--app/static/index.js (renamed from psci/static/index.js)0
-rw-r--r--app/static/normalize.css427
-rw-r--r--app/static/pursuit.css703
-rw-r--r--examples/docs/bower.json1
-rw-r--r--examples/docs/resolutions.json21
-rw-r--r--examples/docs/src/ConstrainedArgument.purs5
-rw-r--r--examples/docs/src/TypeClassWithFunDeps.purs2
-rw-r--r--examples/failing/1071.purs2
-rw-r--r--examples/failing/1310.purs2
-rw-r--r--examples/failing/2567.purs5
-rw-r--r--examples/failing/2601.purs2
-rw-r--r--examples/failing/2616.purs9
-rw-r--r--examples/failing/DuplicateProperties.purs (renamed from examples/failing/DuplicateProperties1.purs)2
-rw-r--r--examples/failing/DuplicateProperties2.purs12
-rw-r--r--examples/failing/InvalidDerivedInstance.purs8
-rw-r--r--examples/failing/InvalidDerivedInstance2.purs6
-rw-r--r--examples/failing/LetPatterns1.purs10
-rw-r--r--examples/failing/LetPatterns2.purs14
-rw-r--r--examples/failing/LetPatterns3.purs13
-rw-r--r--examples/failing/LetPatterns4.purs (renamed from examples/failing/2445.purs)4
-rw-r--r--examples/failing/NonExhaustivePatGuard.purs5
-rw-r--r--examples/failing/Superclasses5.purs6
-rw-r--r--examples/failing/UnusableTypeClassMethod.purs7
-rw-r--r--examples/failing/UnusableTypeClassMethodConflictingIdent.purs7
-rw-r--r--examples/failing/UnusableTypeClassMethodSynonym.purs9
-rw-r--r--examples/passing/1110.purs26
-rw-r--r--examples/passing/1335.purs28
-rw-r--r--examples/passing/1697.purs6
-rw-r--r--examples/passing/1991.purs2
-rw-r--r--examples/passing/2609.purs12
-rw-r--r--examples/passing/2609/Eg.purs6
-rw-r--r--examples/passing/2616.purs13
-rw-r--r--examples/passing/2626.purs13
-rw-r--r--examples/passing/2663.purs9
-rw-r--r--examples/passing/2689.purs36
-rw-r--r--examples/passing/2695.purs13
-rw-r--r--examples/passing/2756.purs20
-rw-r--r--examples/passing/CheckTypeClass.purs4
-rw-r--r--examples/passing/ClassRefSyntax.purs2
-rw-r--r--examples/passing/Collatz.purs4
-rw-r--r--examples/passing/Console.purs6
-rw-r--r--examples/passing/ConstraintParens.purs12
-rw-r--r--examples/passing/DctorOperatorAlias.purs2
-rw-r--r--examples/passing/Do.purs4
-rw-r--r--examples/passing/DuplicateProperties.purs27
-rw-r--r--examples/passing/Eff.purs4
-rw-r--r--examples/passing/EntailsKindedType.purs4
-rw-r--r--examples/passing/ExtendedInfixOperators.purs2
-rw-r--r--examples/passing/Fib.purs4
-rw-r--r--examples/passing/FinalTagless.purs2
-rw-r--r--examples/passing/FunWithFunDeps.purs8
-rw-r--r--examples/passing/GenericsRep.purs8
-rw-r--r--examples/passing/Guards.purs38
-rw-r--r--examples/passing/KindedType.purs10
-rw-r--r--examples/passing/LetPattern.purs196
-rw-r--r--examples/passing/MutRec2.purs2
-rw-r--r--examples/passing/MutRec3.purs2
-rw-r--r--examples/passing/NakedConstraint.purs2
-rw-r--r--examples/passing/NewtypeClass.purs3
-rw-r--r--examples/passing/Operators.purs2
-rw-r--r--examples/passing/OverlappingInstances2.purs54
-rw-r--r--examples/passing/OverlappingInstances3.purs40
-rw-r--r--examples/passing/PrimedTypeName.purs40
-rw-r--r--examples/passing/Rank2TypeSynonym.purs2
-rw-r--r--examples/passing/RebindableSyntax.purs86
-rw-r--r--examples/passing/RowPolyInstanceContext.purs2
-rw-r--r--examples/passing/RowUnion.js10
-rw-r--r--examples/passing/RowUnion.purs68
-rw-r--r--examples/passing/Sequence.purs2
-rw-r--r--examples/passing/SequenceDesugared.purs18
-rw-r--r--examples/passing/StringEscapes.purs52
-rw-r--r--examples/passing/Superclasses1.purs2
-rw-r--r--examples/passing/Superclasses3.purs6
-rw-r--r--examples/passing/TypeClasses.purs8
-rw-r--r--examples/passing/TypeWildcards.purs2
-rw-r--r--examples/passing/TypedBinders.purs6
-rw-r--r--examples/passing/UnicodeType.purs4
-rw-r--r--examples/passing/UnifyInTypeInstanceLookup.purs4
-rw-r--r--examples/passing/UnknownInTypeClassLookup.purs2
-rw-r--r--examples/passing/UsableTypeClassMethods.purs35
-rw-r--r--examples/warning/ShadowedBinderPatternGuard.purs7
-rw-r--r--examples/warning/ShadowedNameParens.purs5
-rw-r--r--psc-ide-client/Main.hs50
-rw-r--r--psc-package/Main.hs423
-rw-r--r--psc-publish/Main.hs57
-rw-r--r--purescript.cabal238
-rw-r--r--src/Language/PureScript/AST/Binders.hs10
-rw-r--r--src/Language/PureScript/AST/Declarations.hs56
-rw-r--r--src/Language/PureScript/AST/Exported.hs2
-rw-r--r--src/Language/PureScript/AST/Traversals.hs121
-rw-r--r--src/Language/PureScript/Bundle.hs19
-rw-r--r--src/Language/PureScript/CodeGen.hs2
-rw-r--r--src/Language/PureScript/CodeGen/JS.hs325
-rw-r--r--src/Language/PureScript/CodeGen/JS/AST.hs398
-rw-r--r--src/Language/PureScript/CodeGen/JS/Common.hs24
-rw-r--r--src/Language/PureScript/CodeGen/JS/Optimizer.hs73
-rw-r--r--src/Language/PureScript/CodeGen/JS/Optimizer/Blocks.hs32
-rw-r--r--src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs78
-rw-r--r--src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs137
-rw-r--r--src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs120
-rw-r--r--src/Language/PureScript/CodeGen/JS/Optimizer/Unused.hs35
-rw-r--r--src/Language/PureScript/CodeGen/JS/Printer.hs (renamed from src/Language/PureScript/Pretty/JS.hs)139
-rw-r--r--src/Language/PureScript/Constants.hs21
-rw-r--r--src/Language/PureScript/CoreFn/Desugar.hs112
-rw-r--r--src/Language/PureScript/CoreFn/Meta.hs4
-rw-r--r--src/Language/PureScript/CoreImp.hs13
-rw-r--r--src/Language/PureScript/CoreImp/AST.hs224
-rw-r--r--src/Language/PureScript/CoreImp/Optimizer.hs60
-rw-r--r--src/Language/PureScript/CoreImp/Optimizer/Blocks.hs28
-rw-r--r--src/Language/PureScript/CoreImp/Optimizer/Common.hs76
-rw-r--r--src/Language/PureScript/CoreImp/Optimizer/Inliner.hs (renamed from src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs)208
-rw-r--r--src/Language/PureScript/CoreImp/Optimizer/MagicDo.hs134
-rw-r--r--src/Language/PureScript/CoreImp/Optimizer/TCO.hs123
-rw-r--r--src/Language/PureScript/CoreImp/Optimizer/Unused.hs34
-rw-r--r--src/Language/PureScript/Docs/AsHtml.hs11
-rw-r--r--src/Language/PureScript/Docs/Convert/ReExports.hs2
-rw-r--r--src/Language/PureScript/Docs/Convert/Single.hs2
-rw-r--r--src/Language/PureScript/Docs/Prim.hs15
-rw-r--r--src/Language/PureScript/Docs/RenderedCode/RenderType.hs14
-rw-r--r--src/Language/PureScript/Docs/Types.hs8
-rw-r--r--src/Language/PureScript/Environment.hs238
-rw-r--r--src/Language/PureScript/Errors.hs103
-rw-r--r--src/Language/PureScript/Externs.hs22
-rw-r--r--src/Language/PureScript/Ide.hs2
-rw-r--r--src/Language/PureScript/Ide/Error.hs44
-rw-r--r--src/Language/PureScript/Ide/Externs.hs10
-rw-r--r--src/Language/PureScript/Ide/Imports.hs151
-rw-r--r--src/Language/PureScript/Ide/Pursuit.hs6
-rw-r--r--src/Language/PureScript/Ide/Rebuild.hs18
-rw-r--r--src/Language/PureScript/Ide/Reexports.hs13
-rw-r--r--src/Language/PureScript/Ide/SourceFile.hs32
-rw-r--r--src/Language/PureScript/Ide/Types.hs66
-rw-r--r--src/Language/PureScript/Ide/Util.hs25
-rw-r--r--src/Language/PureScript/Interactive.hs26
-rw-r--r--src/Language/PureScript/Interactive/Completion.hs10
-rw-r--r--src/Language/PureScript/Interactive/Directive.hs9
-rw-r--r--src/Language/PureScript/Interactive/Message.hs25
-rw-r--r--src/Language/PureScript/Interactive/Module.hs23
-rw-r--r--src/Language/PureScript/Interactive/Parser.hs44
-rw-r--r--src/Language/PureScript/Interactive/Types.hs10
-rw-r--r--src/Language/PureScript/Kinds.hs3
-rw-r--r--src/Language/PureScript/Linter.hs9
-rw-r--r--src/Language/PureScript/Linter/Exhaustive.hs52
-rw-r--r--src/Language/PureScript/Linter/Imports.hs13
-rw-r--r--src/Language/PureScript/Make.hs11
-rw-r--r--src/Language/PureScript/ModuleDependencies.hs32
-rw-r--r--src/Language/PureScript/Names.hs2
-rw-r--r--src/Language/PureScript/Options.hs40
-rw-r--r--src/Language/PureScript/Parser.hs46
-rw-r--r--src/Language/PureScript/Parser/Declarations.hs178
-rw-r--r--src/Language/PureScript/Parser/Kinds.hs20
-rw-r--r--src/Language/PureScript/Parser/Lexer.hs9
-rw-r--r--src/Language/PureScript/Parser/Types.hs31
-rw-r--r--src/Language/PureScript/Pretty.hs13
-rw-r--r--src/Language/PureScript/Pretty/Types.hs9
-rw-r--r--src/Language/PureScript/Pretty/Values.hs18
-rw-r--r--src/Language/PureScript/Publish.hs195
-rw-r--r--src/Language/PureScript/Publish/ErrorsWarnings.hs110
-rw-r--r--src/Language/PureScript/Publish/Utils.hs43
-rw-r--r--src/Language/PureScript/Sugar.hs5
-rw-r--r--src/Language/PureScript/Sugar/BindingGroups.hs28
-rw-r--r--src/Language/PureScript/Sugar/CaseDeclarations.hs277
-rw-r--r--src/Language/PureScript/Sugar/DoNotation.hs52
-rw-r--r--src/Language/PureScript/Sugar/LetPattern.hs47
-rw-r--r--src/Language/PureScript/Sugar/Names.hs36
-rw-r--r--src/Language/PureScript/Sugar/Names/Common.hs5
-rw-r--r--src/Language/PureScript/Sugar/ObjectWildcards.hs16
-rw-r--r--src/Language/PureScript/Sugar/TypeClasses.hs71
-rwxr-xr-xsrc/Language/PureScript/Sugar/TypeClasses/Deriving.hs253
-rw-r--r--src/Language/PureScript/Sugar/TypeDeclarations.hs8
-rw-r--r--src/Language/PureScript/TypeChecker.hs50
-rw-r--r--src/Language/PureScript/TypeChecker/Entailment.hs114
-rw-r--r--src/Language/PureScript/TypeChecker/Kinds.hs11
-rw-r--r--src/Language/PureScript/TypeChecker/Monad.hs5
-rw-r--r--src/Language/PureScript/TypeChecker/Rows.hs53
-rw-r--r--src/Language/PureScript/TypeChecker/Skolems.hs162
-rw-r--r--src/Language/PureScript/TypeChecker/Subsumption.hs35
-rw-r--r--src/Language/PureScript/TypeChecker/TypeSearch.hs39
-rw-r--r--src/Language/PureScript/TypeChecker/Types.hs168
-rw-r--r--src/Language/PureScript/TypeChecker/Unify.hs77
-rw-r--r--src/Language/PureScript/TypeClassDictionaries.hs7
-rw-r--r--src/Language/PureScript/Types.hs138
-rw-r--r--stack.yaml1
-rw-r--r--tests/Language/PureScript/Ide/ImportsSpec.hs39
-rw-r--r--tests/Language/PureScript/Ide/ReexportsSpec.hs29
-rw-r--r--tests/Language/PureScript/Ide/SourceFileSpec.hs2
-rw-r--r--tests/Language/PureScript/Ide/StateSpec.hs2
-rw-r--r--tests/Language/PureScript/Ide/Test.hs8
-rw-r--r--tests/TestDocs.hs14
-rw-r--r--tests/TestPscPublish.hs10
-rw-r--r--tests/TestPsci.hs126
-rw-r--r--tests/TestPsci/CommandTest.hs35
-rw-r--r--tests/TestPsci/CompletionTest.hs108
-rw-r--r--tests/TestPsci/TestEnv.hs81
-rw-r--r--tests/TestUtils.hs2
-rw-r--r--tests/support/bower.json29
-rw-r--r--tests/support/prelude-resolutions.json7
215 files changed, 6330 insertions, 4724 deletions
diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md
index 65443cc..f935b7a 100644
--- a/CONTRIBUTING.md
+++ b/CONTRIBUTING.md
@@ -10,11 +10,25 @@ If you would like to contribute, please consider the issues in the current miles
Please follow the following guidelines:
-- Add at least a test to `examples/passing/` and possibly to `examples/failing`.
+- Add at least a test to `examples/passing/` and possibly to `examples/failing/`.
- Build the binaries and libs with `stack build`
-- Run the test suite with `stack test`. You will need `npm`, `bower` and `node` on your PATH to run the tests.
+- Make sure that all test suites are passing. Run the test suites with `stack test`.
- Build the core libraries by running the script in `core-tests`.
+## Tests
+
+Run all test suites with `stack test`. You will need `npm`, `bower` and `node` on your PATH to run the tests.
+
+To build and run a specific test in `examples/passing/` or `examples/failing/`, execute the following commands.
+
+``` bash
+# Build
+stack exec psc -- 'tests/support/bower_components/purescript-*/src/**/*.purs' examples/blah/Blah.purs
+
+# Run
+node -e "require('./output/Main/').main()"
+```
+
## Code Review
To prevent core libraries from getting broken, every change must be reviewed. A pull request will be merged as long as one other team member has verified the changes.
diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md
index 45057f1..69999df 100644
--- a/CONTRIBUTORS.md
+++ b/CONTRIBUTORS.md
@@ -2,96 +2,115 @@
This file lists the contributors to the PureScript compiler project, and the terms under which their code is licensed.
-### Individuals
+### Contributors using Standard Terms
-- [@5outh](https://github.com/5outh) (Benjamin Kovach) - My existing contributions and all future contributions until further notice are Copyright Benjamin Kovach, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license.
-- [@andreypopp](https://github.com/andreypopp) (Andrey Popp) My existing contributions and all future contributions until further notice are Copyright Andrey Popp, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license.
-- [@andyarvanitis](https://github.com/andyarvanitis) (Andy Arvanitis) My existing contributions and all future contributions until further notice are Copyright Andy Arvanitis, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
-- [@anthok88](https://github.com/anthoq88) - My existing contributions and all future contributions until further notice are Copyright anthoq88, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license
-- [@ardumont](https://github.com/ardumont) (Antoine R. Dumont) My existing contributions and all future contributions until further notice are Copyright Antoine R. Dumont, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
-- [@aspidites](https://github.com/aspidites) (Edwin Marshall) My existing contributions and all future contributions until further notice are Copyright Edwin Marshall, 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).
-- [@bagl](https://github.com/bagl) (Petr Vapenka) My existing contributions and all future contributions until further notice are Copyright Petr Vapenka, 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).
-- [@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.
-- [@bmjames](https://github.com/bmjames) (Ben James) My existing contributions and all future contributions until further notice are Copyright Ben James, 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).
-- [@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).
-- [@bsermons](https://github.com/bsermons) (Brian Sermons) My existing contributions and all future contributions until further notice are Copyright Brian Sermons, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
-- [@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).
-- [@charleso](https://github.com/charleso) (Charles O'Farrell) My existing contributions to the PureScript compiler and all future contributions to the PureScript compiler until further notice, are Copyright Charles O'Farrell, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
-- [@chrisdone](https://github.com/chrisdone) (Chris Done) - My existing contributions and all future contributions until further notice are Copyright Chris Done, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license.
-- [@chrissmoak](https://github.com/chrissmoak) (Chris Smoak) My existing contributions to the PureScript compiler and all future contributions to the PureScript compiler until further notice, are Copyright Chris Smoak, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
-- [@codedmart](https://github.com/codedmart) (Brandon Martin) My existing contributions and all future contributions until further notice are Copyright Brandon Martin, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
-- [@davidchambers](https://github.com/davidchambers) (David Chambers) My existing contributions and all future contributions until further notice are Copyright David Chambers, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
-- [@DavidLindbom](https://github.com/DavidLindbom) (David Lindbom) My existing contributions and all future contributions until further notice are Copyright David Lindbom, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
-- [@dckc](https://github.com/dckc) (Dan Connolly) My existing contributions and all future contributions until further notice are Copyright Dan Connolly, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
-- [@dylex](https://github.com/dylex) (Dylan Simon) My existing and all future contributions to the PureScript compiler until further notice are Copyright Dylan Simon, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
-- [@eamelink](https://github.com/eamelink) (Erik Bakker) - My existing contributions and all future contributions until further notice are Copyright Erik Bakker, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license.
-- [@epost](https://github.com/epost) (Erik Post) - My existing contributions and all future contributions until further notice are Copyright Erik Post, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license
-- [@erdeszt](https://github.com/erdeszt) (Tibor Erdesz) My existing contributions and all future contributions until further notice are Copyright Tibor Erdesz, 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).
-- [@etrepum](https://github.com/etrepum) (Bob Ippolito) My existing contributions and all future contributions until further notice are Copyright Bob Ippolito, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
-- [@faineance](https://github.com/faineance) My existing contributions and all future contributions until further notice are Copyright faineance, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
-- [@felixSchl](https://github.com/felixSchl) (Felix Schlitter) My existing contributions and all future contributions until further notice are Copyright Felix Schlitter, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
-- [@FrigoEU](https://github.com/FrigoEU) (Simon Van Casteren) My existing contributions and all future contributions until further notice are Copyright Simon Van Casteren, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
-- [@garyb](https://github.com/garyb) (Gary Burgess) My existing contributions and all future contributions until further notice are Copyright Gary Burgess, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
-- [@hdgarrood](https://github.com/hdgarrood) (Harry Garrood) My existing contributions and all future contributions until further notice are Copyright Harry Garrood, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
-- [@ianbollinger](https://github.com/ianbollinger) (Ian D. Bollinger) My existing contributions and all future contributions until further notice are Copyright Ian D. Bollinger, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
-- [@ilovezfs](https://github.com/ilovezfs) - My existing contributions and all future contributions until further notice are Copyright ilovezfs, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license
-- [@izgzhen](https://github.com/izgzhen) (Zhen Zhang) My existing contributions and all future contributions until further notice are Copyright Zhen Zhang, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
-- [@jacereda](https://github.com/jacereda) (Jorge Acereda) My existing contributions and all future contributions until further notice are Copyright Jorge Acereda, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
-- [@japesinator](https://github.com/japesinator) (JP Smith) My existing contributions and all future contributions until further notice are Copyright JP Smith, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
-- [@joneshf](https://github.com/joneshf) (Hardy Jones) - My existing contributions and all future contributions until further notice are Copyright Hardy Jones, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license.
-- [@kika](https://github.com/kika) (Kirill Pertsev) - My existing contributions and all future contributions until further notice are Copyright Kirill Pertsev, 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).
-- [@LiamGoodacre](https://github.com/LiamGoodacre) (Liam Goodacre) My existing contributions and all future contributions until further notice are Copyright Liam Goodacre, 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).
-- [@mpietrzak](https://github.com/mpietrzak) (Maciej Pietrzak) My existing contributions and all future contributions until further notice are Copyright Maciej Pietrzak, 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).
-- [@mrhania](https://github.com/mrhania) (Łukasz Hanuszczak) - My existing contributions and all future contributions until further notice are Copyright Łukasz Hanuszczak, 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).
-- [@nagisa](https://github.com/nagisa) I hereby release my [only contribution](https://github.com/purescript/purescript/commit/80287a5d0de619862d3b4cda9c1ee276d18fdcd8) into public domain.
-- [@natefaubion](https://github.com/natefaubion) (Nathan Faubion) My existing contributions and all future contributions until further notice are Copyright Nathan Faubion, 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).
-- [@nicodelpiano](https://github.com/nicodelpiano) (Nicolas Del Piano) My existing contributions and all future contributions until further notice are Copyright Nicolas Del Piano, 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).
-- [@nullobject](https://github.com/nullobject) (Josh Bassett) My existing contributions and all future contributions until further notice are Copyright Josh Bassett, 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).
-- [@nwolverson](https://github.com/nwolverson) (Nicholas Wolverson) My existing contributions and all future contributions until further notice are Copyright Nicholas Wolverson, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
-- [@osa1](https://github.com/osa1) (Ömer Sinan Ağacan) - My existing contributions and all future contributions until further notice are Copyright Ömer Sinan Ağacan, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license.
-- [@paf31](https://github.com/paf31) (Phil Freeman) My existing contributions and all future contributions until further notice are Copyright Phil Freeman, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
-- [@passy](https://github.com/passy) (Pascal Hartig) My existing contributions and all future contributions until further notice are Copyright Pascal Hartig, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
-- [@paulyoung](https://github.com/paulyoung) (Paul Young) My existing contributions and all future contributions until further notice are Copyright Paul Young, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
-- [@pelotom](https://github.com/pelotom) (Thomas Crockett) My existing contributions and all future contributions until further notice are Copyright Thomas Crockett, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
-- [@phadej](https://github.com/phadej) (Oleg Grenrus) My existing contributions and all future contributions until further notice are Copyright Oleg Grenrus, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
-- [@phiggins](https://github.com/phiggins) (Pete Higgins) My existing contributions and all future contributions until further notice are Copyright Pete Higgins, 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).
-- [@philopon](https://github.com/philopon) (Hirotomo Moriwaki) - My existing contributions and all future contributions until further notice are Copyright Hirotomo Moriwaki, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
-- [@pseudonom](https://github.com/pseudonom) (Eric Easley) My existing contributions and all future contributions until further notice are Copyright Eric Easley, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
-- [@puffnfresh](https://github.com/puffnfresh) (Brian McKenna) All contributions I made during June 2015 were during employment at [SlamData, Inc.](#companies) who owns the copyright. I assign copyright of all my personal contributions before June 2015 to the owners of the PureScript compiler.
-- [@rightfold](https://github.com/rightfold) (rightfold) My existing contributions and all future contributions until further notice are Copyright rightfold, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](https://opensource.org/licenses/MIT).
-- [@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).
-- [@rvion](https://github.com/rvion) (Rémi Vion) My existing contributions and all future contributions until further notice are Copyright Rémi Vion, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
-- [@sebastiaanvisser](https://github.com/sebastiaanvisser) (Sebastiaan Visser) - My existing contributions and all future contributions until further notice are Copyright Sebastiaan Visser, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license.
-- [@senju](https://github.com/senju) - My existing contributions and all future contributions until further notice are Copyright senju, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
-- [@sharkdp](https://github.com/sharkdp) (David Peter) My existing contributions and all future contributions until further notice are Copyright David Peter, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
-- [@soupi](https://github.com/soupi) (Gil Mizrahi) My existing contributions and all future contributions until further notice are Copyright Gil Mizrahi, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
-- [@sztupi](https://github.com/sztupi) (Attila Sztupak) My existing contributions and all future contributions until further notice are Copyright Attila Sztupak, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
-- [@taktoa](https://github.com/taktoa) (Remy Goldschmidt) My existing contributions and all future contributions until further notice are Copyright Remy Goldschmidt, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
-- [@taku0](https://github.com/taku0) - My existing contributions and all future contributions until further notice are Copyright taku0, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
-- [@tfausak](https://github.com/tfausak) (Taylor Fausak) My existing contributions and all future contributions until further notice are Copyright Taylor Fausak, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
-- [@tmcgilchrist](https://github.com/tmcgilchrist) (Tim McGilchrist) My existing contributions and all future contributions until further notice are Copyright Tim McGilchrist, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
-- [@trofi](https://github.com/trofi) (Sergei Trofimovich) My existing contributions and all future contributions until further notice are Copyright Sergei Trofimovich, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
-- [@utkarshkukreti](https://github.com/utkarshkukreti) (Utkarsh Kukreti) My existing contributions and all future contributions until further notice are Copyright Utkarsh Kukreti, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
-- [@vkorablin](https://github.com/vkorablin) (Vladimir Korablin) - My existing contributions and all future contributions until further notice are Copyright Vladimir Korablin, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license.
-- [@zudov](https://github.com/zudov) (Konstantin Zudov) My existing contributions and all future contributions until further notice are Copyright Konstantin Zudov, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
-- [@brandonhamilton](https://github.com/brandonhamilton) (Brandon Hamilton) My existing contributions and all future contributions until further notice are Copyright Brandon Hamilton, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
-- [@bbqbaron](https://github.com/bbqbaron) (Eric Loren) My existing contributions and all future contributions until further notice are Copyright Eric Loren, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
-- [@RyanGlScott](https://github.com/RyanGlScott) (Ryan Scott) My existing contributions and all future contributions until further notice are Copyright Ryan Scott, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
-- [@seungha-kim](https://github.com/seungha-kim) (Seungha Kim) My existing contributions and all future contributions until further notice are Copyright Seungha Kim, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
-- [@matthewleon](https://github.com/matthewleon) (Matthew Leon) My existing contributions and all future contributions until further notice are Copyright Matthew Leon, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
-- [@alexbiehl](https://github.com/alexbiehl) (Alexander Biehl) My existing contributions and all future contributions until further notice are Copyright Alexander Biehl, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
-- [@noraesae](https://github.com/noraesae) (Hyunje Jun) My existing contributions and all future contributions until further notice are Copyright Hyunje Jun, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
+Contributors listed here agree to license their contributions under the following terms:
+
+> My existing contributions and all future contributions until further notice are Copyright {Name}, and are licensed to the owners and users of the PureScript compiler project under the terms of the {License}.
+
+By adding your name to the list below, you agree to license your contributions under these following terms.
+
+If you would prefer to use different terms, please use the section below instead.
+
+| Username | Name | License |
+| :------- | :--- | :------ |
+| [@5outh](https://github.com/5outh) | Benjamin Kovach | MIT license |
+| [@alexbiehl](https://github.com/alexbiehl) | Alexander Biehl | [MIT license](http://opensource.org/licenses/MIT) |
+| [@andreypopp](https://github.com/andreypopp) | Andrey Popp | MIT license |
+| [@andyarvanitis](https://github.com/andyarvanitis) | Andy Arvanitis | [MIT license](http://opensource.org/licenses/MIT) |
+| [@anthok88](https://github.com/anthok88) | anthoq88 | MIT license |
+| [@ardumont](https://github.com/ardumont) | Antoine R. Dumont | [MIT license](http://opensource.org/licenses/MIT) |
+| [@aspidites](https://github.com/aspidites) | Edwin Marshall | [MIT license](http://opensource.org/licenses/MIT) |
+| [@bagl](https://github.com/bagl) | Petr Vapenka | [MIT license](http://opensource.org/licenses/MIT) |
+| [@balajirrao](https://github.com/balajirrao) | Balaji Rao | MIT license |
+| [@bbqbaron](https://github.com/bbqbaron) | Eric Loren | [MIT license](http://opensource.org/licenses/MIT) |
+| [@bergmark](https://github.com/bergmark) | Adam Bergmark | MIT license |
+| [@bmjames](https://github.com/bmjames) | Ben James | [MIT license](http://opensource.org/licenses/MIT) |
+| [@Bogdanp](https://github.com/Bogdanp) | Bogdan Paul Popa | [MIT license](http://opensource.org/licenses/MIT) |
+| [@brandonhamilton](https://github.com/brandonhamilton) | Brandon Hamilton | [MIT license](http://opensource.org/licenses/MIT) |
+| [@bsermons](https://github.com/bsermons) | Brian Sermons | [MIT license](http://opensource.org/licenses/MIT) |
+| [@cdepillabout](https://github.com/cdepillabout) | Dennis Gosnell | [MIT license](http://opensource.org/licenses/MIT) |
+| [@chrisdone](https://github.com/chrisdone) | Chris Done | MIT license |
+| [@codedmart](https://github.com/codedmart) | Brandon Martin | [MIT license](http://opensource.org/licenses/MIT) |
+| [@davidchambers](https://github.com/davidchambers) | David Chambers | [MIT license](http://opensource.org/licenses/MIT) |
+| [@DavidLindbom](https://github.com/DavidLindbom) | David Lindbom | [MIT license](http://opensource.org/licenses/MIT) |
+| [@dckc](https://github.com/dckc) | Dan Connolly | [MIT license](http://opensource.org/licenses/MIT) |
+| [@eamelink](https://github.com/eamelink) | Erik Bakker | MIT license |
+| [@epost](https://github.com/epost) | Erik Post | MIT license |
+| [@erdeszt](https://github.com/erdeszt) | Tibor Erdesz | [MIT license](http://opensource.org/licenses/MIT) |
+| [@etrepum](https://github.com/etrepum) | Bob Ippolito | [MIT license](http://opensource.org/licenses/MIT) |
+| [@faineance](https://github.com/faineance) | faineance | [MIT license](http://opensource.org/licenses/MIT) |
+| [@felixSchl](https://github.com/felixSchl) | Felix Schlitter | [MIT license](http://opensource.org/licenses/MIT) |
+| [@FrigoEU](https://github.com/FrigoEU) | Simon Van Casteren | [MIT license](http://opensource.org/licenses/MIT) |
+| [@garyb](https://github.com/garyb) | Gary Burgess | [MIT license](http://opensource.org/licenses/MIT) |
+| [@hdgarrood](https://github.com/hdgarrood) | Harry Garrood | [MIT license](http://opensource.org/licenses/MIT) |
+| [@ianbollinger](https://github.com/ianbollinger) | Ian D. Bollinger | [MIT license](http://opensource.org/licenses/MIT) |
+| [@ilovezfs](https://github.com/ilovezfs) | ilovezfs | MIT license |
+| [@izgzhen](https://github.com/izgzhen) | Zhen Zhang | [MIT license](http://opensource.org/licenses/MIT) |
+| [@jacereda](https://github.com/jacereda) | Jorge Acereda | [MIT license](http://opensource.org/licenses/MIT) |
+| [@japesinator](https://github.com/japesinator) | JP Smith | [MIT license](http://opensource.org/licenses/MIT) |
+| [@joneshf](https://github.com/joneshf) | Hardy Jones | MIT license |
+| [@kika](https://github.com/kika) | Kirill Pertsev | MIT license |
+| [@kRITZCREEK](https://github.com/kRITZCREEK) | Christoph Hegemann | MIT license |
+| [@L8D](https://github.com/L8D) | Tenor Biel | [MIT license](http://opensource.org/licenses/MIT) |
+| [@LiamGoodacre](https://github.com/LiamGoodacre) | Liam Goodacre | [MIT license](http://opensource.org/licenses/MIT) |
+| [@lukerandall](https://github.com/lukerandall) | Luke Randall | [MIT license](http://opensource.org/licenses/MIT) |
+| [@matthewleon](https://github.com/matthewleon) | Matthew Leon | [MIT license](http://opensource.org/licenses/MIT) |
+| [@mcoffin](https://github.com/mcoffin) | Matt Coffin | [MIT license](http://opensource.org/licenses/MIT) |
+| [@mrkgnao](https://github.com/mrkgnao) | Soham Chowdhury | [MIT license](http://opensource.org/licenses/MIT) |
+| [@mgmeier](https://github.com/mgmeier) | Michael Gilliland | [MIT license](http://opensource.org/licenses/MIT) |
+| [@michaelficarra](https://github.com/michaelficarra) | Michael Ficarra | [MIT license](http://opensource.org/licenses/MIT) |
+| [@MichaelXavier](https://github.com/MichaelXavier) | Michael Xavier | MIT license |
+| [@mjgpy3](https://github.com/mjgpy3) | Michael Gilliland | [MIT license](http://opensource.org/licenses/MIT) |
+| [@mpietrzak](https://github.com/mpietrzak) | Maciej Pietrzak | [MIT license](http://opensource.org/licenses/MIT) |
+| [@mrhania](https://github.com/mrhania) | Łukasz Hanuszczak | [MIT license](http://opensource.org/licenses/MIT) |
+| [@natefaubion](https://github.com/natefaubion) | Nathan Faubion | [MIT license](http://opensource.org/licenses/MIT) |
+| [@nicodelpiano](https://github.com/nicodelpiano) | Nicolas Del Piano | [MIT license](http://opensource.org/licenses/MIT) |
+| [@noraesae](https://github.com/noraesae) | Hyunje Jun | [MIT license](http://opensource.org/licenses/MIT) |
+| [@nullobject](https://github.com/nullobject) | Josh Bassett | [MIT license](http://opensource.org/licenses/MIT) |
+| [@nwolverson](https://github.com/nwolverson) | Nicholas Wolverson | [MIT license](http://opensource.org/licenses/MIT) |
+| [@osa1](https://github.com/osa1) | Ömer Sinan Ağacan | MIT license |
+| [@paf31](https://github.com/paf31) | Phil Freeman | [MIT license](http://opensource.org/licenses/MIT) |
+| [@passy](https://github.com/passy) | Pascal Hartig | [MIT license](http://opensource.org/licenses/MIT) |
+| [@paulyoung](https://github.com/paulyoung) | Paul Young | [MIT license](http://opensource.org/licenses/MIT) |
+| [@pelotom](https://github.com/pelotom) | Thomas Crockett | [MIT license](http://opensource.org/licenses/MIT) |
+| [@phadej](https://github.com/phadej) | Oleg Grenrus | [MIT license](http://opensource.org/licenses/MIT) |
+| [@phiggins](https://github.com/phiggins) | Pete Higgins | [MIT license](http://opensource.org/licenses/MIT) |
+| [@philopon](https://github.com/philopon) | Hirotomo Moriwaki | [MIT license](http://opensource.org/licenses/MIT) |
+| [@pseudonom](https://github.com/pseudonom) | Eric Easley | [MIT license](http://opensource.org/licenses/MIT) |
+| [@rightfold](https://github.com/rightfold) | rightfold | [MIT license](https://opensource.org/licenses/MIT) |
+| [@robdaemon](https://github.com/robdaemon) | Robert Roland | [MIT license](http://opensource.org/licenses/MIT) |
+| [@RossMeikleham](https://github.com/RossMeikleham) | Ross Meikleham | [MIT license](http://opensource.org/licenses/MIT) |
+| [@rvion](https://github.com/rvion) | Rémi Vion | [MIT license](http://opensource.org/licenses/MIT) |
+| [@RyanGlScott](https://github.com/RyanGlScott) | Ryan Scott | [MIT license](http://opensource.org/licenses/MIT) |
+| [@sebastiaanvisser](https://github.com/sebastiaanvisser) | Sebastiaan Visser | MIT license |
+| [@senju](https://github.com/senju) | senju | [MIT license](http://opensource.org/licenses/MIT) |
+| [@seungha-kim](https://github.com/seungha-kim) | Seungha Kim | [MIT license](http://opensource.org/licenses/MIT) |
+| [@sharkdp](https://github.com/sharkdp) | David Peter | [MIT license](http://opensource.org/licenses/MIT) |
+| [@soupi](https://github.com/soupi) | Gil Mizrahi | [MIT license](http://opensource.org/licenses/MIT) |
+| [@sztupi](https://github.com/sztupi) | Attila Sztupak | [MIT license](http://opensource.org/licenses/MIT) |
+| [@taktoa](https://github.com/taktoa) | Remy Goldschmidt | [MIT license](http://opensource.org/licenses/MIT) |
+| [@taku0](https://github.com/taku0) | taku0 | [MIT license](http://opensource.org/licenses/MIT) |
+| [@tfausak](https://github.com/tfausak) | Taylor Fausak | [MIT license](http://opensource.org/licenses/MIT) |
+| [@tmcgilchrist](https://github.com/tmcgilchrist) | Tim McGilchrist | [MIT license](http://opensource.org/licenses/MIT) |
+| [@trofi](https://github.com/trofi) | Sergei Trofimovich | [MIT license](http://opensource.org/licenses/MIT) |
+| [@utkarshkukreti](https://github.com/utkarshkukreti) | Utkarsh Kukreti | [MIT license](http://opensource.org/licenses/MIT) |
+| [@vkorablin](https://github.com/vkorablin) | Vladimir Korablin | MIT license |
+| [@zudov](https://github.com/zudov) | Konstantin Zudov | [MIT license](http://opensource.org/licenses/MIT) |
+
+### Contributors using Modified Terms
+
+| Username | Name | Terms |
+| :------- | :--- | :------ |
+| [@charleso](https://github.com/charleso) | Charles O'Farrell | My existing contributions to the PureScript compiler and all future contributions to the PureScript compiler until further notice, are Copyright Charles O'Farrell, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). |
+| [@chrissmoak](https://github.com/chrissmoak) | Chris Smoak | My existing contributions to the PureScript compiler and all future contributions to the PureScript compiler until further notice, are Copyright Chris Smoak, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). |
+| [@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). |
+| [@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). |
+| [@nagisa](https://github.com/nagisa) | nagisa | I hereby release my [only contribution](https://github.com/purescript/purescript/commit/80287a5d0de619862d3b4cda9c1ee276d18fdcd8) into public domain. |
+| [@puffnfresh](https://github.com/puffnfresh) | Brian McKenna | All contributions I made during June 2015 were during employment at [SlamData, Inc.](#companies) who owns the copyright. I assign copyright of all my personal contributions before June 2015 to the owners of the PureScript compiler. |
### Companies
-- [@slamdata](https://github.com/slamdata) (SlamData, Inc.) Speaking on behalf of SlamData for SlamData employees, our existing contributions and all future contributions to the PureScript compiler are, until further notice, Copyright SlamData Inc., 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). - @jdegoes
+| Username | Company | Terms |
+| :------- | :--- | :------ |
+| [@slamdata](https://github.com/slamdata) | SlamData, Inc. | Speaking on behalf of SlamData for SlamData employees, our existing contributions and all future contributions to the PureScript compiler are, until further notice, Copyright SlamData Inc., 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). - @jdegoes |
diff --git a/LICENSE b/LICENSE
index 2272766..b25d9b3 100644
--- a/LICENSE
+++ b/LICENSE
@@ -1,4 +1,4 @@
-Copyright (c) 2013-16 Phil Freeman, (c) 2014-2016 Gary Burgess, and other
+Copyright (c) 2013-17 Phil Freeman, (c) 2014-2017 Gary Burgess, and other
contributors
All rights reserved.
@@ -79,7 +79,6 @@ PureScript uses the following Haskell library packages. Their license files foll
fast-logger
file-embed
filepath
- foldl
free
fsnotify
ghc-prim
@@ -87,7 +86,6 @@ PureScript uses the following Haskell library packages. Their license files foll
haskeline
hex
hinotify
- hostname
hourglass
http-client
http-client-tls
@@ -100,7 +98,6 @@ PureScript uses the following Haskell library packages. Their license files foll
language-javascript
lens
lifted-base
- managed
memory
mime-types
mmorph
@@ -108,12 +105,10 @@ PureScript uses the following Haskell library packages. Their license files foll
monad-logger
monad-loops
mtl
- mwc-random
network
network-uri
old-locale
old-time
- optional-args
optparse-applicative
parallel
parsec
@@ -146,12 +141,9 @@ PureScript uses the following Haskell library packages. Their license files foll
streaming-commons
stringsearch
syb
- system-fileio
- system-filepath
tagged
tagsoup
template-haskell
- temporary
terminfo
text
time
@@ -159,7 +151,6 @@ PureScript uses the following Haskell library packages. Their license files foll
transformers
transformers-base
transformers-compat
- turtle
uniplate
unix
unix-compat
@@ -2285,33 +2276,6 @@ filepath LICENSE file:
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-foldl LICENSE file:
-
- Copyright (c) 2013 Gabriel Gonzalez
- All rights reserved.
-
- Redistribution and use in source and binary forms, with or without modification,
- are permitted provided that the following conditions are met:
- * Redistributions of source code must retain the above copyright notice,
- this list of conditions and the following disclaimer.
- * Redistributions in binary form must reproduce the above copyright notice,
- this list of conditions and the following disclaimer in the documentation
- and/or other materials provided with the distribution.
- * Neither the name of Gabriel Gonzalez nor the names of other contributors
- may be used to endorse or promote products derived from this software
- without specific prior written permission.
-
- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR
- ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
- (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
- LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
- ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
- (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
free LICENSE file:
Copyright 2008-2013 Edward Kmett
@@ -2567,31 +2531,6 @@ hinotify LICENSE file:
ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.
-hostname LICENSE file:
-
- Copyright (c) 2008, Maximilian Bolingbroke
- All rights reserved.
-
- Redistribution and use in source and binary forms, with or without modification, are permitted
- provided that the following conditions are met:
-
- * Redistributions of source code must retain the above copyright notice, this list of
- conditions and the following disclaimer.
- * Redistributions in binary form must reproduce the above copyright notice, this list of
- conditions and the following disclaimer in the documentation and/or other materials
- provided with the distribution.
- * Neither the name of Maximilian Bolingbroke nor the names of other contributors may be used to
- endorse or promote products derived from this software without specific prior written permission.
-
- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR
- IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
- FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR
- CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
- DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER
- IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT
- OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
hourglass LICENSE file:
Copyright (c) 2014 Vincent Hanquez <vincent@snarc.org>
@@ -2962,33 +2901,6 @@ lifted-base LICENSE file:
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-managed LICENSE file:
-
- Copyright (c) 2014 Gabriel Gonzalez
- All rights reserved.
-
- Redistribution and use in source and binary forms, with or without modification,
- are permitted provided that the following conditions are met:
- * Redistributions of source code must retain the above copyright notice,
- this list of conditions and the following disclaimer.
- * Redistributions in binary form must reproduce the above copyright notice,
- this list of conditions and the following disclaimer in the documentation
- and/or other materials provided with the distribution.
- * Neither the name of Gabriel Gonzalez nor the names of other contributors
- may be used to endorse or promote products derived from this software
- without specific prior written permission.
-
- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR
- ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
- (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
- LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
- ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
- (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
memory LICENSE file:
Copyright (c) 2015 Vincent Hanquez <vincent@snarc.org>
@@ -3160,35 +3072,6 @@ mtl LICENSE file:
OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
DAMAGE.
-mwc-random LICENSE file:
-
- Copyright (c) 2009, Bryan O'Sullivan
- All rights reserved.
-
- Redistribution and use in source and binary forms, with or without
- modification, are permitted provided that the following conditions
- are met:
-
- * Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
-
- * Redistributions in binary form must reproduce the above
- copyright notice, this list of conditions and the following
- disclaimer in the documentation and/or other materials provided
- with the distribution.
-
- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
- A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
- OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
- LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
- DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
- THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
- (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
network LICENSE file:
Copyright (c) 2002-2010, The University Court of the University of Glasgow.
@@ -3385,33 +3268,6 @@ old-time LICENSE file:
-----------------------------------------------------------------------------
-optional-args LICENSE file:
-
- Copyright (c) 2015 Gabriel Gonzalez
- All rights reserved.
-
- Redistribution and use in source and binary forms, with or without modification,
- are permitted provided that the following conditions are met:
- * Redistributions of source code must retain the above copyright notice,
- this list of conditions and the following disclaimer.
- * Redistributions in binary form must reproduce the above copyright notice,
- this list of conditions and the following disclaimer in the documentation
- and/or other materials provided with the distribution.
- * Neither the name of Gabriel Gonzalez nor the names of other contributors
- may be used to endorse or promote products derived from this software
- without specific prior written permission.
-
- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR
- ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
- (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
- LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
- ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
- (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
optparse-applicative LICENSE file:
Copyright (c) 2012, Paolo Capriotti
@@ -4499,56 +4355,6 @@ syb LICENSE file:
-----------------------------------------------------------------------------
-system-fileio LICENSE file:
-
- Copyright (c) 2011 John Millikin
-
- Permission is hereby granted, free of charge, to any person
- obtaining a copy of this software and associated documentation
- files (the "Software"), to deal in the Software without
- restriction, including without limitation the rights to use,
- copy, modify, merge, publish, distribute, sublicense, and/or sell
- copies of the Software, and to permit persons to whom the
- Software is furnished to do so, subject to the following
- conditions:
-
- The above copyright notice and this permission notice shall be
- included in all copies or substantial portions of the Software.
-
- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
- EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
- OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
- NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
- HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
- WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
- FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
- OTHER DEALINGS IN THE SOFTWARE.
-
-system-filepath LICENSE file:
-
- Copyright (c) 2010 John Millikin
-
- Permission is hereby granted, free of charge, to any person
- obtaining a copy of this software and associated documentation
- files (the "Software"), to deal in the Software without
- restriction, including without limitation the rights to use,
- copy, modify, merge, publish, distribute, sublicense, and/or sell
- copies of the Software, and to permit persons to whom the
- Software is furnished to do so, subject to the following
- conditions:
-
- The above copyright notice and this permission notice shall be
- included in all copies or substantial portions of the Software.
-
- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
- EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
- OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
- NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
- HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
- WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
- FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
- OTHER DEALINGS IN THE SOFTWARE.
-
tagged LICENSE file:
Copyright (c) 2009-2015 Edward Kmett
@@ -4651,31 +4457,6 @@ template-haskell LICENSE file:
DAMAGE.
-temporary LICENSE file:
-
- Copyright (c) 2008, Maximilian Bolingbroke
- All rights reserved.
-
- Redistribution and use in source and binary forms, with or without modification, are permitted
- provided that the following conditions are met:
-
- * Redistributions of source code must retain the above copyright notice, this list of
- conditions and the following disclaimer.
- * Redistributions in binary form must reproduce the above copyright notice, this list of
- conditions and the following disclaimer in the documentation and/or other materials
- provided with the distribution.
- * Neither the name of Maximilian Bolingbroke nor the names of other contributors may be used to
- endorse or promote products derived from this software without specific prior written permission.
-
- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR
- IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
- FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR
- CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
- DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER
- IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT
- OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
terminfo LICENSE file:
Copyright 2007, Judah Jacobson.
@@ -4871,33 +4652,6 @@ transformers-compat LICENSE file:
ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.
-turtle LICENSE file:
-
- Copyright (c) 2015 Gabriel Gonzalez
- All rights reserved.
-
- Redistribution and use in source and binary forms, with or without modification,
- are permitted provided that the following conditions are met:
- * Redistributions of source code must retain the above copyright notice,
- this list of conditions and the following disclaimer.
- * Redistributions in binary form must reproduce the above copyright notice,
- this list of conditions and the following disclaimer in the documentation
- and/or other materials provided with the distribution.
- * Neither the name of Gabriel Gonzalez nor the names of other contributors
- may be used to endorse or promote products derived from this software
- without specific prior written permission.
-
- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR
- ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
- (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
- LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
- ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
- (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
uniplate LICENSE file:
Copyright Neil Mitchell 2006-2013.
diff --git a/README.md b/README.md
index b6c4df2..504c5ca 100644
--- a/README.md
+++ b/README.md
@@ -1,6 +1,6 @@
[![PureScript](logo.png)](http://purescript.org)
-A small strongly typed programming language with expressive types that compiles to Javascript, written in and inspired by Haskell.
+A small strongly typed programming language with expressive types that compiles to JavaScript, written in and inspired by Haskell.
[![Hackage](https://img.shields.io/hackage/v/purescript.svg)](http://hackage.haskell.org/package/purescript) [![Build Status](https://api.travis-ci.org/purescript/purescript.svg?branch=master)](http://travis-ci.org/purescript/purescript)
diff --git a/psc-bundle/Main.hs b/app/Command/Bundle.hs
index 2bd9428..4ea338a 100644
--- a/psc-bundle/Main.hs
+++ b/app/Command/Bundle.hs
@@ -4,39 +4,30 @@
{-# LANGUAGE RecordWildCards #-}
-- | Bundles compiled PureScript modules for the browser.
-module Main (main) where
-
-import Data.Traversable (for)
-import Data.Version (showVersion)
-import Data.Monoid ((<>))
-import Data.Aeson (encode)
-import Data.Maybe (isNothing)
-
-import Control.Applicative
-import Control.Monad
-import Control.Monad.Error.Class
-import Control.Monad.Trans.Except
-import Control.Monad.IO.Class
-
-import System.FilePath (takeDirectory, (</>), (<.>), takeFileName)
-import System.FilePath.Glob (glob)
-import System.Exit (exitFailure)
-import System.IO (stderr, stdout, hPutStrLn, hSetEncoding, utf8)
-import System.IO.UTF8 (readUTF8File, writeUTF8File)
-import System.Directory (createDirectoryIfMissing, getCurrentDirectory)
-
+module Command.Bundle (command) where
+
+import Data.Traversable (for)
+import Data.Monoid ((<>))
+import Data.Aeson (encode)
+import Data.Maybe (isNothing)
+import Control.Applicative
+import Control.Monad
+import Control.Monad.Error.Class
+import Control.Monad.Trans.Except
+import Control.Monad.IO.Class
+import System.FilePath (takeDirectory, (</>), (<.>), takeFileName)
+import System.FilePath.Glob (glob)
+import System.Exit (exitFailure)
+import System.IO (stderr, hPutStr, hPutStrLn)
+import System.IO.UTF8 (readUTF8File, writeUTF8File)
+import System.Directory (createDirectoryIfMissing, getCurrentDirectory)
import qualified Data.ByteString.Lazy as B
import qualified Data.ByteString.UTF8 as BU8
-
-import Language.PureScript.Bundle
-
-import Options.Applicative (Parser, ParseError (..))
+import Language.PureScript.Bundle
+import Options.Applicative (Parser)
import qualified Options.Applicative as Opts
-
-import qualified Paths_purescript as Paths
-
-import SourceMap
-import SourceMap.Types
+import SourceMap
+import SourceMap.Types
-- | Command line options.
data Options = Options
@@ -55,10 +46,10 @@ app :: (MonadError ErrorMessage m, MonadIO m) => Options -> m (Maybe SourceMappi
app Options{..} = do
inputFiles <- concat <$> mapM (liftIO . glob) optionsInputFiles
when (null inputFiles) . liftIO $ do
- hPutStrLn stderr "psc-bundle: No input files."
+ hPutStrLn stderr "purs bundle: No input files."
exitFailure
when (isNothing optionsOutputFile && optionsSourceMaps == True) . liftIO $ do
- hPutStrLn stderr "psc-bundle: Source maps only supported when output file specified."
+ hPutStrLn stderr "purs bundle: Source maps only supported when output file specified."
exitFailure
input <- for inputFiles $ \filename -> do
@@ -117,31 +108,22 @@ options = Options <$> some inputFile
<> Opts.help "Whether to generate source maps for the bundle (requires --output)."
-- | Make it go.
-main :: IO ()
-main = do
- hSetEncoding stdout utf8
- hSetEncoding stderr utf8
- opts <- Opts.execParser (Opts.info (version <*> Opts.helper <*> options) infoModList)
- output <- runExceptT (app opts)
- case output of
- Left err -> do
- hPutStrLn stderr (unlines (printErrorMessage err))
- exitFailure
- Right (sourcemap, js) ->
- case optionsOutputFile opts of
- Just outputFile -> do
- createDirectoryIfMissing True (takeDirectory outputFile)
- case sourcemap of
- Just sm -> do
- writeUTF8File outputFile $ js ++ "\n//# sourceMappingURL=" ++ (takeFileName outputFile <.> "map") ++ "\n"
- writeUTF8File (outputFile <.> "map") $ BU8.toString . B.toStrict . encode $ generate sm
- Nothing -> writeUTF8File outputFile js
- Nothing -> putStrLn js
- where
- infoModList = Opts.fullDesc <> headerInfo <> footerInfo
- headerInfo = Opts.header "psc-bundle - Bundles compiled PureScript modules for the browser"
- footerInfo = Opts.footer $ "psc-bundle " ++ showVersion Paths.version
-
- version :: Parser (a -> a)
- version = Opts.abortOption (InfoMsg (showVersion Paths.version)) $
- Opts.long "version" <> Opts.help "Show the version number" <> Opts.hidden
+command :: Opts.Parser (IO ())
+command = run <$> (Opts.helper <*> options) where
+ run :: Options -> IO ()
+ run opts = do
+ output <- runExceptT (app opts)
+ case output of
+ Left err -> do
+ hPutStr stderr (unlines (printErrorMessage err))
+ exitFailure
+ Right (sourcemap, js) ->
+ case optionsOutputFile opts of
+ Just outputFile -> do
+ createDirectoryIfMissing True (takeDirectory outputFile)
+ case sourcemap of
+ Just sm -> do
+ writeUTF8File outputFile $ js ++ "\n//# sourceMappingURL=" ++ (takeFileName outputFile <.> "map") ++ "\n"
+ writeUTF8File (outputFile <.> "map") $ BU8.toString . B.toStrict . encode $ generate sm
+ Nothing -> writeUTF8File outputFile js
+ Nothing -> putStrLn js
diff --git a/psc/Main.hs b/app/Command/Compile.hs
index be42b3f..04c9520 100644
--- a/psc/Main.hs
+++ b/app/Command/Compile.hs
@@ -4,32 +4,27 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
-module Main where
+module Command.Compile (command) where
import Control.Applicative
import Control.Monad
import Control.Monad.Writer.Strict
-
import qualified Data.Aeson as A
import Data.Bool (bool)
import qualified Data.ByteString.Lazy as B
import qualified Data.ByteString.UTF8 as BU8
import qualified Data.Map as M
import Data.Text (Text)
-import Data.Version (showVersion)
-
import qualified Language.PureScript as P
import Language.PureScript.Errors.JSON
import Language.PureScript.Make
-
-import Options.Applicative as Opts
-
-import qualified Paths_purescript as Paths
-
+import qualified Options.Applicative as Opts
import qualified System.Console.ANSI as ANSI
import System.Exit (exitSuccess, exitFailure)
+import System.Directory (getCurrentDirectory)
+import System.FilePath (makeRelative)
import System.FilePath.Glob (glob)
-import System.IO (hSetEncoding, hPutStrLn, stdout, stderr, utf8)
+import System.IO (hPutStr, hPutStrLn, stderr)
import System.IO.UTF8 (readUTF8FileT)
data PSCMakeOptions = PSCMakeOptions
@@ -60,13 +55,16 @@ printWarningsAndErrors verbose True warnings errors = do
compile :: PSCMakeOptions -> IO ()
compile PSCMakeOptions{..} = do
+ pwd <- getCurrentDirectory
input <- globWarningOnMisses (unless pscmJSONErrors . warnFileTypeNotFound) pscmInput
when (null input && not pscmJSONErrors) $ do
- hPutStrLn stderr "psc: No input files."
+ hPutStr stderr $ unlines [ "purs compile: No input files."
+ , "Usage: For basic information, try the `--help' option."
+ ]
exitFailure
moduleFiles <- readInput input
(makeErrors, makeWarnings) <- runMake pscmOpts $ do
- ms <- P.parseModulesFromFiles id moduleFiles
+ ms <- P.parseModulesFromFiles (makeRelative pwd) moduleFiles
let filePathMap = M.fromList $ map (\(fp, P.Module _ _ mn _ _) -> (mn, Right fp)) ms
foreigns <- inferForeignModules filePathMap
let makeActions = buildMakeActions pscmOutputDir filePathMap foreigns pscmUsePrefix
@@ -75,7 +73,7 @@ compile PSCMakeOptions{..} = do
exitSuccess
warnFileTypeNotFound :: String -> IO ()
-warnFileTypeNotFound = hPutStrLn stderr . ("psc: No files found using pattern: " ++)
+warnFileTypeNotFound = hPutStrLn stderr . ("purs compile: No files found using pattern: " ++)
globWarningOnMisses :: (String -> IO ()) -> [FilePath] -> IO [FilePath]
globWarningOnMisses warn = concatMapM globWithWarning
@@ -89,94 +87,64 @@ globWarningOnMisses warn = concatMapM globWithWarning
readInput :: [FilePath] -> IO [(FilePath, Text)]
readInput inputFiles = forM inputFiles $ \inFile -> (inFile, ) <$> readUTF8FileT inFile
-inputFile :: Parser FilePath
-inputFile = strArgument $
- metavar "FILE"
- <> help "The input .purs file(s)"
+inputFile :: Opts.Parser FilePath
+inputFile = Opts.strArgument $
+ Opts.metavar "FILE"
+ <> Opts.help "The input .purs file(s)"
-outputDirectory :: Parser FilePath
-outputDirectory = strOption $
- short 'o'
- <> long "output"
+outputDirectory :: Opts.Parser FilePath
+outputDirectory = Opts.strOption $
+ Opts.short 'o'
+ <> Opts.long "output"
<> Opts.value "output"
- <> showDefault
- <> help "The output directory"
-
-noTco :: Parser Bool
-noTco = switch $
- long "no-tco"
- <> help "Disable tail call optimizations"
-
-noMagicDo :: Parser Bool
-noMagicDo = switch $
- long "no-magic-do"
- <> help "Disable the optimization that overloads the do keyword to generate efficient code specifically for the Eff monad"
-
-noOpts :: Parser Bool
-noOpts = switch $
- long "no-opts"
- <> help "Skip the optimization phase"
-
-comments :: Parser Bool
-comments = switch $
- short 'c'
- <> long "comments"
- <> help "Include comments in the generated code"
-
-verboseErrors :: Parser Bool
-verboseErrors = switch $
- short 'v'
- <> long "verbose-errors"
- <> help "Display verbose error messages"
-
-noPrefix :: Parser Bool
-noPrefix = switch $
- short 'p'
- <> long "no-prefix"
- <> help "Do not include comment header"
-
-jsonErrors :: Parser Bool
-jsonErrors = switch $
- long "json-errors"
- <> help "Print errors to stderr as JSON"
-sourceMaps :: Parser Bool
-sourceMaps = switch $
- long "source-maps"
- <> help "Generate source maps"
-
-dumpCoreFn :: Parser Bool
-dumpCoreFn = switch $
- long "dump-corefn"
- <> help "Dump the (functional) core representation of the compiled code at output/*/corefn.json"
-
-
-options :: Parser P.Options
-options = P.Options <$> noTco
- <*> noMagicDo
- <*> pure Nothing
- <*> noOpts
- <*> verboseErrors
+ <> Opts.showDefault
+ <> Opts.help "The output directory"
+
+comments :: Opts.Parser Bool
+comments = Opts.switch $
+ Opts.short 'c'
+ <> Opts.long "comments"
+ <> Opts.help "Include comments in the generated code"
+
+verboseErrors :: Opts.Parser Bool
+verboseErrors = Opts.switch $
+ Opts.short 'v'
+ <> Opts.long "verbose-errors"
+ <> Opts.help "Display verbose error messages"
+
+noPrefix :: Opts.Parser Bool
+noPrefix = Opts.switch $
+ Opts.short 'p'
+ <> Opts.long "no-prefix"
+ <> Opts.help "Do not include comment header"
+
+jsonErrors :: Opts.Parser Bool
+jsonErrors = Opts.switch $
+ Opts.long "json-errors"
+ <> Opts.help "Print errors to stderr as JSON"
+
+sourceMaps :: Opts.Parser Bool
+sourceMaps = Opts.switch $
+ Opts.long "source-maps"
+ <> Opts.help "Generate source maps"
+
+dumpCoreFn :: Opts.Parser Bool
+dumpCoreFn = Opts.switch $
+ Opts.long "dump-corefn"
+ <> Opts.help "Dump the (functional) core representation of the compiled code at output/*/corefn.json"
+
+options :: Opts.Parser P.Options
+options = P.Options <$> verboseErrors
<*> (not <$> comments)
<*> sourceMaps
<*> dumpCoreFn
-pscMakeOptions :: Parser PSCMakeOptions
+pscMakeOptions :: Opts.Parser PSCMakeOptions
pscMakeOptions = PSCMakeOptions <$> many inputFile
<*> outputDirectory
<*> options
<*> (not <$> noPrefix)
<*> jsonErrors
-main :: IO ()
-main = do
- hSetEncoding stdout utf8
- hSetEncoding stderr utf8
- execParser opts >>= compile
- where
- opts = info (version <*> helper <*> pscMakeOptions) infoModList
- infoModList = fullDesc <> headerInfo <> footerInfo
- headerInfo = header "psc - Compiles PureScript to Javascript"
- footerInfo = footer $ "psc " ++ showVersion Paths.version
-
- version :: Parser (a -> a)
- version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> help "Show the version number" <> hidden
+command :: Opts.Parser (IO ())
+command = compile <$> (Opts.helper <*> pscMakeOptions)
diff --git a/psc-docs/Main.hs b/app/Command/Docs.hs
index e6ffe6d..8e728eb 100644
--- a/psc-docs/Main.hs
+++ b/app/Command/Docs.hs
@@ -1,43 +1,43 @@
{-# LANGUAGE TupleSections #-}
-module Main where
-
-import Control.Applicative
-import Control.Monad.Trans.Except (runExceptT)
-import Control.Arrow (first, second)
-import Control.Category ((>>>))
-import Control.Monad.Writer
-import Data.Text (Text)
+module Command.Docs (command, infoModList) where
+
+import Protolude (ordNub)
+
+import Command.Docs.Etags
+import Command.Docs.Ctags
+import Command.Docs.Html
+import Control.Applicative
+import Control.Arrow (first, second)
+import Control.Category ((>>>))
+import Control.Monad.Writer
+import Control.Monad.Trans.Except (runExceptT)
+import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.IO as T
-import Data.Function (on)
-import Data.List
-import Data.Maybe (fromMaybe)
-import Data.Tuple (swap)
-import Data.Version (showVersion)
-
-import Options.Applicative
-import qualified Text.PrettyPrint.ANSI.Leijen as PP
-
+import Data.Function (on)
+import Data.List
+import Data.Maybe (fromMaybe)
+import Data.Tuple (swap)
import qualified Language.PureScript as P
-import qualified Paths_purescript as Paths
-import System.Exit (exitFailure)
-import System.IO (hPutStrLn, hPrint, hSetEncoding, stderr, stdout, utf8)
-import System.IO.UTF8 (readUTF8FileT, writeUTF8FileT)
-import System.Directory (createDirectoryIfMissing)
-import System.FilePath (takeDirectory)
-import System.FilePath.Glob (glob)
-
-import Etags
-import Ctags
import qualified Language.PureScript.Docs as D
import qualified Language.PureScript.Docs.AsMarkdown as D
-
--- Available output formats
-data Format = Markdown -- Output documentation in Markdown format
- | Ctags -- Output ctags symbol index suitable for use with vi
- | Etags -- Output etags symbol index suitable for use with emacs
- deriving (Show, Eq, Ord)
+import qualified Options.Applicative as Opts
+import qualified Text.PrettyPrint.ANSI.Leijen as PP
+import System.Directory (createDirectoryIfMissing)
+import System.Exit (exitFailure)
+import System.FilePath (takeDirectory)
+import System.FilePath.Glob (glob)
+import System.IO (hPutStrLn, hPrint, stderr)
+import System.IO.UTF8 (readUTF8FileT, writeUTF8FileT)
+
+-- | Available output formats
+data Format
+ = Markdown
+ | Html
+ | Ctags -- Output ctags symbol index suitable for use with vi
+ | Etags -- Output etags symbol index suitable for use with emacs
+ deriving (Show, Eq, Ord)
-- | Available methods of outputting Markdown documentation
data DocgenOutput
@@ -47,22 +47,31 @@ data DocgenOutput
deriving (Show)
data PSCDocsOptions = PSCDocsOptions
- { pscdFormat :: Format
- , pscdInputFiles :: [FilePath]
- , pscdDocgen :: DocgenOutput
+ { _pscdFormat :: Format
+ , _pscdInputFiles :: [FilePath]
+ , _pscdDocgen :: DocgenOutput
}
deriving (Show)
docgen :: PSCDocsOptions -> IO ()
docgen (PSCDocsOptions fmt inputGlob output) = do
input <- concat <$> mapM glob inputGlob
+ when (null input) $ do
+ hPutStrLn stderr "purs docs: no input files."
+ exitFailure
+
case fmt of
Etags -> dumpTags input dumpEtags
Ctags -> dumpTags input dumpCtags
+ Html -> do
+ let outputDir = "./generated-docs" -- TODO: make this configurable
+ ms <- parseAndConvert input
+ let msHtml = map asHtml (D.primDocsModule : ms)
+ createDirectoryIfMissing False outputDir
+ writeHtmlModules outputDir msHtml
+
Markdown -> do
- ms <- runExceptT (D.parseFilesInPackages input []
- >>= uncurry D.convertModulesInPackage)
- >>= successOrExit
+ ms <- parseAndConvert input
case output of
EverythingToStdOut ->
@@ -84,10 +93,10 @@ docgen (PSCDocsOptions fmt inputGlob output) = do
where
guardMissing [] = return ()
guardMissing [mn] = do
- hPutStrLn stderr ("psc-docs: error: unknown module \"" ++ T.unpack (P.runModuleName mn) ++ "\"")
+ hPutStrLn stderr ("purs docs: error: unknown module \"" ++ T.unpack (P.runModuleName mn) ++ "\"")
exitFailure
guardMissing mns = do
- hPutStrLn stderr "psc-docs: error: unknown modules:"
+ hPutStrLn stderr "purs docs: error: unknown modules:"
forM_ mns $ \mn ->
hPutStrLn stderr (" * " ++ T.unpack (P.runModuleName mn))
exitFailure
@@ -104,6 +113,11 @@ docgen (PSCDocsOptions fmt inputGlob output) = do
takeByName = takeModulesByName D.modName
takeByName' = takeModulesByName' D.modName
+ parseAndConvert input =
+ runExceptT (D.parseFilesInPackages input []
+ >>= uncurry D.convertModulesInPackage)
+ >>= successOrExit
+
-- |
-- 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
@@ -127,7 +141,7 @@ takeModulesByName' getModuleName modules = foldl go ([], [])
dumpTags :: [FilePath] -> ([(String, P.Module)] -> [String]) -> IO ()
dumpTags input renderTags = do
- e <- P.parseModulesFromFiles (fromMaybe "") <$> mapM (fmap (first Just) . parseFile) (nub input)
+ e <- P.parseModulesFromFiles (fromMaybe "") <$> mapM (fmap (first Just) . parseFile) (ordNub input)
case e of
Left err -> do
hPrint stderr err
@@ -145,29 +159,30 @@ dumpTags input renderTags = do
parseFile :: FilePath -> IO (FilePath, Text)
parseFile input = (,) input <$> readUTF8FileT input
-inputFile :: Parser FilePath
-inputFile = strArgument $
- metavar "FILE"
- <> help "The input .purs file(s)"
+inputFile :: Opts.Parser FilePath
+inputFile = Opts.strArgument $
+ Opts.metavar "FILE"
+ <> Opts.help "The input .purs file(s)"
instance Read Format where
readsPrec _ "etags" = [(Etags, "")]
readsPrec _ "ctags" = [(Ctags, "")]
readsPrec _ "markdown" = [(Markdown, "")]
+ readsPrec _ "html" = [(Html, "")]
readsPrec _ _ = []
-format :: Parser Format
-format = option auto $ value Markdown
- <> long "format"
- <> metavar "FORMAT"
- <> help "Set output FORMAT (markdown | etags | ctags)"
+format :: Opts.Parser Format
+format = Opts.option Opts.auto $ Opts.value Markdown
+ <> Opts.long "format"
+ <> Opts.metavar "FORMAT"
+ <> Opts.help "Set output FORMAT (markdown | html | etags | ctags)"
-docgenModule :: Parser String
-docgenModule = strOption $
- long "docgen"
- <> help "A list of module names which should appear in the output. This can optionally include file paths to write individual modules to, by separating with a colon ':'. For example, Prelude:docs/Prelude.md. This option may be specified multiple times."
+docgenModule :: Opts.Parser String
+docgenModule = Opts.strOption $
+ Opts.long "docgen"
+ <> Opts.help "A list of module names which should appear in the output. This can optionally include file paths to write individual modules to, by separating with a colon ':'. For example, Prelude:docs/Prelude.md. This option may be specified multiple times."
-pscDocsOptions :: Parser (Format, [FilePath], [String])
+pscDocsOptions :: Opts.Parser (Format, [FilePath], [String])
pscDocsOptions = (,,) <$> format <*> many inputFile <*> many docgenModule
parseDocgen :: [String] -> Either String DocgenOutput
@@ -214,40 +229,32 @@ buildOptions (fmt, input, mapping) =
case parseDocgen mapping of
Right mapping' -> return (PSCDocsOptions fmt input mapping')
Left err -> do
- hPutStrLn stderr "psc-docs: error in --docgen option:"
+ hPutStrLn stderr "purs docs: error in --docgen option:"
hPutStrLn stderr (" " ++ err)
exitFailure
-main :: IO ()
-main = do
- hSetEncoding stdout utf8
- hSetEncoding stderr utf8
- execParser opts >>= buildOptions >>= docgen
- where
- opts = info (version <*> helper <*> pscDocsOptions) infoModList
- infoModList = fullDesc <> headerInfo <> footerInfo
- headerInfo = header "psc-docs - Generate Markdown documentation from PureScript source files"
- footerInfo = footerDoc $ Just $ PP.vcat
- [ examples, PP.empty, PP.text ("psc-docs " ++ showVersion Paths.version) ]
+command :: Opts.Parser (IO ())
+command = (buildOptions >=> docgen) <$> (Opts.helper <*> pscDocsOptions)
- version :: Parser (a -> a)
- version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> help "Show the version number" <> hidden
+infoModList :: Opts.InfoMod a
+infoModList = Opts.fullDesc <> footerInfo where
+ footerInfo = Opts.footerDoc $ Just examples
examples :: PP.Doc
examples =
PP.vcat $ map PP.text
[ "Examples:"
, " print documentation for Data.List to stdout:"
- , " psc-docs \"src/**/*.purs\" \".psc-package/*/*/*/src/**/*.purs\" \\"
+ , " purs docs \"src/**/*.purs\" \".psc-package/*/*/*/src/**/*.purs\" \\"
, " --docgen Data.List"
, ""
, " write documentation for Data.List to docs/Data.List.md:"
- , " psc-docs \"src/**/*.purs\" \".psc-package/*/*/*/src/**/*.purs\" \\"
+ , " purs docs \"src/**/*.purs\" \".psc-package/*/*/*/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\" \".psc-package/*/*/*/src/**/*.purs\" \\"
+ , " purs docs \"src/**/*.purs\" \".psc-package/*/*/*/src/**/*.purs\" \\"
, " --docgen Data.List:docs/Data.List.md \\"
, " --docgen Data.List.Lazy:docs/Data.List.Lazy.md"
]
diff --git a/psc-docs/Ctags.hs b/app/Command/Docs/Ctags.hs
index d5018ea..9cfd714 100644
--- a/psc-docs/Ctags.hs
+++ b/app/Command/Docs/Ctags.hs
@@ -1,8 +1,8 @@
-module Ctags (dumpCtags) where
+module Command.Docs.Ctags (dumpCtags) where
+import Command.Docs.Tags
+import Data.List (sort)
import qualified Language.PureScript as P
-import Tags
-import Data.List (sort)
dumpCtags :: [(String, P.Module)] -> [String]
dumpCtags = sort . concatMap renderModCtags
diff --git a/psc-docs/Etags.hs b/app/Command/Docs/Etags.hs
index 5aec45d..c6e4319 100644
--- a/psc-docs/Etags.hs
+++ b/app/Command/Docs/Etags.hs
@@ -1,7 +1,7 @@
-module Etags (dumpEtags) where
+module Command.Docs.Etags (dumpEtags) where
+import Command.Docs.Tags
import qualified Language.PureScript as P
-import Tags
dumpEtags :: [(String, P.Module)] -> [String]
dumpEtags = concatMap renderModEtags
diff --git a/app/Command/Docs/Html.hs b/app/Command/Docs/Html.hs
new file mode 100644
index 0000000..507917e
--- /dev/null
+++ b/app/Command/Docs/Html.hs
@@ -0,0 +1,181 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Command.Docs.Html
+ ( asHtml
+ , layout
+ , writeHtmlModule
+ , writeHtmlModules
+ ) where
+
+import Control.Applicative
+import Control.Arrow ((&&&))
+import Control.Monad.Writer
+import Data.List (sort)
+import Data.Text (Text)
+import Data.Text.Lazy (toStrict)
+import qualified Data.Text as T
+import Data.FileEmbed (embedStringFile)
+import qualified Language.PureScript as P
+import qualified Language.PureScript.Docs as D
+import qualified Language.PureScript.Docs.AsHtml as D
+import Text.Blaze.Html5 (Html, (!), toMarkup)
+import qualified Text.Blaze.Html5 as H
+import qualified Text.Blaze.Html5.Attributes as A
+import qualified Text.Blaze.Html.Renderer.Text as Blaze
+import System.IO.UTF8 (writeUTF8FileT)
+import System.FilePath.Glob (glob)
+import System.Directory (removeFile)
+import Version (versionString)
+
+writeHtmlModules :: FilePath -> [(P.ModuleName, D.HtmlOutputModule Html)] -> IO ()
+writeHtmlModules outputDir modules = do
+ glob (outputDir <> "/*.html") >>= mapM_ removeFile
+ let moduleList = sort $ map fst modules
+ writeHtmlFile (outputDir ++ "/index.html") (renderIndexModule moduleList)
+ mapM_ (writeHtmlModule outputDir . (fst &&& layout moduleList)) modules
+
+asHtml :: D.Module -> (P.ModuleName, D.HtmlOutputModule Html)
+asHtml m = D.moduleAsHtml (getHtmlRenderContext (D.modName m)) m
+
+writeHtmlModule :: FilePath -> (P.ModuleName, Html) -> IO ()
+writeHtmlModule outputDir (mn, html) = do
+ let filepath = outputDir ++ "/" ++ T.unpack (P.runModuleName mn) ++ ".html"
+ writeHtmlFile filepath html
+
+writeHtmlFile :: FilePath -> Html -> IO ()
+writeHtmlFile filepath =
+ writeUTF8FileT filepath . toStrict . Blaze.renderHtml
+
+getHtmlRenderContext :: P.ModuleName -> D.HtmlRenderContext
+getHtmlRenderContext mn = D.HtmlRenderContext
+ { D.currentModuleName = mn
+ , D.buildDocLink = getLink mn
+ , D.renderDocLink = renderLink
+ , D.renderSourceLink = const Nothing
+ }
+
+-- TODO: try to combine this with the one in Docs.Types?
+getLink :: P.ModuleName -> D.Namespace -> Text -> D.ContainingModule -> Maybe D.DocLink
+getLink curMn namespace target containingMod = do
+ location <- getLinkLocation
+ return D.DocLink
+ { D.linkLocation = location
+ , D.linkTitle = target
+ , D.linkNamespace = namespace
+ }
+
+ where
+ getLinkLocation = builtinLinkLocation <|> normalLinkLocation
+
+ normalLinkLocation = do
+ case containingMod of
+ D.ThisModule ->
+ return D.SameModule
+ D.OtherModule destMn ->
+ -- This is OK because all modules count as 'local' for purs docs in
+ -- html mode
+ return $ D.LocalModule curMn destMn
+
+ builtinLinkLocation = do
+ let primMn = P.moduleNameFromString "Prim"
+ guard $ containingMod == D.OtherModule primMn
+ return $ D.BuiltinModule primMn
+
+renderLink :: D.DocLink -> Text
+renderLink l =
+ case D.linkLocation l of
+ D.SameModule ->
+ ""
+ D.LocalModule _ dest ->
+ P.runModuleName dest <> ".html"
+ D.DepsModule{} ->
+ P.internalError "DepsModule: not implemented"
+ D.BuiltinModule dest ->
+ P.runModuleName dest <> ".html"
+
+layout :: [P.ModuleName] -> (P.ModuleName, D.HtmlOutputModule Html) -> Html
+layout moduleList (mn, htmlDocs) =
+ basicLayout ("PureScript: " <> modName) $ do
+ H.div ! A.class_ "page-title clearfix" $ do
+ H.div ! A.class_ "page-title__label" $ "Module"
+ H.h1 ! A.class_ "page-title__title" $ toMarkup modName
+
+ H.div ! A.class_ "col col--main" $ do
+ D.htmlOutputModuleLocals htmlDocs
+ mapM_ renderReExports (D.htmlOutputModuleReExports htmlDocs)
+
+ H.div ! A.class_ "col col--aside" $ do
+ H.h3 "Modules"
+ renderModuleList moduleList
+ where
+ modName = P.runModuleName mn
+
+ renderReExports :: (D.InPackage P.ModuleName, Html) -> Html
+ renderReExports (reExpFrom, html) = do
+ H.h2 ! A.class_ "re-exports" $ do
+ toMarkup ("Re-exports from " :: Text)
+ H.a ! A.href (H.toValue (toText reExpFrom <> ".html")) $
+ toMarkup (toText reExpFrom)
+ html
+
+ toText = P.runModuleName . D.ignorePackage
+
+basicLayout :: Text -> Html -> Html
+basicLayout title inner =
+ H.docTypeHtml $ do
+ H.head $ do
+ H.meta ! A.charset "utf-8"
+ H.meta ! A.httpEquiv "X-UA-Compatible" ! A.content "IE=edge"
+ H.meta ! A.name "viewport" ! A.content "width=device-width, initial-scale=1"
+ H.title (toMarkup title)
+
+ H.link ! A.href "https://fonts.googleapis.com/css?family=Roboto+Mono|Roboto:300,400,400i,700,700i"
+ ! A.type_ "text/css" ! A.rel "stylesheet"
+ H.style ! A.type_ "text/css" $
+ toMarkup normalize_css
+ H.style ! A.type_ "text/css" $
+ toMarkup pursuit_css
+ H.body $ do
+ H.div ! A.class_ "everything-except-footer" $ do
+ H.div ! A.class_ "top-banner clearfix" $ do
+ H.div ! A.class_ "container clearfix" $ do
+ H.div ! A.style inlineHeaderStyles $ do
+ "PureScript API documentation"
+
+ H.div ! A.class_ "top-banner__actions" $ do
+ H.div ! A.class_ "top-banner__actions__item" $ do
+ H.a ! A.href "index.html" $ "Index"
+
+ H.main ! A.class_ "container clearfix" ! H.customAttribute "role" "main" $ do
+ inner
+
+ H.div ! A.class_ "footer clearfix" $
+ H.p $ toMarkup $ "Generated by purs " <> versionString
+
+ where
+ -- Like Pursuit's .top-banner__logo except without the 'hover' styles
+ inlineHeaderStyles = "float: left; font-size: 2.44em; font-weight: 300; line-height: 90px; margin: 0"
+
+renderIndexModule :: [P.ModuleName] -> Html
+renderIndexModule moduleList =
+ basicLayout "PureScript API documentation" $ do
+ H.div ! A.class_ "page-title clearfix" $ do
+ H.h1 ! A.class_ "page-title__title" $ "Index"
+ H.div ! A.class_ "col col--main" $ do
+ renderModuleList moduleList
+
+renderModuleList :: [P.ModuleName] -> Html
+renderModuleList moduleList =
+ H.ul $ mapM_ listItem moduleList
+
+ where
+ listItem mn = H.li $
+ H.a ! A.href (H.toValue (P.runModuleName mn <> ".html")) $
+ toMarkup (P.runModuleName mn)
+
+normalize_css :: Text
+normalize_css = $(embedStringFile "app/static/normalize.css")
+
+pursuit_css :: Text
+pursuit_css = $(embedStringFile "app/static/pursuit.css")
diff --git a/psc-docs/Tags.hs b/app/Command/Docs/Tags.hs
index 5bee382..6f15169 100644
--- a/psc-docs/Tags.hs
+++ b/app/Command/Docs/Tags.hs
@@ -1,6 +1,6 @@
-module Tags where
+module Command.Docs.Tags where
-import Control.Arrow (first)
+import Control.Arrow (first)
import qualified Data.Text as T
import qualified Language.PureScript as P
diff --git a/hierarchy/Main.hs b/app/Command/Hierarchy.hs
index 8700870..90f3226 100644
--- a/hierarchy/Main.hs
+++ b/app/Command/Hierarchy.hs
@@ -16,35 +16,32 @@
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE DataKinds #-}
-module Main where
+module Command.Hierarchy (command) where
-import Control.Applicative (optional)
-import Control.Monad (unless)
+import Protolude (ordNub)
-import Data.List (intercalate,nub,sort)
-import Data.Foldable (for_)
-import Data.Version (showVersion)
-import Data.Monoid ((<>))
+import Control.Applicative (optional)
+import Control.Monad (unless)
+import Data.List (intercalate, sort)
+import Data.Foldable (for_)
+import Data.Monoid ((<>))
import qualified Data.Text as T
-
-import Options.Applicative (Parser)
+import Options.Applicative (Parser)
import qualified Options.Applicative as Opts
-import System.Directory (createDirectoryIfMissing)
-import System.FilePath ((</>))
-import System.FilePath.Glob (glob)
-import System.Exit (exitFailure, exitSuccess)
-import System.IO (hPutStr, stderr)
-import System.IO.UTF8 (readUTF8FileT)
-
+import System.Directory (createDirectoryIfMissing)
+import System.FilePath ((</>))
+import System.FilePath.Glob (glob)
+import System.Exit (exitFailure, exitSuccess)
+import System.IO (hPutStr, stderr)
+import System.IO.UTF8 (readUTF8FileT)
import qualified Language.PureScript as P
-import qualified Paths_purescript as Paths
data HierarchyOptions = HierarchyOptions
- { hierachyInput :: FilePath
- , hierarchyOutput :: Maybe FilePath
+ { _hierachyInput :: FilePath
+ , _hierarchyOutput :: Maybe FilePath
}
-newtype SuperMap = SuperMap { unSuperMap :: Either (P.ProperName 'P.ClassName) (P.ProperName 'P.ClassName, P.ProperName 'P.ClassName) }
+newtype SuperMap = SuperMap { _unSuperMap :: Either (P.ProperName 'P.ClassName) (P.ProperName 'P.ClassName, P.ProperName 'P.ClassName) }
deriving Eq
instance Show SuperMap where
@@ -74,7 +71,7 @@ compile (HierarchyOptions inputGlob mOutput) = do
for_ ms $ \(P.Module _ _ moduleName decls _) ->
let name = runModuleName moduleName
tcs = filter P.isTypeClassDeclaration decls
- supers = sort . nub . filter (not . null) $ fmap superClasses tcs
+ supers = sort . ordNub . filter (not . null) $ fmap superClasses tcs
prologue = "digraph " ++ name ++ " {\n"
body = intercalate "\n" (concatMap (fmap (\s -> " " ++ show s ++ ";")) supers)
epilogue = "\n}"
@@ -110,10 +107,5 @@ pscOptions :: Parser HierarchyOptions
pscOptions = HierarchyOptions <$> inputFile
<*> outputFile
-main :: IO ()
-main = Opts.execParser opts >>= compile
- where
- opts = Opts.info (Opts.helper <*> pscOptions) infoModList
- infoModList = Opts.fullDesc <> headerInfo <> footerInfo
- headerInfo = Opts.header "hierarchy - Creates a GraphViz directed graph of PureScript TypeClasses"
- footerInfo = Opts.footer $ "hierarchy " ++ showVersion Paths.version
+command :: Opts.Parser (IO ())
+command = compile <$> (Opts.helper <*> pscOptions)
diff --git a/psc-ide-server/Main.hs b/app/Command/Ide.hs
index 8b214c8..b7d45cc 100644
--- a/psc-ide-server/Main.hs
+++ b/app/Command/Ide.hs
@@ -16,10 +16,11 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
+{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE NoImplicitPrelude #-}
-module Main where
+module Command.Ide (command) where
import Protolude
@@ -27,8 +28,8 @@ import qualified Data.Aeson as Aeson
import Control.Concurrent.STM
import "monad-logger" Control.Monad.Logger
import qualified Data.Text.IO as T
-import qualified Data.ByteString.Lazy.Char8 as BS8
-import Data.Version (showVersion)
+import qualified Data.ByteString.Char8 as BS8
+import qualified Data.ByteString.Lazy.Char8 as BSL8
import GHC.IO.Exception (IOErrorType(..), IOException(..))
import Language.PureScript.Ide
import Language.PureScript.Ide.Command
@@ -40,14 +41,12 @@ import Network hiding (socketPort, accept)
import Network.BSD (getProtocolNumber)
import Network.Socket hiding (PortNumber, Type,
sClose)
-import Options.Applicative (ParseError (..))
import qualified Options.Applicative as Opts
import System.Directory
import System.Info as SysInfo
import System.FilePath
import System.IO hiding (putStrLn, print)
import System.IO.Error (isEOFError)
-import qualified Paths_purescript as Paths
listenOnLocalhost :: PortNumber -> IO Socket
listenOnLocalhost port = do
@@ -62,67 +61,94 @@ listenOnLocalhost port = do
listen sock maxListenQueue
pure sock)
-data Options = Options
- { optionsDirectory :: Maybe FilePath
- , optionsGlobs :: [FilePath]
- , optionsOutputPath :: FilePath
- , optionsPort :: PortNumber
- , optionsNoWatch :: Bool
- , optionsPolling :: Bool
- , optionsDebug :: Bool
- , optionsLoglevel :: IdeLogLevel
+data ServerOptions = ServerOptions
+ { _serverDirectory :: Maybe FilePath
+ , _serverGlobs :: [FilePath]
+ , _serverOutputPath :: FilePath
+ , _serverPort :: PortNumber
+ , _serverNoWatch :: Bool
+ , _serverPolling :: Bool
+ , _serverLoglevel :: IdeLogLevel
} deriving (Show)
-main :: IO ()
-main = do
- opts'@(Options dir globs outputPath port noWatch polling debug logLevel) <- Opts.execParser opts
- when debug (putText "Parsed Options:" *> print opts')
- maybe (pure ()) setCurrentDirectory dir
- ideState <- newTVarIO emptyIdeState
- cwd <- getCurrentDirectory
- let fullOutputPath = cwd </> outputPath
-
- unlessM (doesDirectoryExist fullOutputPath) $ do
- putStrLn ("Your output directory didn't exist. I'll create it at: " <> fullOutputPath)
- createDirectory fullOutputPath
- putText "This usually means you didn't compile your project yet."
- putText "psc-ide needs you to compile your project (for example by running pulp build)"
-
- unless noWatch $
- void (forkFinally (watcher polling ideState fullOutputPath) print)
- -- TODO: deprecate and get rid of `debug`
- let conf = Configuration {confLogLevel = if debug then LogDebug else logLevel, confOutputPath = outputPath, confGlobs = globs}
- env = IdeEnvironment {ideStateVar = ideState, ideConfiguration = conf}
- startServer port env
- where
- parser =
- Options
- <$> optional (Opts.strOption (Opts.long "directory" `mappend` Opts.short 'd'))
- <*> many (Opts.argument Opts.str (Opts.metavar "Source GLOBS..."))
- <*> Opts.strOption (Opts.long "output-directory" `mappend` Opts.value "output/")
- <*> (fromIntegral <$>
- Opts.option Opts.auto (Opts.long "port" `mappend` Opts.short 'p' `mappend` Opts.value (4242 :: Integer)))
- <*> Opts.switch (Opts.long "no-watch")
- <*> flipIfWindows (Opts.switch (Opts.long "polling"))
- <*> Opts.switch (Opts.long "debug")
- <*> (parseLogLevel <$> Opts.strOption
- (Opts.long "log-level"
- `mappend` Opts.value ""
- `mappend` Opts.help "One of \"debug\", \"perf\", \"all\" or \"none\""))
- opts = Opts.info (version <*> Opts.helper <*> parser) mempty
- parseLogLevel s = case s of
- "debug" -> LogDebug
- "perf" -> LogPerf
- "all" -> LogAll
- "none" -> LogNone
- _ -> LogDefault
- version = Opts.abortOption
- (InfoMsg (showVersion Paths.version))
- (Opts.long "version" `mappend` Opts.help "Show the version number")
-
- -- polling is the default on Windows and the flag turns it off. See
- -- #2209 and #2414 for explanations
- flipIfWindows = map (if SysInfo.os == "mingw32" then not else identity)
+data ClientOptions = ClientOptions
+ { clientPort :: PortID
+ }
+
+command :: Opts.Parser (IO ())
+command = Opts.helper <*> subcommands where
+ subcommands :: Opts.Parser (IO ())
+ subcommands = (Opts.subparser . fold)
+ [ Opts.command "server"
+ (Opts.info (fmap server serverOptions)
+ (Opts.progDesc "Start a server process"))
+ , Opts.command "client"
+ (Opts.info (fmap client clientOptions)
+ (Opts.progDesc "Connect to a running server"))
+ ]
+
+ client :: ClientOptions -> IO ()
+ client ClientOptions{..} = do
+ hSetEncoding stdin utf8
+ hSetEncoding stdout utf8
+ let handler (SomeException e) = do
+ T.putStrLn ("Couldn't connect to purs ide server on port " <> show clientPort <> ":")
+ print e
+ exitFailure
+ h <- connectTo "127.0.0.1" clientPort `catch` handler
+ T.hPutStrLn h =<< T.getLine
+ BS8.putStrLn =<< BS8.hGetLine h
+ hFlush stdout
+ hClose h
+
+ clientOptions :: Opts.Parser ClientOptions
+ clientOptions = ClientOptions . PortNumber . fromIntegral <$>
+ Opts.option Opts.auto (Opts.long "port" <> Opts.short 'p' <> Opts.value (4242 :: Integer))
+
+ server :: ServerOptions -> IO ()
+ server opts'@(ServerOptions dir globs outputPath port noWatch polling logLevel) = do
+ when (logLevel == LogDebug || logLevel == LogAll)
+ (putText "Parsed Options:" *> print opts')
+ maybe (pure ()) setCurrentDirectory dir
+ ideState <- newTVarIO emptyIdeState
+ cwd <- getCurrentDirectory
+ let fullOutputPath = cwd </> outputPath
+
+ unlessM (doesDirectoryExist fullOutputPath) $ do
+ putText "Your output directory didn't exist. This usually means you didn't compile your project yet."
+ putText "psc-ide needs you to compile your project (for example by running pulp build)"
+
+ unless noWatch $
+ void (forkFinally (watcher polling ideState fullOutputPath) print)
+ let conf = Configuration {confLogLevel = logLevel, confOutputPath = outputPath, confGlobs = globs}
+ env = IdeEnvironment {ideStateVar = ideState, ideConfiguration = conf}
+ startServer port env
+
+ serverOptions :: Opts.Parser ServerOptions
+ serverOptions =
+ ServerOptions
+ <$> optional (Opts.strOption (Opts.long "directory" `mappend` Opts.short 'd'))
+ <*> many (Opts.argument Opts.str (Opts.metavar "Source GLOBS..."))
+ <*> Opts.strOption (Opts.long "output-directory" `mappend` Opts.value "output/")
+ <*> (fromIntegral <$>
+ Opts.option Opts.auto (Opts.long "port" `mappend` Opts.short 'p' `mappend` Opts.value (4242 :: Integer)))
+ <*> Opts.switch (Opts.long "no-watch")
+ <*> flipIfWindows (Opts.switch (Opts.long "polling"))
+ <*> (parseLogLevel <$> Opts.strOption
+ (Opts.long "log-level"
+ `mappend` Opts.value ""
+ `mappend` Opts.help "One of \"debug\", \"perf\", \"all\" or \"none\""))
+
+ parseLogLevel s = case s of
+ "debug" -> LogDebug
+ "perf" -> LogPerf
+ "all" -> LogAll
+ "none" -> LogNone
+ _ -> LogDefault
+
+ -- polling is the default on Windows and the flag turns it off. See
+ -- #2209 and #2414 for explanations
+ flipIfWindows = map (if SysInfo.os == "mingw32" then not else identity)
startServer :: PortNumber -> IdeEnvironment -> IO ()
startServer port env = withSocketsDo $ do
@@ -145,8 +171,8 @@ startServer port env = withSocketsDo $ do
-- $(logDebug) ("Answer was: " <> T.pack (show result))
liftIO (hFlush stdout)
case result of
- Right r -> liftIO $ catchGoneHandle (BS8.hPutStrLn h (Aeson.encode r))
- Left err -> liftIO $ catchGoneHandle (BS8.hPutStrLn h (Aeson.encode err))
+ Right r -> liftIO $ catchGoneHandle (BSL8.hPutStrLn h (Aeson.encode r))
+ Left err -> liftIO $ catchGoneHandle (BSL8.hPutStrLn h (Aeson.encode err))
Nothing -> do
$(logError) ("Parsing the command failed. Command: " <> cmd)
liftIO $ do
diff --git a/app/Command/Publish.hs b/app/Command/Publish.hs
new file mode 100644
index 0000000..0440bae
--- /dev/null
+++ b/app/Command/Publish.hs
@@ -0,0 +1,52 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Command.Publish (command) where
+
+import Control.Monad.IO.Class (liftIO)
+import qualified Data.Aeson as A
+import qualified Data.ByteString.Lazy.Char8 as BL
+import Data.Monoid ((<>))
+import Data.Time.Clock (getCurrentTime)
+import Data.Version (Version(..))
+import Language.PureScript.Publish
+import Language.PureScript.Publish.ErrorsWarnings
+import Options.Applicative (Parser)
+import qualified Options.Applicative as Opts
+
+manifestPath :: Parser FilePath
+manifestPath = Opts.strOption $
+ Opts.long "manifest"
+ <> Opts.metavar "FILE"
+ <> Opts.help "The package manifest file"
+
+resolutionsPath :: Parser FilePath
+resolutionsPath = Opts.strOption $
+ Opts.long "resolutions"
+ <> Opts.metavar "FILE"
+ <> Opts.help "The resolutions file"
+
+dryRun :: Parser Bool
+dryRun = Opts.switch $
+ Opts.long "dry-run"
+ <> Opts.help "Produce no output, and don't require a tagged version to be checked out."
+
+dryRunOptions :: PublishOptions
+dryRunOptions = defaultPublishOptions
+ { publishGetVersion = return dummyVersion
+ , publishWorkingTreeDirty = warn DirtyWorkingTree_Warn
+ , publishGetTagTime = const (liftIO getCurrentTime)
+ }
+ where dummyVersion = ("0.0.0", Version [0,0,0] [])
+
+command :: Opts.Parser (IO ())
+command = publish <$> manifestPath <*> resolutionsPath <*> (Opts.helper <*> dryRun)
+
+publish :: FilePath -> FilePath -> Bool -> IO ()
+publish manifestFile resolutionsFile isDryRun =
+ if isDryRun
+ then do
+ _ <- unsafePreparePackage manifestFile resolutionsFile dryRunOptions
+ putStrLn "Dry run completed, no errors."
+ else do
+ pkg <- unsafePreparePackage manifestFile resolutionsFile defaultPublishOptions
+ BL.putStrLn (A.encode pkg)
diff --git a/psci/Main.hs b/app/Command/REPL.hs
index 1a8bec8..8698607 100644
--- a/psci/Main.hs
+++ b/app/Command/REPL.hs
@@ -10,18 +10,10 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
-module Main (main) where
+module Command.REPL (command) where
import Prelude ()
import Prelude.Compat
-
-import Data.FileEmbed (embedStringFile)
-import Data.Monoid ((<>))
-import Data.String (IsString(..))
-import Data.Text (Text, unpack)
-import Data.Traversable (for)
-import Data.Version (showVersion)
-
import Control.Applicative (many, (<|>))
import Control.Concurrent (forkIO)
import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar,
@@ -37,11 +29,15 @@ import Control.Monad.Trans.Class
import Control.Monad.Trans.Except (ExceptT(..), runExceptT)
import Control.Monad.Trans.State.Strict (StateT, evalStateT)
import Control.Monad.Trans.Reader (ReaderT, runReaderT)
-
+import Data.FileEmbed (embedStringFile)
+import Data.Foldable (for_)
+import Data.Monoid ((<>))
+import Data.String (IsString(..))
+import Data.Text (Text, unpack)
+import Data.Traversable (for)
import qualified Language.PureScript as P
import qualified Language.PureScript.Bundle as Bundle
import Language.PureScript.Interactive
-
import Network.HTTP.Types.Header (hContentType, hCacheControl,
hPragma, hExpires)
import Network.HTTP.Types.Status (status200, status404, status503)
@@ -49,14 +45,11 @@ import qualified Network.Wai as Wai
import qualified Network.Wai.Handler.Warp as Warp
import qualified Network.Wai.Handler.WebSockets as WS
import qualified Network.WebSockets as WS
-
import qualified Options.Applicative as Opts
-
-import qualified Paths_purescript as Paths
-
import System.Console.Haskeline
import System.IO.UTF8 (readUTF8File)
import System.Exit
+import System.Directory (doesFileExist, getCurrentDirectory)
import System.FilePath ((</>))
import System.FilePath.Glob (glob)
import System.Process (readProcessWithExitCode)
@@ -102,20 +95,6 @@ psciOptions :: Opts.Parser PSCiOptions
psciOptions = PSCiOptions <$> many inputFile
<*> backend
-version :: Opts.Parser (a -> a)
-version = Opts.abortOption (Opts.InfoMsg (showVersion Paths.version)) $
- Opts.long "version" <>
- Opts.help "Show the version number" <>
- Opts.hidden
-
-getOpt :: IO PSCiOptions
-getOpt = Opts.execParser opts
- where
- opts = Opts.info (version <*> Opts.helper <*> psciOptions) infoModList
- infoModList = Opts.fullDesc <> headerInfo <> footerInfo
- headerInfo = Opts.header "psci - Interactive mode for PureScript"
- footerInfo = Opts.footer $ "psci " ++ showVersion Paths.version
-
-- | Parses the input and returns either a command, or an error as a 'String'.
getCommand :: forall m. MonadException m => InputT m (Either String (Maybe Command))
getCommand = handleInterrupt (return (Right Nothing)) $ do
@@ -143,10 +122,10 @@ bundle = runExceptT $ do
Bundle.bundle input [] Nothing "PSCI"
indexJS :: IsString string => string
-indexJS = $(embedStringFile "psci/static/index.js")
+indexJS = $(embedStringFile "app/static/index.js")
indexPage :: IsString string => string
-indexPage = $(embedStringFile "psci/static/index.html")
+indexPage = $(embedStringFile "app/static/index.html")
-- | All of the functions required to implement a PSCi backend
data Backend = forall state. Backend
@@ -164,8 +143,8 @@ data Backend = forall state. Backend
data BrowserCommand
= Eval (MVar String)
-- ^ Evaluate the latest JS
- | Reload
- -- ^ Reload the page
+ | Refresh
+ -- ^ Refresh the page
-- | State for the browser backend
data BrowserState = BrowserState
@@ -208,7 +187,7 @@ browserBackend serverPort = Backend setup evaluate reload shutdown
-- With many connected clients, all but one of
-- these attempts will fail.
tryPutMVar resultVar (unpack result)
- Reload ->
+ Refresh ->
WS.sendTextData conn ("reload" :: Text)
shutdownHandler :: IO () -> IO ()
@@ -273,7 +252,7 @@ browserBackend serverPort = Backend setup evaluate reload shutdown
createBundle :: BrowserState -> IO ()
createBundle state = do
- putStrLn "Bundling Javascript..."
+ putStrLn "Bundling JavaScript..."
ejs <- bundle
case ejs of
Left err -> do
@@ -285,7 +264,7 @@ browserBackend serverPort = Backend setup evaluate reload shutdown
reload :: BrowserState -> IO ()
reload state = do
createBundle state
- atomically $ writeTChan (browserCommands state) Reload
+ atomically $ writeTChan (browserCommands state) Refresh
shutdown :: BrowserState -> IO ()
shutdown state = putMVar (browserShutdownNotice state) ()
@@ -321,17 +300,23 @@ nodeBackend nodePath nodeArgs = Backend setup eval reload shutdown
shutdown :: () -> IO ()
shutdown _ = return ()
+options :: Opts.Parser PSCiOptions
+options = Opts.helper <*> psciOptions
+
-- | Get command line options and drop into the REPL
-main :: IO ()
-main = getOpt >>= loop
+command :: Opts.Parser (IO ())
+command = loop <$> options
where
loop :: PSCiOptions -> IO ()
loop PSCiOptions{..} = do
inputFiles <- concat <$> traverse glob psciInputFile
e <- runExceptT $ do
modules <- ExceptT (loadAllModules inputFiles)
+ when (null modules) . liftIO $ do
+ putStr noInputMessage
+ exitFailure
unless (supportModuleIsDefined (map snd modules)) . liftIO $ do
- putStrLn supportModuleMessage
+ putStr supportModuleMessage
exitFailure
(externs, env) <- ExceptT . runMake . make $ modules
return (modules, externs, env)
@@ -348,6 +333,9 @@ main = getOpt >>= loop
. flip evalStateT initialState
. runInputT (setComplete completion settings)
+ handleCommand' :: state -> Command -> StateT PSCiState (ReaderT PSCiConfig IO) ()
+ handleCommand' state = handleCommand (liftIO . eval state) (liftIO (reload state))
+
go :: state -> InputT (StateT PSCiState (ReaderT PSCiConfig IO)) ()
go state = do
c <- getCommand
@@ -364,14 +352,28 @@ main = getOpt >>= loop
liftIO $ shutdown state
Right (Just c') -> handleCommandWithInterrupts state c'
+ loadUserConfig :: state -> StateT PSCiState (ReaderT PSCiConfig IO) ()
+ loadUserConfig state = do
+ configFile <- (</> ".purs-repl") <$> liftIO getCurrentDirectory
+ exists <- liftIO $ doesFileExist configFile
+ when exists $ do
+ ls <- lines <$> liftIO (readUTF8File configFile)
+ for_ ls $ \l -> do
+ liftIO (putStrLn l)
+ case parseCommand l of
+ Left err -> liftIO (putStrLn err >> exitFailure)
+ Right cmd@Import{} -> handleCommand' state cmd
+ Right _ -> liftIO (putStrLn "The .purs-repl file only supports import declarations")
+
handleCommandWithInterrupts
:: state
-> Command
-> InputT (StateT PSCiState (ReaderT PSCiConfig IO)) ()
handleCommandWithInterrupts state cmd = do
handleInterrupt (outputStrLn "Interrupted.")
- (withInterrupt (lift (handleCommand (liftIO . eval state) (liftIO (reload state)) cmd)))
+ (withInterrupt (lift (handleCommand' state cmd)))
go state
putStrLn prologueMessage
- setup >>= runner . go
+ backendState <- setup
+ runner (lift (loadUserConfig backendState) >> go backendState)
diff --git a/app/Main.hs b/app/Main.hs
new file mode 100644
index 0000000..6e4b60d
--- /dev/null
+++ b/app/Main.hs
@@ -0,0 +1,64 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TupleSections #-}
+
+module Main where
+
+import qualified Command.Bundle as Bundle
+import qualified Command.Compile as Compile
+import qualified Command.Docs as Docs
+import qualified Command.Hierarchy as Hierarchy
+import qualified Command.Ide as Ide
+import qualified Command.Publish as Publish
+import qualified Command.REPL as REPL
+import Data.Foldable (fold)
+import Data.Monoid ((<>))
+import qualified Options.Applicative as Opts
+import qualified System.IO as IO
+import Version (versionString)
+
+
+main :: IO ()
+main = do
+ IO.hSetEncoding IO.stdout IO.utf8
+ IO.hSetEncoding IO.stderr IO.utf8
+ cmd <- Opts.execParser opts
+ cmd
+ where
+ opts = Opts.info (versionInfo <*> Opts.helper <*> commands) infoModList
+ infoModList = Opts.fullDesc <> headerInfo <> footerInfo
+ headerInfo = Opts.progDesc "The PureScript compiler and tools"
+ footerInfo = Opts.footer $ "purs " ++ versionString
+
+ versionInfo :: Opts.Parser (a -> a)
+ versionInfo = Opts.abortOption (Opts.InfoMsg versionString) $
+ Opts.long "version" <> Opts.help "Show the version number" <> Opts.hidden
+
+ commands :: Opts.Parser (IO ())
+ commands =
+ (Opts.subparser . fold)
+ [ Opts.command "bundle"
+ (Opts.info Bundle.command
+ (Opts.progDesc "Bundle compiled PureScript modules for the browser"))
+ , Opts.command "compile"
+ (Opts.info Compile.command
+ (Opts.progDesc "Compile PureScript source files"))
+ , Opts.command "docs"
+ (Opts.info Docs.command
+ (Opts.progDesc "Generate Markdown documentation from PureScript source files" <> Docs.infoModList))
+ , Opts.command "hierarchy"
+ (Opts.info Hierarchy.command
+ (Opts.progDesc "Generate a GraphViz directed graph of PureScript type classes"))
+ , Opts.command "ide"
+ (Opts.info Ide.command
+ (Opts.progDesc "Start or query an IDE server process"))
+ , Opts.command "publish"
+ (Opts.info Publish.command
+ (Opts.progDesc "Generates documentation packages for upload to Pursuit"))
+ , Opts.command "repl"
+ (Opts.info REPL.command
+ (Opts.progDesc "Enter the interactive mode (PSCi)"))
+ ]
diff --git a/app/Version.hs b/app/Version.hs
new file mode 100644
index 0000000..dcf3850
--- /dev/null
+++ b/app/Version.hs
@@ -0,0 +1,23 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Version where
+
+import Data.Version (showVersion)
+import Paths_purescript as Paths
+
+#ifndef RELEASE
+import qualified Development.GitRev as GitRev
+#endif
+
+versionString :: String
+versionString = showVersion Paths.version ++ extra
+ where
+#ifdef RELEASE
+ extra = ""
+#else
+ extra = " [development build; commit: " ++ $(GitRev.gitHash) ++ dirty ++ "]"
+ dirty
+ | $(GitRev.gitDirty) = " DIRTY"
+ | otherwise = ""
+#endif
diff --git a/psci/static/index.html b/app/static/index.html
index f749b8a..f749b8a 100644
--- a/psci/static/index.html
+++ b/app/static/index.html
diff --git a/psci/static/index.js b/app/static/index.js
index e6ea3ea..e6ea3ea 100644
--- a/psci/static/index.js
+++ b/app/static/index.js
diff --git a/app/static/normalize.css b/app/static/normalize.css
new file mode 100644
index 0000000..458eea1
--- /dev/null
+++ b/app/static/normalize.css
@@ -0,0 +1,427 @@
+/*! normalize.css v3.0.2 | MIT License | git.io/normalize */
+
+/**
+ * 1. Set default font family to sans-serif.
+ * 2. Prevent iOS text size adjust after orientation change, without disabling
+ * user zoom.
+ */
+
+html {
+ font-family: sans-serif; /* 1 */
+ -ms-text-size-adjust: 100%; /* 2 */
+ -webkit-text-size-adjust: 100%; /* 2 */
+}
+
+/**
+ * Remove default margin.
+ */
+
+body {
+ margin: 0;
+}
+
+/* HTML5 display definitions
+ ========================================================================== */
+
+/**
+ * Correct `block` display not defined for any HTML5 element in IE 8/9.
+ * Correct `block` display not defined for `details` or `summary` in IE 10/11
+ * and Firefox.
+ * Correct `block` display not defined for `main` in IE 11.
+ */
+
+article,
+aside,
+details,
+figcaption,
+figure,
+footer,
+header,
+hgroup,
+main,
+menu,
+nav,
+section,
+summary {
+ display: block;
+}
+
+/**
+ * 1. Correct `inline-block` display not defined in IE 8/9.
+ * 2. Normalize vertical alignment of `progress` in Chrome, Firefox, and Opera.
+ */
+
+audio,
+canvas,
+progress,
+video {
+ display: inline-block; /* 1 */
+ vertical-align: baseline; /* 2 */
+}
+
+/**
+ * Prevent modern browsers from displaying `audio` without controls.
+ * Remove excess height in iOS 5 devices.
+ */
+
+audio:not([controls]) {
+ display: none;
+ height: 0;
+}
+
+/**
+ * Address `[hidden]` styling not present in IE 8/9/10.
+ * Hide the `template` element in IE 8/9/11, Safari, and Firefox < 22.
+ */
+
+[hidden],
+template {
+ display: none;
+}
+
+/* Links
+ ========================================================================== */
+
+/**
+ * Remove the gray background color from active links in IE 10.
+ */
+
+a {
+ background-color: transparent;
+}
+
+/**
+ * Improve readability when focused and also mouse hovered in all browsers.
+ */
+
+a:active,
+a:hover {
+ outline: 0;
+}
+
+/* Text-level semantics
+ ========================================================================== */
+
+/**
+ * Address styling not present in IE 8/9/10/11, Safari, and Chrome.
+ */
+
+abbr[title] {
+ border-bottom: 1px dotted;
+}
+
+/**
+ * Address style set to `bolder` in Firefox 4+, Safari, and Chrome.
+ */
+
+b,
+strong {
+ font-weight: bold;
+}
+
+/**
+ * Address styling not present in Safari and Chrome.
+ */
+
+dfn {
+ font-style: italic;
+}
+
+/**
+ * Address variable `h1` font-size and margin within `section` and `article`
+ * contexts in Firefox 4+, Safari, and Chrome.
+ */
+
+h1 {
+ font-size: 2em;
+ margin: 0.67em 0;
+}
+
+/**
+ * Address styling not present in IE 8/9.
+ */
+
+mark {
+ background: #ff0;
+ color: #000;
+}
+
+/**
+ * Address inconsistent and variable font size in all browsers.
+ */
+
+small {
+ font-size: 80%;
+}
+
+/**
+ * Prevent `sub` and `sup` affecting `line-height` in all browsers.
+ */
+
+sub,
+sup {
+ font-size: 75%;
+ line-height: 0;
+ position: relative;
+ vertical-align: baseline;
+}
+
+sup {
+ top: -0.5em;
+}
+
+sub {
+ bottom: -0.25em;
+}
+
+/* Embedded content
+ ========================================================================== */
+
+/**
+ * Remove border when inside `a` element in IE 8/9/10.
+ */
+
+img {
+ border: 0;
+}
+
+/**
+ * Correct overflow not hidden in IE 9/10/11.
+ */
+
+svg:not(:root) {
+ overflow: hidden;
+}
+
+/* Grouping content
+ ========================================================================== */
+
+/**
+ * Address margin not present in IE 8/9 and Safari.
+ */
+
+figure {
+ margin: 1em 40px;
+}
+
+/**
+ * Address differences between Firefox and other browsers.
+ */
+
+hr {
+ -moz-box-sizing: content-box;
+ box-sizing: content-box;
+ height: 0;
+}
+
+/**
+ * Contain overflow in all browsers.
+ */
+
+pre {
+ overflow: auto;
+}
+
+/**
+ * Address odd `em`-unit font size rendering in all browsers.
+ */
+
+code,
+kbd,
+pre,
+samp {
+ font-family: monospace, monospace;
+ font-size: 1em;
+}
+
+/* Forms
+ ========================================================================== */
+
+/**
+ * Known limitation: by default, Chrome and Safari on OS X allow very limited
+ * styling of `select`, unless a `border` property is set.
+ */
+
+/**
+ * 1. Correct color not being inherited.
+ * Known issue: affects color of disabled elements.
+ * 2. Correct font properties not being inherited.
+ * 3. Address margins set differently in Firefox 4+, Safari, and Chrome.
+ */
+
+button,
+input,
+optgroup,
+select,
+textarea {
+ color: inherit; /* 1 */
+ font: inherit; /* 2 */
+ margin: 0; /* 3 */
+}
+
+/**
+ * Address `overflow` set to `hidden` in IE 8/9/10/11.
+ */
+
+button {
+ overflow: visible;
+}
+
+/**
+ * Address inconsistent `text-transform` inheritance for `button` and `select`.
+ * All other form control elements do not inherit `text-transform` values.
+ * Correct `button` style inheritance in Firefox, IE 8/9/10/11, and Opera.
+ * Correct `select` style inheritance in Firefox.
+ */
+
+button,
+select {
+ text-transform: none;
+}
+
+/**
+ * 1. Avoid the WebKit bug in Android 4.0.* where (2) destroys native `audio`
+ * and `video` controls.
+ * 2. Correct inability to style clickable `input` types in iOS.
+ * 3. Improve usability and consistency of cursor style between image-type
+ * `input` and others.
+ */
+
+button,
+html input[type="button"], /* 1 */
+input[type="reset"],
+input[type="submit"] {
+ -webkit-appearance: button; /* 2 */
+ cursor: pointer; /* 3 */
+}
+
+/**
+ * Re-set default cursor for disabled elements.
+ */
+
+button[disabled],
+html input[disabled] {
+ cursor: default;
+}
+
+/**
+ * Remove inner padding and border in Firefox 4+.
+ */
+
+button::-moz-focus-inner,
+input::-moz-focus-inner {
+ border: 0;
+ padding: 0;
+}
+
+/**
+ * Address Firefox 4+ setting `line-height` on `input` using `!important` in
+ * the UA stylesheet.
+ */
+
+input {
+ line-height: normal;
+}
+
+/**
+ * It's recommended that you don't attempt to style these elements.
+ * Firefox's implementation doesn't respect box-sizing, padding, or width.
+ *
+ * 1. Address box sizing set to `content-box` in IE 8/9/10.
+ * 2. Remove excess padding in IE 8/9/10.
+ */
+
+input[type="checkbox"],
+input[type="radio"] {
+ box-sizing: border-box; /* 1 */
+ padding: 0; /* 2 */
+}
+
+/**
+ * Fix the cursor style for Chrome's increment/decrement buttons. For certain
+ * `font-size` values of the `input`, it causes the cursor style of the
+ * decrement button to change from `default` to `text`.
+ */
+
+input[type="number"]::-webkit-inner-spin-button,
+input[type="number"]::-webkit-outer-spin-button {
+ height: auto;
+}
+
+/**
+ * 1. Address `appearance` set to `searchfield` in Safari and Chrome.
+ * 2. Address `box-sizing` set to `border-box` in Safari and Chrome
+ * (include `-moz` to future-proof).
+ */
+
+input[type="search"] {
+ -webkit-appearance: textfield; /* 1 */
+ -moz-box-sizing: content-box;
+ -webkit-box-sizing: content-box; /* 2 */
+ box-sizing: content-box;
+}
+
+/**
+ * Remove inner padding and search cancel button in Safari and Chrome on OS X.
+ * Safari (but not Chrome) clips the cancel button when the search input has
+ * padding (and `textfield` appearance).
+ */
+
+input[type="search"]::-webkit-search-cancel-button,
+input[type="search"]::-webkit-search-decoration {
+ -webkit-appearance: none;
+}
+
+/**
+ * Define consistent border, margin, and padding.
+ */
+
+fieldset {
+ border: 1px solid #c0c0c0;
+ margin: 0 2px;
+ padding: 0.35em 0.625em 0.75em;
+}
+
+/**
+ * 1. Correct `color` not being inherited in IE 8/9/10/11.
+ * 2. Remove padding so people aren't caught out if they zero out fieldsets.
+ */
+
+legend {
+ border: 0; /* 1 */
+ padding: 0; /* 2 */
+}
+
+/**
+ * Remove default vertical scrollbar in IE 8/9/10/11.
+ */
+
+textarea {
+ overflow: auto;
+}
+
+/**
+ * Don't inherit the `font-weight` (applied by a rule above).
+ * NOTE: the default cannot safely be changed in Chrome and Safari on OS X.
+ */
+
+optgroup {
+ font-weight: bold;
+}
+
+/* Tables
+ ========================================================================== */
+
+/**
+ * Remove most spacing between table cells.
+ */
+
+table {
+ border-collapse: collapse;
+ border-spacing: 0;
+}
+
+td,
+th {
+ padding: 0;
+}
diff --git a/app/static/pursuit.css b/app/static/pursuit.css
new file mode 100644
index 0000000..e0c7f6e
--- /dev/null
+++ b/app/static/pursuit.css
@@ -0,0 +1,703 @@
+/** ************************************************************************* *
+ ** Pursuit CSS
+ **
+ ** STRUCTURE
+ **
+ ** This CSS file is structured into several sections, from general to
+ ** specific, and (mostly) alphabetically within the sections.
+ **
+ ** Several global element styles are used. This is not encouraged and should
+ ** be kept to a minimum. If you want to add new styles you'll most likely
+ ** want to add a new CSS component. See the Components section for examples.
+ **
+ ** CSS components use three simple naming ideas from the BEM system:
+ ** - Block: `.my-component`
+ ** - Element: `.my-component__item`
+ ** - Modifier: `.my-component.my-component--highlighted`
+ **
+ ** Example:
+ ** <div .my-component>
+ ** <div .my-component__item>
+ ** <div .my-component__item>
+ ** ...
+ ** <div .my-component.my-component--highlighted>
+ ** <div .my-component__item>
+ ** <div .my-component__item>
+ **
+ ** Components can be nested.
+ **
+ **
+ ** TYPOGRAPHY
+ **
+ ** Typographic choices for sizes, line-heights and margins are based on a
+ ** musical major third scale (4:5). This gives us a way to find numbers
+ ** and relationships between them that are perceived as harmonic.
+ **
+ ** To make use of this modular scale, use a ratio of the form
+ ** (5/4)^n
+ ** where n ∈ ℤ, -6 ≤ n ≤ 8.
+ ** ************************************************************************* */
+/* Section: Variables
+ * ========================================================================== */
+/* Section: Document Styles
+ * ========================================================================== */
+html {
+ box-sizing: border-box;
+ /* This overflow rule prevents everything from shifting slightly to the side
+ when moving from a page which isn't large enough to generate a scrollbar
+ to one that is. */
+ overflow-y: scroll;
+}
+*,
+*::before,
+*::after {
+ box-sizing: inherit;
+}
+body {
+ background-color: #ffffff;
+ color: #000;
+ font-family: "Roboto", sans-serif;
+ font-size: 87.5%;
+ line-height: 1.563;
+}
+@media (min-width: 38em) {
+ body {
+ font-size: 100%;
+ }
+}
+/* Section: Utility Classes
+ * ========================================================================== */
+.clear-floats {
+ clear: both;
+}
+.clearfix::before,
+.clearfix::after {
+ content: " ";
+ display: table;
+}
+.clearfix::after {
+ clear: both;
+}
+/* Content hidden like this will still be read by a screen reader */
+.hide-visually {
+ position: absolute;
+ left: -10000px;
+ top: auto;
+ width: 1px;
+ height: 1px;
+ overflow: hidden;
+}
+/* Section: Layout
+ * ========================================================================== */
+.container {
+ display: block;
+ max-width: 66em;
+ margin-left: auto;
+ margin-right: auto;
+ padding-left: 20px;
+ padding-right: 20px;
+}
+.col {
+ display: block;
+ position: relative;
+ width: 100%;
+}
+.col.col--main {
+ margin-bottom: 3.08em;
+}
+.col.col--aside {
+ margin-bottom: 2.44em;
+}
+@media (min-width: 52em) {
+ .container {
+ padding-left: 30px;
+ padding-right: 30px;
+ }
+ .col.col--main {
+ float: left;
+ width: 63.655%;
+ /* 66.6…% - 30px */
+ }
+ .col.col--aside {
+ float: right;
+ font-size: 87.5%;
+ width: 33.333333%;
+ }
+}
+@media (min-width: 66em) {
+ .col.col--aside {
+ font-size: inherit;
+ }
+}
+/* Footer
+ * Based on http://www.lwis.net/journal/2008/02/08/pure-css-sticky-footer/
+ * Except we don't support IE6
+ * -------------------------------------------------------------------------- */
+html,
+body {
+ height: 100%;
+}
+.everything-except-footer {
+ min-height: 100%;
+ padding-bottom: 3em;
+}
+.footer {
+ position: relative;
+ height: 3em;
+ margin-top: -3em;
+ width: 100%;
+ text-align: center;
+ background-color: #1d222d;
+ color: #f0f0f0;
+}
+.footer * {
+ margin-bottom: 0;
+}
+/* Section: Element Styles
+ *
+ * Have as few of these as possible and keep them general, because they will
+ * influence every component hereafter.
+ * ========================================================================== */
+:target {
+ background-color: #f1f5f9;
+}
+a,
+a:visited {
+ color: #c4953a;
+ text-decoration: none;
+ font-weight: bold;
+}
+a:hover {
+ color: #7b5904;
+ text-decoration: none;
+}
+code,
+pre {
+ background-color: #f1f5f9;
+ border-radius: 3px;
+ color: #194a5b;
+ font-family: "Roboto Mono", monospace;
+ font-size: 87.5%;
+}
+:target code,
+:target pre {
+ background-color: #dfe8f1;
+}
+code {
+ padding: 0.2em 0;
+ margin: 0;
+ white-space: pre-wrap;
+ word-wrap: break-word;
+}
+code::before,
+code::after {
+ letter-spacing: -0.2em;
+ content: "\00a0";
+}
+a > code {
+ font-weight: normal;
+}
+a > code::before {
+ content: "🡒";
+ letter-spacing: 0.33em;
+}
+a:hover > code {
+ color: #c4953a;
+}
+pre {
+ margin-top: 0;
+ margin-bottom: 0;
+ padding: 1em 1.25rem;
+ /* Using rem here to align with lists etc. */
+ overflow: auto;
+ white-space: pre;
+ word-wrap: normal;
+}
+pre code {
+ background-color: transparent;
+ border: 0;
+ font-size: 100%;
+ max-width: auto;
+ padding: 0;
+ margin: 0;
+ overflow: visible;
+ line-height: inherit;
+ white-space: pre;
+ word-break: normal;
+ word-wrap: normal;
+}
+pre code::before,
+pre code::after {
+ content: normal;
+}
+h1 {
+ font-size: 3.052em;
+ font-weight: 300;
+ letter-spacing: -0.5px;
+ line-height: 1.125;
+ margin-top: 1.563rem;
+ margin-bottom: 1.25rem;
+}
+@media (min-width: 52em) {
+ h1 {
+ font-size: 3.814em;
+ margin-top: 5.96rem;
+ }
+}
+h2 {
+ font-size: 1.953em;
+ font-weight: normal;
+ line-height: 1.250;
+ margin-top: 3.052rem;
+ margin-bottom: 1rem;
+}
+h3 {
+ font-size: 1.563em;
+ font-weight: normal;
+ line-height: 1.250;
+ margin-top: 2.441rem;
+ margin-bottom: 1rem;
+}
+h4 {
+ font-size: 1.25em;
+ font-weight: normal;
+ margin-top: 2.441rem;
+ margin-bottom: 1rem;
+}
+h1 + h2,
+h1 + h3,
+h1 + h4,
+h2 + h3,
+h2 + h4,
+h3 + h4 {
+ margin-top: 1rem;
+}
+hr {
+ border: none;
+ height: 1px;
+ background-color: #cccccc;
+}
+img {
+ border-style: none;
+ max-width: 100%;
+}
+p {
+ font-size: 1em;
+ margin-top: 1rem;
+ margin-bottom: 1rem;
+}
+table {
+ border-bottom: 1px solid #cccccc;
+ border-collapse: collapse;
+ border-spacing: 0;
+ margin-top: 1rem;
+ margin-bottom: 1rem;
+ width: 100%;
+}
+td,
+th {
+ text-align: left;
+ padding: 0.41em 0.51em;
+}
+td {
+ border-top: 1px solid #cccccc;
+}
+td:first-child,
+th:first-child {
+ padding-left: 0;
+}
+td:last-child,
+th:last-child {
+ padding-right: 0;
+}
+ul {
+ list-style-type: none;
+ margin-top: 1rem;
+ margin-bottom: 1rem;
+ padding-left: 0;
+}
+ul li {
+ position: relative;
+ padding-left: 1.250em;
+}
+ul li::before {
+ position: absolute;
+ color: #a0a0a0;
+ content: "–";
+ display: inline-block;
+ margin-left: -1.25em;
+ width: 1.250em;
+}
+/* Tying this tightly to ul at the moment because it's a slight variation thereof */
+ul.ul--search li::before {
+ content: "⚲";
+ top: -0.2em;
+ transform: rotate(-45deg);
+}
+ol {
+ margin-top: 1rem;
+ margin-bottom: 1rem;
+ padding-left: 1.250em;
+}
+ol li {
+ position: relative;
+ padding-left: 0;
+}
+/* Section: Components
+ * ========================================================================== */
+/* Component: Badge
+ * -------------------------------------------------------------------------- */
+.badge {
+ position: relative;
+ top: -0.1em;
+ display: inline-block;
+ background-color: #000;
+ border-radius: 1.3em;
+ color: #fff;
+ font-size: 77%;
+ font-weight: bold;
+ line-height: 1.563;
+ text-align: center;
+ height: 1.5em;
+ width: 1.5em;
+}
+.badge.badge--package {
+ background-color: #c4953a;
+ letter-spacing: -0.1em;
+}
+.badge.badge--module {
+ background-color: #75B134;
+}
+/* Component: Declarations
+ * -------------------------------------------------------------------------- */
+.decl__title {
+ position: relative;
+ padding-bottom: 0.328em;
+ margin-bottom: 0.262em;
+}
+.decl__source {
+ display: block;
+ float: right;
+ font-size: 64%;
+ position: relative;
+ top: 0.57em;
+}
+.decl__anchor,
+.decl__anchor:visited {
+ position: absolute;
+ left: -0.8em;
+ color: #bababa;
+}
+.decl__anchor:hover {
+ color: #c4953a;
+}
+.decl__signature {
+ background-color: transparent;
+ border-radius: 0;
+ border-top: 1px solid #cccccc;
+ border-bottom: 1px solid #cccccc;
+ padding: 0.328em 0;
+}
+.decl__signature code {
+ display: block;
+ padding-left: 2.441em;
+ text-indent: -2.441em;
+ white-space: normal;
+}
+:target .decl__signature,
+:target .decl__signature code {
+ /* We want the background to be transparent, even when the parent is a target */
+ background-color: transparent;
+}
+.decl__body .keyword,
+.decl__body .syntax {
+ color: #0B71B4;
+}
+/* Component: Dependency Link
+ * -------------------------------------------------------------------------- */
+.deplink {
+ /* Currently no root styles, but keep the class as a namespace */
+}
+.deplink__link {
+ display: inline-block;
+ margin-right: 0.41em;
+}
+.deplink__version {
+ color: #666666;
+ display: inline-block;
+ font-size: 0.8em;
+ line-height: 1;
+}
+/* Component: Grouped List
+ * -------------------------------------------------------------------------- */
+.grouped-list {
+ border-top: 1px solid #cccccc;
+ margin: 0 0 2.44em 0;
+}
+.grouped-list__title {
+ color: #666666;
+ font-size: 0.8em;
+ font-weight: 300;
+ letter-spacing: 1px;
+ margin: 0.8em 0 -0.1em 0;
+ text-transform: uppercase;
+}
+.grouped-list__item {
+ margin: 0;
+}
+/* Component: Message
+ * -------------------------------------------------------------------------- */
+.message {
+ border: 5px solid;
+ border-radius: 5px;
+ padding: 1em !important;
+}
+.message.message--error {
+ background-color: #fff0f0;
+ border-color: #c85050;
+}
+.message.message--not-available {
+ background-color: #f0f096;
+ border-color: #e3e33d;
+}
+/* Component: Multi Col
+ * Multiple columns side by side
+ * -------------------------------------------------------------------------- */
+.multi-col {
+ margin-bottom: 2.44em;
+}
+.multi-col__col {
+ display: block;
+ padding-right: 1em;
+ position: relative;
+ width: 100%;
+}
+@media (min-width: 38em) and (max-width: 51.999999em) {
+ .multi-col__col {
+ float: left;
+ width: 50%;
+ }
+ .multi-col__col:nth-child(2n+3) {
+ clear: both;
+ }
+}
+@media (min-width: 52em) {
+ .multi-col__col {
+ float: left;
+ width: 33.333333%;
+ }
+ .multi-col__col:nth-child(3n+4) {
+ clear: both;
+ }
+}
+/* Component: Page Title
+ * -------------------------------------------------------------------------- */
+.page-title {
+ margin: 4.77em 0 1.56em;
+ padding-bottom: 1.25em;
+ position: relative;
+}
+.page-title__title {
+ margin: 0 0 0 -0.05em;
+ /* Visually align on left edge */
+}
+.page-title__label {
+ position: relative;
+ color: #666666;
+ font-size: 0.8rem;
+ font-weight: 300;
+ letter-spacing: 1px;
+ margin-bottom: -0.8em;
+ text-transform: uppercase;
+ z-index: 1;
+}
+/* Component: Top Banner
+ * -------------------------------------------------------------------------- */
+.top-banner {
+ background-color: #1d222d;
+ color: #f0f0f0;
+ font-weight: normal;
+}
+.top-banner__logo,
+.top-banner__logo:visited {
+ float: left;
+ color: #f0f0f0;
+ font-size: 2.44em;
+ font-weight: 300;
+ line-height: 90px;
+ margin: 0;
+}
+.top-banner__logo:hover {
+ color: #c4953a;
+ text-decoration: none;
+}
+.top-banner__form {
+ margin-bottom: 1.25em;
+}
+.top-banner__form input {
+ border: 1px solid #1d222d;
+ border-radius: 3px;
+ color: #1d222d;
+ font-weight: 300;
+ line-height: 2;
+ padding: 0.21em 0.512em;
+ width: 100%;
+}
+.top-banner__actions {
+ float: right;
+ text-align: right;
+}
+.top-banner__actions__item {
+ display: inline-block;
+ line-height: 90px;
+ margin: 0;
+ padding-left: 1.25em;
+}
+.top-banner__actions__item:first-child {
+ padding-left: 0;
+}
+.top-banner__actions__item a,
+.top-banner__actions__item a:visited {
+ color: #f0f0f0;
+}
+.top-banner__actions__item a:hover {
+ color: #c4953a;
+}
+@media (min-width: 38em) {
+ .top-banner__logo {
+ float: left;
+ width: 25%;
+ }
+ .top-banner__form {
+ float: left;
+ line-height: 90px;
+ margin-bottom: 0;
+ width: 50%;
+ }
+ .top-banner__actions {
+ float: right;
+ width: 25%;
+ }
+}
+/* Component: Search Results
+ * -------------------------------------------------------------------------- */
+.result.result--empty {
+ font-size: 1.25em;
+}
+.result__title {
+ font-size: 1.25em;
+ margin-bottom: 0.2rem;
+}
+.result__badge {
+ margin-left: -0.1em;
+}
+.result__body > *:first-child {
+ margin-top: 0!important;
+}
+.result__body > *:last-child {
+ margin-bottom: 0!important;
+}
+.result__signature {
+ background-color: transparent;
+ border-radius: 0;
+ border-top: 1px solid #cccccc;
+ border-bottom: 1px solid #cccccc;
+ padding: 0.328em 0;
+}
+.result__signature code {
+ display: block;
+ padding-left: 2.441em;
+ text-indent: -2.441em;
+ white-space: normal;
+}
+.result__actions {
+ margin-top: 0.2rem;
+}
+.result__actions__item {
+ font-size: 80%;
+}
+.result__actions__item + .result__actions__item {
+ margin-left: 0.65em;
+}
+/* Component: Version Selector
+ * -------------------------------------------------------------------------- */
+.version-selector {
+ margin-bottom: 0.8em;
+}
+@media (min-width: 38em) {
+ .version-selector {
+ position: absolute;
+ top: 0.8em;
+ right: 0;
+ margin-bottom: 0;
+ }
+}
+/* Section: FIXME
+ * These styles should be cleaned up
+ * ========================================================================== */
+/* Help paragraphs */
+.help {
+ padding: 5px 0;
+}
+.help h3 {
+ /* FIXME: target with class */
+ margin-top: 16px;
+}
+/* Section: Markdown
+ * Github rendered README
+ * ========================================================================== */
+.markdown-body {
+ /*
+ Useful for narrow screens, such as mobiles. Documentation often contains URLs
+ which would otherwise force the page to become wider, and force creation of
+ horizontal scrollbars. Yuck.
+ */
+ word-wrap: break-word;
+}
+.markdown-body > *:first-child {
+ margin-top: 0 !important;
+}
+.markdown-body > *:last-child {
+ margin-bottom: 0 !important;
+}
+.markdown-body a:not([href]) {
+ color: inherit;
+ text-decoration: none;
+}
+.markdown-body blockquote {
+ margin: 0;
+ padding: 0 1em;
+ color: #777;
+ border-left: 0.25em solid #ddd;
+}
+.markdown-body blockquote > :first-child {
+ margin-top: 0;
+}
+.markdown-body blockquote > :last-child {
+ margin-bottom: 0;
+}
+.markdown-body .anchor {
+ /* We hide the anchor because the link doesn't point to a valid location */
+ display: none;
+}
+.markdown-body .pl-k {
+ /* Keyword */
+ color: #a0a0a0;
+}
+.markdown-body .pl-c1,
+.markdown-body .pl-en {
+ /* Not really sure what this is */
+ color: #39d;
+}
+.markdown-body .pl-s {
+ /* String literals */
+ color: #1a1;
+}
+.markdown-body .pl-cce {
+ /* String literal escape sequences */
+ color: #921;
+}
+.markdown-body .pl-smi {
+ /* type variables? */
+ color: #62b;
+}
diff --git a/examples/docs/bower.json b/examples/docs/bower.json
index 54f1c97..a6a0385 100644
--- a/examples/docs/bower.json
+++ b/examples/docs/bower.json
@@ -15,6 +15,7 @@
"output"
],
"dependencies": {
+ "purescript-prelude": "./bower_components/purescript-prelude"
},
"license": "MIT"
}
diff --git a/examples/docs/resolutions.json b/examples/docs/resolutions.json
new file mode 100644
index 0000000..c3fced5
--- /dev/null
+++ b/examples/docs/resolutions.json
@@ -0,0 +1,21 @@
+{
+ "canonicalDir": ".",
+ "pkgMeta": {
+ "dependencies": {
+ "purescript-prelude": "./bower_components/purescript-prelude"
+ }
+ },
+ "dependencies": {
+ "purescript-prelude": {
+ "canonicalDir": "bower_components/purescript-prelude",
+ "pkgMeta": {
+ "_resolution": {
+ "type": "version",
+ "tag": "v2.4.0",
+ "commit": "21067a4c782f42d08bc877214f85b92ce6769b21"
+ }
+ },
+ "dependencies": {}
+ }
+ }
+}
diff --git a/examples/docs/src/ConstrainedArgument.purs b/examples/docs/src/ConstrainedArgument.purs
index 65156a5..00bc5be 100644
--- a/examples/docs/src/ConstrainedArgument.purs
+++ b/examples/docs/src/ConstrainedArgument.purs
@@ -4,6 +4,5 @@ class Foo t
type WithoutArgs = forall a. (Partial => a) -> a
type WithArgs = forall a. (Foo a => a) -> a
-type MultiWithoutArgs = forall a. ((Partial, Partial) => a) -> a
-type MultiWithArgs = forall a b. ((Foo a, Foo b) => a) -> a
-
+type MultiWithoutArgs = forall a. (Partial => Partial => a) -> a
+type MultiWithArgs = forall a b. (Foo a => Foo b => a) -> a
diff --git a/examples/docs/src/TypeClassWithFunDeps.purs b/examples/docs/src/TypeClassWithFunDeps.purs
index 3fd918a..3aee885 100644
--- a/examples/docs/src/TypeClassWithFunDeps.purs
+++ b/examples/docs/src/TypeClassWithFunDeps.purs
@@ -2,4 +2,4 @@
module TypeClassWithFunDeps where
class TypeClassWithFunDeps a b c d e | a b -> c, c -> d e where
- aMember :: a
+ aMember :: a -> b
diff --git a/examples/failing/1071.purs b/examples/failing/1071.purs
index 806f51a..1f560d1 100644
--- a/examples/failing/1071.purs
+++ b/examples/failing/1071.purs
@@ -4,5 +4,5 @@ module Main where
class Foo a b where
foo :: a -> b
-bar :: forall a. (Foo a) => a -> a
+bar :: forall a. Foo a => a -> a
bar a = a
diff --git a/examples/failing/1310.purs b/examples/failing/1310.purs
index 5bc0442..02fde55 100644
--- a/examples/failing/1310.purs
+++ b/examples/failing/1310.purs
@@ -12,7 +12,7 @@ class Inject f g where
instance inject :: Inject f f where
inj x = x
-foreign import data Oops :: !
+foreign import data Oops :: Effect
main :: forall eff. Eff (oops :: Oops | eff) Unit
main = inj (log "Oops")
diff --git a/examples/failing/2567.purs b/examples/failing/2567.purs
new file mode 100644
index 0000000..00f8ea8
--- /dev/null
+++ b/examples/failing/2567.purs
@@ -0,0 +1,5 @@
+-- @shouldFailWith NoInstanceFound
+module Main where
+
+foo :: Int
+foo = (0 :: Fail "This constraint should be checked" => Int)
diff --git a/examples/failing/2601.purs b/examples/failing/2601.purs
index 00dc25f..988e3d8 100644
--- a/examples/failing/2601.purs
+++ b/examples/failing/2601.purs
@@ -1,7 +1,7 @@
-- @shouldFailWith KindsDoNotUnify
module Main where
-type Syn (a :: * -> *) = String
+type Syn (a :: Type -> Type) = String
val :: Syn Int
val = "bad"
diff --git a/examples/failing/2616.purs b/examples/failing/2616.purs
new file mode 100644
index 0000000..55ff188
--- /dev/null
+++ b/examples/failing/2616.purs
@@ -0,0 +1,9 @@
+-- @shouldFailWith NoInstanceFound
+module Main where
+
+import Prelude
+
+newtype Foo r = Foo { | r }
+
+derive instance eqFoo :: Eq (Foo r)
+derive instance ordFoo :: Ord (Foo r)
diff --git a/examples/failing/DuplicateProperties1.purs b/examples/failing/DuplicateProperties.purs
index d8bba9d..6349b30 100644
--- a/examples/failing/DuplicateProperties1.purs
+++ b/examples/failing/DuplicateProperties.purs
@@ -3,7 +3,7 @@ module DuplicateProperties where
import Prelude
-foreign import data Test :: # * -> *
+foreign import data Test :: # Type -> Type
foreign import subtractX :: forall r. Test (x :: Unit | r) -> Test r
diff --git a/examples/failing/DuplicateProperties2.purs b/examples/failing/DuplicateProperties2.purs
deleted file mode 100644
index bf88690..0000000
--- a/examples/failing/DuplicateProperties2.purs
+++ /dev/null
@@ -1,12 +0,0 @@
--- @shouldFailWith DuplicateLabel
-module DuplicateProperties where
-
-import Prelude
-
-foreign import data Test :: # * -> *
-
-foreign import subtractX :: forall r. Test (x :: Unit | r) -> Test r
-
-foreign import hasX :: forall r. Test (x :: Unit, y :: Unit | r)
-
-baz = subtractX (subtractX hasX)
diff --git a/examples/failing/InvalidDerivedInstance.purs b/examples/failing/InvalidDerivedInstance.purs
new file mode 100644
index 0000000..11b1b46
--- /dev/null
+++ b/examples/failing/InvalidDerivedInstance.purs
@@ -0,0 +1,8 @@
+-- @shouldFailWith InvalidDerivedInstance
+module Main where
+
+import Prelude
+
+data X = X
+
+derive instance eqX :: Eq X X
diff --git a/examples/failing/InvalidDerivedInstance2.purs b/examples/failing/InvalidDerivedInstance2.purs
new file mode 100644
index 0000000..ec46733
--- /dev/null
+++ b/examples/failing/InvalidDerivedInstance2.purs
@@ -0,0 +1,6 @@
+-- @shouldFailWith ExpectedTypeConstructor
+module Main where
+
+import Prelude
+
+derive instance eqRecord :: Eq {}
diff --git a/examples/failing/LetPatterns1.purs b/examples/failing/LetPatterns1.purs
new file mode 100644
index 0000000..1531ede
--- /dev/null
+++ b/examples/failing/LetPatterns1.purs
@@ -0,0 +1,10 @@
+-- @shouldFailWith ErrorParsingModule
+module Main where
+
+import Prelude
+
+-- wrong binders for function, the first one should be VarBinder
+x =
+ let (X a b) x y = hoge
+ in
+ a
diff --git a/examples/failing/LetPatterns2.purs b/examples/failing/LetPatterns2.purs
new file mode 100644
index 0000000..ebfd7f0
--- /dev/null
+++ b/examples/failing/LetPatterns2.purs
@@ -0,0 +1,14 @@
+-- @shouldFailWith UnknownName
+module Main where
+
+import Prelude
+
+data X a = X a
+
+-- wrong dependency order
+x =
+ let
+ b = a
+ X a = X 10
+ in
+ b
diff --git a/examples/failing/LetPatterns3.purs b/examples/failing/LetPatterns3.purs
new file mode 100644
index 0000000..58be165
--- /dev/null
+++ b/examples/failing/LetPatterns3.purs
@@ -0,0 +1,13 @@
+-- @shouldFailWith IncorrectConstructorArity
+module Main where
+
+import Prelude
+
+data X a = X a
+
+-- a parameter binder should be with nullary constructor, or with parens
+x =
+ let
+ a X b = b
+ in
+ a $ X 10
diff --git a/examples/failing/2445.purs b/examples/failing/LetPatterns4.purs
index 10ad41a..a361a43 100644
--- a/examples/failing/2445.purs
+++ b/examples/failing/LetPatterns4.purs
@@ -1,6 +1,6 @@
-- @shouldFailWith ErrorParsingModule
module Main where
-data X a = X
+data X a = X a
-eg = \(X :: (forall a. X a)) -> X
+X a = a
diff --git a/examples/failing/NonExhaustivePatGuard.purs b/examples/failing/NonExhaustivePatGuard.purs
new file mode 100644
index 0000000..cdcfc2f
--- /dev/null
+++ b/examples/failing/NonExhaustivePatGuard.purs
@@ -0,0 +1,5 @@
+-- @shouldFailWith NoInstanceFound
+module Main where
+
+f :: Int -> Int
+f x | 1 <- x = x \ No newline at end of file
diff --git a/examples/failing/Superclasses5.purs b/examples/failing/Superclasses5.purs
index 0de8d4b..486f4e8 100644
--- a/examples/failing/Superclasses5.purs
+++ b/examples/failing/Superclasses5.purs
@@ -8,19 +8,19 @@ import Control.Monad.Eff.Console (logShow)
class Su a where
su :: a -> a
-class (Su (Array a)) <= Cl a where
+class Su (Array a) <= Cl a where
cl :: a -> a -> a
instance suNumber :: Su Number where
su n = n + 1.0
-instance suArray :: (Su a) => Su (Array a) where
+instance suArray :: Su a => Su (Array a) where
su [x] = [su x]
instance clNumber :: Cl Number where
cl n m = n + m
-test :: forall a. (Cl a) => a -> Array a
+test :: forall a. Cl a => a -> Array a
test x = su [cl x x]
main = logShow $ test 10.0
diff --git a/examples/failing/UnusableTypeClassMethod.purs b/examples/failing/UnusableTypeClassMethod.purs
new file mode 100644
index 0000000..058f504
--- /dev/null
+++ b/examples/failing/UnusableTypeClassMethod.purs
@@ -0,0 +1,7 @@
+-- @shouldFailWith UnusableDeclaration
+module Main where
+
+class C a b where
+ -- type doesn't contain `a`, which is also required to determine an instance
+ c :: b
+
diff --git a/examples/failing/UnusableTypeClassMethodConflictingIdent.purs b/examples/failing/UnusableTypeClassMethodConflictingIdent.purs
new file mode 100644
index 0000000..08ed602
--- /dev/null
+++ b/examples/failing/UnusableTypeClassMethodConflictingIdent.purs
@@ -0,0 +1,7 @@
+-- @shouldFailWith UnusableDeclaration
+module Main where
+
+class C a where
+ -- type doesn't contain the type class var `a`
+ c :: forall a. a
+
diff --git a/examples/failing/UnusableTypeClassMethodSynonym.purs b/examples/failing/UnusableTypeClassMethodSynonym.purs
new file mode 100644
index 0000000..aae1e33
--- /dev/null
+++ b/examples/failing/UnusableTypeClassMethodSynonym.purs
@@ -0,0 +1,9 @@
+-- @shouldFailWith UnusableDeclaration
+module Main where
+
+type M x = forall a. a
+
+class C a where
+ -- after synonym expansion, the type doesn't actually contain an `a`
+ c :: M a
+
diff --git a/examples/passing/1110.purs b/examples/passing/1110.purs
new file mode 100644
index 0000000..f475fc0
--- /dev/null
+++ b/examples/passing/1110.purs
@@ -0,0 +1,26 @@
+module Main where
+
+import Prelude
+import Control.Monad.Eff.Console (log)
+
+data X a = X
+
+x :: forall a. X a
+x = X
+
+type Y = { x :: X Int }
+
+test :: forall m. Monad m => m Y
+test = pure { x: x }
+
+type Z t = forall x. t x -> (forall a. t a) -> t x
+
+class C t where c :: Z t
+
+instance cA :: C Array where
+ c x _ = x
+
+test2 :: forall m. Monad m => m { ccc :: Z Array }
+test2 = pure { ccc: (c :: Z Array) }
+
+main = log "Done"
diff --git a/examples/passing/1335.purs b/examples/passing/1335.purs
index 6b31a7f..3a0bb6b 100644
--- a/examples/passing/1335.purs
+++ b/examples/passing/1335.purs
@@ -1,14 +1,14 @@
-module Main where
-
-import Prelude
-import Control.Monad.Eff.Console (log)
-
-x :: forall a. a -> String
-x a = y "Test"
- where
- y :: forall a. (Show a) => a -> String
- y a = show (a :: a)
-
-main = do
- log (x 0)
- log "Done"
+module Main where
+
+import Prelude
+import Control.Monad.Eff.Console (log)
+
+x :: forall a. a -> String
+x a = y "Test"
+ where
+ y :: forall a. Show a => a -> String
+ y a = show (a :: a)
+
+main = do
+ log (x 0)
+ log "Done"
diff --git a/examples/passing/1697.purs b/examples/passing/1697.purs
index 4c9570b..83e87eb 100644
--- a/examples/passing/1697.purs
+++ b/examples/passing/1697.purs
@@ -6,17 +6,17 @@ import Control.Monad.Eff.Console (log)
_2 :: forall a. a -> a
_2 a = a
-x :: forall m. (Monad m) => m Unit
+x :: forall m. Monad m => m Unit
x = do
_ <- pure unit
pure unit
-y :: forall m. (Monad m) => m Unit
+y :: forall m. Monad m => m Unit
y = do
_ <- pure unit
pure unit
-wtf :: forall m. (Monad m) => m Unit
+wtf :: forall m. Monad m => m Unit
wtf = do
_ <- pure unit
let tmp = _2 1
diff --git a/examples/passing/1991.purs b/examples/passing/1991.purs
index c0f5ff2..f7d10b6 100644
--- a/examples/passing/1991.purs
+++ b/examples/passing/1991.purs
@@ -9,7 +9,7 @@ singleton x = [x]
empty :: forall a. Array a
empty = []
-foldMap :: forall a m. (Semigroup m) => (a -> m) -> Array a -> m
+foldMap :: forall a m. Semigroup m => (a -> m) -> Array a -> m
foldMap f [a, b, c, d, e] = f a <> f b <> f c <> f d <> f e
foldMap f xs = foldMap f xs -- spin, not used
diff --git a/examples/passing/2609.purs b/examples/passing/2609.purs
new file mode 100644
index 0000000..eb54bb8
--- /dev/null
+++ b/examples/passing/2609.purs
@@ -0,0 +1,12 @@
+module Main where
+
+import Prelude
+import Eg (Foo'(Bar'), (:->))
+import Control.Monad.Eff (Eff)
+import Control.Monad.Eff.Console (CONSOLE, log)
+
+bar' :: Foo'
+bar' = 4 :-> 5
+
+main :: forall e. Eff (console :: CONSOLE | e) Unit
+main = case bar' of Bar' l r -> log "Done"
diff --git a/examples/passing/2609/Eg.purs b/examples/passing/2609/Eg.purs
new file mode 100644
index 0000000..ceb6c36
--- /dev/null
+++ b/examples/passing/2609/Eg.purs
@@ -0,0 +1,6 @@
+module Eg (Foo'(Bar'), (:->)) where
+
+data Foo' = Bar' Int Int
+
+infix 4 Bar' as :->
+
diff --git a/examples/passing/2616.purs b/examples/passing/2616.purs
new file mode 100644
index 0000000..d48e99d
--- /dev/null
+++ b/examples/passing/2616.purs
@@ -0,0 +1,13 @@
+module Main where
+
+import Prelude
+import Control.Monad.Eff.Console (log)
+
+newtype F r a = F { x :: a | r }
+
+unF :: forall r a. F r a -> { x :: a | r }
+unF (F x) = x
+
+derive instance functorF :: Functor (F r)
+
+main = log (unF (map id (F { x: "Done", y: 42 }))).x
diff --git a/examples/passing/2626.purs b/examples/passing/2626.purs
new file mode 100644
index 0000000..cee8514
--- /dev/null
+++ b/examples/passing/2626.purs
@@ -0,0 +1,13 @@
+module Main where
+
+import Control.Monad.Eff.Console (log)
+
+f = \(x :: forall a. a -> a) -> x x
+
+test1 = (f \x -> x) 1
+
+g = \(x :: (forall a. a -> a) -> Int) -> x (\y -> y)
+
+test2 = g \f -> if f true then f 0 else f 1
+
+main = log "Done"
diff --git a/examples/passing/2663.purs b/examples/passing/2663.purs
new file mode 100644
index 0000000..1bd70dc
--- /dev/null
+++ b/examples/passing/2663.purs
@@ -0,0 +1,9 @@
+module Main where
+
+import Prelude
+import Control.Monad.Eff.Console (log)
+
+foo :: forall t. Warn "Example" => t -> t
+foo x = x
+
+main = when (foo 42 == 42) $ log "Done"
diff --git a/examples/passing/2689.purs b/examples/passing/2689.purs
new file mode 100644
index 0000000..ab0afd8
--- /dev/null
+++ b/examples/passing/2689.purs
@@ -0,0 +1,36 @@
+module Main where
+
+import Prelude
+import Control.Monad.Eff.Console
+import Data.Array.Partial
+import Partial.Unsafe
+
+sumTCObug = go id where
+ go f 0 = f
+ go f n =
+ let
+ f' a = n + a
+ in
+ go f' 0
+
+sumTCObug' = go id where
+ go f 0 = f
+ go f n = go (\a -> n + a) 0
+
+count :: forall a. (a -> Boolean) -> Array a -> Int
+count p = count' 0 where
+ count' acc [] = acc
+ count' acc xs =
+ let h = unsafePartial head xs
+ in count' (acc + if p h then 1 else 0) (unsafePartial tail xs)
+
+main = do
+ let x = sumTCObug 7 3
+ y = sumTCObug' 7 3
+ z = count (_ > 0) [-1, 0, 1]
+ logShow x
+ logShow y
+ logShow z
+ if x == 10 && y == 10 && z == 1
+ then log "Done"
+ else log "Fail"
diff --git a/examples/passing/2695.purs b/examples/passing/2695.purs
new file mode 100644
index 0000000..1957342
--- /dev/null
+++ b/examples/passing/2695.purs
@@ -0,0 +1,13 @@
+module Main where
+
+import Prelude
+import Data.Generic
+import Control.Monad.Eff.Console (log)
+
+type Foo = { foo :: Int }
+
+newtype Foo' = Foo' Foo
+
+derive instance genericFoo :: Generic Foo'
+
+main = log "Done"
diff --git a/examples/passing/2756.purs b/examples/passing/2756.purs
new file mode 100644
index 0000000..81e5660
--- /dev/null
+++ b/examples/passing/2756.purs
@@ -0,0 +1,20 @@
+module Main where
+
+import Control.Monad.Eff (Eff)
+import Control.Monad.Eff.Console (log)
+import Prelude
+
+pu :: forall eff. Eff eff Unit
+pu = pure unit
+
+type C eff = { pu :: Eff eff Unit }
+
+sampleC :: C ()
+sampleC = { pu: pu }
+
+newtype Identity a = Id a
+
+sampleIdC :: Identity (C ())
+sampleIdC = Id { pu : pu }
+
+main = log "Done"
diff --git a/examples/passing/CheckTypeClass.purs b/examples/passing/CheckTypeClass.purs
index c26b2d0..50f2d3e 100644
--- a/examples/passing/CheckTypeClass.purs
+++ b/examples/passing/CheckTypeClass.purs
@@ -9,8 +9,8 @@ data Baz
class Foo a where
foo :: Bar a -> Baz
-foo_ :: forall a. (Foo a) => a -> Baz
-foo_ x = foo ((mkBar :: forall a. (Foo a) => a -> Bar a) x)
+foo_ :: forall a. Foo a => a -> Baz
+foo_ x = foo ((mkBar :: forall a. Foo a => a -> Bar a) x)
mkBar :: forall a. a -> Bar a
mkBar _ = Bar
diff --git a/examples/passing/ClassRefSyntax.purs b/examples/passing/ClassRefSyntax.purs
index 8601125..13e4e64 100644
--- a/examples/passing/ClassRefSyntax.purs
+++ b/examples/passing/ClassRefSyntax.purs
@@ -3,7 +3,7 @@ module Main where
import Lib (class X, go)
import Control.Monad.Eff.Console (log)
-go' :: forall a. (X a) => a -> a
+go' :: forall a. X a => a -> a
go' = go
main = log "Done"
diff --git a/examples/passing/Collatz.purs b/examples/passing/Collatz.purs
index 6cdb363..0fda815 100644
--- a/examples/passing/Collatz.purs
+++ b/examples/passing/Collatz.purs
@@ -10,9 +10,9 @@ collatz n = runPure (runST (do
r <- newSTRef n
count <- newSTRef 0
untilE $ do
- modifySTRef count $ (+) 1
+ _ <- modifySTRef count $ (+) 1
m <- readSTRef r
- writeSTRef r $ if m `mod` 2 == 0 then m / 2 else 3 * m + 1
+ _ <- writeSTRef r $ if m `mod` 2 == 0 then m / 2 else 3 * m + 1
pure $ m == 1
readSTRef count))
diff --git a/examples/passing/Console.purs b/examples/passing/Console.purs
index 2f442ae..a12d699 100644
--- a/examples/passing/Console.purs
+++ b/examples/passing/Console.purs
@@ -4,10 +4,10 @@ import Prelude
import Control.Monad.Eff
import Control.Monad.Eff.Console
-replicateM_ :: forall m a. (Monad m) => Number -> m a -> m {}
-replicateM_ 0.0 _ = pure {}
+replicateM_ :: forall m a. Monad m => Number -> m a -> m Unit
+replicateM_ 0.0 _ = pure unit
replicateM_ n act = do
- act
+ _ <- act
replicateM_ (n - 1.0) act
main = do
diff --git a/examples/passing/ConstraintParens.purs b/examples/passing/ConstraintParens.purs
new file mode 100644
index 0000000..5545332
--- /dev/null
+++ b/examples/passing/ConstraintParens.purs
@@ -0,0 +1,12 @@
+module Main where
+
+import Prelude
+import Control.Monad.Eff.Console (log)
+
+class Foo a where
+ foo ∷ a → a
+
+test ∷ ∀ a. (Foo a) ⇒ a → a
+test = foo
+
+main = log "Done"
diff --git a/examples/passing/DctorOperatorAlias.purs b/examples/passing/DctorOperatorAlias.purs
index c07fe95..0a12c8f 100644
--- a/examples/passing/DctorOperatorAlias.purs
+++ b/examples/passing/DctorOperatorAlias.purs
@@ -1,6 +1,6 @@
module Main where
- import Prelude (Unit, bind, (==))
+ import Prelude (Unit, bind, discard, (==))
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Test.Assert (ASSERT, assert')
diff --git a/examples/passing/Do.purs b/examples/passing/Do.purs
index 3cfa9e4..0dd00c6 100644
--- a/examples/passing/Do.purs
+++ b/examples/passing/Do.purs
@@ -31,8 +31,8 @@ test2 = \_ -> do
Just (x + y)
test3 = \_ -> do
- Just 1.0
- Nothing :: Maybe Number
+ _ <- Just 1.0
+ _ <- Nothing :: Maybe Number
Just 2.0
test4 mx my = do
diff --git a/examples/passing/DuplicateProperties.purs b/examples/passing/DuplicateProperties.purs
new file mode 100644
index 0000000..d91f6bd
--- /dev/null
+++ b/examples/passing/DuplicateProperties.purs
@@ -0,0 +1,27 @@
+module Main where
+
+import Prelude
+import Control.Monad.Eff.Console (log)
+
+data RProxy (r :: # Type) = RProxy
+
+data Proxy (a :: Type) = Proxy
+
+subtractX :: forall r a. RProxy (x :: a | r) -> RProxy r
+subtractX RProxy = RProxy
+
+extractX :: forall r a. RProxy (x :: a | r) -> Proxy a
+extractX RProxy = Proxy
+
+hasX :: forall r a b. RProxy (x :: a, y :: b | r)
+hasX = RProxy
+
+test1 = subtractX (subtractX hasX)
+
+test2
+ :: forall r a b
+ . RProxy (x :: a, x :: b, x :: Int | r)
+ -> Proxy Int
+test2 x = extractX (subtractX (subtractX x))
+
+main = log "Done"
diff --git a/examples/passing/Eff.purs b/examples/passing/Eff.purs
index f0b1ea8..4c74c25 100644
--- a/examples/passing/Eff.purs
+++ b/examples/passing/Eff.purs
@@ -11,12 +11,12 @@ test1 = do
test2 = runPure (runST (do
ref <- newSTRef 0.0
- modifySTRef ref $ \n -> n + 1.0
+ _ <- modifySTRef ref $ \n -> n + 1.0
readSTRef ref))
test3 = pureST (do
ref <- newSTRef 0.0
- modifySTRef ref $ \n -> n + 1.0
+ _ <- modifySTRef ref $ \n -> n + 1.0
readSTRef ref)
main = do
diff --git a/examples/passing/EntailsKindedType.purs b/examples/passing/EntailsKindedType.purs
index cd2489a..5d345b5 100644
--- a/examples/passing/EntailsKindedType.purs
+++ b/examples/passing/EntailsKindedType.purs
@@ -4,8 +4,8 @@ import Prelude
import Control.Monad.Eff
import Control.Monad.Eff.Console
-test x = show (x :: _ :: *)
+test x = show (x :: _ :: Type)
main = do
- when (show (unit :: Unit :: *) == "unit") (log "Done")
+ when (show (unit :: Unit :: Type) == "unit") (log "Done")
when (test unit == "unit") (log "Done")
diff --git a/examples/passing/ExtendedInfixOperators.purs b/examples/passing/ExtendedInfixOperators.purs
index 34481c0..5e12f60 100644
--- a/examples/passing/ExtendedInfixOperators.purs
+++ b/examples/passing/ExtendedInfixOperators.purs
@@ -4,7 +4,7 @@ import Prelude
import Control.Monad.Eff.Console (log, logShow)
import Data.Function (on)
-comparing :: forall a b. (Ord b) => (a -> b) -> a -> a -> Ordering
+comparing :: forall a b. Ord b => (a -> b) -> a -> a -> Ordering
comparing f = compare `on` f
null [] = true
diff --git a/examples/passing/Fib.purs b/examples/passing/Fib.purs
index 83220aa..c9729c7 100644
--- a/examples/passing/Fib.purs
+++ b/examples/passing/Fib.purs
@@ -12,7 +12,7 @@ main = do
whileE ((>) 1000.0 <$> readSTRef n1) $ do
n1' <- readSTRef n1
n2' <- readSTRef n2
- writeSTRef n2 $ n1' + n2'
- writeSTRef n1 n2'
+ _ <- writeSTRef n2 $ n1' + n2'
+ _ <- writeSTRef n1 n2'
logShow n2'
log "Done"
diff --git a/examples/passing/FinalTagless.purs b/examples/passing/FinalTagless.purs
index be7f04b..b7cd4d8 100644
--- a/examples/passing/FinalTagless.purs
+++ b/examples/passing/FinalTagless.purs
@@ -7,7 +7,7 @@ class E e where
num :: Number -> e Number
add :: e Number -> e Number -> e Number
-type Expr a = forall e. (E e) => e a
+type Expr a = forall e. E e => e a
data Id a = Id a
diff --git a/examples/passing/FunWithFunDeps.purs b/examples/passing/FunWithFunDeps.purs
index fa40b2f..d69aa33 100644
--- a/examples/passing/FunWithFunDeps.purs
+++ b/examples/passing/FunWithFunDeps.purs
@@ -23,11 +23,11 @@ instance natMultZ :: NatMult Z n Z
instance natMultS :: (NatMult m n r, NatPlus n r s) => NatMult (S m) n s
-- Foreign Vect
-foreign import data FVect :: * -> * -> *
+foreign import data FVect :: Type -> Type -> Type
foreign import fnil :: forall e. FVect Z e
foreign import fcons :: forall n e. e -> FVect n e -> FVect (S n) e
-foreign import fappend :: forall l r o e. (NatPlus l r o) => FVect l e -> FVect r e -> FVect o e
-foreign import fflatten :: forall f s t o. (NatMult f s o) => FVect f (FVect s t) -> FVect o t
+foreign import fappend :: forall l r o e. NatPlus l r o => FVect l e -> FVect r e -> FVect o e
+foreign import fflatten :: forall f s t o. NatMult f s o => FVect f (FVect s t) -> FVect o t
foreign import ftoArray :: forall n e. FVect n e -> Array e
-- should be able to figure these out
@@ -37,5 +37,5 @@ fexample2 = fexample `fappend` fexample `fappend` fexample
fexample3 = fsingleton fexample `fappend` fsingleton fexample `fappend` fsingleton fexample
fexample4 = fflatten fexample3
-
+
main = log "Done"
diff --git a/examples/passing/GenericsRep.purs b/examples/passing/GenericsRep.purs
index be75d86..b83537e 100644
--- a/examples/passing/GenericsRep.purs
+++ b/examples/passing/GenericsRep.purs
@@ -43,6 +43,13 @@ derive instance genericV :: Generic V _
instance eqV :: Eq V where
eq x y = genericEq x y
+newtype U = U {}
+
+derive instance genericU :: Generic U _
+
+instance eqU :: Eq U where
+ eq x y = genericEq x y
+
main :: Eff (console :: CONSOLE) Unit
main = do
logShow (X 0 == X 1)
@@ -52,4 +59,5 @@ main = do
logShow (Y == Y :: Y Z)
logShow (W { x: 0, y: "A" } == W { x: 0, y: "A" })
logShow (V { x: 0 } { x: 0 } == V { x: 0 } { x: 0 })
+ logShow (U {} == U {})
log "Done"
diff --git a/examples/passing/Guards.purs b/examples/passing/Guards.purs
index ddc7678..6f86d59 100644
--- a/examples/passing/Guards.purs
+++ b/examples/passing/Guards.purs
@@ -12,11 +12,11 @@ collatz2 = \x y -> case x of
z | y > 0.0 -> z / 2.0
z -> z * 3.0 + 1.0
-min :: forall a. (Ord a) => a -> a -> a
+min :: forall a. Ord a => a -> a -> a
min n m | n < m = n
| otherwise = m
-max :: forall a. (Ord a) => a -> a -> a
+max :: forall a. Ord a => a -> a -> a
max n m = case unit of
_ | m < n -> n
| otherwise -> m
@@ -27,4 +27,38 @@ testIndentation x y | x > 0.0
| otherwise
= y - x
+-- pattern guard example with two clauses
+clunky1 :: Int -> Int -> Int
+clunky1 a b | x <- max a b
+ , x > 5
+ = x
+clunky1 a _ = a
+
+clunky2 :: Int -> Int -> Int
+clunky2 a b | x <- max a b
+ , x > 5
+ = x
+ | otherwise
+ = a + b
+
+-- pattern guards on case epxressions
+clunky_case1 :: Int -> Int -> Int
+clunky_case1 a b =
+ case unit of
+ unit | x <- max a b
+ , x > 5
+ -> x
+ | otherwise -> a + b
+
+-- test indentation
+clunky_case2 :: Int -> Int -> Int
+clunky_case2 a b =
+ case unit of
+ unit
+ | x <- max a b
+ , x > 5
+ -> x
+ | otherwise
+ -> a + b
+
main = log $ min "Done" "ZZZZ"
diff --git a/examples/passing/KindedType.purs b/examples/passing/KindedType.purs
index 2a4959b..3abe512 100644
--- a/examples/passing/KindedType.purs
+++ b/examples/passing/KindedType.purs
@@ -3,9 +3,9 @@ module Main where
import Prelude
import Control.Monad.Eff.Console (log)
-type Star2Star f = f :: * -> *
+type Star2Star f = f :: Type -> Type
-type Star t = t :: *
+type Star t = t :: Type
test1 :: Star2Star Array String
test1 = ["test"]
@@ -15,17 +15,17 @@ f s = s
test2 = f "test"
-data Proxy (f :: * -> *) = Proxy
+data Proxy (f :: Type -> Type) = Proxy
test3 :: Proxy Array
test3 = Proxy
-type Test (f :: * -> *) = f String
+type Test (f :: Type -> Type) = f String
test4 :: Test Array
test4 = ["test"]
-class Clazz (a :: *) where
+class Clazz (a :: Type) where
def :: a
instance clazzString :: Clazz String where
diff --git a/examples/passing/LetPattern.purs b/examples/passing/LetPattern.purs
new file mode 100644
index 0000000..e823120
--- /dev/null
+++ b/examples/passing/LetPattern.purs
@@ -0,0 +1,196 @@
+module Main where
+
+import Prelude
+import Partial.Unsafe (unsafePartial)
+import Control.Monad.Eff (Eff)
+import Control.Monad.Eff.Console (CONSOLE, log)
+import Test.Assert (ASSERT, assert')
+
+patternSimple :: Boolean
+patternSimple =
+ let x = 25252
+ in
+ x == 25252
+
+patternDoSimple :: forall e. Eff e Boolean
+patternDoSimple = do
+ let x = 25252
+ pure $ x == 25252
+
+newtype X = X Int
+
+patternNewtype :: Boolean
+patternNewtype =
+ let X a = X 123
+ in
+ a == 123
+
+patternDoNewtype :: forall e. Eff e Boolean
+patternDoNewtype = do
+ let X a = X 123
+ pure $ a == 123
+
+data Y = Y Int String Boolean
+
+patternData :: Boolean
+patternData =
+ let Y a b c = Y 456 "hello, world" false
+ in
+ a == 456 && b == "hello, world" && not c
+
+patternDataIgnored :: Boolean
+patternDataIgnored =
+ let Y _ x _ = Y 789 "world, hello" true
+ in
+ x == "world, hello"
+
+patternDoData :: forall e. Eff e Boolean
+patternDoData = do
+ let Y a b c = Y 456 "hello, world" false
+ pure $ a == 456 && b == "hello, world" && not c
+
+patternDoDataIgnored :: forall e. Eff e Boolean
+patternDoDataIgnored = do
+ let Y _ x _ = Y 789 "world, hello" true
+ pure $ x == "world, hello"
+
+patternArray :: Boolean
+patternArray = unsafePartial $
+ let [a, b] = [1, 2]
+ in
+ a == 1 && b == 2
+
+patternDoArray :: forall e. Eff e Boolean
+patternDoArray = unsafePartial do
+ let [a, b] = [1, 2]
+ pure $ a == 1 && b == 2
+
+patternMultiple :: Boolean
+patternMultiple = unsafePartial $
+ let
+ x = 25252
+ X a = X x
+ Y b c d = Y x "hello, world" false
+ Y _ e _ = Y 789 "world, hello" true
+ [f, g] = [1, 2]
+ in
+ x == 25252 && a == 25252 && b == 25252 && c == "hello, world" &&
+ not d && e == "world, hello" && f == 1 && g == 2
+
+patternDoMultiple :: forall e. Eff e Boolean
+patternDoMultiple = unsafePartial do
+ let
+ x = 25252
+ X a = X x
+ Y b c d = Y x "hello, world" false
+ Y _ e _ = Y 789 "world, hello" true
+ [f, g] = [1, 2]
+ pure $ x == 25252 && a == 25252 && b == 25252 && c == "hello, world" &&
+ not d && e == "world, hello" && f == 1 && g == 2
+
+patternMultipleWithNormal :: Boolean
+patternMultipleWithNormal = unsafePartial $
+ let
+ x = 25252
+ X a = X x
+ y = 2525
+ Y b c d = Y y "hello, world" false
+ in
+ x == 25252 && y == 2525 &&
+ a == 25252 && b == 2525 && c == "hello, world" && not d
+
+patternDoMultipleWithNormal :: forall e. Eff e Boolean
+patternDoMultipleWithNormal = unsafePartial do
+ let
+ x = 25252
+ X a = X x
+ y = 2525
+ Y b c d = Y y "hello, world" false
+ pure $ x == 25252 && y == 2525 &&
+ a == 25252 && b == 2525 && c == "hello, world" && not d
+
+patternWithParens :: Boolean
+patternWithParens = unsafePartial $
+ let
+ (x) = 25252
+ (X a) = X x
+ (Y b c d) = Y x "hello, world" false
+ (Y _ e _) = Y 789 "world, hello" true
+ ([f, g]) = [1, 2]
+ in
+ x == 25252 && a == 25252 && b == 25252 && c == "hello, world" &&
+ not d && e == "world, hello" && f == 1 && g == 2
+
+patternDoWithParens :: forall e. Eff e Boolean
+patternDoWithParens = unsafePartial do
+ let
+ (x) = 25252
+ (X a) = X x
+ (Y b c d) = Y x "hello, world" false
+ (Y _ e _) = Y 789 "world, hello" true
+ ([f, g]) = [1, 2]
+ pure $ x == 25252 && a == 25252 && b == 25252 && c == "hello, world" &&
+ not d && e == "world, hello" && f == 1 && g == 2
+
+patternWithNamedBinder :: Boolean
+patternWithNamedBinder = unsafePartial $
+ let
+ a@{x, y} = {x: 10, y: 20}
+ in
+ a.x == 10 && x == 10 && a.y == 20 && y == 20
+
+patternDoWithNamedBinder :: forall e. Eff e Boolean
+patternDoWithNamedBinder = unsafePartial do
+ let
+ a@{x, y} = {x: 10, y: 20}
+ pure $
+ a.x == 10 && x == 10 && a.y == 20 && y == 20
+
+data List a = Nil | Cons a (List a)
+infixr 6 Cons as :
+
+instance eqList :: Eq a => Eq (List a) where
+ eq xs ys = go xs ys true
+ where
+ go _ _ false = false
+ go Nil Nil acc = acc
+ go (x : xs') (y : ys') acc = go xs' ys' $ acc && (y == x)
+ go _ _ _ = false
+
+patternWithInfixOp :: Boolean
+patternWithInfixOp = unsafePartial $
+ let
+ x : xs = 1 : 2 : 3 : 4 : Nil
+ in
+ x == 1 && xs == 2 : 3 : 4 : Nil
+
+patternDoWithInfixOp :: forall e. Eff e Boolean
+patternDoWithInfixOp = unsafePartial do
+ let
+ x : xs = 1 : 2 : 3 : 4 : Nil
+ pure $
+ x == 1 && xs == 2 : 3 : 4 : Nil
+
+main :: Eff (assert :: ASSERT, console :: CONSOLE) Unit
+main = do
+ assert' "simple variable pattern" patternSimple
+ assert' "simple variable pattern with do" =<< patternDoSimple
+ assert' "constructor pattern (newtype)" patternNewtype
+ assert' "constructor pattern (newtype) with do" =<< patternDoNewtype
+ assert' "constructor pattern (data)" patternData
+ assert' "constructor pattern with ignorances" patternDataIgnored
+ assert' "constructor pattern (data) with do" =<< patternDoData
+ assert' "constructor pattern with ignorances and do" =<< patternDoDataIgnored
+ assert' "array pattern" patternArray
+ assert' "array pattern with do" =<< patternDoArray
+ assert' "multiple patterns" patternMultiple
+ assert' "multiple patterns with do" =<< patternDoMultiple
+ assert' "multiple patterns with normal let's" patternMultipleWithNormal
+ assert' "multiple patterns with normal let's and do" =<< patternDoMultipleWithNormal
+ assert' "multiple patterns with parens" patternWithParens
+ assert' "multiple patterns with parens and do" =<< patternDoWithParens
+ assert' "multiple patterns with named binder" patternWithNamedBinder
+ assert' "multiple patterns with named binder and do" =<< patternDoWithNamedBinder
+ assert' "pattern with infix operator" patternWithInfixOp
+ assert' "pattern with infix operator and do" =<< patternDoWithInfixOp
+ log "Done"
diff --git a/examples/passing/MutRec2.purs b/examples/passing/MutRec2.purs
index 844f9fe..bac1237 100644
--- a/examples/passing/MutRec2.purs
+++ b/examples/passing/MutRec2.purs
@@ -7,7 +7,7 @@ data A = A B
data B = B A
-foreign import data S :: *
+foreign import data S :: Type
f :: A -> S
f a = case a of A b -> g b
diff --git a/examples/passing/MutRec3.purs b/examples/passing/MutRec3.purs
index 82a710f..ac22c69 100644
--- a/examples/passing/MutRec3.purs
+++ b/examples/passing/MutRec3.purs
@@ -7,7 +7,7 @@ data A = A B
data B = B A
-foreign import data S :: *
+foreign import data S :: Type
f a = case a of A b -> g b
diff --git a/examples/passing/NakedConstraint.purs b/examples/passing/NakedConstraint.purs
index f4b3a55..8ec2099 100644
--- a/examples/passing/NakedConstraint.purs
+++ b/examples/passing/NakedConstraint.purs
@@ -4,7 +4,7 @@ import Control.Monad.Eff.Console
data List a = Nil | Cons a (List a)
-head :: (Partial) => List Int -> Int
+head :: Partial => List Int -> Int
head (Cons x _) = x
main = log "Done"
diff --git a/examples/passing/NewtypeClass.purs b/examples/passing/NewtypeClass.purs
index 1352339..0e7c8a8 100644
--- a/examples/passing/NewtypeClass.purs
+++ b/examples/passing/NewtypeClass.purs
@@ -24,7 +24,8 @@ foldPair f (Pair a b) = f a <> f b
ala
:: forall f t a
- . (Functor f, Newtype t a)
+ . Functor f
+ => Newtype t a
=> (a -> t)
-> ((a -> t) -> f t)
-> f a
diff --git a/examples/passing/Operators.purs b/examples/passing/Operators.purs
index 835584a..aa6f24f 100644
--- a/examples/passing/Operators.purs
+++ b/examples/passing/Operators.purs
@@ -11,7 +11,7 @@ op1 x _ = x
infix 4 op1 as ?!
-test1 :: forall n. (Semiring n) => n -> n -> (n -> n -> n) -> n
+test1 :: forall n. Semiring n => n -> n -> (n -> n -> n) -> n
test1 x y z = x * y + z x y
test2 = (\x -> x.foo false) { foo : \_ -> 1.0 }
diff --git a/examples/passing/OverlappingInstances2.purs b/examples/passing/OverlappingInstances2.purs
index 9694cfa..6b6fb0a 100644
--- a/examples/passing/OverlappingInstances2.purs
+++ b/examples/passing/OverlappingInstances2.purs
@@ -1,27 +1,27 @@
-module Main where
-
-import Prelude
-import Control.Monad.Eff.Console (log)
-import Test.Assert (assert)
-
-data A = A | B
-
-instance eqA1 :: Eq A where
- eq A A = true
- eq B B = true
- eq _ _ = false
-
-instance eqA2 :: Eq A where
- eq _ _ = true
-
-instance ordA :: Ord A where
- compare A B = LT
- compare B A = GT
- compare _ _ = EQ
-
-test :: forall a. (Ord a) => a -> a -> String
-test x y = show $ x == y
-
-main = do
- assert $ test A B == "false"
- log "Done"
+module Main where
+
+import Prelude
+import Control.Monad.Eff.Console (log)
+import Test.Assert (assert)
+
+data A = A | B
+
+instance eqA1 :: Eq A where
+ eq A A = true
+ eq B B = true
+ eq _ _ = false
+
+instance eqA2 :: Eq A where
+ eq _ _ = true
+
+instance ordA :: Ord A where
+ compare A B = LT
+ compare B A = GT
+ compare _ _ = EQ
+
+test :: forall a. Ord a => a -> a -> String
+test x y = show $ x == y
+
+main = do
+ assert $ test A B == "false"
+ log "Done"
diff --git a/examples/passing/OverlappingInstances3.purs b/examples/passing/OverlappingInstances3.purs
index 14d9561..011c1f9 100644
--- a/examples/passing/OverlappingInstances3.purs
+++ b/examples/passing/OverlappingInstances3.purs
@@ -1,20 +1,20 @@
-module Main where
-
-import Prelude
-import Control.Monad.Eff.Console (log)
-import Test.Assert (assert)
-
-class Foo a
-
-instance foo1 :: Foo Number
-
-instance foo2 :: Foo Number
-
-test :: forall a. (Foo a) => a -> a
-test a = a
-
-test1 = test 0.0
-
-main = do
- assert (test1 == 0.0)
- log "Done"
+module Main where
+
+import Prelude
+import Control.Monad.Eff.Console (log)
+import Test.Assert (assert)
+
+class Foo a
+
+instance foo1 :: Foo Number
+
+instance foo2 :: Foo Number
+
+test :: forall a. Foo a => a -> a
+test a = a
+
+test1 = test 0.0
+
+main = do
+ assert (test1 == 0.0)
+ log "Done"
diff --git a/examples/passing/PrimedTypeName.purs b/examples/passing/PrimedTypeName.purs
index 5241c16..7b59c0b 100644
--- a/examples/passing/PrimedTypeName.purs
+++ b/examples/passing/PrimedTypeName.purs
@@ -1,20 +1,20 @@
-module Main (T, T', T'', T''', main) where
-
-import Prelude
-import Control.Monad.Eff.Console (log)
-
-data T a = T
-type T' = T Unit
-
-data T'' = TP
-
-foreign import data T''' ∷ *
-
-instance eqT ∷ Eq T'' where
- eq _ _ = true
-
-type A' a b = b → a
-
-infixr 4 type A' as ↫
-
-main = log "Done"
+module Main (T, T', T'', T''', main) where
+
+import Prelude
+import Control.Monad.Eff.Console (log)
+
+data T a = T
+type T' = T Unit
+
+data T'' = TP
+
+foreign import data T''' ∷ Type
+
+instance eqT ∷ Eq T'' where
+ eq _ _ = true
+
+type A' a b = b → a
+
+infixr 4 type A' as ↫
+
+main = log "Done"
diff --git a/examples/passing/Rank2TypeSynonym.purs b/examples/passing/Rank2TypeSynonym.purs
index e4b8ffe..3db194d 100644
--- a/examples/passing/Rank2TypeSynonym.purs
+++ b/examples/passing/Rank2TypeSynonym.purs
@@ -3,7 +3,7 @@ module Main where
import Prelude
import Control.Monad.Eff.Console (log, logShow)
-type Foo a = forall f. (Monad f) => f a
+type Foo a = forall f. Monad f => f a
foo :: forall a. a -> Foo a
foo x = pure x
diff --git a/examples/passing/RebindableSyntax.purs b/examples/passing/RebindableSyntax.purs
index 95303a8..b0a7cc3 100644
--- a/examples/passing/RebindableSyntax.purs
+++ b/examples/passing/RebindableSyntax.purs
@@ -1,43 +1,43 @@
-module Main where
-
-import Prelude
-import Control.Monad.Eff.Console (log)
-
-example1 :: String
-example1 = do
- "Do"
- " notation"
- " for"
- " Semigroup"
- where
- bind x f = x <> f unit
-
-applySecond :: forall f a b. (Apply f) => f a -> f b -> f b
-applySecond fa fb = const id <$> fa <*> fb
-
-infixl 4 applySecond as *>
-
-newtype Const a b = Const a
-
-runConst :: forall a b. Const a b -> a
-runConst (Const a) = a
-
-instance functorConst :: Functor (Const a) where
- map _ (Const a) = Const a
-
-instance applyConst :: (Semigroup a) => Apply (Const a) where
- apply (Const a1) (Const a2) = Const (a1 <> a2)
-
-example2 :: Const String Unit
-example2 = do
- Const "Do"
- Const " notation"
- Const " for"
- Const " Apply"
- where
- bind x f = x *> f unit
-
-main = do
- log example1
- log $ runConst example2
- log "Done"
+module Main where
+
+import Prelude
+import Control.Monad.Eff.Console (log)
+
+example1 :: String
+example1 = do
+ "Do"
+ " notation"
+ " for"
+ " Semigroup"
+ where
+ discard x f = x <> f unit
+
+applySecond :: forall f a b. Apply f => f a -> f b -> f b
+applySecond fa fb = const id <$> fa <*> fb
+
+infixl 4 applySecond as *>
+
+newtype Const a b = Const a
+
+runConst :: forall a b. Const a b -> a
+runConst (Const a) = a
+
+instance functorConst :: Functor (Const a) where
+ map _ (Const a) = Const a
+
+instance applyConst :: Semigroup a => Apply (Const a) where
+ apply (Const a1) (Const a2) = Const (a1 <> a2)
+
+example2 :: Const String Unit
+example2 = do
+ Const "Do"
+ Const " notation"
+ Const " for"
+ Const " Apply"
+ where
+ discard x f = x *> f unit
+
+main = do
+ log example1
+ log $ runConst example2
+ log "Done"
diff --git a/examples/passing/RowPolyInstanceContext.purs b/examples/passing/RowPolyInstanceContext.purs
index caefb72..796adef 100644
--- a/examples/passing/RowPolyInstanceContext.purs
+++ b/examples/passing/RowPolyInstanceContext.purs
@@ -14,7 +14,7 @@ instance st :: T s (S s) where
test1 :: forall r . S { foo :: String | r } Unit
test1 = state $ \o -> o { foo = o.foo <> "!" }
-test2 :: forall m r . (T { foo :: String | r } m) => m Unit
+test2 :: forall m r . T { foo :: String | r } m => m Unit
test2 = state $ \o -> o { foo = o.foo <> "!" }
main = do
diff --git a/examples/passing/RowUnion.js b/examples/passing/RowUnion.js
new file mode 100644
index 0000000..c002b18
--- /dev/null
+++ b/examples/passing/RowUnion.js
@@ -0,0 +1,10 @@
+"use strict";
+
+exports.merge = function (dict) {
+ return function (l) {
+ return function (r) {
+ var o = {};
+ return Object.assign(o, r, l);
+ };
+ };
+};
diff --git a/examples/passing/RowUnion.purs b/examples/passing/RowUnion.purs
new file mode 100644
index 0000000..57a47e6
--- /dev/null
+++ b/examples/passing/RowUnion.purs
@@ -0,0 +1,68 @@
+module Main where
+
+import Prelude
+import Control.Monad.Eff
+import Control.Monad.Eff.Console
+
+foreign import merge
+ :: forall r1 r2 r3
+ . Union r1 r2 r3
+ => Record r1
+ -> Record r2
+ -> Record r3
+
+test1 = merge { x: 1 } { y: true }
+
+test2 = merge { x: 1 } { x: true }
+
+mergeWithExtras
+ :: forall r1 r2 r3
+ . Union r1 (y :: Boolean | r2) (y :: Boolean | r3)
+ => { x :: Int | r1 }
+ -> { y :: Boolean | r2 }
+ -> { x :: Int, y :: Boolean | r3}
+mergeWithExtras = merge
+
+test3 x = merge { x: 1 } x
+test3' x = merge x { x: 1 }
+
+type Mandatory r = (x :: Int | r)
+type Optional r = (x :: Int, y :: Int, z :: Int | r)
+
+withDefaults
+ :: forall r s
+ . Union r (y :: Int, z :: Int) (y :: Int, z :: Int | s)
+ => Record (Mandatory r)
+ -> Record (Optional s)
+withDefaults p = merge p { y: 1, z: 1 }
+
+withDefaultsClosed
+ :: forall r s
+ . Union r (y :: Int, z :: Int) (y :: Int, z :: Int | s)
+ => Subrow s (y :: Int, z :: Int)
+ => Record (Mandatory r)
+ -> Record (Optional s)
+withDefaultsClosed p = merge p { y: 1, z: 1 }
+
+test4 = withDefaults { x: 1, y: 2 }
+
+-- r is a subrow of s if Union r t s for some t.
+class Subrow (r :: # Type) (s :: # Type)
+instance subrow :: Union r t s => Subrow r s
+
+main :: Eff (console :: CONSOLE) Unit
+main = do
+ logShow test1.x
+ logShow test1.y
+ logShow (test1.x == 1)
+ logShow (mergeWithExtras { x: 1 } { x: 0, y: true, z: 42.0 }).x
+ logShow (withDefaults { x: 1 }).x
+ logShow (withDefaults { x: 1 }).y
+ logShow (withDefaults { x: 1 }).z
+ logShow (withDefaults { x: 1, y: 2 }).x
+ logShow (withDefaults { x: 1, y: 2 }).y
+ logShow (withDefaults { x: 1, y: 2 }).z
+ logShow (withDefaultsClosed { x: 1, y: 2 }).x
+ logShow (withDefaultsClosed { x: 1, y: 2 }).y
+ logShow (withDefaultsClosed { x: 1, y: 2 }).z
+ log "Done"
diff --git a/examples/passing/Sequence.purs b/examples/passing/Sequence.purs
index c6ba367..37febf1 100644
--- a/examples/passing/Sequence.purs
+++ b/examples/passing/Sequence.purs
@@ -7,7 +7,7 @@ import Control.Monad.Eff.Console (log)
data List a = Cons a (List a) | Nil
class Sequence t where
- sequence :: forall m a. (Monad m) => t (m a) -> m (t a)
+ sequence :: forall m a. Monad m => t (m a) -> m (t a)
instance sequenceList :: Sequence List where
sequence Nil = pure Nil
diff --git a/examples/passing/SequenceDesugared.purs b/examples/passing/SequenceDesugared.purs
index f4ea3d1..9268a27 100644
--- a/examples/passing/SequenceDesugared.purs
+++ b/examples/passing/SequenceDesugared.purs
@@ -6,12 +6,12 @@ import Control.Monad.Eff.Console (log)
data List a = Cons a (List a) | Nil
-data Sequence t = Sequence (forall m a. (Monad m) => t (m a) -> m (t a))
+data Sequence t = Sequence (forall m a. Monad m => t (m a) -> m (t a))
-sequence :: forall t. Sequence t -> (forall m a. (Monad m) => t (m a) -> m (t a))
+sequence :: forall t. Sequence t -> (forall m a. Monad m => t (m a) -> m (t a))
sequence (Sequence s) = s
-sequenceListSeq :: forall m a. (Monad m) => List (m a) -> m (List a)
+sequenceListSeq :: forall m a. Monad m => List (m a) -> m (List a)
sequenceListSeq Nil = pure Nil
sequenceListSeq (Cons x xs) = Cons <$> x <*> sequenceListSeq xs
@@ -24,15 +24,15 @@ sequenceList' = Sequence ((\val -> case val of
Cons x xs -> Cons <$> x <*> sequence sequenceList' xs))
sequenceList'' :: Sequence List
-sequenceList'' = Sequence (sequenceListSeq :: forall m a. (Monad m) => List (m a) -> m (List a))
+sequenceList'' = Sequence (sequenceListSeq :: forall m a. Monad m => List (m a) -> m (List a))
sequenceList''' :: Sequence List
sequenceList''' = Sequence ((\val -> case val of
Nil -> pure Nil
- Cons x xs -> Cons <$> x <*> sequence sequenceList''' xs) :: forall m a. (Monad m) => List (m a) -> m (List a))
+ Cons x xs -> Cons <$> x <*> sequence sequenceList''' xs) :: forall m a. Monad m => List (m a) -> m (List a))
main = do
- sequence sequenceList $ Cons (log "Done") Nil
- sequence sequenceList' $ Cons (log "Done") Nil
- sequence sequenceList'' $ Cons (log "Done") Nil
- sequence sequenceList''' $ Cons (log "Done") Nil
+ void $ sequence sequenceList $ Cons (log "Done") Nil
+ void $ sequence sequenceList' $ Cons (log "Done") Nil
+ void $ sequence sequenceList'' $ Cons (log "Done") Nil
+ void $ sequence sequenceList''' $ Cons (log "Done") Nil
diff --git a/examples/passing/StringEscapes.purs b/examples/passing/StringEscapes.purs
index 9fbcab2..7d0732b 100644
--- a/examples/passing/StringEscapes.purs
+++ b/examples/passing/StringEscapes.purs
@@ -1,26 +1,26 @@
-module Main where
-
-import Prelude ((==), (/=), (<>), bind)
-import Test.Assert (assert, assert')
-import Control.Monad.Eff.Console (log)
-
-singleCharacter = "\0\b\t\n\v\f\r\"\\" == "\x0\x8\x9\xA\xB\xC\xD\x22\x5C"
-hex = "\x1D306\x2603\x3C6\xE0\x0" == "𝌆☃φà\0"
-decimal = "\119558\9731\966\224\0" == "𝌆☃φà\0"
-surrogatePair = "\xD834\xDF06" == "\x1D306"
-highSurrogate = "\xD834"
-lowSurrogate = "\xDF06"
-loneSurrogates = (highSurrogate <> lowSurrogate) == "\x1D306"
-outOfOrderSurrogates = (lowSurrogate <> highSurrogate) == "\xDF06\xD834"
-replacement = "\xFFFD"
-notReplacing = replacement /= highSurrogate
-
-main = do
- assert' "single-character escape sequences" singleCharacter
- assert' "hex escape sequences" hex
- assert' "decimal escape sequences" decimal
- assert' "astral code points are represented as a UTF-16 surrogate pair" surrogatePair
- assert' "lone surrogates may be combined into a surrogate pair" loneSurrogates
- assert' "lone surrogates may be combined out of order to remain lone surrogates" outOfOrderSurrogates
- assert' "lone surrogates are not replaced with the Unicode replacement character U+FFFD" notReplacing
- log "Done"
+module Main where
+
+import Prelude ((==), (/=), (<>), discard)
+import Test.Assert (assert, assert')
+import Control.Monad.Eff.Console (log)
+
+singleCharacter = "\0\b\t\n\v\f\r\"\\" == "\x0\x8\x9\xA\xB\xC\xD\x22\x5C"
+hex = "\x1D306\x2603\x3C6\xE0\x0" == "𝌆☃φà\0"
+decimal = "\119558\9731\966\224\0" == "𝌆☃φà\0"
+surrogatePair = "\xD834\xDF06" == "\x1D306"
+highSurrogate = "\xD834"
+lowSurrogate = "\xDF06"
+loneSurrogates = (highSurrogate <> lowSurrogate) == "\x1D306"
+outOfOrderSurrogates = (lowSurrogate <> highSurrogate) == "\xDF06\xD834"
+replacement = "\xFFFD"
+notReplacing = replacement /= highSurrogate
+
+main = do
+ assert' "single-character escape sequences" singleCharacter
+ assert' "hex escape sequences" hex
+ assert' "decimal escape sequences" decimal
+ assert' "astral code points are represented as a UTF-16 surrogate pair" surrogatePair
+ assert' "lone surrogates may be combined into a surrogate pair" loneSurrogates
+ assert' "lone surrogates may be combined out of order to remain lone surrogates" outOfOrderSurrogates
+ assert' "lone surrogates are not replaced with the Unicode replacement character U+FFFD" notReplacing
+ log "Done"
diff --git a/examples/passing/Superclasses1.purs b/examples/passing/Superclasses1.purs
index 342f9ac..4f00c1f 100644
--- a/examples/passing/Superclasses1.purs
+++ b/examples/passing/Superclasses1.purs
@@ -15,7 +15,7 @@ instance suNumber :: Su Number where
instance clNumber :: Cl Number where
cl n m = n + m
-test :: forall a. (Cl a) => a -> a
+test :: forall a. Cl a => a -> a
test a = su (cl a a)
main = do
diff --git a/examples/passing/Superclasses3.purs b/examples/passing/Superclasses3.purs
index 1419864..8115fb2 100644
--- a/examples/passing/Superclasses3.purs
+++ b/examples/passing/Superclasses3.purs
@@ -4,13 +4,13 @@ import Prelude
import Control.Monad.Eff.Console
import Control.Monad.Eff
-class (Monad m) <= MonadWriter w m where
+class Monad m <= MonadWriter w m where
tell :: w -> m Unit
-testFunctor :: forall m. (Monad m) => m Number -> m Number
+testFunctor :: forall m. Monad m => m Number -> m Number
testFunctor n = (+) 1.0 <$> n
-test :: forall w m. (Monad m, MonadWriter w m) => w -> m Unit
+test :: forall w m. Monad m => MonadWriter w m => w -> m Unit
test w = do
tell w
tell w
diff --git a/examples/passing/TypeClasses.purs b/examples/passing/TypeClasses.purs
index b65d93d..2a52bac 100644
--- a/examples/passing/TypeClasses.purs
+++ b/examples/passing/TypeClasses.purs
@@ -5,19 +5,19 @@ import Control.Monad.Eff.Console (log)
test1 = \_ -> show "testing"
-f :: forall a. (Show a) => a -> String
+f :: forall a. Show a => a -> String
f x = show x
test2 = \_ -> f "testing"
-test7 :: forall a. (Show a) => a -> String
+test7 :: forall a. Show a => a -> String
test7 = show
test8 = \_ -> show $ "testing"
data Data a = Data a
-instance showData :: (Show a) => Show (Data a) where
+instance showData :: Show a => Show (Data a) where
show (Data a) = "Data (" <> show a <> ")"
test3 = \_ -> show (Data "testing")
@@ -53,7 +53,7 @@ instance bindMaybe :: Bind Maybe where
instance monadMaybe :: Monad Maybe
-test4 :: forall a m. (Monad m) => a -> m Number
+test4 :: forall a m. Monad m => a -> m Number
test4 = \_ -> pure 1.0
test5 = \_ -> Just 1.0 >>= \n -> pure (n + 1.0)
diff --git a/examples/passing/TypeWildcards.purs b/examples/passing/TypeWildcards.purs
index df9e3fd..262cf2c 100644
--- a/examples/passing/TypeWildcards.purs
+++ b/examples/passing/TypeWildcards.purs
@@ -6,7 +6,7 @@ import Control.Monad.Eff.Console (log)
testTopLevel :: _ -> _
testTopLevel n = n + 1.0
-test :: forall a. (Eq a) => (a -> a) -> a -> a
+test :: forall a. Eq a => (a -> a) -> a -> a
test f a = go (f a) a
where
go :: _ -> _ -> _
diff --git a/examples/passing/TypedBinders.purs b/examples/passing/TypedBinders.purs
index 2d3da7c..92e50b6 100644
--- a/examples/passing/TypedBinders.purs
+++ b/examples/passing/TypedBinders.purs
@@ -7,7 +7,7 @@ data Tuple a b = Tuple a b
class MonadState s m where
get :: m s
- put :: s -> m {}
+ put :: s -> m Unit
data State s a = State (s -> Tuple s a)
@@ -30,9 +30,9 @@ instance monadState :: Monad (State s)
instance monadStateState :: MonadState s (State s) where
get = State (\s -> Tuple s s)
- put s = State (\_ -> Tuple s {})
+ put s = State (\_ -> Tuple s unit)
-modify :: forall m s. (Monad m, MonadState s m) => (s -> s) -> m {}
+modify :: forall m s. Monad m => MonadState s m => (s -> s) -> m Unit
modify f = do
s <- get
put (f s)
diff --git a/examples/passing/UnicodeType.purs b/examples/passing/UnicodeType.purs
index 59e732f..ea92525 100644
--- a/examples/passing/UnicodeType.purs
+++ b/examples/passing/UnicodeType.purs
@@ -4,10 +4,10 @@ import Prelude
import Control.Monad.Eff.Console (log)
class Monad m ⇐ Monad1 m where
- f1 :: Int
+ f1 :: m Int
class Monad m <= Monad2 m where
- f2 :: Int
+ f2 :: m Int
f ∷ ∀ m. Monad m ⇒ Int → m Int
f n = do
diff --git a/examples/passing/UnifyInTypeInstanceLookup.purs b/examples/passing/UnifyInTypeInstanceLookup.purs
index a1920b8..b235a83 100644
--- a/examples/passing/UnifyInTypeInstanceLookup.purs
+++ b/examples/passing/UnifyInTypeInstanceLookup.purs
@@ -12,13 +12,13 @@ class EQ x y b
instance eqT :: EQ x x T
instance eqF :: EQ x y F
-test :: forall a b. (EQ a b T) => a -> b -> a
+test :: forall a b. EQ a b T => a -> b -> a
test a _ = a
spin :: forall a b. a -> b
spin a = spin a
--- Expected type:
+-- Expected type:
-- forall t. (EQ t (S Z) T) => t
test1 = test (spin 1) (S Z)
diff --git a/examples/passing/UnknownInTypeClassLookup.purs b/examples/passing/UnknownInTypeClassLookup.purs
index 7ba6806..8b90b1f 100644
--- a/examples/passing/UnknownInTypeClassLookup.purs
+++ b/examples/passing/UnknownInTypeClassLookup.purs
@@ -7,7 +7,7 @@ class EQ a b
instance eqAA :: EQ a a
-test :: forall a b. (EQ a b) => a -> b -> String
+test :: forall a b. EQ a b => a -> b -> String
test _ _ = "Done"
runTest a = test a a
diff --git a/examples/passing/UsableTypeClassMethods.purs b/examples/passing/UsableTypeClassMethods.purs
new file mode 100644
index 0000000..5545ded
--- /dev/null
+++ b/examples/passing/UsableTypeClassMethods.purs
@@ -0,0 +1,35 @@
+-- this is testing that we don't see an `UnusableDeclaration` error for type
+-- class methods that should be valid based on various configurations of fundeps
+module Main where
+
+import Control.Monad.Eff.Console (log)
+
+-- no fundeps
+class C0 a b where
+ c0 :: a -> b
+
+-- simple fundep
+class C1 a b | a -> b where
+ c1 :: a
+ c1' :: a -> b
+
+-- transitive
+class C2 a b c | a -> b, b -> c where
+ c2 :: a
+ c2' :: a -> b
+ c2'' :: a -> c
+ c2''' :: a -> b -> c
+
+-- with cycles
+class C3 a b c | a -> b, b -> a, b -> c where
+ c3 :: a
+ c3' :: b
+ c3'' :: a -> c
+ c3''' :: b -> c
+ c3'''' :: a -> b -> c
+
+-- nullary class
+class C4 where
+ c4 :: forall a. a
+
+main = log "Done"
diff --git a/examples/warning/ShadowedBinderPatternGuard.purs b/examples/warning/ShadowedBinderPatternGuard.purs
new file mode 100644
index 0000000..f4bb85d
--- /dev/null
+++ b/examples/warning/ShadowedBinderPatternGuard.purs
@@ -0,0 +1,7 @@
+-- @shouldWarnWith ShadowedName
+module Main where
+
+f :: Int -> Int
+f n | i <- true -- this i is shadowed
+ , i <- 1234
+ = i \ No newline at end of file
diff --git a/examples/warning/ShadowedNameParens.purs b/examples/warning/ShadowedNameParens.purs
new file mode 100644
index 0000000..9241f68
--- /dev/null
+++ b/examples/warning/ShadowedNameParens.purs
@@ -0,0 +1,5 @@
+-- @shouldWarnWith ShadowedName
+module Main where
+
+f :: Int -> Int -> Int
+f n = \(n) -> 1
diff --git a/psc-ide-client/Main.hs b/psc-ide-client/Main.hs
deleted file mode 100644
index 8d47074..0000000
--- a/psc-ide-client/Main.hs
+++ /dev/null
@@ -1,50 +0,0 @@
-module Main where
-
-import Prelude ()
-import Prelude.Compat
-
-import Control.Exception
-import qualified Data.ByteString.Char8 as BS8
-import qualified Data.Text.IO as T
-import Data.Version (showVersion)
-import Data.Monoid ((<>))
-import Network
-import Options.Applicative (ParseError (..))
-import qualified Options.Applicative as Opts
-import System.Exit
-import System.IO
-
-import qualified Paths_purescript as Paths
-
-data Options = Options
- { optionsPort :: PortID
- }
-
-main :: IO ()
-main = do
- Options port <- Opts.execParser opts
- client port
- where
- parser =
- Options <$>
- (PortNumber . fromIntegral <$>
- Opts.option Opts.auto (Opts.long "port" <> Opts.short 'p' <> Opts.value (4242 :: Integer)))
- opts = Opts.info (version <*> Opts.helper <*> parser) mempty
- version = Opts.abortOption (InfoMsg (showVersion Paths.version)) $
- Opts.long "version" <> Opts.help "Show the version number" <> Opts.hidden
-
-client :: PortID -> IO ()
-client port = do
- hSetEncoding stdin utf8
- hSetEncoding stdout utf8
- h <-
- connectTo "127.0.0.1" port `catch`
- (\(SomeException e) ->
- putStrLn
- ("Couldn't connect to psc-ide-server on port: " ++
- show port ++ " Error: " ++ show e) >>
- exitFailure)
- T.hPutStrLn h =<< T.getLine
- BS8.putStrLn =<< BS8.hGetLine h
- hFlush stdout
- hClose h
diff --git a/psc-package/Main.hs b/psc-package/Main.hs
deleted file mode 100644
index 897515b..0000000
--- a/psc-package/Main.hs
+++ /dev/null
@@ -1,423 +0,0 @@
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE TupleSections #-}
-
-module Main where
-
-import qualified Control.Foldl as Foldl
-import qualified Data.Aeson as Aeson
-import Data.Aeson.Encode.Pretty
-import Data.Foldable (fold, for_, traverse_)
-import Data.List (nub)
-import qualified Data.Map as Map
-import Data.Maybe (fromMaybe, mapMaybe)
-import qualified Data.Set as Set
-import Data.Text (pack)
-import qualified Data.Text as T
-import Data.Text.Encoding (encodeUtf8)
-import qualified Data.Text.Lazy as TL
-import qualified Data.Text.Lazy.Builder as TB
-import qualified Data.Text.Read as TR
-import Data.Traversable (for)
-import Data.Version (showVersion)
-import qualified Filesystem.Path.CurrentOS as Path
-import GHC.Generics (Generic)
-import qualified Options.Applicative as Opts
-import qualified Paths_purescript as Paths
-import qualified System.IO as IO
-import Turtle hiding (echo, fold, s, x)
-import qualified Turtle
-
-echoT :: Text -> IO ()
-echoT = Turtle.printf (Turtle.s % "\n")
-
-packageFile :: Path.FilePath
-packageFile = "psc-package.json"
-
-data PackageConfig = PackageConfig
- { name :: Text
- , depends :: [Text]
- , set :: Text
- , source :: Text
- } deriving (Show, Generic, Aeson.FromJSON, Aeson.ToJSON)
-
-pathToTextUnsafe :: Turtle.FilePath -> Text
-pathToTextUnsafe = either (error "Path.toText failed") id . Path.toText
-
-defaultPackage :: Text -> PackageConfig
-defaultPackage pkgName =
- PackageConfig { name = pkgName
- , depends = [ "prelude" ]
- , set = "psc-" <> pack (showVersion Paths.version)
- , source = "https://github.com/purescript/package-sets.git"
- }
-
-readPackageFile :: IO PackageConfig
-readPackageFile = do
- exists <- testfile packageFile
- unless exists $ do
- echoT "psc-package.json does not exist"
- exit (ExitFailure 1)
- mpkg <- Aeson.decodeStrict . encodeUtf8 <$> readTextFile packageFile
- case mpkg of
- Nothing -> do
- echoT "Unable to parse psc-package.json"
- exit (ExitFailure 1)
- Just pkg -> return pkg
-
-packageConfigToJSON :: PackageConfig -> Text
-packageConfigToJSON =
- TL.toStrict
- . TB.toLazyText
- . encodePrettyToTextBuilder' config
- where
- config = defConfig
- { confCompare =
- keyOrder [ "name"
- , "set"
- , "source"
- , "depends"
- ]
- }
-
-packageSetToJSON :: PackageSet -> Text
-packageSetToJSON =
- TL.toStrict
- . TB.toLazyText
- . encodePrettyToTextBuilder' config
- where
- config = defConfig { confCompare = compare }
-
-writePackageFile :: PackageConfig -> IO ()
-writePackageFile =
- writeTextFile packageFile
- . packageConfigToJSON
-
-data PackageInfo = PackageInfo
- { repo :: Text
- , version :: Text
- , dependencies :: [Text]
- } deriving (Show, Eq, Generic, Aeson.FromJSON, Aeson.ToJSON)
-
-type PackageSet = Map.Map Text PackageInfo
-
-cloneShallow
- :: Text
- -- ^ repo
- -> Text
- -- ^ branch/tag
- -> Turtle.FilePath
- -- ^ target directory
- -> IO ExitCode
-cloneShallow from ref into =
- proc "git"
- [ "clone"
- , "-q"
- , "-c", "advice.detachedHead=false"
- , "--depth", "1"
- , "-b", ref
- , from
- , pathToTextUnsafe into
- ] empty .||. exit (ExitFailure 1)
-
-listRemoteTags
- :: Text
- -- ^ repo
- -> Turtle.Shell Text
-listRemoteTags from = let gitProc = inproc "git"
- [ "ls-remote"
- , "-q"
- , "-t"
- , from
- ] empty
- in lineToText <$> gitProc
-
-getPackageSet :: PackageConfig -> IO ()
-getPackageSet PackageConfig{ source, set } = do
- let pkgDir = ".psc-package" </> fromText set </> ".set"
- exists <- testdir pkgDir
- unless exists . void $ cloneShallow source set pkgDir
-
-readPackageSet :: PackageConfig -> IO PackageSet
-readPackageSet PackageConfig{ set } = do
- let dbFile = ".psc-package" </> fromText set </> ".set" </> "packages.json"
- exists <- testfile dbFile
- unless exists $ do
- echoT $ format (fp%" does not exist") dbFile
- exit (ExitFailure 1)
- mdb <- Aeson.decodeStrict . encodeUtf8 <$> readTextFile dbFile
- case mdb of
- Nothing -> do
- echoT "Unable to parse packages.json"
- exit (ExitFailure 1)
- Just db -> return db
-
-writePackageSet :: PackageConfig -> PackageSet -> IO ()
-writePackageSet PackageConfig{ set } =
- let dbFile = ".psc-package" </> fromText set </> ".set" </> "packages.json"
- in writeTextFile dbFile . packageSetToJSON
-
-installOrUpdate :: Text -> Text -> PackageInfo -> IO Turtle.FilePath
-installOrUpdate set pkgName PackageInfo{ repo, version } = do
- echoT ("Updating " <> pkgName)
- let pkgDir = ".psc-package" </> fromText set </> fromText pkgName </> fromText version
- exists <- testdir pkgDir
- unless exists . void $ cloneShallow repo version pkgDir
- pure pkgDir
-
-getTransitiveDeps :: PackageSet -> [Text] -> IO [(Text, PackageInfo)]
-getTransitiveDeps db depends = do
- pkgs <- for depends $ \pkg ->
- case Map.lookup pkg db of
- Nothing -> do
- echoT ("Package " <> pkg <> " does not exist in package set")
- exit (ExitFailure 1)
- Just PackageInfo{ dependencies } -> return (pkg : dependencies)
- let unique = Set.toList (foldMap Set.fromList pkgs)
- return (mapMaybe (\name -> fmap (name, ) (Map.lookup name db)) unique)
-
-updateImpl :: PackageConfig -> IO ()
-updateImpl config@PackageConfig{ depends } = do
- getPackageSet config
- db <- readPackageSet config
- trans <- getTransitiveDeps db depends
- echoT ("Updating " <> pack (show (length trans)) <> " packages...")
- for_ trans $ \(pkgName, pkg) -> installOrUpdate (set config) pkgName pkg
-
-initialize :: IO ()
-initialize = do
- exists <- testfile "psc-package.json"
- when exists $ do
- echoT "psc-package.json already exists"
- exit (ExitFailure 1)
- echoT "Initializing new project in current directory"
- pkgName <- pathToTextUnsafe . Path.filename <$> pwd
- let pkg = defaultPackage pkgName
- writePackageFile pkg
- updateImpl pkg
-
-update :: IO ()
-update = do
- pkg <- readPackageFile
- updateImpl pkg
- echoT "Update complete"
-
-install :: String -> IO ()
-install pkgName = do
- pkg <- readPackageFile
- let pkg' = pkg { depends = nub (pack pkgName : depends pkg) }
- updateImpl pkg'
- writePackageFile pkg'
- echoT "psc-package.json file was updated"
-
-uninstall :: String -> IO ()
-uninstall pkgName = do
- pkg <- readPackageFile
- let pkg' = pkg { depends = filter (/= pack pkgName) $ depends pkg }
- updateImpl pkg'
- writePackageFile pkg'
- echoT "psc-package.json file was updated"
-
-listDependencies :: IO ()
-listDependencies = do
- pkg@PackageConfig{ depends } <- readPackageFile
- db <- readPackageSet pkg
- trans <- getTransitiveDeps db depends
- traverse_ (echoT . fst) trans
-
-listPackages :: IO ()
-listPackages = do
- pkg <- readPackageFile
- db <- readPackageSet pkg
- traverse_ echoT (fmt <$> Map.assocs db)
- where
- fmt :: (Text, PackageInfo) -> Text
- fmt (name, PackageInfo{ version }) = name <> " (" <> version <> ")"
-
-getSourcePaths :: PackageConfig -> PackageSet -> [Text] -> IO [Turtle.FilePath]
-getSourcePaths PackageConfig{..} db pkgNames = do
- trans <- getTransitiveDeps db pkgNames
- let paths = [ ".psc-package"
- </> fromText set
- </> fromText pkgName
- </> fromText version
- </> "src" </> "**" </> "*.purs"
- | (pkgName, PackageInfo{ version }) <- trans
- ]
- return paths
-
-listSourcePaths :: IO ()
-listSourcePaths = do
- pkg@PackageConfig{ depends } <- readPackageFile
- db <- readPackageSet pkg
- paths <- getSourcePaths pkg db depends
- traverse_ (echoT . pathToTextUnsafe) paths
-
-exec :: Text -> IO ()
-exec exeName = do
- pkg@PackageConfig{..} <- readPackageFile
- db <- readPackageSet pkg
- paths <- getSourcePaths pkg db depends
- procs exeName
- (map pathToTextUnsafe ("src" </> "**" </> "*.purs" : paths))
- empty
-
-checkForUpdates :: Bool -> Bool -> IO ()
-checkForUpdates applyMinorUpdates applyMajorUpdates = do
- pkg <- readPackageFile
- db <- readPackageSet pkg
-
- echoT ("Checking " <> pack (show (Map.size db)) <> " packages for updates.")
- echoT "Warning: this could take some time!"
-
- newDb <- Map.fromList <$> (for (Map.toList db) $ \(name, p@PackageInfo{ repo, version }) -> do
- echoT ("Checking package " <> name)
- tagLines <- Turtle.fold (listRemoteTags repo) Foldl.list
- let tags = mapMaybe parseTag tagLines
- newVersion <- case parseVersion version of
- Just parts ->
- let applyMinor =
- case filter (isMinorReleaseFrom parts) tags of
- [] -> pure version
- minorReleases -> do
- echoT ("New minor release available")
- case applyMinorUpdates of
- True -> do
- let latestMinorRelease = maximum minorReleases
- pure ("v" <> T.intercalate "." (map (pack . show) latestMinorRelease))
- False -> pure version
- applyMajor =
- case filter (isMajorReleaseFrom parts) tags of
- [] -> applyMinor
- newReleases -> do
- echoT ("New major release available")
- case applyMajorUpdates of
- True -> do
- let latestRelease = maximum newReleases
- pure ("v" <> T.intercalate "." (map (pack . show) latestRelease))
- False -> applyMinor
- in applyMajor
- _ -> do
- echoT "Unable to parse version string"
- pure version
- pure (name, p { version = newVersion }))
-
- when (applyMinorUpdates || applyMajorUpdates)
- (writePackageSet pkg newDb)
- where
- parseTag :: Text -> Maybe [Int]
- parseTag line =
- case T.splitOn "\t" line of
- [_sha, ref] ->
- case T.stripPrefix "refs/tags/" ref of
- Just tag ->
- case parseVersion tag of
- Just parts -> pure parts
- _ -> Nothing
- _ -> Nothing
- _ -> Nothing
-
- parseVersion :: Text -> Maybe [Int]
- parseVersion ref =
- case T.stripPrefix "v" ref of
- Just tag ->
- traverse parseDecimal (T.splitOn "." tag)
- _ -> Nothing
-
- parseDecimal :: Text -> Maybe Int
- parseDecimal s =
- case TR.decimal s of
- Right (n, "") -> Just n
- _ -> Nothing
-
- isMajorReleaseFrom :: [Int] -> [Int] -> Bool
- isMajorReleaseFrom (0 : xs) (0 : ys) = isMajorReleaseFrom xs ys
- isMajorReleaseFrom (x : _) (y : _) = y > x
- isMajorReleaseFrom _ _ = False
-
- isMinorReleaseFrom :: [Int] -> [Int] -> Bool
- isMinorReleaseFrom (0 : xs) (0 : ys) = isMinorReleaseFrom xs ys
- isMinorReleaseFrom (x : xs) (y : ys) = y == x && ys > xs
- isMinorReleaseFrom _ _ = False
-
-verifyPackageSet :: IO ()
-verifyPackageSet = do
- pkg <- readPackageFile
- db <- readPackageSet pkg
-
- echoT ("Verifying " <> pack (show (Map.size db)) <> " packages.")
- echoT "Warning: this could take some time!"
-
- let installOrUpdate' (name, pkgInfo) = (name, ) <$> installOrUpdate (set pkg) name pkgInfo
- paths <- Map.fromList <$> traverse installOrUpdate' (Map.toList db)
-
- for_ (Map.toList db) $ \(name, PackageInfo{..}) -> do
- let dirFor = fromMaybe (error "verifyPackageSet: no directory") . (`Map.lookup` paths)
- echoT ("Verifying package " <> name)
- let srcGlobs = map (pathToTextUnsafe . (</> ("src" </> "**" </> "*.purs")) . dirFor) (name : dependencies)
- procs "psc" srcGlobs empty
-
-main :: IO ()
-main = do
- IO.hSetEncoding IO.stdout IO.utf8
- IO.hSetEncoding IO.stderr IO.utf8
- cmd <- Opts.execParser opts
- cmd
- where
- opts = Opts.info (versionInfo <*> Opts.helper <*> commands) infoModList
- infoModList = Opts.fullDesc <> headerInfo <> footerInfo
- headerInfo = Opts.progDesc "Manage package dependencies"
- footerInfo = Opts.footer $ "psc-package " ++ showVersion Paths.version
-
- versionInfo :: Parser (a -> a)
- versionInfo = Opts.abortOption (Opts.InfoMsg (showVersion Paths.version)) $
- Opts.long "version" <> Opts.help "Show the version number" <> Opts.hidden
-
- commands :: Parser (IO ())
- commands = (Opts.subparser . fold)
- [ Opts.command "init"
- (Opts.info (pure initialize)
- (Opts.progDesc "Initialize a new package"))
- , Opts.command "update"
- (Opts.info (pure update)
- (Opts.progDesc "Update dependencies"))
- , Opts.command "uninstall"
- (Opts.info (uninstall <$> pkg)
- (Opts.progDesc "Uninstall the named package"))
- , Opts.command "install"
- (Opts.info (install <$> pkg)
- (Opts.progDesc "Install the named package"))
- , Opts.command "build"
- (Opts.info (pure (exec "psc"))
- (Opts.progDesc "Build the current package and dependencies"))
- , Opts.command "dependencies"
- (Opts.info (pure listDependencies)
- (Opts.progDesc "List all (transitive) dependencies for the current package"))
- , Opts.command "sources"
- (Opts.info (pure listSourcePaths)
- (Opts.progDesc "List all (active) source paths for dependencies"))
- , Opts.command "available"
- (Opts.info (pure listPackages)
- (Opts.progDesc "List all packages available in the package set"))
- , Opts.command "updates"
- (Opts.info (checkForUpdates <$> apply <*> applyMajor)
- (Opts.progDesc "Check all packages in the package set for new releases"))
- , Opts.command "verify-set"
- (Opts.info (pure verifyPackageSet)
- (Opts.progDesc "Verify that the packages in the package set build correctly"))
- ]
- where
- pkg = Opts.strArgument $
- Opts.metavar "PACKAGE"
- <> Opts.help "The name of the package to install"
-
- apply = Opts.switch $
- Opts.long "apply"
- <> Opts.help "Apply all minor package updates"
-
- applyMajor = Opts.switch $
- Opts.long "apply-breaking"
- <> Opts.help "Apply all major package updates"
diff --git a/psc-publish/Main.hs b/psc-publish/Main.hs
deleted file mode 100644
index fd84ec4..0000000
--- a/psc-publish/Main.hs
+++ /dev/null
@@ -1,57 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module Main where
-
-import Control.Monad.IO.Class (liftIO)
-import Data.Version (Version(..), showVersion)
-import qualified Data.Aeson as A
-import qualified Data.ByteString.Lazy.Char8 as BL
-import Data.Monoid ((<>))
-import Data.Time.Clock (getCurrentTime)
-
-import Options.Applicative (Parser, ParseError (..))
-import qualified Options.Applicative as Opts
-
-import System.IO (hSetEncoding, stderr, stdout, utf8)
-
-import qualified Paths_purescript as Paths
-import Language.PureScript.Publish
-import Language.PureScript.Publish.ErrorsWarnings
-
-dryRun :: Parser Bool
-dryRun = Opts.switch $
- Opts.long "dry-run"
- <> Opts.help "Produce no output, and don't require a tagged version to be checked out."
-
-dryRunOptions :: PublishOptions
-dryRunOptions = defaultPublishOptions
- { publishGetVersion = return dummyVersion
- , publishWorkingTreeDirty = warn DirtyWorkingTree_Warn
- , publishGetTagTime = const (liftIO getCurrentTime)
- }
- where dummyVersion = ("0.0.0", Version [0,0,0] [])
-
-main :: IO ()
-main = do
- hSetEncoding stdout utf8
- hSetEncoding stderr utf8
- Opts.execParser opts >>= publish
- where
- opts = Opts.info (version <*> Opts.helper <*> dryRun) infoModList
- infoModList = Opts.fullDesc <> headerInfo <> footerInfo
- headerInfo = Opts.header "psc-publish - Generates documentation packages for upload to http://pursuit.purescript.org"
- footerInfo = Opts.footer $ "psc-publish " ++ showVersion Paths.version
-
- version :: Parser (a -> a)
- version = Opts.abortOption (InfoMsg (showVersion Paths.version)) $
- Opts.long "version" <> Opts.help "Show the version number" <> Opts.hidden
-
-publish :: Bool -> IO ()
-publish isDryRun =
- if isDryRun
- then do
- _ <- unsafePreparePackage dryRunOptions
- putStrLn "Dry run completed, no errors."
- else do
- pkg <- unsafePreparePackage defaultPublishOptions
- BL.putStrLn (A.encode pkg)
diff --git a/purescript.cabal b/purescript.cabal
index 4bd0b62..0df22a1 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,5 +1,5 @@
name: purescript
-version: 0.10.7
+version: 0.11.0
cabal-version: >=1.8
build-type: Simple
license: BSD3
@@ -8,7 +8,7 @@ copyright: (c) 2013-16 Phil Freeman, (c) 2014-16 Gary Burgess
maintainer: Phil Freeman <paf31@cantab.net>
stability: experimental
synopsis: PureScript Programming Language Compiler
-description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to Javascript.
+description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to JavaScript.
category: Language
Homepage: http://www.purescript.org/
author: Phil Freeman <paf31@cantab.net>,
@@ -23,6 +23,7 @@ extra-source-files: examples/passing/*.purs
, examples/passing/*.js
, examples/passing/2018/*.purs
, examples/passing/2138/*.purs
+ , examples/passing/2609/*.purs
, examples/passing/ClassRefSyntax/*.purs
, examples/passing/DctorOperatorAlias/*.purs
, examples/passing/ExplicitImportReExport/*.purs
@@ -92,8 +93,10 @@ extra-source-files: examples/passing/*.purs
, examples/docs/bower_components/purescript-prelude/src/*.purs
, examples/docs/bower.json
, examples/docs/src/*.purs
- , psci/static/index.html
- , psci/static/index.js
+ , examples/docs/resolutions.json
+ , app/static/index.html
+ , app/static/index.js
+ , app/static/*.css
, tests/support/package.json
, tests/support/bower.json
, tests/support/setup-win.cmd
@@ -101,6 +104,7 @@ extra-source-files: examples/passing/*.purs
, tests/support/pscide/src/*.purs
, tests/support/pscide/src/*.js
, tests/support/pscide/src/*.fail
+ , tests/support/prelude-resolutions.json
, stack.yaml
, README.md
, INSTALL.md
@@ -111,9 +115,14 @@ source-repository head
type: git
location: https://github.com/purescript/purescript.git
+flag release
+ description: Mark this build as a release build: prevents inclusion of extra
+ info e.g. commit SHA in --version output)
+ default: False
+
library
build-depends: base >=4.8 && <5,
- aeson >= 0.8 && < 1.0,
+ aeson >= 0.8 && < 1.1,
aeson-better-errors >= 0.8,
ansi-terminal >= 0.6.2 && < 0.7,
base-compat >=0.6.0,
@@ -133,7 +142,7 @@ library
fsnotify >= 0.2.1,
Glob >= 0.7 && < 0.8,
haskeline >= 0.7.0.0,
- http-client >= 0.4.30 && <0.5,
+ http-client >= 0.4.30 && < 0.6.0,
http-types -any,
language-javascript >= 0.6.0.9 && < 0.7,
lens == 4.*,
@@ -144,7 +153,7 @@ library
parallel >= 3.2 && < 3.3,
parsec >=3.1.10,
pattern-arrows >= 0.0.2 && < 0.1,
- pipes >= 4.0.0 && < 4.3.0,
+ pipes >= 4.0.0 && < 4.4.0,
pipes-http -any,
process >= 1.2.0 && < 1.5,
protolude >= 0.1.6,
@@ -180,15 +189,8 @@ library
Language.PureScript.Externs
Language.PureScript.CodeGen
Language.PureScript.CodeGen.JS
- Language.PureScript.CodeGen.JS.AST
Language.PureScript.CodeGen.JS.Common
- Language.PureScript.CodeGen.JS.Optimizer
- Language.PureScript.CodeGen.JS.Optimizer.Blocks
- Language.PureScript.CodeGen.JS.Optimizer.Common
- Language.PureScript.CodeGen.JS.Optimizer.Inliner
- Language.PureScript.CodeGen.JS.Optimizer.MagicDo
- Language.PureScript.CodeGen.JS.Optimizer.TCO
- Language.PureScript.CodeGen.JS.Optimizer.Unused
+ Language.PureScript.CodeGen.JS.Printer
Language.PureScript.Constants
Language.PureScript.CoreFn
Language.PureScript.CoreFn.Ann
@@ -199,6 +201,15 @@ library
Language.PureScript.CoreFn.Module
Language.PureScript.CoreFn.Traversals
Language.PureScript.CoreFn.ToJSON
+ Language.PureScript.CoreImp
+ Language.PureScript.CoreImp.AST
+ Language.PureScript.CoreImp.Optimizer
+ Language.PureScript.CoreImp.Optimizer.Blocks
+ Language.PureScript.CoreImp.Optimizer.Common
+ Language.PureScript.CoreImp.Optimizer.Inliner
+ Language.PureScript.CoreImp.Optimizer.MagicDo
+ Language.PureScript.CoreImp.Optimizer.TCO
+ Language.PureScript.CoreImp.Optimizer.Unused
Language.PureScript.Comments
Language.PureScript.Environment
Language.PureScript.Errors
@@ -221,7 +232,6 @@ library
Language.PureScript.Parser.Types
Language.PureScript.Pretty
Language.PureScript.Pretty.Common
- Language.PureScript.Pretty.JS
Language.PureScript.Pretty.Kinds
Language.PureScript.Pretty.Types
Language.PureScript.Pretty.Values
@@ -231,6 +241,7 @@ library
Language.PureScript.Sugar.BindingGroups
Language.PureScript.Sugar.CaseDeclarations
Language.PureScript.Sugar.DoNotation
+ Language.PureScript.Sugar.LetPattern
Language.PureScript.Sugar.Names
Language.PureScript.Sugar.Names.Common
Language.PureScript.Sugar.Names.Env
@@ -250,7 +261,6 @@ library
Language.PureScript.TypeChecker.Entailment
Language.PureScript.TypeChecker.Kinds
Language.PureScript.TypeChecker.Monad
- Language.PureScript.TypeChecker.Rows
Language.PureScript.TypeChecker.Skolems
Language.PureScript.TypeChecker.Subsumption
Language.PureScript.TypeChecker.Synonyms
@@ -339,191 +349,64 @@ library
other-modules: Paths_purescript
ghc-options: -Wall -O2
-executable psc
+executable purs
build-depends: base >=4 && <5,
- purescript -any,
- aeson >= 0.8 && < 1.0,
+ aeson >= 0.8 && < 1.1,
ansi-terminal >= 0.6.2 && < 0.7,
+ ansi-wl-pprint -any,
base-compat >=0.6.0,
- bytestring -any,
- containers -any,
- directory -any,
- filepath -any,
- Glob >= 0.7 && < 0.8,
- mtl -any,
- optparse-applicative >= 0.13.0,
- parsec -any,
- text -any,
- time -any,
- transformers -any,
- transformers-compat -any,
- utf8-string >= 1 && < 2
- main-is: Main.hs
- buildable: True
- hs-source-dirs: psc
- other-modules: Paths_purescript
- ghc-options: -Wall -O2 -fno-warn-unused-do-bind -threaded -rtsopts "-with-rtsopts=-N"
-
-executable psci
- build-depends: base >=4 && <5,
- purescript -any,
- base-compat >=0.6.0,
+ blaze-html -any,
boxes >= 0.1.4 && < 0.2.0,
bytestring -any,
containers -any,
directory -any,
- filepath -any,
file-embed -any,
- Glob -any,
+ filepath -any,
+ Glob >= 0.7 && < 0.8,
haskeline >= 0.7.0.0,
http-types == 0.9.*,
+ monad-logger -any,
mtl -any,
+ network -any,
optparse-applicative >= 0.13.0,
parsec -any,
process -any,
+ protolude >= 0.1.6,
+ purescript -any,
+ sourcemap >= 0.1.6,
+ split -any,
stm >= 0.2.4.0,
text -any,
time -any,
transformers -any,
transformers-compat -any,
+ utf8-string >= 1 && < 2,
wai == 3.*,
wai-websockets == 3.*,
warp == 3.*,
- websockets >= 0.9 && <0.10
+ websockets >= 0.9 && <0.11
main-is: Main.hs
buildable: True
- hs-source-dirs: psci
+ hs-source-dirs: app
other-modules: Paths_purescript
- ghc-options: -Wall -O2
-
-executable psc-docs
- build-depends: base >=4 && <5,
- purescript -any,
- ansi-wl-pprint -any,
- directory -any,
- filepath -any,
- Glob -any,
- mtl -any,
- optparse-applicative >= 0.13.0,
- process -any,
- split -any,
- text -any,
- transformers -any,
- transformers-compat -any
- main-is: Main.hs
- other-modules: Paths_purescript
- buildable: True
- hs-source-dirs: psc-docs
- other-modules: Ctags
- Etags
- Tags
- ghc-options: -Wall -O2
-
-executable psc-publish
- build-depends: base >=4 && <5,
- purescript -any,
- aeson >= 0.8 && < 1.0,
- bytestring -any,
- optparse-applicative -any,
- time -any,
- transformers -any
- main-is: Main.hs
- other-modules: Paths_purescript
- buildable: True
- hs-source-dirs: psc-publish
- ghc-options: -Wall -O2
-
-executable psc-package
- build-depends: base >=4 && <5,
- purescript -any,
- aeson -any,
- aeson-pretty -any,
- bytestring -any,
- containers -any,
- foldl -any,
- optparse-applicative -any,
- system-filepath -any,
- text -any,
- turtle ==1.3.*
- main-is: Main.hs
- other-modules: Paths_purescript
- buildable: True
- hs-source-dirs: psc-package
- ghc-options: -Wall -O2
-
-executable psc-hierarchy
- build-depends: base >=4 && <5,
- purescript -any,
- directory -any,
- filepath -any,
- Glob -any,
- mtl -any,
- optparse-applicative >= 0.13.0,
- parsec -any,
- process -any,
- text -any
- main-is: Main.hs
- other-modules: Paths_purescript
- buildable: True
- hs-source-dirs: hierarchy
- other-modules:
- ghc-options: -Wall -O2
-
-executable psc-bundle
- main-is: Main.hs
- other-modules: Paths_purescript
- other-extensions:
- build-depends: base >=4 && <5,
- bytestring -any,
- purescript -any,
- directory -any,
- aeson >= 0.8 && < 1.0,
- filepath -any,
- Glob -any,
- mtl -any,
- optparse-applicative >= 0.13.0,
- sourcemap >= 0.1.6,
- transformers -any,
- transformers-compat -any,
- utf8-string >= 1 && < 2
-
- ghc-options: -Wall -O2
- hs-source-dirs: psc-bundle
-
-executable psc-ide-server
- main-is: Main.hs
- other-modules: Paths_purescript
- other-extensions:
- build-depends: base >=4 && <5,
- aeson >= 0.8 && < 1.0,
- bytestring -any,
- purescript -any,
- directory -any,
- filepath -any,
- monad-logger -any,
- mtl -any,
- network -any,
- optparse-applicative >= 0.13.0,
- protolude >= 0.1.6,
- stm -any,
- text -any,
- transformers -any
- ghc-options: -Wall -O2 -threaded
- hs-source-dirs: psc-ide-server
+ Command.Bundle
+ Command.Compile
+ Command.Docs
+ Command.Docs.Ctags
+ Command.Docs.Etags
+ Command.Docs.Tags
+ Command.Docs.Html
+ Command.Hierarchy
+ Command.Ide
+ Command.Publish
+ Command.REPL
+ Version
+ ghc-options: -Wall -O2 -fno-warn-unused-do-bind -threaded -rtsopts "-with-rtsopts=-N"
-executable psc-ide-client
- main-is: Main.hs
- other-modules: Paths_purescript
- other-extensions:
- build-depends: base >=4 && <5,
- base-compat >=0.6.0,
- bytestring -any,
- mtl -any,
- network -any,
- optparse-applicative >= 0.13.0,
- text -any
- ghc-options: -Wall -O2
- hs-source-dirs: psc-ide-client
+ if flag(release)
+ cpp-options: -DRELEASE
+ else
+ build-depends: gitrev >= 1.2.0 && <1.3
test-suite tests
build-depends: base >=4 && <5,
@@ -566,6 +449,9 @@ test-suite tests
TestPrimDocs
TestPscPublish
TestPsci
+ TestPsci.CommandTest
+ TestPsci.CompletionTest
+ TestPsci.TestEnv
TestPscIde
PscIdeSpec
Language.PureScript.Ide.Test
diff --git a/src/Language/PureScript/AST/Binders.hs b/src/Language/PureScript/AST/Binders.hs
index c7c7d12..834b4be 100644
--- a/src/Language/PureScript/AST/Binders.hs
+++ b/src/Language/PureScript/AST/Binders.hs
@@ -61,7 +61,7 @@ data Binder
-- A binder with a type annotation
--
| TypedBinder Type Binder
- deriving (Show, Eq)
+ deriving (Show, Eq, Ord)
-- |
-- Collect all names introduced in binders in an expression
@@ -81,3 +81,11 @@ binderNames = go []
lit ns (ObjectLiteral bs) = foldl go ns (map snd bs)
lit ns (ArrayLiteral bs) = foldl go ns bs
lit ns _ = ns
+
+isIrrefutable :: Binder -> Bool
+isIrrefutable NullBinder = True
+isIrrefutable (VarBinder _) = True
+isIrrefutable (PositionedBinder _ _ b) = isIrrefutable b
+isIrrefutable (TypedBinder _ b) = isIrrefutable b
+isIrrefutable _ = False
+
diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs
index 6544cae..97a6843 100644
--- a/src/Language/PureScript/AST/Declarations.hs
+++ b/src/Language/PureScript/AST/Declarations.hs
@@ -38,14 +38,27 @@ type Context = [(Ident, Type)]
data TypeSearch
= TSBefore Environment
-- ^ An Environment captured for later consumption by type directed search
- | TSAfter [(Qualified Ident, Type)]
+ | TSAfter
+ { tsAfterIdentifiers :: [(Qualified Text, Type)]
+ -- ^ The identifiers that fully satisfy the subsumption check
+ , tsAfterRecordFields :: Maybe [(Label, Type)]
+ -- ^ Record fields that are available on the first argument to the typed
+ -- hole
+ }
-- ^ Results of applying type directed search to the previously captured
-- Environment
deriving Show
+onTypeSearchTypes :: (Type -> Type) -> TypeSearch -> TypeSearch
+onTypeSearchTypes f = runIdentity . onTypeSearchTypesM (Identity . f)
+
+onTypeSearchTypesM :: (Applicative m) => (Type -> m Type) -> TypeSearch -> m TypeSearch
+onTypeSearchTypesM f (TSAfter i r) = TSAfter <$> traverse (traverse f) i <*> traverse (traverse (traverse f)) r
+onTypeSearchTypesM _ (TSBefore env) = pure (TSBefore env)
+
-- | A type of error messages
data SimpleErrorMessage
- = ModuleNotFound ModuleName
+ = ModuleNotFound ModuleName
| ErrorParsingFFIModule FilePath (Maybe Bundle.ErrorMessage)
| ErrorParsingModule P.ParseError
| MissingFFIModule ModuleName
@@ -83,7 +96,7 @@ data SimpleErrorMessage
| NameIsUndefined Ident
| UndefinedTypeVariable (ProperName 'TypeName)
| PartiallyAppliedSynonym (Qualified (ProperName 'TypeName))
- | EscapedSkolem (Maybe Expr)
+ | EscapedSkolem Text (Maybe SourceSpan) Type
| TypesDoNotUnify Type Type
| KindsDoNotUnify Kind Kind
| ConstrainedTypeUnified Type Type
@@ -93,6 +106,8 @@ data SimpleErrorMessage
| UnknownClass (Qualified (ProperName 'ClassName))
| PossiblyInfiniteInstance (Qualified (ProperName 'ClassName)) [Type]
| CannotDerive (Qualified (ProperName 'ClassName)) [Type]
+ | InvalidDerivedInstance (Qualified (ProperName 'ClassName)) [Type] Int
+ | ExpectedTypeConstructor (Qualified (ProperName 'ClassName)) [Type] Type
| InvalidNewtypeInstance (Qualified (ProperName 'ClassName)) [Type]
| CannotFindDerivingType (ProperName 'TypeName)
| DuplicateLabel Label (Maybe Expr)
@@ -140,11 +155,14 @@ data SimpleErrorMessage
| CannotGeneralizeRecursiveFunction Ident Type
| CannotDeriveNewtypeForData (ProperName 'TypeName)
| ExpectedWildcard (ProperName 'TypeName)
- | CannotUseBindWithDo
+ | CannotUseBindWithDo Ident
-- | instance name, type class, expected argument count, actual argument count
| ClassInstanceArityMismatch Ident (Qualified (ProperName 'ClassName)) Int Int
-- | a user-defined warning raised by using the Warn type class
| UserDefinedWarning Type
+ -- | a declaration couldn't be used because there wouldn't be enough information
+ -- | to choose an instance
+ | UnusableDeclaration Ident
deriving (Show)
-- | Error message hints, providing more detailed information about failure.
@@ -388,7 +406,10 @@ data Declaration
-- |
-- A value declaration (name, top-level binders, optional guard, value)
--
- | ValueDeclaration Ident NameKind [Binder] (Either [(Guard, Expr)] Expr)
+ | ValueDeclaration Ident NameKind [Binder] [GuardedExpr]
+ -- |
+ -- A declaration paired with pattern matching in let-in expression (binder, optional guard, value)
+ | BoundValueDeclaration Binder Expr
-- |
-- A minimal mutually recursive set of value declarations
--
@@ -550,7 +571,18 @@ flattenDecls = concatMap flattenOne
-- |
-- A guard is just a boolean-valued expression that appears alongside a set of binders
--
-type Guard = Expr
+data Guard = ConditionGuard Expr
+ | PatternGuard Binder Expr
+ deriving (Show)
+
+-- |
+-- The right hand side of a binder in value declarations
+-- and case expressions.
+data GuardedExpr = GuardedExpr [Guard] Expr
+ deriving (Show)
+
+pattern MkUnguarded :: Expr -> GuardedExpr
+pattern MkUnguarded e = GuardedExpr [] e
-- |
-- Data type for expressions and terms
@@ -595,7 +627,7 @@ data Expr
-- |
-- Function introduction
--
- | Abs (Either Ident Binder) Expr
+ | Abs Binder Expr
-- |
-- Function application
--
@@ -682,7 +714,7 @@ data CaseAlternative = CaseAlternative
-- |
-- The result expression or a collect of guarded expressions
--
- , caseAlternativeResult :: Either [(Guard, Expr)] Expr
+ , caseAlternativeResult :: [GuardedExpr]
} deriving (Show)
-- |
@@ -742,3 +774,11 @@ newtype AssocList k t = AssocList { runAssocList :: [(k, t)] }
$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''DeclarationRef)
$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ImportDeclarationType)
+
+isTrueExpr :: Expr -> Bool
+isTrueExpr (Literal (BooleanLiteral True)) = True
+isTrueExpr (Var (Qualified (Just (ModuleName [ProperName "Prelude"])) (Ident "otherwise"))) = True
+isTrueExpr (Var (Qualified (Just (ModuleName [ProperName "Data", ProperName "Boolean"])) (Ident "otherwise"))) = True
+isTrueExpr (TypedValue _ e _) = isTrueExpr e
+isTrueExpr (PositionedValue _ _ e) = isTrueExpr e
+isTrueExpr _ = False
diff --git a/src/Language/PureScript/AST/Exported.hs b/src/Language/PureScript/AST/Exported.hs
index 8c7c720..759b9a3 100644
--- a/src/Language/PureScript/AST/Exported.hs
+++ b/src/Language/PureScript/AST/Exported.hs
@@ -108,7 +108,7 @@ typeInstanceConstituents (TypeInstanceDeclaration _ constraints className tys _)
-- Note that type synonyms are disallowed in instance declarations, so
-- we don't need to handle them here.
go (TypeConstructor n) = [Right n]
- go (ConstrainedType cs _) = concatMap fromConstraint cs
+ go (ConstrainedType c _) = fromConstraint c
go _ = []
typeInstanceConstituents (PositionedDeclaration _ _ d) = typeInstanceConstituents d
diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs
index 169bd67..d1a8ce5 100644
--- a/src/Language/PureScript/AST/Traversals.hs
+++ b/src/Language/PureScript/AST/Traversals.hs
@@ -6,7 +6,6 @@ module Language.PureScript.AST.Traversals where
import Prelude.Compat
import Control.Monad
-import Control.Arrow ((***), (+++))
import Data.Foldable (fold)
import Data.List (mapAccumL)
@@ -21,6 +20,21 @@ import Language.PureScript.Names
import Language.PureScript.Traversals
import Language.PureScript.Types
+guardedExprM :: Applicative m
+ => (Guard -> m Guard)
+ -> (Expr -> m Expr)
+ -> GuardedExpr
+ -> m GuardedExpr
+guardedExprM f g (GuardedExpr guards rhs) =
+ GuardedExpr <$> traverse f guards <*> g rhs
+
+mapGuardedExpr :: (Guard -> Guard)
+ -> (Expr -> Expr)
+ -> GuardedExpr
+ -> GuardedExpr
+mapGuardedExpr f g (GuardedExpr guards rhs) =
+ GuardedExpr (map f guards) (g rhs)
+
everywhereOnValues
:: (Declaration -> Declaration)
-> (Expr -> Expr)
@@ -33,7 +47,8 @@ everywhereOnValues f g h = (f', g', h')
where
f' :: Declaration -> Declaration
f' (DataBindingGroupDeclaration ds) = f (DataBindingGroupDeclaration (map f' ds))
- f' (ValueDeclaration name nameKind bs val) = f (ValueDeclaration name nameKind (map h' bs) ((map (g' *** g') +++ g') val))
+ f' (ValueDeclaration name nameKind bs val) = f (ValueDeclaration name nameKind (map h' bs) (map (mapGuardedExpr handleGuard g') val))
+ f' (BoundValueDeclaration b expr) = f (BoundValueDeclaration (h' b) (g' expr))
f' (BindingGroupDeclaration ds) = f (BindingGroupDeclaration (map (\(name, nameKind, val) -> (name, nameKind, g' val)) ds))
f' (TypeClassDeclaration name args implies deps ds) = f (TypeClassDeclaration name args implies deps (map f' ds))
f' (TypeInstanceDeclaration name cs className args ds) = f (TypeInstanceDeclaration name cs className args (mapTypeInstanceBody (map f') ds))
@@ -49,7 +64,7 @@ everywhereOnValues f g h = (f', g', h')
g' (Accessor prop v) = g (Accessor prop (g' v))
g' (ObjectUpdate obj vs) = g (ObjectUpdate (g' obj) (map (fmap g') vs))
g' (ObjectUpdateNested obj vs) = g (ObjectUpdateNested (g' obj) (fmap g' vs))
- g' (Abs name v) = g (Abs name (g' v))
+ g' (Abs binder v) = g (Abs (h' binder) (g' v))
g' (App v1 v2) = g (App (g' v1) (g' v2))
g' (IfThenElse v1 v2 v3) = g (IfThenElse (g' v1) (g' v2) (g' v3))
g' (Case vs alts) = g (Case (map g' vs) (map handleCaseAlternative alts))
@@ -77,7 +92,7 @@ everywhereOnValues f g h = (f', g', h')
handleCaseAlternative :: CaseAlternative -> CaseAlternative
handleCaseAlternative ca =
ca { caseAlternativeBinders = map h' (caseAlternativeBinders ca)
- , caseAlternativeResult = (map (g' *** g') +++ g') (caseAlternativeResult ca)
+ , caseAlternativeResult = map (mapGuardedExpr handleGuard g') (caseAlternativeResult ca)
}
handleDoNotationElement :: DoNotationElement -> DoNotationElement
@@ -86,6 +101,10 @@ everywhereOnValues f g h = (f', g', h')
handleDoNotationElement (DoNotationLet ds) = DoNotationLet (map f' ds)
handleDoNotationElement (PositionedDoNotationElement pos com e) = PositionedDoNotationElement pos com (handleDoNotationElement e)
+ handleGuard :: Guard -> Guard
+ handleGuard (ConditionGuard e) = ConditionGuard (g' e)
+ handleGuard (PatternGuard b e) = PatternGuard (h' b) (g' e)
+
everywhereOnValuesTopDownM
:: forall m
. (Monad m)
@@ -101,10 +120,11 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)
f' :: Declaration -> m Declaration
f' (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> traverse (f' <=< f) ds
- f' (ValueDeclaration name nameKind bs val) = ValueDeclaration name nameKind <$> traverse (h' <=< h) bs <*> eitherM (traverse (pairM (g' <=< g) (g' <=< g))) (g' <=< g) val
+ f' (ValueDeclaration name nameKind bs val) = ValueDeclaration name nameKind <$> traverse (h' <=< h) bs <*> traverse (guardedExprM handleGuard (g' <=< g)) val
f' (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> traverse (\(name, nameKind, val) -> (,,) name nameKind <$> (g val >>= g')) ds
f' (TypeClassDeclaration name args implies deps ds) = TypeClassDeclaration name args implies deps <$> traverse (f' <=< f) ds
f' (TypeInstanceDeclaration name cs className args ds) = TypeInstanceDeclaration name cs className args <$> traverseTypeInstanceBody (traverse (f' <=< f)) ds
+ f' (BoundValueDeclaration b expr) = BoundValueDeclaration <$> h' b <*> g' expr
f' (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> (f d >>= f')
f' other = f other
@@ -117,7 +137,7 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)
g' (Accessor prop v) = Accessor prop <$> (g v >>= g')
g' (ObjectUpdate obj vs) = ObjectUpdate <$> (g obj >>= g') <*> traverse (sndM (g' <=< g)) vs
g' (ObjectUpdateNested obj vs) = ObjectUpdateNested <$> (g obj >>= g') <*> traverse (g' <=< g) vs
- g' (Abs name v) = Abs name <$> (g v >>= g')
+ g' (Abs binder v) = Abs <$> (h binder >>= h') <*> (g v >>= g')
g' (App v1 v2) = App <$> (g v1 >>= g') <*> (g v2 >>= g')
g' (IfThenElse v1 v2 v3) = IfThenElse <$> (g v1 >>= g') <*> (g v2 >>= g') <*> (g v3 >>= g')
g' (Case vs alts) = Case <$> traverse (g' <=< g) vs <*> traverse handleCaseAlternative alts
@@ -146,7 +166,7 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)
handleCaseAlternative (CaseAlternative bs val) =
CaseAlternative
<$> traverse (h' <=< h) bs
- <*> eitherM (traverse (pairM (g' <=< g) (g' <=< g))) (g' <=< g) val
+ <*> traverse (guardedExprM handleGuard (g' <=< g)) val
handleDoNotationElement :: DoNotationElement -> m DoNotationElement
handleDoNotationElement (DoNotationValue v) = DoNotationValue <$> (g' <=< g) v
@@ -154,6 +174,10 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)
handleDoNotationElement (DoNotationLet ds) = DoNotationLet <$> traverse (f' <=< f) ds
handleDoNotationElement (PositionedDoNotationElement pos com e) = PositionedDoNotationElement pos com <$> handleDoNotationElement e
+ handleGuard :: Guard -> m Guard
+ handleGuard (ConditionGuard e) = ConditionGuard <$> (g' <=< g) e
+ handleGuard (PatternGuard b e) = PatternGuard <$> (h' <=< h) b <*> (g' <=< g) e
+
everywhereOnValuesM
:: forall m
. (Monad m)
@@ -169,8 +193,9 @@ everywhereOnValuesM f g h = (f', g', h')
f' :: Declaration -> m Declaration
f' (DataBindingGroupDeclaration ds) = (DataBindingGroupDeclaration <$> traverse f' ds) >>= f
- f' (ValueDeclaration name nameKind bs val) = (ValueDeclaration name nameKind <$> traverse h' bs <*> eitherM (traverse (pairM g' g')) g' val) >>= f
+ f' (ValueDeclaration name nameKind bs val) = (ValueDeclaration name nameKind <$> traverse h' bs <*> traverse (guardedExprM handleGuard g') val) >>= f
f' (BindingGroupDeclaration ds) = (BindingGroupDeclaration <$> traverse (\(name, nameKind, val) -> (,,) name nameKind <$> g' val) ds) >>= f
+ f' (BoundValueDeclaration b expr) = (BoundValueDeclaration <$> h' b <*> g' expr) >>= f
f' (TypeClassDeclaration name args implies deps ds) = (TypeClassDeclaration name args implies deps <$> traverse f' ds) >>= f
f' (TypeInstanceDeclaration name cs className args ds) = (TypeInstanceDeclaration name cs className args <$> traverseTypeInstanceBody (traverse f') ds) >>= f
f' (PositionedDeclaration pos com d) = (PositionedDeclaration pos com <$> f' d) >>= f
@@ -185,7 +210,7 @@ everywhereOnValuesM f g h = (f', g', h')
g' (Accessor prop v) = (Accessor prop <$> g' v) >>= g
g' (ObjectUpdate obj vs) = (ObjectUpdate <$> g' obj <*> traverse (sndM g') vs) >>= g
g' (ObjectUpdateNested obj vs) = (ObjectUpdateNested <$> g' obj <*> traverse g' vs) >>= g
- g' (Abs name v) = (Abs name <$> g' v) >>= g
+ g' (Abs binder v) = (Abs <$> h' binder <*> g' v) >>= g
g' (App v1 v2) = (App <$> g' v1 <*> g' v2) >>= g
g' (IfThenElse v1 v2 v3) = (IfThenElse <$> g' v1 <*> g' v2 <*> g' v3) >>= g
g' (Case vs alts) = (Case <$> traverse g' vs <*> traverse handleCaseAlternative alts) >>= g
@@ -214,7 +239,7 @@ everywhereOnValuesM f g h = (f', g', h')
handleCaseAlternative (CaseAlternative bs val) =
CaseAlternative
<$> traverse h' bs
- <*> eitherM (traverse (pairM g' g')) g' val
+ <*> traverse (guardedExprM handleGuard g') val
handleDoNotationElement :: DoNotationElement -> m DoNotationElement
handleDoNotationElement (DoNotationValue v) = DoNotationValue <$> g' v
@@ -222,6 +247,10 @@ everywhereOnValuesM f g h = (f', g', h')
handleDoNotationElement (DoNotationLet ds) = DoNotationLet <$> traverse f' ds
handleDoNotationElement (PositionedDoNotationElement pos com e) = PositionedDoNotationElement pos com <$> handleDoNotationElement e
+ handleGuard :: Guard -> m Guard
+ handleGuard (ConditionGuard e) = ConditionGuard <$> g' e
+ handleGuard (PatternGuard b e) = PatternGuard <$> h' b <*> g' e
+
everythingOnValues
:: forall r
. (r -> r -> r)
@@ -241,11 +270,11 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j')
f' :: Declaration -> r
f' d@(DataBindingGroupDeclaration ds) = foldl (<>) (f d) (map f' ds)
- f' d@(ValueDeclaration _ _ bs (Right val)) = foldl (<>) (f d) (map h' bs) <> g' val
- f' d@(ValueDeclaration _ _ bs (Left gs)) = foldl (<>) (f d) (map h' bs ++ concatMap (\(grd, val) -> [g' grd, g' val]) gs)
+ f' d@(ValueDeclaration _ _ bs val) = foldl (<>) (f d) (map h' bs ++ concatMap (\(GuardedExpr grd v) -> map k' grd ++ [g' v]) val)
f' d@(BindingGroupDeclaration ds) = foldl (<>) (f d) (map (\(_, _, val) -> g' val) ds)
f' d@(TypeClassDeclaration _ _ _ _ ds) = foldl (<>) (f d) (map f' ds)
f' d@(TypeInstanceDeclaration _ _ _ _ (ExplicitInstance ds)) = foldl (<>) (f d) (map f' ds)
+ f' d@(BoundValueDeclaration b expr) = f d <> h' b <> g' expr
f' d@(PositionedDeclaration _ _ d1) = f d <> f' d1
f' d = f d
@@ -258,7 +287,7 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j')
g' v@(Accessor _ v1) = g v <> g' v1
g' v@(ObjectUpdate obj vs) = foldl (<>) (g v <> g' obj) (map (g' . snd) vs)
g' v@(ObjectUpdateNested obj vs) = foldl (<>) (g v <> g' obj) (fmap g' vs)
- g' v@(Abs _ v1) = g v <> g' v1
+ g' v@(Abs b v1) = g v <> h' b <> g' v1
g' v@(App v1 v2) = g v <> g' v1 <> g' v2
g' v@(IfThenElse v1 v2 v3) = g v <> g' v1 <> g' v2 <> g' v3
g' v@(Case vs alts) = foldl (<>) (foldl (<>) (g v) (map g' vs)) (map i' alts)
@@ -284,8 +313,8 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j')
lit r _ _ = r
i' :: CaseAlternative -> r
- i' ca@(CaseAlternative bs (Right val)) = foldl (<>) (i ca) (map h' bs) <> g' val
- i' ca@(CaseAlternative bs (Left gs)) = foldl (<>) (i ca) (map h' bs ++ concatMap (\(grd, val) -> [g' grd, g' val]) gs)
+ i' ca@(CaseAlternative bs gs) =
+ foldl (<>) (i ca) (map h' bs ++ concatMap (\(GuardedExpr grd val) -> map k' grd ++ [g' val]) gs)
j' :: DoNotationElement -> r
j' e@(DoNotationValue v) = j e <> g' v
@@ -293,6 +322,10 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j')
j' e@(DoNotationLet ds) = foldl (<>) (j e) (map f' ds)
j' e@(PositionedDoNotationElement _ _ e1) = j e <> j' e1
+ k' :: Guard -> r
+ k' (ConditionGuard e) = g' e
+ k' (PatternGuard b e) = h' b <> g' e
+
everythingWithContextOnValues
:: forall s r
. s
@@ -316,8 +349,7 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'
f' :: s -> Declaration -> r
f' s (DataBindingGroupDeclaration ds) = foldl (<>) r0 (map (f'' s) ds)
- f' s (ValueDeclaration _ _ bs (Right val)) = foldl (<>) r0 (map (h'' s) bs) <> g'' s val
- f' s (ValueDeclaration _ _ bs (Left gs)) = foldl (<>) r0 (map (h'' s) bs ++ concatMap (\(grd, val) -> [g'' s grd, g'' s val]) gs)
+ f' s (ValueDeclaration _ _ bs val) = foldl (<>) r0 (map (h'' s) bs ++ concatMap (\(GuardedExpr grd v) -> map (k' s) grd ++ [g'' s v]) val)
f' s (BindingGroupDeclaration ds) = foldl (<>) r0 (map (\(_, _, val) -> g'' s val) ds)
f' s (TypeClassDeclaration _ _ _ _ ds) = foldl (<>) r0 (map (f'' s) ds)
f' s (TypeInstanceDeclaration _ _ _ _ (ExplicitInstance ds)) = foldl (<>) r0 (map (f'' s) ds)
@@ -336,7 +368,7 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'
g' s (Accessor _ v1) = g'' s v1
g' s (ObjectUpdate obj vs) = foldl (<>) (g'' s obj) (map (g'' s . snd) vs)
g' s (ObjectUpdateNested obj vs) = foldl (<>) (g'' s obj) (fmap (g'' s) vs)
- g' s (Abs _ v1) = g'' s v1
+ g' s (Abs binder v1) = h'' s binder <> 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) = foldl (<>) (foldl (<>) r0 (map (g'' s) vs)) (map (i'' s) alts)
@@ -368,8 +400,7 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'
i'' s ca = let (s', r) = i s ca in r <> i' s' ca
i' :: s -> CaseAlternative -> r
- i' s (CaseAlternative bs (Right val)) = foldl (<>) r0 (map (h'' s) bs) <> g'' s val
- i' s (CaseAlternative bs (Left gs)) = foldl (<>) r0 (map (h'' s) bs ++ concatMap (\(grd, val) -> [g'' s grd, g'' s val]) gs)
+ i' s (CaseAlternative bs gs) = foldl (<>) r0 (map (h'' s) bs ++ concatMap (\(GuardedExpr grd val) -> map (k' s) grd ++ [g'' s val]) gs)
j'' :: s -> DoNotationElement -> r
j'' s e = let (s', r) = j s e in r <> j' s' e
@@ -380,6 +411,10 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'
j' s (DoNotationLet ds) = foldl (<>) r0 (map (f'' s) ds)
j' s (PositionedDoNotationElement _ _ e1) = j'' s e1
+ k' :: s -> Guard -> r
+ k' s (ConditionGuard e) = g'' s e
+ k' s (PatternGuard b e) = h'' s b <> g'' s e
+
everywhereWithContextOnValuesM
:: forall m s
. (Monad m)
@@ -393,13 +428,14 @@ everywhereWithContextOnValuesM
, Expr -> m Expr
, Binder -> m Binder
, CaseAlternative -> m CaseAlternative
- , DoNotationElement -> m DoNotationElement)
+ , DoNotationElement -> m DoNotationElement
+ )
everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j'' s0)
where
f'' s = uncurry f' <=< f s
f' s (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> traverse (f'' s) ds
- f' s (ValueDeclaration name nameKind bs val) = ValueDeclaration name nameKind <$> traverse (h'' s) bs <*> eitherM (traverse (pairM (g'' s) (g'' s))) (g'' s) val
+ f' s (ValueDeclaration name nameKind bs val) = ValueDeclaration name nameKind <$> traverse (h'' s) bs <*> traverse (guardedExprM (k' s) (g'' s)) val
f' s (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> traverse (thirdM (g'' s)) ds
f' s (TypeClassDeclaration name args implies deps ds) = TypeClassDeclaration name args implies deps <$> traverse (f'' s) ds
f' s (TypeInstanceDeclaration name cs className args ds) = TypeInstanceDeclaration name cs className args <$> traverseTypeInstanceBody (traverse (f'' s)) ds
@@ -416,7 +452,7 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j
g' s (Accessor prop v) = Accessor prop <$> g'' s v
g' s (ObjectUpdate obj vs) = ObjectUpdate <$> g'' s obj <*> traverse (sndM (g'' s)) vs
g' s (ObjectUpdateNested obj vs) = ObjectUpdateNested <$> g'' s obj <*> traverse (g'' s) vs
- g' s (Abs name v) = Abs name <$> g'' s v
+ g' s (Abs binder v) = Abs <$> h' s binder <*> g'' s v
g' s (App v1 v2) = App <$> g'' s v1 <*> g'' s v2
g' s (IfThenElse v1 v2 v3) = IfThenElse <$> g'' s v1 <*> g'' s v2 <*> g'' s v3
g' s (Case vs alts) = Case <$> traverse (g'' s) vs <*> traverse (i'' s) alts
@@ -444,7 +480,7 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j
i'' s = uncurry i' <=< i s
- i' s (CaseAlternative bs val) = CaseAlternative <$> traverse (h'' s) bs <*> eitherM (traverse (pairM (g'' s) (g'' s))) (g'' s) val
+ i' s (CaseAlternative bs val) = CaseAlternative <$> traverse (h'' s) bs <*> traverse (guardedExprM (k' s) (g'' s)) val
j'' s = uncurry j' <=< j s
@@ -453,6 +489,9 @@ 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
+ k' s (ConditionGuard e) = ConditionGuard <$> g'' s e
+ k' s (PatternGuard b e) = PatternGuard <$> h'' s b <*> g'' s e
+
everythingWithScope
:: forall r
. (Monoid r)
@@ -479,14 +518,10 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)
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)) =
+ f' s (ValueDeclaration name _ bs val) =
let s' = S.insert name s
s'' = S.union s' (S.fromList (concatMap binderNames bs))
- 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
+ in foldMap (h'' s') bs <> foldMap (l' s'') val
f' s (BindingGroupDeclaration ds) =
let s' = S.union s (S.fromList (map (\(name, _, _) -> name) ds))
in foldMap (\(_, _, val) -> g'' s' val) ds
@@ -507,12 +542,9 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)
g' s (Accessor _ v1) = g'' s v1
g' s (ObjectUpdate obj vs) = g'' s obj <> foldMap (g'' s . snd) vs
g' s (ObjectUpdateNested obj vs) = g'' s obj <> foldMap (g'' s) vs
- g' s (Abs (Left name) v1) =
- let s' = S.insert name s
- in g'' s' v1
- g' s (Abs (Right b) v1) =
+ g' s (Abs b v1) =
let s' = S.union (S.fromList (binderNames b)) s
- in g'' s' v1
+ in h'' s b <> 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
@@ -546,12 +578,9 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)
i'' s a = i s a <> i' s a
i' :: S.Set Ident -> CaseAlternative -> r
- 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)) =
+ i' s (CaseAlternative bs 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
+ in foldMap (h'' s) bs <> foldMap (l' s') gs
j'' :: S.Set Ident -> DoNotationElement -> (S.Set Ident, r)
j'' s a = let (s', r) = j' s a in (s', j s a <> r)
@@ -566,6 +595,17 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)
in (s', foldMap (f'' s') ds)
j' s (PositionedDoNotationElement _ _ e1) = j'' s e1
+ k' :: S.Set Ident -> Guard -> (S.Set Ident, r)
+ k' s (ConditionGuard e) = (s, g'' s e)
+ k' s (PatternGuard b e) =
+ let s' = S.union (S.fromList (binderNames b)) s
+ in (s', h'' s b <> g'' s' e)
+
+ l' s (GuardedExpr [] e) = g'' s e
+ l' s (GuardedExpr (grd:gs) e) =
+ let (s', r) = k' s grd
+ in r <> l' s' (GuardedExpr gs e)
+
getDeclIdent :: Declaration -> Maybe Ident
getDeclIdent (PositionedDeclaration _ _ d) = getDeclIdent d
getDeclIdent (ValueDeclaration ident _ _ _) = Just ident
@@ -642,4 +682,3 @@ overTypes f = let (_, f', _) = everywhereOnValues id g id in f'
g (TypedValue checkTy val t) = TypedValue checkTy val (f t)
g (TypeClassDictionary c sco hints) = TypeClassDictionary (mapConstraintArgs (map f) c) sco hints
g other = other
-
diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs
index 6b63d19..af226f6 100644
--- a/src/Language/PureScript/Bundle.hs
+++ b/src/Language/PureScript/Bundle.hs
@@ -3,7 +3,7 @@
--
-- This module takes as input the individual generated modules from 'Language.PureScript.Make' and
-- performs dead code elimination, filters empty modules,
--- and generates the final Javascript bundle.
+-- and generates the final JavaScript bundle.
module Language.PureScript.Bundle
( bundle
, bundleSM
@@ -17,6 +17,7 @@ module Language.PureScript.Bundle
) where
import Prelude.Compat
+import Protolude (ordNub)
import Control.Monad
import Control.Monad.Error.Class
@@ -25,7 +26,7 @@ import Control.Arrow ((&&&))
import Data.Char (chr, digitToInt)
import Data.Generics (everything, everywhere, mkQ, mkT)
import Data.Graph
-import Data.List (nub, stripPrefix)
+import Data.List (stripPrefix)
import Data.Maybe (mapMaybe, catMaybes)
import Data.Version (showVersion)
import qualified Data.Set as S
@@ -113,8 +114,8 @@ printErrorMessage :: ErrorMessage -> [String]
printErrorMessage (UnsupportedModulePath s) =
[ "A CommonJS module has an unsupported name (" ++ show s ++ ")."
, "The following file names are supported:"
- , " 1) index.js (psc native modules)"
- , " 2) foreign.js (psc foreign modules)"
+ , " 1) index.js (PureScript native modules)"
+ , " 2) foreign.js (PureScript foreign modules)"
]
printErrorMessage InvalidTopLevel =
[ "Expected a list of source elements at the top level." ]
@@ -184,10 +185,10 @@ withDeps (Module modulePath fn es) = Module modulePath fn (map expandDeps es)
-- | Calculate dependencies and add them to the current element.
expandDeps :: ModuleElement -> ModuleElement
- expandDeps (Member n f nm decl _) = Member n f nm decl (nub $ dependencies modulePath decl)
+ expandDeps (Member n f nm decl _) = Member n f nm decl (ordNub $ dependencies modulePath decl)
expandDeps (ExportsList exps) = ExportsList (map expand exps)
where
- expand (ty, nm, n1, _) = (ty, nm, n1, nub (dependencies modulePath n1))
+ expand (ty, nm, n1, _) = (ty, nm, n1, ordNub (dependencies modulePath n1))
expandDeps other = other
dependencies :: ModuleIdentifier -> JSExpression -> [(ModuleIdentifier, String)]
@@ -249,7 +250,7 @@ trailingCommaList :: JSCommaTrailingList a -> [a]
trailingCommaList (JSCTLComma l _) = commaList l
trailingCommaList (JSCTLNone l) = commaList l
--- | Attempt to create a Module from a Javascript AST.
+-- | Attempt to create a Module from a JavaScript AST.
--
-- Each type of module element is matched using pattern guards, and everything else is bundled into the
-- Other constructor.
@@ -671,7 +672,7 @@ codeGen optionsMainModule optionsNamespace ms outFileOpt = (fmap sourceMapping o
-- | The bundling function.
-- This function performs dead code elimination, filters empty modules
--- and generates and prints the final Javascript bundle.
+-- and generates and prints the final JavaScript bundle.
bundleSM :: (MonadError ErrorMessage m)
=> [(ModuleIdentifier, Maybe FilePath, String)] -- ^ The input modules. Each module should be javascript rendered from 'Language.PureScript.Make' or @psc@.
-> [ModuleIdentifier] -- ^ Entry points. These module identifiers are used as the roots for dead-code elimination
@@ -700,7 +701,7 @@ bundleSM inputStrs entryPoints mainModule namespace outFilename = do
-- | The bundling function.
-- This function performs dead code elimination, filters empty modules
--- and generates and prints the final Javascript bundle.
+-- and generates and prints the final JavaScript bundle.
bundle :: (MonadError ErrorMessage m)
=> [(ModuleIdentifier, String)] -- ^ The input modules. Each module should be javascript rendered from 'Language.PureScript.Make' or @psc@.
-> [ModuleIdentifier] -- ^ Entry points. These module identifiers are used as the roots for dead-code elimination
diff --git a/src/Language/PureScript/CodeGen.hs b/src/Language/PureScript/CodeGen.hs
index d927211..02edf9e 100644
--- a/src/Language/PureScript/CodeGen.hs
+++ b/src/Language/PureScript/CodeGen.hs
@@ -1,7 +1,7 @@
-- |
-- A collection of modules related to code generation:
--
--- [@Language.PureScript.CodeGen.JS@] Code generator for Javascript
+-- [@Language.PureScript.CodeGen.JS@] Code generator for JavaScript
--
module Language.PureScript.CodeGen (module C) where
diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index a6adeca..991223a 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -1,6 +1,5 @@
--- |
--- This module generates code in the simplified Javascript intermediate representation from Purescript code
---
+-- | This module generates code in the core imperative representation from
+-- elaborated PureScript code.
module Language.PureScript.CodeGen.JS
( module AST
, module Common
@@ -8,14 +7,15 @@ module Language.PureScript.CodeGen.JS
) where
import Prelude.Compat
+import Protolude (ordNub)
-import Control.Arrow ((&&&))
+import Control.Arrow ((&&&), second)
import Control.Monad (forM, replicateM, void)
import Control.Monad.Except (MonadError, throwError)
import Control.Monad.Reader (MonadReader, asks)
import Control.Monad.Supply.Class
-import Data.List ((\\), delete, intersect, nub)
+import Data.List ((\\), delete, intersect)
import qualified Data.Foldable as F
import qualified Data.Map as M
import Data.Maybe (fromMaybe, isNothing)
@@ -25,9 +25,10 @@ import Data.Text (Text)
import qualified Data.Text as T
import Language.PureScript.AST.SourcePos
-import Language.PureScript.CodeGen.JS.AST as AST
import Language.PureScript.CodeGen.JS.Common as Common
-import Language.PureScript.CodeGen.JS.Optimizer
+import Language.PureScript.CoreImp.AST (AST, everywhereTopDownM, withSourceSpan)
+import qualified Language.PureScript.CoreImp.AST as AST
+import Language.PureScript.CoreImp.Optimizer
import Language.PureScript.CoreFn
import Language.PureScript.Crash
import Language.PureScript.Errors (ErrorMessageHint(..), SimpleErrorMessage(..),
@@ -41,49 +42,43 @@ import qualified Language.PureScript.Constants as C
import System.FilePath.Posix ((</>))
--- |
--- Generate code in the simplified Javascript intermediate representation for all declarations in a
+-- | Generate code in the simplified JavaScript intermediate representation for all declarations in a
-- module.
---
moduleToJs
:: forall m
. (Monad m, MonadReader Options m, MonadSupply m, MonadError MultipleErrors m)
=> Module Ann
- -> Maybe JS
- -> m [JS]
+ -> Maybe AST
+ -> m [AST]
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 <- traverse (importToJs mnLookup) . delete (ModuleName [ProperName C.prim]) . (\\ [mn]) $ nub $ map snd imps
+ jsImports <- traverse (importToJs mnLookup) . delete (ModuleName [ProperName C.prim]) . (\\ [mn]) $ ordNub $ map snd imps
let decls' = renameModules mnLookup decls
jsDecls <- mapM bindToJs decls'
optimized <- traverse (traverse optimize) jsDecls
F.traverse_ (F.traverse_ checkIntegers) optimized
comments <- not <$> asks optionsNoComments
- let strict = JSStringLiteral Nothing "use strict"
- let header = if comments && not (null coms) then JSComment Nothing coms strict else strict
- let foreign' = [JSVariableIntroduction Nothing "$foreign" foreign_ | not $ null foreigns || isNothing foreign_]
+ let strict = AST.StringLiteral Nothing "use strict"
+ let header = if comments && not (null coms) then AST.Comment Nothing coms strict else strict
+ let foreign' = [AST.VariableIntroduction Nothing "$foreign" foreign_ | not $ null foreigns || isNothing foreign_]
let moduleBody = header : foreign' ++ jsImports ++ concat optimized
let foreignExps = exps `intersect` (fst `map` foreigns)
let standardExps = exps \\ foreignExps
- let exps' = JSObjectLiteral Nothing $ map (mkString . runIdent &&& JSVar Nothing . identToJs) standardExps
+ let exps' = AST.ObjectLiteral Nothing $ map (mkString . runIdent &&& AST.Var Nothing . identToJs) standardExps
++ map (mkString . runIdent &&& foreignIdent) foreignExps
- return $ moduleBody ++ [JSAssignment Nothing (accessorString "exports" (JSVar Nothing "module")) exps']
+ return $ moduleBody ++ [AST.Assignment Nothing (accessorString "exports" (AST.Var Nothing "module")) exps']
where
- -- |
- -- Extracts all declaration names from a binding group.
- --
+ -- | Extracts all declaration names from a binding group.
getNames :: Bind Ann -> [Ident]
getNames (NonRec _ ident _) = [ident]
getNames (Rec vals) = map (snd . fst) vals
- -- |
- -- Creates alternative names for each module to ensure they don't collide
+ -- | Creates alternative names for each module to ensure they don't collide
-- with declaration names.
- --
renameImports :: [Ident] -> [(Ann, ModuleName)] -> M.Map ModuleName (Ann, ModuleName)
renameImports = go M.empty
where
@@ -103,20 +98,16 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
then freshModuleName (i + 1) mn' used
else newName
- -- |
- -- Generates Javascript code for a module import, binding the required module
+ -- | Generates JavaScript code for a module import, binding the required module
-- to the alternative
- --
- importToJs :: M.Map ModuleName (Ann, ModuleName) -> ModuleName -> m JS
+ importToJs :: M.Map ModuleName (Ann, ModuleName) -> ModuleName -> m AST
importToJs mnLookup mn' = do
let ((ss, _, _, _), mnSafe) = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup
- let moduleBody = JSApp Nothing (JSVar Nothing "require") [JSStringLiteral Nothing (fromString (".." </> T.unpack (runModuleName mn')))]
- withPos ss $ JSVariableIntroduction Nothing (moduleNameToJs mnSafe) (Just moduleBody)
+ let moduleBody = AST.App Nothing (AST.Var Nothing "require") [AST.StringLiteral Nothing (fromString (".." </> T.unpack (runModuleName mn')))]
+ withPos ss $ AST.VariableIntroduction Nothing (moduleNameToJs mnSafe) (Just moduleBody)
- -- |
- -- Replaces the `ModuleName`s in the AST so that the generated code refers to
+ -- | Replaces the `ModuleName`s in the AST so that the generated code refers to
-- the collision-avoiding renamed module imports.
- --
renameModules :: M.Map ModuleName (Ann, ModuleName) -> [Bind Ann] -> [Bind Ann]
renameModules mnLookup binds =
let (f, _, _) = everywhereOnValues id goExpr goBinder
@@ -135,29 +126,27 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
renameQual q = q
-- |
- -- Generate code in the simplified Javascript intermediate representation for a declaration
+ -- Generate code in the simplified JavaScript intermediate representation for a declaration
--
- bindToJs :: Bind Ann -> m [JS]
+ bindToJs :: Bind Ann -> m [AST]
bindToJs (NonRec ann ident val) = return <$> nonRecToJS ann ident val
bindToJs (Rec vals) = forM vals (uncurry . uncurry $ nonRecToJS)
- -- |
- -- Generate code in the simplified Javascript intermediate representation for a single non-recursive
+ -- | Generate code in the simplified JavaScript intermediate representation for a single non-recursive
-- declaration.
--
-- The main purpose of this function is to handle code generation for comments.
- --
- nonRecToJS :: Ann -> Ident -> Expr Ann -> m JS
+ nonRecToJS :: Ann -> Ident -> Expr Ann -> m AST
nonRecToJS a i e@(extractAnn -> (_, com, _, _)) | not (null com) = do
withoutComment <- asks optionsNoComments
if withoutComment
then nonRecToJS a i (modifyAnn removeComments e)
- else JSComment Nothing com <$> nonRecToJS a i (modifyAnn removeComments e)
+ else AST.Comment Nothing com <$> nonRecToJS a i (modifyAnn removeComments e)
nonRecToJS (ss, _, _, _) ident val = do
js <- valueToJs val
- withPos ss $ JSVariableIntroduction Nothing (identToJs ident) (Just js)
+ withPos ss $ AST.VariableIntroduction Nothing (identToJs ident) (Just js)
- withPos :: Maybe SourceSpan -> JS -> m JS
+ withPos :: Maybe SourceSpan -> AST -> m AST
withPos (Just ss) js = do
withSM <- asks optionsSourceMaps
return $ if withSM
@@ -165,34 +154,28 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
else js
withPos Nothing js = return js
- -- |
- -- Generate code in the simplified Javascript intermediate representation for a variable based on a
+ -- | Generate code in the simplified JavaScript intermediate representation for a variable based on a
-- PureScript identifier.
- --
- var :: Ident -> JS
- var = JSVar Nothing . identToJs
+ var :: Ident -> AST
+ var = AST.Var Nothing . identToJs
- -- |
- -- Generate code in the simplified Javascript intermediate representation for an accessor based on
- -- a PureScript identifier. If the name is not valid in Javascript (symbol based, reserved name) an
+ -- | Generate code in the simplified JavaScript intermediate representation for an accessor based on
+ -- a PureScript identifier. If the name is not valid in JavaScript (symbol based, reserved name) an
-- indexer is returned.
- --
- accessor :: Ident -> JS -> JS
+ accessor :: Ident -> AST -> AST
accessor (Ident prop) = accessorString $ mkString prop
accessor (GenIdent _ _) = internalError "GenIdent in accessor"
- accessorString :: PSString -> JS -> JS
- accessorString prop = JSIndexer Nothing (JSStringLiteral Nothing prop)
+ accessorString :: PSString -> AST -> AST
+ accessorString prop = AST.Indexer Nothing (AST.StringLiteral Nothing prop)
- -- |
- -- Generate code in the simplified Javascript intermediate representation for a value or expression.
- --
- valueToJs :: Expr Ann -> m JS
+ -- | Generate code in the simplified JavaScript intermediate representation for a value or expression.
+ valueToJs :: Expr Ann -> m AST
valueToJs e =
let (ss, _, _, _) = extractAnn e in
withPos ss =<< valueToJs' e
- valueToJs' :: Expr Ann -> m JS
+ valueToJs' :: Expr Ann -> m AST
valueToJs' (Literal (pos, _, _, _) l) =
maybe id rethrowWithPosition pos $ literalToValueJS l
valueToJs' (Var (_, _, _, Just (IsConstructor _ [])) name) =
@@ -207,27 +190,27 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
extendObj obj sts
valueToJs' e@(Abs (_, _, _, Just IsTypeClassConstructor) _ _) =
let args = unAbs e
- in return $ JSFunction Nothing Nothing (map identToJs args) (JSBlock Nothing $ map assign args)
+ in return $ AST.Function Nothing Nothing (map identToJs args) (AST.Block Nothing $ map assign args)
where
unAbs :: Expr Ann -> [Ident]
unAbs (Abs _ arg val) = arg : unAbs val
unAbs _ = []
- assign :: Ident -> JS
- assign name = JSAssignment Nothing (accessorString (mkString $ runIdent name) (JSVar Nothing "this"))
+ assign :: Ident -> AST
+ assign name = AST.Assignment Nothing (accessorString (mkString $ runIdent name) (AST.Var Nothing "this"))
(var name)
valueToJs' (Abs _ arg val) = do
ret <- valueToJs val
- return $ JSFunction Nothing Nothing [identToJs arg] (JSBlock Nothing [JSReturn Nothing ret])
+ return $ AST.Function Nothing Nothing [identToJs arg] (AST.Block Nothing [AST.Return Nothing ret])
valueToJs' e@App{} = do
let (f, args) = unApp e []
args' <- mapM valueToJs args
case f of
Var (_, _, _, Just IsNewtype) _ -> return (head args')
Var (_, _, _, Just (IsConstructor _ fields)) name | length args == length fields ->
- return $ JSUnary Nothing JSNew $ JSApp Nothing (qualifiedToJS id name) args'
+ return $ AST.Unary Nothing AST.New $ AST.App Nothing (qualifiedToJS id name) args'
Var (_, _, _, Just IsTypeClassConstructor) name ->
- return $ JSUnary Nothing JSNew $ JSApp Nothing (qualifiedToJS id name) args'
- _ -> flip (foldl (\fn a -> JSApp Nothing fn [a])) args' <$> valueToJs f
+ return $ AST.Unary Nothing AST.New $ AST.App Nothing (qualifiedToJS id name) args'
+ _ -> flip (foldl (\fn a -> AST.App Nothing fn [a])) args' <$> valueToJs f
where
unApp :: Expr Ann -> [Expr Ann] -> (Expr Ann, [Expr Ann])
unApp (App _ val arg) args = unApp val (arg : args)
@@ -245,136 +228,142 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
valueToJs' (Let _ ds val) = do
ds' <- concat <$> mapM bindToJs ds
ret <- valueToJs val
- return $ JSApp Nothing (JSFunction Nothing Nothing [] (JSBlock Nothing (ds' ++ [JSReturn Nothing ret]))) []
+ return $ AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing (ds' ++ [AST.Return Nothing ret]))) []
valueToJs' (Constructor (_, _, _, Just IsNewtype) _ (ProperName ctor) _) =
- return $ JSVariableIntroduction Nothing (properToJs ctor) (Just $
- JSObjectLiteral Nothing [("create",
- JSFunction Nothing Nothing ["value"]
- (JSBlock Nothing [JSReturn Nothing $ JSVar Nothing "value"]))])
+ return $ AST.VariableIntroduction Nothing (properToJs ctor) (Just $
+ AST.ObjectLiteral Nothing [("create",
+ AST.Function Nothing Nothing ["value"]
+ (AST.Block Nothing [AST.Return Nothing $ AST.Var Nothing "value"]))])
valueToJs' (Constructor _ _ (ProperName ctor) []) =
- return $ iife (properToJs ctor) [ JSFunction Nothing (Just (properToJs ctor)) [] (JSBlock Nothing [])
- , JSAssignment Nothing (accessorString "value" (JSVar Nothing (properToJs ctor)))
- (JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing (properToJs ctor)) []) ]
+ return $ iife (properToJs ctor) [ AST.Function Nothing (Just (properToJs ctor)) [] (AST.Block Nothing [])
+ , AST.Assignment Nothing (accessorString "value" (AST.Var Nothing (properToJs ctor)))
+ (AST.Unary Nothing AST.New $ AST.App Nothing (AST.Var Nothing (properToJs ctor)) []) ]
valueToJs' (Constructor _ _ (ProperName ctor) fields) =
let constructor =
- let body = [ JSAssignment Nothing ((accessorString $ mkString $ identToJs f) (JSVar Nothing "this")) (var f) | f <- fields ]
- in JSFunction Nothing (Just (properToJs ctor)) (identToJs `map` fields) (JSBlock Nothing body)
+ let body = [ AST.Assignment Nothing ((accessorString $ mkString $ identToJs f) (AST.Var Nothing "this")) (var f) | f <- fields ]
+ in AST.Function Nothing (Just (properToJs ctor)) (identToJs `map` fields) (AST.Block Nothing body)
createFn =
- let body = JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing (properToJs ctor)) (var `map` fields)
- in foldr (\f inner -> JSFunction Nothing Nothing [identToJs f] (JSBlock Nothing [JSReturn Nothing inner])) body fields
+ let body = AST.Unary Nothing AST.New $ AST.App Nothing (AST.Var Nothing (properToJs ctor)) (var `map` fields)
+ in foldr (\f inner -> AST.Function Nothing Nothing [identToJs f] (AST.Block Nothing [AST.Return Nothing inner])) body fields
in return $ iife (properToJs ctor) [ constructor
- , JSAssignment Nothing (accessorString "create" (JSVar Nothing (properToJs ctor))) createFn
+ , AST.Assignment Nothing (accessorString "create" (AST.Var Nothing (properToJs ctor))) createFn
]
- iife :: Text -> [JS] -> JS
- iife v exprs = JSApp Nothing (JSFunction Nothing Nothing [] (JSBlock Nothing $ exprs ++ [JSReturn Nothing $ JSVar Nothing v])) []
+ iife :: Text -> [AST] -> AST
+ iife v exprs = AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing $ exprs ++ [AST.Return Nothing $ AST.Var Nothing v])) []
- literalToValueJS :: Literal (Expr Ann) -> m JS
- literalToValueJS (NumericLiteral (Left i)) = return $ JSNumericLiteral Nothing (Left i)
- literalToValueJS (NumericLiteral (Right n)) = return $ JSNumericLiteral Nothing (Right n)
- literalToValueJS (StringLiteral s) = return $ JSStringLiteral Nothing s
- literalToValueJS (CharLiteral c) = return $ JSStringLiteral Nothing (fromString [c])
- literalToValueJS (BooleanLiteral b) = return $ JSBooleanLiteral Nothing b
- literalToValueJS (ArrayLiteral xs) = JSArrayLiteral Nothing <$> mapM valueToJs xs
- literalToValueJS (ObjectLiteral ps) = JSObjectLiteral Nothing <$> mapM (sndM valueToJs) ps
+ literalToValueJS :: Literal (Expr Ann) -> m AST
+ literalToValueJS (NumericLiteral (Left i)) = return $ AST.NumericLiteral Nothing (Left i)
+ literalToValueJS (NumericLiteral (Right n)) = return $ AST.NumericLiteral Nothing (Right n)
+ literalToValueJS (StringLiteral s) = return $ AST.StringLiteral Nothing s
+ literalToValueJS (CharLiteral c) = return $ AST.StringLiteral Nothing (fromString [c])
+ literalToValueJS (BooleanLiteral b) = return $ AST.BooleanLiteral Nothing b
+ literalToValueJS (ArrayLiteral xs) = AST.ArrayLiteral Nothing <$> mapM valueToJs xs
+ literalToValueJS (ObjectLiteral ps) = AST.ObjectLiteral Nothing <$> mapM (sndM valueToJs) ps
- -- |
- -- Shallow copy an object.
- --
- extendObj :: JS -> [(PSString, JS)] -> m JS
+ -- | Shallow copy an object.
+ extendObj :: AST -> [(PSString, AST)] -> m AST
extendObj obj sts = do
newObj <- freshName
key <- freshName
evaluatedObj <- freshName
let
- jsKey = JSVar Nothing key
- jsNewObj = JSVar Nothing newObj
- jsEvaluatedObj = JSVar Nothing evaluatedObj
- block = JSBlock Nothing (evaluate:objAssign:copy:extend ++ [JSReturn Nothing jsNewObj])
- evaluate = JSVariableIntroduction Nothing evaluatedObj (Just obj)
- objAssign = JSVariableIntroduction Nothing newObj (Just $ JSObjectLiteral Nothing [])
- copy = JSForIn Nothing key jsEvaluatedObj $ JSBlock Nothing [JSIfElse Nothing cond assign Nothing]
- cond = JSApp Nothing (accessorString "call" (accessorString "hasOwnProperty" (JSObjectLiteral Nothing []))) [jsEvaluatedObj, jsKey]
- assign = JSBlock Nothing [JSAssignment Nothing (JSIndexer Nothing jsKey jsNewObj) (JSIndexer Nothing jsKey jsEvaluatedObj)]
- stToAssign (s, js) = JSAssignment Nothing (accessorString s jsNewObj) js
+ jsKey = AST.Var Nothing key
+ jsNewObj = AST.Var Nothing newObj
+ jsEvaluatedObj = AST.Var Nothing evaluatedObj
+ block = AST.Block Nothing (evaluate:objAssign:copy:extend ++ [AST.Return Nothing jsNewObj])
+ evaluate = AST.VariableIntroduction Nothing evaluatedObj (Just obj)
+ objAssign = AST.VariableIntroduction Nothing newObj (Just $ AST.ObjectLiteral Nothing [])
+ copy = AST.ForIn Nothing key jsEvaluatedObj $ AST.Block Nothing [AST.IfElse Nothing cond assign Nothing]
+ cond = AST.App Nothing (accessorString "call" (accessorString "hasOwnProperty" (AST.ObjectLiteral Nothing []))) [jsEvaluatedObj, jsKey]
+ assign = AST.Block Nothing [AST.Assignment Nothing (AST.Indexer Nothing jsKey jsNewObj) (AST.Indexer Nothing jsKey jsEvaluatedObj)]
+ stToAssign (s, js) = AST.Assignment Nothing (accessorString s jsNewObj) js
extend = map stToAssign sts
- return $ JSApp Nothing (JSFunction Nothing Nothing [] block) []
+ return $ AST.App Nothing (AST.Function Nothing Nothing [] block) []
- -- |
- -- Generate code in the simplified Javascript intermediate representation for a reference to a
+ -- | Generate code in the simplified JavaScript intermediate representation for a reference to a
-- variable.
- --
- varToJs :: Qualified Ident -> JS
+ varToJs :: Qualified Ident -> AST
varToJs (Qualified Nothing ident) = var ident
varToJs qual = qualifiedToJS id qual
- -- |
- -- Generate code in the simplified Javascript intermediate representation for a reference to a
+ -- | Generate code in the simplified JavaScript intermediate representation for a reference to a
-- variable that may have a qualified name.
- --
- qualifiedToJS :: (a -> Ident) -> Qualified a -> JS
- qualifiedToJS f (Qualified (Just (ModuleName [ProperName mn'])) a) | mn' == C.prim = JSVar Nothing . runIdent $ f a
- qualifiedToJS f (Qualified (Just mn') a) | mn /= mn' = accessor (f a) (JSVar Nothing (moduleNameToJs mn'))
- qualifiedToJS f (Qualified _ a) = JSVar Nothing $ identToJs (f a)
+ qualifiedToJS :: (a -> Ident) -> Qualified a -> AST
+ qualifiedToJS f (Qualified (Just (ModuleName [ProperName mn'])) a) | mn' == C.prim = AST.Var Nothing . runIdent $ f a
+ qualifiedToJS f (Qualified (Just mn') a) | mn /= mn' = accessor (f a) (AST.Var Nothing (moduleNameToJs mn'))
+ qualifiedToJS f (Qualified _ a) = AST.Var Nothing $ identToJs (f a)
- foreignIdent :: Ident -> JS
- foreignIdent ident = accessorString (mkString $ runIdent ident) (JSVar Nothing "$foreign")
+ foreignIdent :: Ident -> AST
+ foreignIdent ident = accessorString (mkString $ runIdent ident) (AST.Var Nothing "$foreign")
- -- |
- -- Generate code in the simplified Javascript intermediate representation for pattern match binders
+ -- | Generate code in the simplified JavaScript intermediate representation for pattern match binders
-- and guards.
- --
- bindersToJs :: Maybe SourceSpan -> [CaseAlternative Ann] -> [JS] -> m JS
+ bindersToJs :: Maybe SourceSpan -> [CaseAlternative Ann] -> [AST] -> m AST
bindersToJs maybeSpan binders vals = do
valNames <- replicateM (length vals) freshName
- let assignments = zipWith (JSVariableIntroduction Nothing) valNames (map Just vals)
+ let assignments = zipWith (AST.VariableIntroduction Nothing) valNames (map Just vals)
jss <- forM binders $ \(CaseAlternative bs result) -> do
ret <- guardsToJs result
go valNames ret bs
- return $ JSApp Nothing (JSFunction Nothing Nothing [] (JSBlock Nothing (assignments ++ concat jss ++ [JSThrow Nothing $ failedPatternError valNames])))
+ return $ AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing (assignments ++ concat jss ++ [AST.Throw Nothing $ failedPatternError valNames])))
[]
where
- go :: [Text] -> [JS] -> [Binder Ann] -> m [JS]
+ go :: [Text] -> [AST] -> [Binder Ann] -> m [AST]
go _ done [] = return done
go (v:vs) done' (b:bs) = do
done'' <- go vs done' bs
binderToJs v done'' b
go _ _ _ = internalError "Invalid arguments to bindersToJs"
- failedPatternError :: [Text] -> JS
- failedPatternError names = JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing "Error") [JSBinary Nothing Add (JSStringLiteral Nothing $ mkString failedPatternMessage) (JSArrayLiteral Nothing $ zipWith valueError names vals)]
+ failedPatternError :: [Text] -> AST
+ failedPatternError names = AST.Unary Nothing AST.New $ AST.App Nothing (AST.Var Nothing "Error") [AST.Binary Nothing AST.Add (AST.StringLiteral Nothing $ mkString failedPatternMessage) (AST.ArrayLiteral Nothing $ zipWith valueError names vals)]
failedPatternMessage :: Text
failedPatternMessage = "Failed pattern match" <> maybe "" (((" at " <> runModuleName mn <> " ") <>) . displayStartEndPos) maybeSpan <> ": "
- valueError :: Text -> JS -> JS
- valueError _ l@(JSNumericLiteral _ _) = l
- valueError _ l@(JSStringLiteral _ _) = l
- valueError _ l@(JSBooleanLiteral _ _) = l
- valueError s _ = accessorString "name" . accessorString "constructor" $ JSVar Nothing s
-
- guardsToJs :: Either [(Guard Ann, Expr Ann)] (Expr Ann) -> m [JS]
- guardsToJs (Left gs) = forM gs $ \(cond, val) -> do
- cond' <- valueToJs cond
- done <- valueToJs val
- return $ JSIfElse Nothing cond' (JSBlock Nothing [JSReturn Nothing done]) Nothing
- guardsToJs (Right v) = return . JSReturn Nothing <$> valueToJs v
-
- binderToJs :: Text -> [JS] -> Binder Ann -> m [JS]
+ valueError :: Text -> AST -> AST
+ valueError _ l@(AST.NumericLiteral _ _) = l
+ valueError _ l@(AST.StringLiteral _ _) = l
+ valueError _ l@(AST.BooleanLiteral _ _) = l
+ valueError s _ = accessorString "name" . accessorString "constructor" $ AST.Var Nothing s
+
+ guardsToJs :: Either [(Guard Ann, Expr Ann)] (Expr Ann) -> m [AST]
+ guardsToJs (Left gs) = snd <$> F.foldrM genGuard (False, []) gs
+ where
+ genGuard (cond, val) (False, js) = second (: js) <$> genCondVal cond val
+ genGuard _ x = pure x
+
+ genCondVal cond val
+ | condIsTrue cond = do
+ js <- AST.Return Nothing <$> valueToJs val
+ return (True, js)
+ | otherwise = do
+ cond' <- valueToJs cond
+ val' <- valueToJs val
+ return
+ (False, AST.IfElse Nothing cond'
+ (AST.Block Nothing [AST.Return Nothing val']) Nothing)
+
+ -- hopefully the inliner did its job and inlined `otherwise`
+ condIsTrue (Literal _ (BooleanLiteral True)) = True
+ condIsTrue _ = False
+
+ guardsToJs (Right v) = return . AST.Return Nothing <$> valueToJs v
+
+ binderToJs :: Text -> [AST] -> Binder Ann -> m [AST]
binderToJs s done binder =
let (ss, _, _, _) = extractBinderAnn binder in
traverse (withPos ss) =<< binderToJs' s done binder
- -- |
- -- Generate code in the simplified Javascript intermediate representation for a pattern match
+ -- | Generate code in the simplified JavaScript intermediate representation for a pattern match
-- binder.
- --
- binderToJs' :: Text -> [JS] -> Binder Ann -> m [JS]
+ binderToJs' :: Text -> [AST] -> Binder Ann -> m [AST]
binderToJs' _ done NullBinder{} = return done
binderToJs' varName done (LiteralBinder _ l) =
literalToBinderJS varName done l
binderToJs' varName done (VarBinder _ ident) =
- return (JSVariableIntroduction Nothing (identToJs ident) (Just (JSVar Nothing varName)) : done)
+ return (AST.VariableIntroduction Nothing (identToJs ident) (Just (AST.Var Nothing varName)) : done)
binderToJs' varName done (ConstructorBinder (_, _, _, Just IsNewtype) _ _ [b]) =
binderToJs varName done b
binderToJs' varName done (ConstructorBinder (_, _, _, Just (IsConstructor ctorType fields)) _ ctor bs) = do
@@ -382,68 +371,68 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
return $ case ctorType of
ProductType -> js
SumType ->
- [JSIfElse Nothing (JSInstanceOf Nothing (JSVar Nothing varName) (qualifiedToJS (Ident . runProperName) ctor))
- (JSBlock Nothing js)
+ [AST.IfElse Nothing (AST.InstanceOf Nothing (AST.Var Nothing varName) (qualifiedToJS (Ident . runProperName) ctor))
+ (AST.Block Nothing js)
Nothing]
where
- go :: [(Ident, Binder Ann)] -> [JS] -> m [JS]
+ go :: [(Ident, Binder Ann)] -> [AST] -> m [AST]
go [] done' = return done'
go ((field, binder) : remain) done' = do
argVar <- freshName
done'' <- go remain done'
js <- binderToJs argVar done'' binder
- return (JSVariableIntroduction Nothing argVar (Just $ accessorString (mkString $ identToJs field) $ JSVar Nothing varName) : js)
+ return (AST.VariableIntroduction Nothing argVar (Just $ accessorString (mkString $ identToJs field) $ AST.Var Nothing varName) : js)
binderToJs' _ _ ConstructorBinder{} =
internalError "binderToJs: Invalid ConstructorBinder in binderToJs"
binderToJs' varName done (NamedBinder _ ident binder) = do
js <- binderToJs varName done binder
- return (JSVariableIntroduction Nothing (identToJs ident) (Just (JSVar Nothing varName)) : js)
+ return (AST.VariableIntroduction Nothing (identToJs ident) (Just (AST.Var Nothing varName)) : js)
- literalToBinderJS :: Text -> [JS] -> Literal (Binder Ann) -> m [JS]
+ literalToBinderJS :: Text -> [AST] -> Literal (Binder Ann) -> m [AST]
literalToBinderJS varName done (NumericLiteral num) =
- return [JSIfElse Nothing (JSBinary Nothing EqualTo (JSVar Nothing varName) (JSNumericLiteral Nothing num)) (JSBlock Nothing done) Nothing]
+ return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.NumericLiteral Nothing num)) (AST.Block Nothing done) Nothing]
literalToBinderJS varName done (CharLiteral c) =
- return [JSIfElse Nothing (JSBinary Nothing EqualTo (JSVar Nothing varName) (JSStringLiteral Nothing (fromString [c]))) (JSBlock Nothing done) Nothing]
+ return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.StringLiteral Nothing (fromString [c]))) (AST.Block Nothing done) Nothing]
literalToBinderJS varName done (StringLiteral str) =
- return [JSIfElse Nothing (JSBinary Nothing EqualTo (JSVar Nothing varName) (JSStringLiteral Nothing str)) (JSBlock Nothing done) Nothing]
+ return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.StringLiteral Nothing str)) (AST.Block Nothing done) Nothing]
literalToBinderJS varName done (BooleanLiteral True) =
- return [JSIfElse Nothing (JSVar Nothing varName) (JSBlock Nothing done) Nothing]
+ return [AST.IfElse Nothing (AST.Var Nothing varName) (AST.Block Nothing done) Nothing]
literalToBinderJS varName done (BooleanLiteral False) =
- return [JSIfElse Nothing (JSUnary Nothing Not (JSVar Nothing varName)) (JSBlock Nothing done) Nothing]
+ return [AST.IfElse Nothing (AST.Unary Nothing AST.Not (AST.Var Nothing varName)) (AST.Block Nothing done) Nothing]
literalToBinderJS varName done (ObjectLiteral bs) = go done bs
where
- go :: [JS] -> [(PSString, Binder Ann)] -> m [JS]
+ go :: [AST] -> [(PSString, Binder Ann)] -> m [AST]
go done' [] = return done'
go done' ((prop, binder):bs') = do
propVar <- freshName
done'' <- go done' bs'
js <- binderToJs propVar done'' binder
- return (JSVariableIntroduction Nothing propVar (Just (accessorString prop (JSVar Nothing varName))) : js)
+ return (AST.VariableIntroduction Nothing propVar (Just (accessorString prop (AST.Var Nothing varName))) : js)
literalToBinderJS varName done (ArrayLiteral bs) = do
js <- go done 0 bs
- return [JSIfElse Nothing (JSBinary Nothing EqualTo (accessorString "length" (JSVar Nothing varName)) (JSNumericLiteral Nothing (Left (fromIntegral $ length bs)))) (JSBlock Nothing js) Nothing]
+ return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (accessorString "length" (AST.Var Nothing varName)) (AST.NumericLiteral Nothing (Left (fromIntegral $ length bs)))) (AST.Block Nothing js) Nothing]
where
- go :: [JS] -> Integer -> [Binder Ann] -> m [JS]
+ go :: [AST] -> Integer -> [Binder Ann] -> m [AST]
go done' _ [] = return done'
go done' index (binder:bs') = do
elVar <- freshName
done'' <- go done' (index + 1) bs'
js <- binderToJs elVar done'' binder
- return (JSVariableIntroduction Nothing elVar (Just (JSIndexer Nothing (JSNumericLiteral Nothing (Left index)) (JSVar Nothing varName))) : js)
+ return (AST.VariableIntroduction Nothing elVar (Just (AST.Indexer Nothing (AST.NumericLiteral Nothing (Left index)) (AST.Var Nothing varName))) : js)
-- Check that all integers fall within the valid int range for JavaScript.
- checkIntegers :: JS -> m ()
- checkIntegers = void . everywhereOnJSTopDownM go
+ checkIntegers :: AST -> m ()
+ checkIntegers = void . everywhereTopDownM go
where
- go :: JS -> m JS
- go (JSUnary _ Negate (JSNumericLiteral ss (Left i))) =
+ go :: AST -> m AST
+ go (AST.Unary _ AST.Negate (AST.NumericLiteral ss (Left i))) =
-- Move the negation inside the literal; since this is a top-down
-- traversal doing this replacement will stop the next case from raising
-- the error when attempting to use -2147483648, as if left unrewritten
- -- the value is `JSUnary Negate (JSNumericLiteral (Left 2147483648))`, and
+ -- the value is `Unary Negate (NumericLiteral (Left 2147483648))`, and
-- 2147483648 is larger than the maximum allowed int.
- return $ JSNumericLiteral ss (Left (-i))
- go js@(JSNumericLiteral _ (Left i)) =
+ return $ AST.NumericLiteral ss (Left (-i))
+ go js@(AST.NumericLiteral _ (Left i)) =
let minInt = -2147483648
maxInt = 2147483647
in if i < minInt || i > maxInt
diff --git a/src/Language/PureScript/CodeGen/JS/AST.hs b/src/Language/PureScript/CodeGen/JS/AST.hs
deleted file mode 100644
index a8c196f..0000000
--- a/src/Language/PureScript/CodeGen/JS/AST.hs
+++ /dev/null
@@ -1,398 +0,0 @@
--- |
--- Data types for the intermediate simplified-Javascript AST
---
-module Language.PureScript.CodeGen.JS.AST where
-
-import Prelude.Compat
-
-import Control.Monad ((>=>))
-import Control.Monad.Identity (Identity(..), runIdentity)
-import Data.Text (Text)
-
-import Language.PureScript.AST (SourceSpan(..))
-import Language.PureScript.Comments
-import Language.PureScript.PSString (PSString)
-import Language.PureScript.Traversals
-
--- |
--- Built-in unary operators
---
-data UnaryOperator
- -- |
- -- Numeric negation
- --
- = Negate
- -- |
- -- Boolean negation
- --
- | Not
- -- |
- -- Bitwise negation
- --
- | BitwiseNot
- -- |
- -- Numeric unary \'plus\'
- --
- | Positive
- -- |
- -- Constructor
- --
- | JSNew
- deriving (Show, Eq)
-
--- |
--- Built-in binary operators
---
-data BinaryOperator
- -- |
- -- Numeric addition
- --
- = Add
- -- |
- -- Numeric subtraction
- --
- | Subtract
- -- |
- -- Numeric multiplication
- --
- | Multiply
- -- |
- -- Numeric division
- --
- | Divide
- -- |
- -- Remainder
- --
- | Modulus
- -- |
- -- Generic equality test
- --
- | EqualTo
- -- |
- -- Generic inequality test
- --
- | NotEqualTo
- -- |
- -- Numeric less-than
- --
- | LessThan
- -- |
- -- Numeric less-than-or-equal
- --
- | LessThanOrEqualTo
- -- |
- -- Numeric greater-than
- --
- | GreaterThan
- -- |
- -- Numeric greater-than-or-equal
- --
- | GreaterThanOrEqualTo
- -- |
- -- Boolean and
- --
- | And
- -- |
- -- Boolean or
- --
- | Or
- -- |
- -- Bitwise and
- --
- | BitwiseAnd
- -- |
- -- Bitwise or
- --
- | BitwiseOr
- -- |
- -- Bitwise xor
- --
- | BitwiseXor
- -- |
- -- Bitwise left shift
- --
- | ShiftLeft
- -- |
- -- Bitwise right shift
- --
- | ShiftRight
- -- |
- -- Bitwise right shift with zero-fill
- --
- | ZeroFillShiftRight
- deriving (Show, Eq)
-
--- |
--- Data type for simplified Javascript expressions
---
-data JS
- -- |
- -- A numeric literal
- --
- = JSNumericLiteral (Maybe SourceSpan) (Either Integer Double)
- -- |
- -- A string literal
- --
- | JSStringLiteral (Maybe SourceSpan) PSString
- -- |
- -- A boolean literal
- --
- | JSBooleanLiteral (Maybe SourceSpan) Bool
- -- |
- -- A unary operator application
- --
- | JSUnary (Maybe SourceSpan) UnaryOperator JS
- -- |
- -- A binary operator application
- --
- | JSBinary (Maybe SourceSpan) BinaryOperator JS JS
- -- |
- -- An array literal
- --
- | JSArrayLiteral (Maybe SourceSpan) [JS]
- -- |
- -- An array indexer expression
- --
- | JSIndexer (Maybe SourceSpan) JS JS
- -- |
- -- An object literal
- --
- | JSObjectLiteral (Maybe SourceSpan) [(PSString, JS)]
- -- |
- -- A function introduction (optional name, arguments, body)
- --
- | JSFunction (Maybe SourceSpan) (Maybe Text) [Text] JS
- -- |
- -- Function application
- --
- | JSApp (Maybe SourceSpan) JS [JS]
- -- |
- -- Variable
- --
- | JSVar (Maybe SourceSpan) Text
- -- |
- -- Conditional expression
- --
- | JSConditional (Maybe SourceSpan) JS JS JS
- -- |
- -- A block of expressions in braces
- --
- | JSBlock (Maybe SourceSpan) [JS]
- -- |
- -- A variable introduction and optional initialization
- --
- | JSVariableIntroduction (Maybe SourceSpan) Text (Maybe JS)
- -- |
- -- A variable assignment
- --
- | JSAssignment (Maybe SourceSpan) JS JS
- -- |
- -- While loop
- --
- | JSWhile (Maybe SourceSpan) JS JS
- -- |
- -- For loop
- --
- | JSFor (Maybe SourceSpan) Text JS JS JS
- -- |
- -- ForIn loop
- --
- | JSForIn (Maybe SourceSpan) Text JS JS
- -- |
- -- If-then-else statement
- --
- | JSIfElse (Maybe SourceSpan) JS JS (Maybe JS)
- -- |
- -- Return statement
- --
- | JSReturn (Maybe SourceSpan) JS
- -- |
- -- Throw statement
- --
- | JSThrow (Maybe SourceSpan) JS
- -- |
- -- Type-Of operator
- --
- | JSTypeOf (Maybe SourceSpan) JS
- -- |
- -- InstanceOf test
- --
- | JSInstanceOf (Maybe SourceSpan) JS JS
- -- |
- -- Labelled statement
- --
- | JSLabel (Maybe SourceSpan) Text JS
- -- |
- -- Break statement
- --
- | JSBreak (Maybe SourceSpan) Text
- -- |
- -- Continue statement
- --
- | JSContinue (Maybe SourceSpan) Text
- -- |
- -- Raw Javascript (generated when parsing fails for an inline foreign import declaration)
- --
- | JSRaw (Maybe SourceSpan) Text
- -- |
- -- Commented Javascript
- --
- | JSComment (Maybe SourceSpan) [Comment] JS
- deriving (Show, Eq)
-
-withSourceSpan :: SourceSpan -> JS -> JS
-withSourceSpan withSpan = go
- where
- ss :: Maybe SourceSpan
- ss = Just withSpan
-
- go :: JS -> JS
- go (JSNumericLiteral _ n) = JSNumericLiteral ss n
- go (JSStringLiteral _ s) = JSStringLiteral ss s
- go (JSBooleanLiteral _ b) = JSBooleanLiteral ss b
- go (JSUnary _ op j) = JSUnary ss op j
- go (JSBinary _ op j1 j2) = JSBinary ss op j1 j2
- go (JSArrayLiteral _ js) = JSArrayLiteral ss js
- go (JSIndexer _ j1 j2) = JSIndexer ss j1 j2
- go (JSObjectLiteral _ js) = JSObjectLiteral ss js
- go (JSFunction _ name args j) = JSFunction ss name args j
- go (JSApp _ j js) = JSApp ss j js
- go (JSVar _ s) = JSVar ss s
- go (JSConditional _ j1 j2 j3) = JSConditional ss j1 j2 j3
- go (JSBlock _ js) = JSBlock ss js
- go (JSVariableIntroduction _ name j) = JSVariableIntroduction ss name j
- go (JSAssignment _ j1 j2) = JSAssignment ss j1 j2
- go (JSWhile _ j1 j2) = JSWhile ss j1 j2
- go (JSFor _ name j1 j2 j3) = JSFor ss name j1 j2 j3
- go (JSForIn _ name j1 j2) = JSForIn ss name j1 j2
- go (JSIfElse _ j1 j2 j3) = JSIfElse ss j1 j2 j3
- go (JSReturn _ js) = JSReturn ss js
- go (JSThrow _ js) = JSThrow ss js
- go (JSTypeOf _ js) = JSTypeOf ss js
- go (JSInstanceOf _ j1 j2) = JSInstanceOf ss j1 j2
- go (JSLabel _ name js) = JSLabel ss name js
- go (JSBreak _ s) = JSBreak ss s
- go (JSContinue _ s) = JSContinue ss s
- go (JSRaw _ s) = JSRaw ss s
- go (JSComment _ com j) = JSComment ss com j
-
-getSourceSpan :: JS -> Maybe SourceSpan
-getSourceSpan = go
- where
- go :: JS -> Maybe SourceSpan
- go (JSNumericLiteral ss _) = ss
- go (JSStringLiteral ss _) = ss
- go (JSBooleanLiteral ss _) = ss
- go (JSUnary ss _ _) = ss
- go (JSBinary ss _ _ _) = ss
- go (JSArrayLiteral ss _) = ss
- go (JSIndexer ss _ _) = ss
- go (JSObjectLiteral ss _) = ss
- go (JSFunction ss _ _ _) = ss
- go (JSApp ss _ _) = ss
- go (JSVar ss _) = ss
- go (JSConditional ss _ _ _) = ss
- go (JSBlock ss _) = ss
- go (JSVariableIntroduction ss _ _) = ss
- go (JSAssignment ss _ _) = ss
- go (JSWhile ss _ _) = ss
- go (JSFor ss _ _ _ _) = ss
- go (JSForIn ss _ _ _) = ss
- go (JSIfElse ss _ _ _) = ss
- go (JSReturn ss _) = ss
- go (JSThrow ss _) = ss
- go (JSTypeOf ss _) = ss
- go (JSInstanceOf ss _ _) = ss
- go (JSLabel ss _ _) = ss
- go (JSBreak ss _) = ss
- go (JSContinue ss _) = ss
- go (JSRaw ss _) = ss
- go (JSComment ss _ _) = ss
-
---
--- Traversals
---
-
-everywhereOnJS :: (JS -> JS) -> JS -> JS
-everywhereOnJS f = go
- where
- go :: JS -> JS
- go (JSUnary ss op j) = f (JSUnary ss op (go j))
- go (JSBinary ss op j1 j2) = f (JSBinary ss op (go j1) (go j2))
- go (JSArrayLiteral ss js) = f (JSArrayLiteral ss (map go js))
- go (JSIndexer ss j1 j2) = f (JSIndexer ss (go j1) (go j2))
- go (JSObjectLiteral ss js) = f (JSObjectLiteral ss (map (fmap go) js))
- go (JSFunction ss name args j) = f (JSFunction ss name args (go j))
- go (JSApp ss j js) = f (JSApp ss (go j) (map go js))
- go (JSConditional ss j1 j2 j3) = f (JSConditional ss (go j1) (go j2) (go j3))
- go (JSBlock ss js) = f (JSBlock ss (map go js))
- go (JSVariableIntroduction ss name j) = f (JSVariableIntroduction ss name (fmap go j))
- go (JSAssignment ss j1 j2) = f (JSAssignment ss (go j1) (go j2))
- go (JSWhile ss j1 j2) = f (JSWhile ss (go j1) (go j2))
- go (JSFor ss name j1 j2 j3) = f (JSFor ss name (go j1) (go j2) (go j3))
- go (JSForIn ss name j1 j2) = f (JSForIn ss name (go j1) (go j2))
- go (JSIfElse ss j1 j2 j3) = f (JSIfElse ss (go j1) (go j2) (fmap go j3))
- go (JSReturn ss js) = f (JSReturn ss (go js))
- go (JSThrow ss js) = f (JSThrow ss (go js))
- go (JSTypeOf ss js) = f (JSTypeOf ss (go js))
- go (JSLabel ss name js) = f (JSLabel ss name (go js))
- go (JSInstanceOf ss j1 j2) = f (JSInstanceOf ss (go j1) (go j2))
- go (JSComment ss com j) = f (JSComment ss com (go j))
- go other = f other
-
-everywhereOnJSTopDown :: (JS -> JS) -> JS -> JS
-everywhereOnJSTopDown f = runIdentity . everywhereOnJSTopDownM (Identity . f)
-
-everywhereOnJSTopDownM :: (Monad m) => (JS -> m JS) -> JS -> m JS
-everywhereOnJSTopDownM f = f >=> go
- where
- f' = f >=> go
- go (JSUnary ss op j) = JSUnary ss op <$> f' j
- go (JSBinary ss op j1 j2) = JSBinary ss op <$> f' j1 <*> f' j2
- go (JSArrayLiteral ss js) = JSArrayLiteral ss <$> traverse f' js
- go (JSIndexer ss j1 j2) = JSIndexer ss <$> f' j1 <*> f' j2
- go (JSObjectLiteral ss js) = JSObjectLiteral ss <$> traverse (sndM f') js
- go (JSFunction ss name args j) = JSFunction ss name args <$> f' j
- go (JSApp ss j js) = JSApp ss <$> f' j <*> traverse f' js
- go (JSConditional ss j1 j2 j3) = JSConditional ss <$> f' j1 <*> f' j2 <*> f' j3
- go (JSBlock ss js) = JSBlock ss <$> traverse f' js
- go (JSVariableIntroduction ss name j) = JSVariableIntroduction ss name <$> traverse f' j
- go (JSAssignment ss j1 j2) = JSAssignment ss <$> f' j1 <*> f' j2
- go (JSWhile ss j1 j2) = JSWhile ss <$> f' j1 <*> f' j2
- go (JSFor ss name j1 j2 j3) = JSFor ss name <$> f' j1 <*> f' j2 <*> f' j3
- go (JSForIn ss name j1 j2) = JSForIn ss name <$> f' j1 <*> f' j2
- go (JSIfElse ss j1 j2 j3) = JSIfElse ss <$> f' j1 <*> f' j2 <*> traverse f' j3
- go (JSReturn ss j) = JSReturn ss <$> f' j
- go (JSThrow ss j) = JSThrow ss <$> f' j
- go (JSTypeOf ss j) = JSTypeOf ss <$> f' j
- go (JSLabel ss name j) = JSLabel ss name <$> f' j
- go (JSInstanceOf ss j1 j2) = JSInstanceOf ss <$> f' j1 <*> f' j2
- go (JSComment ss com j) = JSComment ss com <$> f' j
- go other = f other
-
-everythingOnJS :: (r -> r -> r) -> (JS -> r) -> JS -> r
-everythingOnJS (<>) f = go
- where
- go j@(JSUnary _ _ j1) = f j <> go j1
- go j@(JSBinary _ _ j1 j2) = f j <> go j1 <> go j2
- go j@(JSArrayLiteral _ js) = foldl (<>) (f j) (map go js)
- go j@(JSIndexer _ j1 j2) = f j <> go j1 <> go j2
- go j@(JSObjectLiteral _ js) = foldl (<>) (f j) (map (go . snd) js)
- go j@(JSFunction _ _ _ j1) = f j <> go j1
- go j@(JSApp _ j1 js) = foldl (<>) (f j <> go j1) (map go js)
- go j@(JSConditional _ j1 j2 j3) = f j <> go j1 <> go j2 <> go j3
- go j@(JSBlock _ js) = foldl (<>) (f j) (map go js)
- go j@(JSVariableIntroduction _ _ (Just j1)) = f j <> go j1
- go j@(JSAssignment _ j1 j2) = f j <> go j1 <> go j2
- go j@(JSWhile _ j1 j2) = f j <> go j1 <> go j2
- go j@(JSFor _ _ j1 j2 j3) = f j <> go j1 <> go j2 <> go j3
- go j@(JSForIn _ _ j1 j2) = f j <> go j1 <> go j2
- go j@(JSIfElse _ j1 j2 Nothing) = f j <> go j1 <> go j2
- go j@(JSIfElse _ j1 j2 (Just j3)) = f j <> go j1 <> go j2 <> go j3
- go j@(JSReturn _ j1) = f j <> go j1
- go j@(JSThrow _ j1) = f j <> go j1
- go j@(JSTypeOf _ j1) = f j <> go j1
- go j@(JSLabel _ _ j1) = f j <> go j1
- go j@(JSInstanceOf _ j1 j2) = f j <> go j1 <> go j2
- go j@(JSComment _ _ j1) = f j <> go j1
- go other = f other
diff --git a/src/Language/PureScript/CodeGen/JS/Common.hs b/src/Language/PureScript/CodeGen/JS/Common.hs
index e07b5ab..0060b56 100644
--- a/src/Language/PureScript/CodeGen/JS/Common.hs
+++ b/src/Language/PureScript/CodeGen/JS/Common.hs
@@ -1,6 +1,4 @@
--- |
--- Common code generation utility functions
---
+-- | Common code generation utility functions
module Language.PureScript.CodeGen.JS.Common where
import Prelude.Compat
@@ -18,15 +16,13 @@ moduleNameToJs (ModuleName pns) =
let name = T.intercalate "_" (runProperName `map` pns)
in if nameIsJsBuiltIn name then "$$" <> name else name
--- |
--- Convert an Ident into a valid Javascript identifier:
+-- | Convert an 'Ident' into a valid JavaScript identifier:
--
-- * Alphanumeric characters are kept unmodified.
--
-- * Reserved javascript identifiers are prefixed with '$$'.
--
-- * Symbols are prefixed with '$' followed by a symbol name or their ordinal value.
---
identToJs :: Ident -> Text
identToJs (Ident name) = properToJs name
identToJs (GenIdent _ _) = internalError "GenIdent in identToJs"
@@ -36,16 +32,12 @@ properToJs name
| nameIsJsReserved name || nameIsJsBuiltIn name = "$$" <> name
| otherwise = T.concatMap identCharToText name
--- |
--- Test if a string is a valid JS identifier without escaping.
---
+-- | Test if a string is a valid AST identifier without escaping.
identNeedsEscaping :: Text -> Bool
identNeedsEscaping s = s /= properToJs s || T.null s
--- |
--- Attempts to find a human-readable name for a symbol, if none has been specified returns the
+-- | Attempts to find a human-readable name for a symbol, if none has been specified returns the
-- ordinal value.
---
identCharToText :: Char -> Text
identCharToText c | isAlphaNum c = T.singleton c
identCharToText '_' = "_"
@@ -72,16 +64,12 @@ identCharToText '@' = "$at"
identCharToText '\'' = "$prime"
identCharToText c = '$' `T.cons` T.pack (show (ord c))
--- |
--- Checks whether an identifier name is reserved in Javascript.
---
+-- | Checks whether an identifier name is reserved in JavaScript.
nameIsJsReserved :: Text -> Bool
nameIsJsReserved name =
name `elem` jsAnyReserved
--- |
--- Checks whether a name matches a built-in value in Javascript.
---
+-- | Checks whether a name matches a built-in value in JavaScript.
nameIsJsBuiltIn :: Text -> Bool
nameIsJsBuiltIn name =
name `elem`
diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer.hs b/src/Language/PureScript/CodeGen/JS/Optimizer.hs
deleted file mode 100644
index 69f9b5b..0000000
--- a/src/Language/PureScript/CodeGen/JS/Optimizer.hs
+++ /dev/null
@@ -1,73 +0,0 @@
--- |
--- This module optimizes code in the simplified-Javascript intermediate representation.
---
--- The following optimizations are supported:
---
--- * Collapsing nested blocks
---
--- * Tail call elimination
---
--- * Inlining of (>>=) and ret for the Eff monad
---
--- * Removal of unnecessary thunks
---
--- * Eta conversion
---
--- * Inlining variables
---
--- * Inline Prelude.($), Prelude.(#), Prelude.(++), Prelude.(!!)
---
--- * Inlining primitive Javascript operators
---
-module Language.PureScript.CodeGen.JS.Optimizer (optimize) where
-
-import Prelude.Compat
-
-import Control.Monad.Reader (MonadReader, ask, asks)
-import Control.Monad.Supply.Class (MonadSupply)
-
-import Language.PureScript.CodeGen.JS.AST
-import Language.PureScript.CodeGen.JS.Optimizer.Blocks
-import Language.PureScript.CodeGen.JS.Optimizer.Common
-import Language.PureScript.CodeGen.JS.Optimizer.Inliner
-import Language.PureScript.CodeGen.JS.Optimizer.MagicDo
-import Language.PureScript.CodeGen.JS.Optimizer.TCO
-import Language.PureScript.CodeGen.JS.Optimizer.Unused
-import Language.PureScript.Options
-
--- |
--- Apply a series of optimizer passes to simplified Javascript code
---
-optimize :: (MonadReader Options m, MonadSupply m) => JS -> m JS
-optimize js = do
- noOpt <- asks optionsNoOptimizations
- if noOpt then return js else optimize' js
-
-optimize' :: (MonadReader Options m, MonadSupply m) => JS -> m JS
-optimize' js = do
- opts <- ask
- js' <- untilFixedPoint (inlineFnComposition . inlineUnsafePartial . tidyUp . applyAll
- [ inlineCommonValues
- , inlineCommonOperators
- ]) js
- untilFixedPoint (return . tidyUp) . tco opts . magicDo opts $ js'
- where
- tidyUp :: JS -> JS
- tidyUp = applyAll
- [ collapseNestedBlocks
- , collapseNestedIfs
- , removeCodeAfterReturnStatements
- , removeUnusedArg
- , removeUndefinedApp
- , unThunk
- , etaConvert
- , evaluateIifes
- , inlineVariables
- ]
-
-untilFixedPoint :: (Monad m, Eq a) => (a -> m a) -> a -> m a
-untilFixedPoint f = go
- where
- go a = do
- a' <- f a
- if a' == a then return a' else go a'
diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Blocks.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Blocks.hs
deleted file mode 100644
index 1c80799..0000000
--- a/src/Language/PureScript/CodeGen/JS/Optimizer/Blocks.hs
+++ /dev/null
@@ -1,32 +0,0 @@
--- |
--- Optimizer steps for simplifying Javascript blocks
---
-module Language.PureScript.CodeGen.JS.Optimizer.Blocks
- ( collapseNestedBlocks
- , collapseNestedIfs
- ) where
-
-import Prelude.Compat
-
-import Language.PureScript.CodeGen.JS.AST
-
--- |
--- Collapse blocks which appear nested directly below another block
---
-collapseNestedBlocks :: JS -> JS
-collapseNestedBlocks = everywhereOnJS collapse
- where
- collapse :: JS -> JS
- collapse (JSBlock ss sts) = JSBlock ss (concatMap go sts)
- collapse js = js
- go :: JS -> [JS]
- go (JSBlock _ sts) = sts
- go s = [s]
-
-collapseNestedIfs :: JS -> JS
-collapseNestedIfs = everywhereOnJS collapse
- where
- collapse :: JS -> JS
- collapse (JSIfElse s1 cond1 (JSBlock _ [JSIfElse s2 cond2 body Nothing]) Nothing) =
- JSIfElse s1 (JSBinary s2 And cond1 cond2) body Nothing
- collapse js = js
diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs
deleted file mode 100644
index 763626a..0000000
--- a/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs
+++ /dev/null
@@ -1,78 +0,0 @@
--- |
--- Common functions used by the various optimizer phases
---
-module Language.PureScript.CodeGen.JS.Optimizer.Common where
-
-import Prelude.Compat
-
-import Data.Text (Text)
-import Data.List (foldl')
-import Data.Maybe (fromMaybe)
-
-import Language.PureScript.Crash
-import Language.PureScript.CodeGen.JS.AST
-import Language.PureScript.PSString (PSString)
-
-applyAll :: [a -> a] -> a -> a
-applyAll = foldl' (.) id
-
-replaceIdent :: Text -> JS -> JS -> JS
-replaceIdent var1 js = everywhereOnJS replace
- where
- replace (JSVar _ var2) | var1 == var2 = js
- replace other = other
-
-replaceIdents :: [(Text, JS)] -> JS -> JS
-replaceIdents vars = everywhereOnJS replace
- where
- replace v@(JSVar _ var) = fromMaybe v $ lookup var vars
- replace other = other
-
-isReassigned :: Text -> JS -> Bool
-isReassigned var1 = everythingOnJS (||) check
- where
- check :: JS -> Bool
- check (JSFunction _ _ args _) | var1 `elem` args = True
- check (JSVariableIntroduction _ arg _) | var1 == arg = True
- check (JSAssignment _ (JSVar _ arg) _) | var1 == arg = True
- check (JSFor _ arg _ _ _) | var1 == arg = True
- check (JSForIn _ arg _ _) | var1 == arg = True
- check _ = False
-
-isRebound :: JS -> JS -> Bool
-isRebound js d = any (\v -> isReassigned v d || isUpdated v d) (everythingOnJS (++) variablesOf js)
- where
- variablesOf (JSVar _ var) = [var]
- variablesOf _ = []
-
-isUsed :: Text -> JS -> Bool
-isUsed var1 = everythingOnJS (||) check
- where
- check :: JS -> Bool
- check (JSVar _ var2) | var1 == var2 = True
- check (JSAssignment _ target _) | var1 == targetVariable target = True
- check _ = False
-
-targetVariable :: JS -> Text
-targetVariable (JSVar _ var) = var
-targetVariable (JSIndexer _ _ tgt) = targetVariable tgt
-targetVariable _ = internalError "Invalid argument to targetVariable"
-
-isUpdated :: Text -> JS -> Bool
-isUpdated var1 = everythingOnJS (||) check
- where
- check :: JS -> Bool
- check (JSAssignment _ target _) | var1 == targetVariable target = True
- check _ = False
-
-removeFromBlock :: ([JS] -> [JS]) -> JS -> JS
-removeFromBlock go (JSBlock ss sts) = JSBlock ss (go sts)
-removeFromBlock _ js = js
-
-isDict :: (Text, PSString) -> JS -> Bool
-isDict (moduleName, dictName) (JSIndexer _ (JSStringLiteral _ x) (JSVar _ y)) =
- x == dictName && y == moduleName
-isDict _ _ = False
-
-isDict' :: [(Text, PSString)] -> JS -> Bool
-isDict' xs js = any (`isDict` js) xs
diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs
deleted file mode 100644
index 0d545a8..0000000
--- a/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs
+++ /dev/null
@@ -1,137 +0,0 @@
--- |
--- 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
-
-import Prelude.Compat
-
-import Data.List (nub)
-import Data.Maybe (fromJust, isJust)
-
-import Language.PureScript.CodeGen.JS.AST
-import Language.PureScript.CodeGen.JS.Optimizer.Common
-import Language.PureScript.Options
-import Language.PureScript.PSString (mkString)
-import qualified Language.PureScript.Constants as C
-
-magicDo :: Options -> JS -> JS
-magicDo opts | optionsNoMagicDo opts = id
- | otherwise = inlineST . magicDo'
-
--- |
--- Inline type class dictionaries for >>= and return for the Eff monad
---
--- E.g.
---
--- Prelude[">>="](dict)(m1)(function(x) {
--- return ...;
--- })
---
--- becomes
---
--- function __do {
--- var x = m1();
--- ...
--- }
---
-magicDo' :: JS -> JS
-magicDo' = everywhereOnJS undo . everywhereOnJSTopDown convert
- where
- -- The name of the function block which is added to denote a do block
- fnName = "__do"
- -- Desugar monomorphic calls to >>= and return for the Eff monad
- convert :: JS -> JS
- -- Desugar pure & return
- convert (JSApp _ (JSApp _ pure' [val]) []) | isPure pure' = val
- -- Desugar >>
- convert (JSApp _ (JSApp _ bind [m]) [JSFunction s1 Nothing [] (JSBlock s2 js)]) | isBind bind =
- JSFunction s1 (Just fnName) [] $ JSBlock s2 (JSApp s2 m [] : map applyReturns js )
- -- Desugar >>=
- convert (JSApp _ (JSApp _ bind [m]) [JSFunction s1 Nothing [arg] (JSBlock s2 js)]) | isBind bind =
- JSFunction s1 (Just fnName) [] $ JSBlock s2 (JSVariableIntroduction s2 arg (Just (JSApp s2 m [])) : map applyReturns js)
- -- Desugar untilE
- convert (JSApp s1 (JSApp _ f [arg]) []) | isEffFunc C.untilE f =
- JSApp s1 (JSFunction s1 Nothing [] (JSBlock s1 [ JSWhile s1 (JSUnary s1 Not (JSApp s1 arg [])) (JSBlock s1 []), JSReturn s1 $ JSObjectLiteral s1 []])) []
- -- Desugar whileE
- convert (JSApp _ (JSApp _ (JSApp s1 f [arg1]) [arg2]) []) | isEffFunc C.whileE f =
- JSApp s1 (JSFunction s1 Nothing [] (JSBlock s1 [ JSWhile s1 (JSApp s1 arg1 []) (JSBlock s1 [ JSApp s1 arg2 [] ]), JSReturn s1 $ JSObjectLiteral s1 []])) []
- convert other = other
- -- Check if an expression represents a monomorphic call to >>= for the Eff monad
- isBind (JSApp _ fn [dict]) | isDict (C.eff, C.bindEffDictionary) dict && isBindPoly fn = True
- isBind _ = False
- -- Check if an expression represents a monomorphic call to pure or return for the Eff applicative
- isPure (JSApp _ fn [dict]) | isDict (C.eff, C.applicativeEffDictionary) dict && isPurePoly fn = True
- isPure _ = False
- -- Check if an expression represents the polymorphic >>= function
- isBindPoly = isDict (C.controlBind, C.bind)
- -- Check if an expression represents the polymorphic pure or return function
- isPurePoly = isDict (C.controlApplicative, C.pure')
- -- Check if an expression represents a function in the Eff module
- isEffFunc name (JSIndexer _ (JSStringLiteral _ name') (JSVar _ eff)) = eff == C.eff && name == name'
- isEffFunc _ _ = False
-
- -- Remove __do function applications which remain after desugaring
- undo :: JS -> JS
- undo (JSReturn _ (JSApp _ (JSFunction _ (Just ident) [] body) [])) | ident == fnName = body
- undo other = other
-
- applyReturns :: JS -> JS
- applyReturns (JSReturn ss ret) = JSReturn ss (JSApp ss ret [])
- applyReturns (JSBlock ss jss) = JSBlock ss (map applyReturns jss)
- applyReturns (JSWhile ss cond js) = JSWhile ss cond (applyReturns js)
- applyReturns (JSFor ss v lo hi js) = JSFor ss v lo hi (applyReturns js)
- applyReturns (JSForIn ss v xs js) = JSForIn ss v xs (applyReturns js)
- applyReturns (JSIfElse ss cond t f) = JSIfElse ss cond (applyReturns t) (applyReturns `fmap` f)
- applyReturns other = other
-
--- |
--- Inline functions in the ST module
---
-inlineST :: JS -> JS
-inlineST = everywhereOnJS convertBlock
- where
- -- Look for runST blocks and inline the STRefs there.
- -- If all STRefs are used in the scope of the same runST, only using { read, write, modify }STRef then
- -- we can be more aggressive about inlining, and actually turn STRefs into local variables.
- convertBlock (JSApp _ f [arg]) | isSTFunc C.runST f =
- let refs = nub . findSTRefsIn $ arg
- usages = findAllSTUsagesIn arg
- allUsagesAreLocalVars = all (\u -> let v = toVar u in isJust v && fromJust v `elem` refs) usages
- localVarsDoNotEscape = all (\r -> length (r `appearingIn` arg) == length (filter (\u -> let v = toVar u in v == Just r) usages)) refs
- in everywhereOnJS (convert (allUsagesAreLocalVars && localVarsDoNotEscape)) arg
- convertBlock other = other
- -- Convert a block in a safe way, preserving object wrappers of references,
- -- or in a more aggressive way, turning wrappers into local variables depending on the
- -- agg(ressive) parameter.
- convert agg (JSApp s1 f [arg]) | isSTFunc C.newSTRef f =
- JSFunction s1 Nothing [] (JSBlock s1 [JSReturn s1 $ if agg then arg else JSObjectLiteral s1 [(mkString C.stRefValue, arg)]])
- convert agg (JSApp _ (JSApp s1 f [ref]) []) | isSTFunc C.readSTRef f =
- if agg then ref else JSIndexer s1 (JSStringLiteral s1 C.stRefValue) ref
- convert agg (JSApp _ (JSApp _ (JSApp s1 f [ref]) [arg]) []) | isSTFunc C.writeSTRef f =
- if agg then JSAssignment s1 ref arg else JSAssignment s1 (JSIndexer s1 (JSStringLiteral s1 C.stRefValue) ref) arg
- convert agg (JSApp _ (JSApp _ (JSApp s1 f [ref]) [func]) []) | isSTFunc C.modifySTRef f =
- if agg then JSAssignment s1 ref (JSApp s1 func [ref]) else JSAssignment s1 (JSIndexer s1 (JSStringLiteral s1 C.stRefValue) ref) (JSApp s1 func [JSIndexer s1 (JSStringLiteral s1 C.stRefValue) ref])
- convert _ other = other
- -- Check if an expression represents a function in the ST module
- isSTFunc name (JSIndexer _ (JSStringLiteral _ name') (JSVar _ st)) = st == C.st && name == name'
- isSTFunc _ _ = False
- -- Find all ST Refs initialized in this block
- findSTRefsIn = everythingOnJS (++) isSTRef
- where
- isSTRef (JSVariableIntroduction _ ident (Just (JSApp _ (JSApp _ f [_]) []))) | isSTFunc C.newSTRef f = [ident]
- isSTRef _ = []
- -- Find all STRefs used as arguments to readSTRef, writeSTRef, modifySTRef
- findAllSTUsagesIn = everythingOnJS (++) isSTUsage
- where
- isSTUsage (JSApp _ (JSApp _ f [ref]) []) | isSTFunc C.readSTRef f = [ref]
- isSTUsage (JSApp _ (JSApp _ (JSApp _ f [ref]) [_]) []) | isSTFunc C.writeSTRef f || isSTFunc C.modifySTRef f = [ref]
- isSTUsage _ = []
- -- Find all uses of a variable
- appearingIn ref = everythingOnJS (++) isVar
- where
- isVar e@(JSVar _ v) | v == ref = [e]
- isVar _ = []
- -- Convert a JS value to a String if it is a JSVar
- toVar (JSVar _ v) = Just v
- toVar _ = Nothing
diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs
deleted file mode 100644
index 1b3f080..0000000
--- a/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs
+++ /dev/null
@@ -1,120 +0,0 @@
--- |
--- This module implements tail call elimination.
---
-module Language.PureScript.CodeGen.JS.Optimizer.TCO (tco) where
-
-import Prelude.Compat
-
-import Data.Text (Text)
-import Data.Monoid ((<>), getAny, Any(..))
-
-import Language.PureScript.Options
-import Language.PureScript.CodeGen.JS.AST
-
--- |
--- Eliminate tail calls
---
-tco :: Options -> JS -> JS
-tco opts | optionsNoTco opts = id
- | otherwise = tco'
-
-tco' :: JS -> JS
-tco' = everywhereOnJS convert
- where
- tcoLabel :: Text
- tcoLabel = "tco"
-
- tcoVar :: Text -> Text
- tcoVar arg = "__tco_" <> arg
-
- copyVar :: Text -> Text
- copyVar arg = "__copy_" <> arg
-
- convert :: JS -> JS
- convert js@(JSVariableIntroduction ss name (Just fn@JSFunction {})) =
- let
- (argss, body', replace) = collectAllFunctionArgs [] id fn
- in case () of
- _ | isTailCall name body' ->
- let
- allArgs = concat $ reverse argss
- in
- JSVariableIntroduction ss name (Just (replace (toLoop name allArgs body')))
- | otherwise -> js
- convert js = js
-
- collectAllFunctionArgs :: [[Text]] -> (JS -> JS) -> JS -> ([[Text]], JS, JS -> JS)
- collectAllFunctionArgs allArgs f (JSFunction s1 ident args (JSBlock s2 (body@(JSReturn _ _):_))) =
- collectAllFunctionArgs (args : allArgs) (\b -> f (JSFunction s1 ident (map copyVar args) (JSBlock s2 [b]))) body
- collectAllFunctionArgs allArgs f (JSFunction ss ident args body@(JSBlock _ _)) =
- (args : allArgs, body, f . JSFunction ss ident (map copyVar args))
- collectAllFunctionArgs allArgs f (JSReturn s1 (JSFunction s2 ident args (JSBlock s3 [body]))) =
- collectAllFunctionArgs (args : allArgs) (\b -> f (JSReturn s1 (JSFunction s2 ident (map copyVar args) (JSBlock s3 [b])))) body
- collectAllFunctionArgs allArgs f (JSReturn s1 (JSFunction s2 ident args body@(JSBlock _ _))) =
- (args : allArgs, body, f . JSReturn s1 . JSFunction s2 ident (map copyVar args))
- collectAllFunctionArgs allArgs f body = (allArgs, body, f)
-
- isTailCall :: Text -> JS -> Bool
- isTailCall ident js =
- let
- numSelfCalls = everythingOnJS (+) countSelfCalls js
- numSelfCallsInTailPosition = everythingOnJS (+) countSelfCallsInTailPosition js
- numSelfCallsUnderFunctions = everythingOnJS (+) countSelfCallsUnderFunctions js
- numSelfCallWithFnArgs = everythingOnJS (+) countSelfCallsWithFnArgs js
- in
- numSelfCalls > 0
- && numSelfCalls == numSelfCallsInTailPosition
- && numSelfCallsUnderFunctions == 0
- && numSelfCallWithFnArgs == 0
- where
- countSelfCalls :: JS -> Int
- countSelfCalls (JSApp _ (JSVar _ ident') _) | ident == ident' = 1
- countSelfCalls _ = 0
-
- countSelfCallsInTailPosition :: JS -> Int
- countSelfCallsInTailPosition (JSReturn _ ret) | isSelfCall ident ret = 1
- countSelfCallsInTailPosition _ = 0
-
- countSelfCallsUnderFunctions :: JS -> Int
- countSelfCallsUnderFunctions (JSFunction _ _ _ js') = everythingOnJS (+) countSelfCalls js'
- countSelfCallsUnderFunctions _ = 0
-
- countSelfCallsWithFnArgs :: JS -> Int
- countSelfCallsWithFnArgs = go [] where
- go acc (JSVar _ ident')
- | ident == ident' && any hasFunction acc = 1
- go acc (JSApp _ fn args) = go (args ++ acc) fn
- go _ _ = 0
-
- hasFunction :: JS -> Bool
- hasFunction = getAny . everythingOnJS mappend (Any . isFunction)
- where
- isFunction JSFunction{} = True
- isFunction _ = False
-
- toLoop :: Text -> [Text] -> JS -> JS
- toLoop ident allArgs js = JSBlock rootSS $
- map (\arg -> JSVariableIntroduction rootSS arg (Just (JSVar rootSS (copyVar arg)))) allArgs ++
- [ JSLabel rootSS tcoLabel $ JSWhile rootSS (JSBooleanLiteral rootSS True) (JSBlock rootSS [ everywhereOnJS loopify js ]) ]
- where
- rootSS = Nothing
-
- loopify :: JS -> JS
- loopify (JSReturn ss ret) | isSelfCall ident ret =
- let
- allArgumentValues = concat $ collectSelfCallArgs [] ret
- in
- JSBlock ss $ zipWith (\val arg ->
- JSVariableIntroduction ss (tcoVar arg) (Just val)) allArgumentValues allArgs
- ++ map (\arg ->
- JSAssignment ss (JSVar ss arg) (JSVar ss (tcoVar arg))) allArgs
- ++ [ JSContinue ss tcoLabel ]
- loopify other = other
- collectSelfCallArgs :: [[JS]] -> JS -> [[JS]]
- collectSelfCallArgs allArgumentValues (JSApp _ fn args') = collectSelfCallArgs (args' : allArgumentValues) fn
- collectSelfCallArgs allArgumentValues _ = allArgumentValues
-
- isSelfCall :: Text -> JS -> Bool
- isSelfCall ident (JSApp _ (JSVar _ ident') _) = ident == ident'
- isSelfCall ident (JSApp _ fn _) = isSelfCall ident fn
- isSelfCall _ _ = False
diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Unused.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Unused.hs
deleted file mode 100644
index 942414b..0000000
--- a/src/Language/PureScript/CodeGen/JS/Optimizer/Unused.hs
+++ /dev/null
@@ -1,35 +0,0 @@
--- |
--- Removes unused variables
---
-module Language.PureScript.CodeGen.JS.Optimizer.Unused
- ( removeCodeAfterReturnStatements
- , removeUnusedArg
- , removeUndefinedApp
- ) where
-
-import Prelude.Compat
-
-import Language.PureScript.CodeGen.JS.AST
-import Language.PureScript.CodeGen.JS.Optimizer.Common
-import qualified Language.PureScript.Constants as C
-
-removeCodeAfterReturnStatements :: JS -> JS
-removeCodeAfterReturnStatements = everywhereOnJS (removeFromBlock go)
- where
- go :: [JS] -> [JS]
- go jss | not (any isJSReturn jss) = jss
- | otherwise = let (body, ret : _) = break isJSReturn jss in body ++ [ret]
- isJSReturn (JSReturn _ _) = True
- isJSReturn _ = False
-
-removeUnusedArg :: JS -> JS
-removeUnusedArg = everywhereOnJS convert
- where
- convert (JSFunction ss name [arg] body) | arg == C.__unused = JSFunction ss name [] body
- convert js = js
-
-removeUndefinedApp :: JS -> JS
-removeUndefinedApp = everywhereOnJS convert
- where
- convert (JSApp ss fn [JSVar _ arg]) | arg == C.undefined = JSApp ss fn []
- convert js = js
diff --git a/src/Language/PureScript/Pretty/JS.hs b/src/Language/PureScript/CodeGen/JS/Printer.hs
index 92de636..8c72e08 100644
--- a/src/Language/PureScript/Pretty/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS/Printer.hs
@@ -1,7 +1,5 @@
--- |
--- Pretty printer for the Javascript AST
---
-module Language.PureScript.Pretty.JS
+-- | Pretty printer for the JavaScript AST
+module Language.PureScript.CodeGen.JS.Printer
( prettyPrintJS
, prettyPrintJSWithSourceMaps
) where
@@ -20,8 +18,8 @@ import Data.Text (Text)
import qualified Data.Text as T
import Language.PureScript.AST (SourceSpan(..))
-import Language.PureScript.CodeGen.JS.AST
import Language.PureScript.CodeGen.JS.Common
+import Language.PureScript.CoreImp.AST
import Language.PureScript.Comments
import Language.PureScript.Crash
import Language.PureScript.Pretty.Common
@@ -29,24 +27,24 @@ import Language.PureScript.PSString (PSString, decodeString, prettyPrintStringJS
-- TODO (Christoph): Get rid of T.unpack / pack
-literals :: (Emit gen) => Pattern PrinterState JS gen
+literals :: (Emit gen) => Pattern PrinterState AST gen
literals = mkPattern' match'
where
- match' :: (Emit gen) => JS -> StateT PrinterState Maybe gen
+ match' :: (Emit gen) => AST -> StateT PrinterState Maybe gen
match' js = (addMapping' (getSourceSpan js) <>) <$> match js
- match :: (Emit gen) => JS -> StateT PrinterState Maybe gen
- match (JSNumericLiteral _ n) = return $ emit $ T.pack $ either show show n
- match (JSStringLiteral _ s) = return $ emit $ prettyPrintStringJS s
- match (JSBooleanLiteral _ True) = return $ emit "true"
- match (JSBooleanLiteral _ False) = return $ emit "false"
- match (JSArrayLiteral _ xs) = mconcat <$> sequence
+ match :: (Emit gen) => AST -> StateT PrinterState Maybe gen
+ match (NumericLiteral _ n) = return $ emit $ T.pack $ either show show n
+ match (StringLiteral _ s) = return $ emit $ prettyPrintStringJS s
+ match (BooleanLiteral _ True) = return $ emit "true"
+ match (BooleanLiteral _ False) = return $ emit "false"
+ match (ArrayLiteral _ xs) = mconcat <$> sequence
[ return $ emit "[ "
, intercalate (emit ", ") <$> forM xs prettyPrintJS'
, return $ emit " ]"
]
- match (JSObjectLiteral _ []) = return $ emit "{}"
- match (JSObjectLiteral _ ps) = mconcat <$> sequence
+ match (ObjectLiteral _ []) = return $ emit "{}"
+ match (ObjectLiteral _ ps) = mconcat <$> sequence
[ return $ emit "{\n"
, withIndent $ do
jss <- forM ps $ \(key, value) -> fmap ((objectPropertyToString key <> emit ": ") <>) . prettyPrintJS' $ value
@@ -64,30 +62,30 @@ literals = mkPattern' match'
s'
_ ->
prettyPrintStringJS s
- match (JSBlock _ sts) = mconcat <$> sequence
+ match (Block _ sts) = mconcat <$> sequence
[ return $ emit "{\n"
, withIndent $ prettyStatements sts
, return $ emit "\n"
, currentIndent
, return $ emit "}"
]
- match (JSVar _ ident) = return $ emit ident
- match (JSVariableIntroduction _ ident value) = mconcat <$> sequence
+ match (Var _ ident) = return $ emit ident
+ match (VariableIntroduction _ ident value) = mconcat <$> sequence
[ return $ emit $ "var " <> ident
, maybe (return mempty) (fmap (emit " = " <>) . prettyPrintJS') value
]
- match (JSAssignment _ target value) = mconcat <$> sequence
+ match (Assignment _ target value) = mconcat <$> sequence
[ prettyPrintJS' target
, return $ emit " = "
, prettyPrintJS' value
]
- match (JSWhile _ cond sts) = mconcat <$> sequence
+ match (While _ cond sts) = mconcat <$> sequence
[ return $ emit "while ("
, prettyPrintJS' cond
, return $ emit ") "
, prettyPrintJS' sts
]
- match (JSFor _ ident start end sts) = mconcat <$> sequence
+ match (For _ ident start end sts) = mconcat <$> sequence
[ return $ emit $ "for (var " <> ident <> " = "
, prettyPrintJS' start
, return $ emit $ "; " <> ident <> " < "
@@ -95,38 +93,32 @@ literals = mkPattern' match'
, return $ emit $ "; " <> ident <> "++) "
, prettyPrintJS' sts
]
- match (JSForIn _ ident obj sts) = mconcat <$> sequence
+ match (ForIn _ ident obj sts) = mconcat <$> sequence
[ return $ emit $ "for (var " <> ident <> " in "
, prettyPrintJS' obj
, return $ emit ") "
, prettyPrintJS' sts
]
- match (JSIfElse _ cond thens elses) = mconcat <$> sequence
+ match (IfElse _ cond thens elses) = mconcat <$> sequence
[ return $ emit "if ("
, prettyPrintJS' cond
, return $ emit ") "
, prettyPrintJS' thens
, maybe (return mempty) (fmap (emit " else " <>) . prettyPrintJS') elses
]
- match (JSReturn _ value) = mconcat <$> sequence
+ match (Return _ value) = mconcat <$> sequence
[ return $ emit "return "
, prettyPrintJS' value
]
- match (JSThrow _ value) = mconcat <$> sequence
+ match (ReturnNoResult _) = return $ emit "return"
+ match (Throw _ value) = mconcat <$> sequence
[ return $ emit "throw "
, prettyPrintJS' value
]
- match (JSBreak _ lbl) = return $ emit $ "break " <> lbl
- match (JSContinue _ lbl) = return $ emit $ "continue " <> lbl
- match (JSLabel _ lbl js) = mconcat <$> sequence
- [ return $ emit $ lbl <> ": "
- , prettyPrintJS' js
- ]
- match (JSComment _ com js) = mconcat <$> sequence
+ match (Comment _ com js) = mconcat <$> sequence
[ mconcat <$> forM com comment
, prettyPrintJS' js
]
- match (JSRaw _ js) = return $ emit js
match _ = mzero
comment :: (Emit gen) => Comment -> StateT PrinterState Maybe gen
@@ -159,122 +151,100 @@ literals = mkPattern' match'
Just (x, xs) -> x `T.cons` removeComments xs
Nothing -> ""
-conditional :: Pattern PrinterState JS ((Maybe SourceSpan, JS, JS), JS)
-conditional = mkPattern match
- where
- match (JSConditional ss cond th el) = Just ((ss, th, el), cond)
- match _ = Nothing
-
-accessor :: Pattern PrinterState JS (Text, JS)
+accessor :: Pattern PrinterState AST (Text, AST)
accessor = mkPattern match
where
- match (JSIndexer _ (JSStringLiteral _ prop) val) =
+ match (Indexer _ (StringLiteral _ prop) val) =
case decodeString prop of
Just s | not (identNeedsEscaping s) -> Just (s, val)
_ -> Nothing
match _ = Nothing
-indexer :: (Emit gen) => Pattern PrinterState JS (gen, JS)
+indexer :: (Emit gen) => Pattern PrinterState AST (gen, AST)
indexer = mkPattern' match
where
- match (JSIndexer _ index val) = (,) <$> prettyPrintJS' index <*> pure val
+ match (Indexer _ index val) = (,) <$> prettyPrintJS' index <*> pure val
match _ = mzero
-lam :: Pattern PrinterState JS ((Maybe Text, [Text], Maybe SourceSpan), JS)
+lam :: Pattern PrinterState AST ((Maybe Text, [Text], Maybe SourceSpan), AST)
lam = mkPattern match
where
- match (JSFunction ss name args ret) = Just ((name, args, ss), ret)
+ match (Function ss name args ret) = Just ((name, args, ss), ret)
match _ = Nothing
-app :: (Emit gen) => Pattern PrinterState JS (gen, JS)
+app :: (Emit gen) => Pattern PrinterState AST (gen, AST)
app = mkPattern' match
where
- match (JSApp _ val args) = do
+ match (App _ val args) = do
jss <- traverse prettyPrintJS' args
return (intercalate (emit ", ") jss, val)
match _ = mzero
-typeOf :: Pattern PrinterState JS ((), JS)
-typeOf = mkPattern match
- where
- match (JSTypeOf _ val) = Just ((), val)
- match _ = Nothing
-
-instanceOf :: Pattern PrinterState JS (JS, JS)
+instanceOf :: Pattern PrinterState AST (AST, AST)
instanceOf = mkPattern match
where
- match (JSInstanceOf _ val ty) = Just (val, ty)
+ match (InstanceOf _ val ty) = Just (val, ty)
match _ = Nothing
-unary' :: (Emit gen) => UnaryOperator -> (JS -> Text) -> Operator PrinterState JS gen
+unary' :: (Emit gen) => UnaryOperator -> (AST -> Text) -> Operator PrinterState AST gen
unary' op mkStr = Wrap match (<>)
where
- match :: (Emit gen) => Pattern PrinterState JS (gen, JS)
+ match :: (Emit gen) => Pattern PrinterState AST (gen, AST)
match = mkPattern match'
where
- match' (JSUnary _ op' val) | op' == op = Just (emit $ mkStr val, val)
+ match' (Unary _ op' val) | op' == op = Just (emit $ mkStr val, val)
match' _ = Nothing
-unary :: (Emit gen) => UnaryOperator -> Text -> Operator PrinterState JS gen
+unary :: (Emit gen) => UnaryOperator -> Text -> Operator PrinterState AST gen
unary op str = unary' op (const str)
-negateOperator :: (Emit gen) => Operator PrinterState JS gen
+negateOperator :: (Emit gen) => Operator PrinterState AST gen
negateOperator = unary' Negate (\v -> if isNegate v then "- " else "-")
where
- isNegate (JSUnary _ Negate _) = True
+ isNegate (Unary _ Negate _) = True
isNegate _ = False
-binary :: (Emit gen) => BinaryOperator -> Text -> Operator PrinterState JS gen
+binary :: (Emit gen) => BinaryOperator -> Text -> Operator PrinterState AST gen
binary op str = AssocL match (\v1 v2 -> v1 <> emit (" " <> str <> " ") <> v2)
where
- match :: Pattern PrinterState JS (JS, JS)
+ match :: Pattern PrinterState AST (AST, AST)
match = mkPattern match'
where
- match' (JSBinary _ op' v1 v2) | op' == op = Just (v1, v2)
+ match' (Binary _ op' v1 v2) | op' == op = Just (v1, v2)
match' _ = Nothing
-prettyStatements :: (Emit gen) => [JS] -> StateT PrinterState Maybe gen
+prettyStatements :: (Emit gen) => [AST] -> StateT PrinterState Maybe gen
prettyStatements sts = do
jss <- forM sts prettyPrintJS'
indentString <- currentIndent
return $ intercalate (emit "\n") $ map ((<> emit ";") . (indentString <>)) jss
--- |
--- Generate a pretty-printed string representing a Javascript expression
---
-prettyPrintJS1 :: (Emit gen) => JS -> gen
-prettyPrintJS1 = fromMaybe (internalError "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyPrintJS'
-
--- |
--- Generate a pretty-printed string representing a collection of Javascript expressions at the same indentation level
---
-prettyPrintJSWithSourceMaps :: [JS] -> (Text, [SMap])
+-- | Generate a pretty-printed string representing a collection of JavaScript expressions at the same indentation level
+prettyPrintJSWithSourceMaps :: [AST] -> (Text, [SMap])
prettyPrintJSWithSourceMaps js =
let StrPos (_, s, mp) = (fromMaybe (internalError "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyStatements) js
in (s, mp)
-prettyPrintJS :: [JS] -> Text
+prettyPrintJS :: [AST] -> Text
prettyPrintJS = maybe (internalError "Incomplete pattern") runPlainString . flip evalStateT (PrinterState 0) . prettyStatements
--- |
--- Generate an indented, pretty-printed string representing a Javascript expression
---
-prettyPrintJS' :: (Emit gen) => JS -> StateT PrinterState Maybe gen
+
+-- | Generate an indented, pretty-printed string representing a JavaScript expression
+prettyPrintJS' :: (Emit gen) => AST -> StateT PrinterState Maybe gen
prettyPrintJS' = A.runKleisli $ runPattern matchValue
where
- matchValue :: (Emit gen) => Pattern PrinterState JS gen
+ matchValue :: (Emit gen) => Pattern PrinterState AST gen
matchValue = buildPrettyPrinter operators (literals <+> fmap parensPos matchValue)
- operators :: (Emit gen) => OperatorTable PrinterState JS gen
+ operators :: (Emit gen) => OperatorTable PrinterState AST gen
operators =
OperatorTable [ [ Wrap indexer $ \index val -> val <> emit "[" <> index <> emit "]" ]
, [ Wrap accessor $ \prop val -> val <> emit "." <> emit prop ]
, [ Wrap app $ \args val -> val <> emit "(" <> args <> emit ")" ]
- , [ unary JSNew "new " ]
+ , [ unary New "new " ]
, [ Wrap lam $ \(name, args, ss) ret -> addMapping' ss <>
emit ("function "
<> fromMaybe "" name
<> "(" <> intercalate ", " args <> ") ")
<> ret ]
- , [ Wrap typeOf $ \_ s -> emit "typeof " <> s ]
, [ unary Not "!"
, unary BitwiseNot "~"
, unary Positive "+"
@@ -299,5 +269,4 @@ prettyPrintJS' = A.runKleisli $ runPattern matchValue
, [ binary BitwiseOr "|" ]
, [ binary And "&&" ]
, [ binary Or "||" ]
- , [ Wrap conditional $ \(ss, th, el) cond -> cond <> addMapping' ss <> emit " ? " <> prettyPrintJS1 th <> addMapping' ss <> emit " : " <> prettyPrintJS1 el ]
]
diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs
index baf9c10..81bca24 100644
--- a/src/Language/PureScript/Constants.hs
+++ b/src/Language/PureScript/Constants.hs
@@ -34,6 +34,12 @@ append = "append"
bind :: forall a. (IsString a) => a
bind = "bind"
+discard :: forall a. (IsString a) => a
+discard = "discard"
+
+pattern Discard :: Qualified (ProperName 'ClassName)
+pattern Discard = Qualified (Just ControlBind) (ProperName "Discard")
+
(+) :: forall a. (IsString a) => a
(+) = "+"
@@ -234,6 +240,9 @@ applicativeEffDictionary = "applicativeEff"
bindEffDictionary :: forall a. (IsString a) => a
bindEffDictionary = "bindEff"
+discardUnitDictionary :: forall a. (IsString a) => a
+discardUnitDictionary = "discardUnit"
+
semiringNumber :: forall a. (IsString a) => a
semiringNumber = "semiringNumber"
@@ -372,20 +381,17 @@ pattern Fail = Qualified (Just Prim) (ProperName "Fail")
pattern Warn :: Qualified (ProperName 'ClassName)
pattern Warn = Qualified (Just Prim) (ProperName "Warn")
+pattern Union :: Qualified (ProperName 'ClassName)
+pattern Union = Qualified (Just Prim) (ProperName "Union")
+
typ :: forall a. (IsString a) => a
typ = "Type"
-effect :: forall a. (IsString a) => a
-effect = "Effect"
-
symbol :: forall a. (IsString a) => a
symbol = "Symbol"
-- Code Generation
-__superclass_ :: forall a. (IsString a) => a
-__superclass_ = "__superclass_"
-
__unused :: forall a. (IsString a) => a
__unused = "__unused"
@@ -412,6 +418,9 @@ controlApplicative = "Control_Applicative"
controlSemigroupoid :: forall a. (IsString a) => a
controlSemigroupoid = "Control_Semigroupoid"
+pattern ControlBind :: ModuleName
+pattern ControlBind = ModuleName [ProperName "Control", ProperName "Bind"]
+
controlBind :: forall a. (IsString a) => a
controlBind = "Control_Bind"
diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs
index d02657c..800c630 100644
--- a/src/Language/PureScript/CoreFn/Desugar.hs
+++ b/src/Language/PureScript/CoreFn/Desugar.hs
@@ -1,19 +1,20 @@
module Language.PureScript.CoreFn.Desugar (moduleToCoreFn) where
import Prelude.Compat
+import Protolude (ordNub)
-import Control.Arrow (second, (***))
+import Control.Arrow (second)
import Data.Function (on)
-import Data.List (sort, sortBy, nub)
+import Data.List (sort, sortBy)
import Data.Maybe (mapMaybe)
+import Data.Tuple (swap)
import qualified Data.Map as M
import Language.PureScript.AST.Literals
import Language.PureScript.AST.SourcePos
import Language.PureScript.AST.Traversals
import Language.PureScript.Comments
-import qualified Language.PureScript.Constants as C
import Language.PureScript.CoreFn.Ann
import Language.PureScript.CoreFn.Binders
import Language.PureScript.CoreFn.Expr
@@ -27,38 +28,38 @@ import Language.PureScript.Types
import Language.PureScript.PSString (mkString)
import qualified Language.PureScript.AST as A
--- |
--- Desugars a module from AST to CoreFn representation.
---
+-- | Desugars a module from AST to CoreFn representation.
moduleToCoreFn :: Environment -> A.Module -> Module Ann
moduleToCoreFn _ (A.Module _ _ _ _ Nothing) =
internalError "Module exports were not elaborated before moduleToCoreFn"
moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =
let imports = mapMaybe importToCoreFn decls ++ findQualModules decls
- imports' = nub $ filter (keepImp imports) imports-- TODO could be more efficient
- exps' = nub $ concatMap exportToCoreFn exps
- externs = nub $ mapMaybe externToCoreFn decls
+ imports' = keepPositionedImports imports
+ exps' = ordNub $ concatMap exportToCoreFn exps
+ externs = ordNub $ mapMaybe externToCoreFn decls
decls' = concatMap (declToCoreFn Nothing []) decls
in Module coms mn imports' exps' externs decls'
where
- -- Remove duplicate imports favoring the one containing sourcespan info
- keepImp :: [(Ann, ModuleName)] -> (Ann, ModuleName) -> Bool
- keepImp imps (a, i) = hasSS a || not (any hasDup imps)
+ -- | Remove duplicate imports favoring the ones containing source span
+ -- information
+ keepPositionedImports :: [(Ann, ModuleName)] -> [(Ann, ModuleName)]
+ keepPositionedImports =
+ map swap . M.toList . M.fromListWith preferSSpan . map swap
where
- hasDup (a', i') = i == i' && hasSS a'
+ preferSSpan x y
+ | hasSS x = x
+ | otherwise = y
- hasSS :: Ann -> Bool
- hasSS (Just _, _, _, _) = True
- hasSS _ = False
+ hasSS :: Ann -> Bool
+ hasSS (Just _, _, _, _) = True
+ hasSS _ = False
ssA :: Maybe SourceSpan -> Ann
ssA ss = (ss, [], Nothing, Nothing)
- -- |
- -- Desugars member declarations from AST to CoreFn representation.
- --
+ -- | Desugars member declarations from AST to CoreFn representation.
declToCoreFn :: Maybe SourceSpan -> [Comment] -> A.Declaration -> [Bind Ann]
declToCoreFn ss com (A.DataDeclaration Newtype _ _ [(ctor, _)]) =
[NonRec (ssA ss) (properToIdent ctor) $
@@ -70,7 +71,7 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =
let (_, _, _, fields) = lookupConstructor env (Qualified (Just mn) ctor)
in NonRec (ssA ss) (properToIdent ctor) $ Constructor (ss, com, Nothing, Nothing) tyName ctor fields
declToCoreFn ss _ (A.DataBindingGroupDeclaration ds) = concatMap (declToCoreFn ss []) ds
- declToCoreFn ss com (A.ValueDeclaration name _ _ (Right e)) =
+ declToCoreFn ss com (A.ValueDeclaration name _ _ [A.MkUnguarded e]) =
[NonRec (ssA ss) name (exprToCoreFn ss com Nothing e)]
declToCoreFn ss _ (A.BindingGroupDeclaration ds) =
[Rec $ map (\(name, _, e) -> ((ssA ss, name), exprToCoreFn ss [] Nothing e)) ds]
@@ -80,9 +81,7 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =
declToCoreFn (Just ss) (com ++ com1) d
declToCoreFn _ _ _ = []
- -- |
- -- Desugars expressions from AST to CoreFn representation.
- --
+ -- | Desugars expressions from AST to CoreFn representation.
exprToCoreFn :: Maybe SourceSpan -> [Comment] -> Maybe Type -> A.Expr -> Expr Ann
exprToCoreFn ss com ty (A.Literal lit) =
Literal (ss, com, ty, Nothing) (fmap (exprToCoreFn ss com Nothing) lit)
@@ -90,7 +89,7 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =
Accessor (ss, com, ty, Nothing) name (exprToCoreFn ss [] Nothing v)
exprToCoreFn ss com ty (A.ObjectUpdate obj vs) =
ObjectUpdate (ss, com, ty, Nothing) (exprToCoreFn ss [] Nothing obj) $ map (second (exprToCoreFn ss [] Nothing)) vs
- exprToCoreFn ss com ty (A.Abs (Left name) v) =
+ exprToCoreFn ss com ty (A.Abs (A.VarBinder name) v) =
Abs (ss, com, ty, Nothing) name (exprToCoreFn ss [] Nothing v)
exprToCoreFn _ _ _ (A.Abs _ _) =
internalError "Abs with Binder argument was not desugared before exprToCoreFn mn"
@@ -102,7 +101,7 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =
Case (ss, com, ty, Nothing) [exprToCoreFn ss [] Nothing v1]
[ CaseAlternative [LiteralBinder nullAnn $ BooleanLiteral True]
(Right $ exprToCoreFn Nothing [] Nothing v2)
- , CaseAlternative [LiteralBinder nullAnn $ BooleanLiteral False]
+ , CaseAlternative [NullBinder nullAnn]
(Right $ exprToCoreFn Nothing [] Nothing v3) ]
exprToCoreFn ss com ty (A.Constructor name) =
Var (ss, com, ty, Just $ getConstructorMeta name) $ fmap properToIdent name
@@ -126,19 +125,23 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =
exprToCoreFn _ _ _ e =
error $ "Unexpected value in exprToCoreFn mn: " ++ show e
- -- |
- -- Desugars case alternatives from AST to CoreFn representation.
- --
+ -- | Desugars case alternatives from AST to CoreFn representation.
altToCoreFn :: Maybe SourceSpan -> A.CaseAlternative -> CaseAlternative Ann
altToCoreFn ss (A.CaseAlternative bs vs) = CaseAlternative (map (binderToCoreFn ss []) bs) (go vs)
where
- go :: Either [(A.Guard, A.Expr)] A.Expr -> Either [(Guard Ann, Expr Ann)] (Expr Ann)
- go (Left ges) = Left $ map (exprToCoreFn ss [] Nothing *** exprToCoreFn ss [] Nothing) ges
- go (Right e) = Right (exprToCoreFn ss [] Nothing e)
+ go :: [A.GuardedExpr] -> Either [(Guard Ann, Expr Ann)] (Expr Ann)
+ go [A.MkUnguarded e]
+ = Right (exprToCoreFn ss [] Nothing e)
+ go gs
+ = Left [ (exprToCoreFn ss [] Nothing cond, exprToCoreFn ss [] Nothing e)
+ | A.GuardedExpr g e <- gs
+ , let cond = guardToExpr g
+ ]
- -- |
- -- Desugars case binders from AST to CoreFn representation.
- --
+ guardToExpr [A.ConditionGuard cond] = cond
+ guardToExpr _ = internalError "Guard not correctly desugared"
+
+ -- | Desugars case binders from AST to CoreFn representation.
binderToCoreFn :: Maybe SourceSpan -> [Comment] -> A.Binder -> Binder Ann
binderToCoreFn ss com (A.LiteralBinder lit) =
LiteralBinder (ss, com, Nothing, Nothing) (fmap (binderToCoreFn ss com) lit)
@@ -162,18 +165,14 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =
binderToCoreFn _ _ A.ParensInBinder{} =
internalError "ParensInBinder should have been desugared before binderToCoreFn"
- -- |
- -- Gets metadata for values.
- --
+ -- | Gets metadata for values.
getValueMeta :: Qualified Ident -> Maybe Meta
getValueMeta name =
case lookupValue env name of
Just (_, External, _) -> Just IsForeign
_ -> Nothing
- -- |
- -- Gets metadata for data constructors.
- --
+ -- | Gets metadata for data constructors.
getConstructorMeta :: Qualified (ProperName 'ConstructorName) -> Meta
getConstructorMeta ctor =
case lookupConstructor env ctor of
@@ -194,11 +193,9 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =
typeConstructor (Qualified (Just mn') _, (_, tyCtor, _, _)) = (mn', tyCtor)
typeConstructor _ = internalError "Invalid argument to typeConstructor"
--- |
--- Find module names from qualified references to values. This is used to
+-- | Find module names from qualified references to values. This is used to
-- ensure instances are imported from any module that is referenced by the
-- current module, not just from those that are imported explicitly (#667).
---
findQualModules :: [A.Declaration] -> [(Ann, ModuleName)]
findQualModules decls =
let (f, _, _, _, _) = everythingOnValues (++) fqDecls fqValues fqBinders (const []) (const [])
@@ -213,11 +210,10 @@ findQualModules decls =
fqValues :: A.Expr -> [ModuleName]
fqValues (A.Var q) = getQual' q
fqValues (A.Constructor q) = getQual' q
- -- IsSymbol instances for literal symbols are automatically solved and the type
- -- class dictionaries are built inline instead of having a named instance defined
- -- and imported. We therefore need to import the IsSymbol constructor from
- -- Data.Symbol if it hasn't already been imported.
- fqValues (A.TypeClassDictionaryConstructorApp C.IsSymbol _) = getQual' C.IsSymbol
+ -- Some instances are automatically solved and have their class dictionaries
+ -- built inline instead of having a named instance defined and imported.
+ -- We therefore need to import these constructors if they aren't already.
+ fqValues (A.TypeClassDictionaryConstructorApp c _) = getQual' c
fqValues _ = []
fqBinders :: A.Binder -> [ModuleName]
@@ -227,28 +223,22 @@ findQualModules decls =
getQual' :: Qualified a -> [ModuleName]
getQual' = maybe [] return . getQual
--- |
--- Desugars import declarations from AST to CoreFn representation.
---
+-- | Desugars import declarations from AST to CoreFn representation.
importToCoreFn :: A.Declaration -> Maybe (Ann, ModuleName)
importToCoreFn (A.ImportDeclaration name _ _) = Just (nullAnn, name)
importToCoreFn (A.PositionedDeclaration ss _ d) =
((,) (Just ss, [], Nothing, Nothing) . snd) <$> importToCoreFn d
importToCoreFn _ = Nothing
--- |
--- Desugars foreign declarations from AST to CoreFn representation.
---
+-- | Desugars foreign declarations from AST to CoreFn representation.
externToCoreFn :: A.Declaration -> Maybe ForeignDecl
externToCoreFn (A.ExternDeclaration name ty) = Just (name, ty)
externToCoreFn (A.PositionedDeclaration _ _ d) = externToCoreFn d
externToCoreFn _ = Nothing
--- |
--- Desugars export declarations references from AST to CoreFn representation.
+-- | Desugars export declarations references from AST to CoreFn representation.
-- CoreFn modules only export values, so all data constructors, class
-- constructor, instances and values are flattened into one list.
---
exportToCoreFn :: A.DeclarationRef -> [Ident]
exportToCoreFn (A.TypeRef _ (Just dctors)) = map properToIdent dctors
exportToCoreFn (A.ValueRef name) = [name]
@@ -257,11 +247,9 @@ exportToCoreFn (A.TypeInstanceRef name) = [name]
exportToCoreFn (A.PositionedDeclarationRef _ _ d) = exportToCoreFn d
exportToCoreFn _ = []
--- |
--- Makes a typeclass dictionary constructor function. The returned expression
+-- | Makes a typeclass dictionary constructor function. The returned expression
-- is a function that accepts the superclass instances and member
-- implementations and returns a record for the instance dictionary.
---
mkTypeClassConstructor :: Maybe SourceSpan -> [Comment] -> [Constraint] -> [A.Declaration] -> Expr Ann
mkTypeClassConstructor ss com [] [] = Literal (ss, com, Nothing, Just IsTypeClassConstructor) (ObjectLiteral [])
mkTypeClassConstructor ss com supers members =
@@ -272,8 +260,6 @@ mkTypeClassConstructor ss com supers members =
(Ident a)
(foldr (Abs nullAnn . Ident) dict as)
--- |
--- Converts a ProperName to an Ident.
---
+-- | Converts a ProperName to an Ident.
properToIdent :: ProperName a -> Ident
properToIdent = Ident . runProperName
diff --git a/src/Language/PureScript/CoreFn/Meta.hs b/src/Language/PureScript/CoreFn/Meta.hs
index 88cbe7f..65e5dcd 100644
--- a/src/Language/PureScript/CoreFn/Meta.hs
+++ b/src/Language/PureScript/CoreFn/Meta.hs
@@ -26,7 +26,7 @@ data Meta
-- |
-- The contained reference is for a foreign member
--
- | IsForeign deriving (Show, Eq)
+ | IsForeign deriving (Show, Eq, Ord)
-- |
-- Data constructor metadata
@@ -39,4 +39,4 @@ data ConstructorType
-- |
-- The constructor is for a type with multiple construcors
--
- | SumType deriving (Show, Eq)
+ | SumType deriving (Show, Eq, Ord)
diff --git a/src/Language/PureScript/CoreImp.hs b/src/Language/PureScript/CoreImp.hs
new file mode 100644
index 0000000..5029aff
--- /dev/null
+++ b/src/Language/PureScript/CoreImp.hs
@@ -0,0 +1,13 @@
+-- | The imperative core language
+module Language.PureScript.CoreImp (
+ module C
+) where
+
+import Language.PureScript.CoreImp.AST as C
+import Language.PureScript.CoreImp.Optimizer as C
+import Language.PureScript.CoreImp.Optimizer.Blocks as C
+import Language.PureScript.CoreImp.Optimizer.Common as C
+import Language.PureScript.CoreImp.Optimizer.Inliner as C
+import Language.PureScript.CoreImp.Optimizer.MagicDo as C
+import Language.PureScript.CoreImp.Optimizer.TCO as C
+import Language.PureScript.CoreImp.Optimizer.Unused as C
diff --git a/src/Language/PureScript/CoreImp/AST.hs b/src/Language/PureScript/CoreImp/AST.hs
new file mode 100644
index 0000000..3606233
--- /dev/null
+++ b/src/Language/PureScript/CoreImp/AST.hs
@@ -0,0 +1,224 @@
+-- | Data types for the imperative core AST
+module Language.PureScript.CoreImp.AST where
+
+import Prelude.Compat
+
+import Control.Monad ((>=>))
+import Control.Monad.Identity (Identity(..), runIdentity)
+import Data.Text (Text)
+
+import Language.PureScript.AST (SourceSpan(..))
+import Language.PureScript.Comments
+import Language.PureScript.PSString (PSString)
+import Language.PureScript.Traversals
+
+-- | Built-in unary operators
+data UnaryOperator
+ = Negate
+ | Not
+ | BitwiseNot
+ | Positive
+ | New
+ deriving (Show, Eq)
+
+-- | Built-in binary operators
+data BinaryOperator
+ = Add
+ | Subtract
+ | Multiply
+ | Divide
+ | Modulus
+ | EqualTo
+ | NotEqualTo
+ | LessThan
+ | LessThanOrEqualTo
+ | GreaterThan
+ | GreaterThanOrEqualTo
+ | And
+ | Or
+ | BitwiseAnd
+ | BitwiseOr
+ | BitwiseXor
+ | ShiftLeft
+ | ShiftRight
+ | ZeroFillShiftRight
+ deriving (Show, Eq)
+
+-- | Data type for simplified JavaScript expressions
+data AST
+ = NumericLiteral (Maybe SourceSpan) (Either Integer Double)
+ -- ^ A numeric literal
+ | StringLiteral (Maybe SourceSpan) PSString
+ -- ^ A string literal
+ | BooleanLiteral (Maybe SourceSpan) Bool
+ -- ^ A boolean literal
+ | Unary (Maybe SourceSpan) UnaryOperator AST
+ -- ^ A unary operator application
+ | Binary (Maybe SourceSpan) BinaryOperator AST AST
+ -- ^ A binary operator application
+ | ArrayLiteral (Maybe SourceSpan) [AST]
+ -- ^ An array literal
+ | Indexer (Maybe SourceSpan) AST AST
+ -- ^ An array indexer expression
+ | ObjectLiteral (Maybe SourceSpan) [(PSString, AST)]
+ -- ^ An object literal
+ | Function (Maybe SourceSpan) (Maybe Text) [Text] AST
+ -- ^ A function introduction (optional name, arguments, body)
+ | App (Maybe SourceSpan) AST [AST]
+ -- ^ Function application
+ | Var (Maybe SourceSpan) Text
+ -- ^ Variable
+ | Block (Maybe SourceSpan) [AST]
+ -- ^ A block of expressions in braces
+ | VariableIntroduction (Maybe SourceSpan) Text (Maybe AST)
+ -- ^ A variable introduction and optional initialization
+ | Assignment (Maybe SourceSpan) AST AST
+ -- ^ A variable assignment
+ | While (Maybe SourceSpan) AST AST
+ -- ^ While loop
+ | For (Maybe SourceSpan) Text AST AST AST
+ -- ^ For loop
+ | ForIn (Maybe SourceSpan) Text AST AST
+ -- ^ ForIn loop
+ | IfElse (Maybe SourceSpan) AST AST (Maybe AST)
+ -- ^ If-then-else statement
+ | Return (Maybe SourceSpan) AST
+ -- ^ Return statement
+ | ReturnNoResult (Maybe SourceSpan)
+ -- ^ Return statement with no return value
+ | Throw (Maybe SourceSpan) AST
+ -- ^ Throw statement
+ | InstanceOf (Maybe SourceSpan) AST AST
+ -- ^ instanceof check
+ | Comment (Maybe SourceSpan) [Comment] AST
+ -- ^ Commented JavaScript
+ deriving (Show, Eq)
+
+withSourceSpan :: SourceSpan -> AST -> AST
+withSourceSpan withSpan = go where
+ ss :: Maybe SourceSpan
+ ss = Just withSpan
+
+ go :: AST -> AST
+ go (NumericLiteral _ n) = NumericLiteral ss n
+ go (StringLiteral _ s) = StringLiteral ss s
+ go (BooleanLiteral _ b) = BooleanLiteral ss b
+ go (Unary _ op j) = Unary ss op j
+ go (Binary _ op j1 j2) = Binary ss op j1 j2
+ go (ArrayLiteral _ js) = ArrayLiteral ss js
+ go (Indexer _ j1 j2) = Indexer ss j1 j2
+ go (ObjectLiteral _ js) = ObjectLiteral ss js
+ go (Function _ name args j) = Function ss name args j
+ go (App _ j js) = App ss j js
+ go (Var _ s) = Var ss s
+ go (Block _ js) = Block ss js
+ go (VariableIntroduction _ name j) = VariableIntroduction ss name j
+ go (Assignment _ j1 j2) = Assignment ss j1 j2
+ go (While _ j1 j2) = While ss j1 j2
+ go (For _ name j1 j2 j3) = For ss name j1 j2 j3
+ go (ForIn _ name j1 j2) = ForIn ss name j1 j2
+ go (IfElse _ j1 j2 j3) = IfElse ss j1 j2 j3
+ go (Return _ js) = Return ss js
+ go (ReturnNoResult _) = ReturnNoResult ss
+ go (Throw _ js) = Throw ss js
+ go (InstanceOf _ j1 j2) = InstanceOf ss j1 j2
+ go (Comment _ com j) = Comment ss com j
+
+getSourceSpan :: AST -> Maybe SourceSpan
+getSourceSpan = go where
+ go :: AST -> Maybe SourceSpan
+ go (NumericLiteral ss _) = ss
+ go (StringLiteral ss _) = ss
+ go (BooleanLiteral ss _) = ss
+ go (Unary ss _ _) = ss
+ go (Binary ss _ _ _) = ss
+ go (ArrayLiteral ss _) = ss
+ go (Indexer ss _ _) = ss
+ go (ObjectLiteral ss _) = ss
+ go (Function ss _ _ _) = ss
+ go (App ss _ _) = ss
+ go (Var ss _) = ss
+ go (Block ss _) = ss
+ go (VariableIntroduction ss _ _) = ss
+ go (Assignment ss _ _) = ss
+ go (While ss _ _) = ss
+ go (For ss _ _ _ _) = ss
+ go (ForIn ss _ _ _) = ss
+ go (IfElse ss _ _ _) = ss
+ go (Return ss _) = ss
+ go (ReturnNoResult ss) = ss
+ go (Throw ss _) = ss
+ go (InstanceOf ss _ _) = ss
+ go (Comment ss _ _) = ss
+
+everywhere :: (AST -> AST) -> AST -> AST
+everywhere f = go where
+ go :: AST -> AST
+ go (Unary ss op j) = f (Unary ss op (go j))
+ go (Binary ss op j1 j2) = f (Binary ss op (go j1) (go j2))
+ go (ArrayLiteral ss js) = f (ArrayLiteral ss (map go js))
+ go (Indexer ss j1 j2) = f (Indexer ss (go j1) (go j2))
+ go (ObjectLiteral ss js) = f (ObjectLiteral ss (map (fmap go) js))
+ go (Function ss name args j) = f (Function ss name args (go j))
+ go (App ss j js) = f (App ss (go j) (map go js))
+ go (Block ss js) = f (Block ss (map go js))
+ go (VariableIntroduction ss name j) = f (VariableIntroduction ss name (fmap go j))
+ go (Assignment ss j1 j2) = f (Assignment ss (go j1) (go j2))
+ go (While ss j1 j2) = f (While ss (go j1) (go j2))
+ go (For ss name j1 j2 j3) = f (For ss name (go j1) (go j2) (go j3))
+ go (ForIn ss name j1 j2) = f (ForIn ss name (go j1) (go j2))
+ go (IfElse ss j1 j2 j3) = f (IfElse ss (go j1) (go j2) (fmap go j3))
+ go (Return ss js) = f (Return ss (go js))
+ go (Throw ss js) = f (Throw ss (go js))
+ go (InstanceOf ss j1 j2) = f (InstanceOf ss (go j1) (go j2))
+ go (Comment ss com j) = f (Comment ss com (go j))
+ go other = f other
+
+everywhereTopDown :: (AST -> AST) -> AST -> AST
+everywhereTopDown f = runIdentity . everywhereTopDownM (Identity . f)
+
+everywhereTopDownM :: (Monad m) => (AST -> m AST) -> AST -> m AST
+everywhereTopDownM f = f >=> go where
+ f' = f >=> go
+ go (Unary ss op j) = Unary ss op <$> f' j
+ go (Binary ss op j1 j2) = Binary ss op <$> f' j1 <*> f' j2
+ go (ArrayLiteral ss js) = ArrayLiteral ss <$> traverse f' js
+ go (Indexer ss j1 j2) = Indexer ss <$> f' j1 <*> f' j2
+ go (ObjectLiteral ss js) = ObjectLiteral ss <$> traverse (sndM f') js
+ go (Function ss name args j) = Function ss name args <$> f' j
+ go (App ss j js) = App ss <$> f' j <*> traverse f' js
+ go (Block ss js) = Block ss <$> traverse f' js
+ go (VariableIntroduction ss name j) = VariableIntroduction ss name <$> traverse f' j
+ go (Assignment ss j1 j2) = Assignment ss <$> f' j1 <*> f' j2
+ go (While ss j1 j2) = While ss <$> f' j1 <*> f' j2
+ go (For ss name j1 j2 j3) = For ss name <$> f' j1 <*> f' j2 <*> f' j3
+ go (ForIn ss name j1 j2) = ForIn ss name <$> f' j1 <*> f' j2
+ go (IfElse ss j1 j2 j3) = IfElse ss <$> f' j1 <*> f' j2 <*> traverse f' j3
+ go (Return ss j) = Return ss <$> f' j
+ go (Throw ss j) = Throw ss <$> f' j
+ go (InstanceOf ss j1 j2) = InstanceOf ss <$> f' j1 <*> f' j2
+ go (Comment ss com j) = Comment ss com <$> f' j
+ go other = f other
+
+everything :: (r -> r -> r) -> (AST -> r) -> AST -> r
+everything (<>) f = go where
+ go j@(Unary _ _ j1) = f j <> go j1
+ go j@(Binary _ _ j1 j2) = f j <> go j1 <> go j2
+ go j@(ArrayLiteral _ js) = foldl (<>) (f j) (map go js)
+ go j@(Indexer _ j1 j2) = f j <> go j1 <> go j2
+ go j@(ObjectLiteral _ js) = foldl (<>) (f j) (map (go . snd) js)
+ go j@(Function _ _ _ j1) = f j <> go j1
+ go j@(App _ j1 js) = foldl (<>) (f j <> go j1) (map go js)
+ go j@(Block _ js) = foldl (<>) (f j) (map go js)
+ go j@(VariableIntroduction _ _ (Just j1)) = f j <> go j1
+ go j@(Assignment _ j1 j2) = f j <> go j1 <> go j2
+ go j@(While _ j1 j2) = f j <> go j1 <> go j2
+ go j@(For _ _ j1 j2 j3) = f j <> go j1 <> go j2 <> go j3
+ go j@(ForIn _ _ j1 j2) = f j <> go j1 <> go j2
+ go j@(IfElse _ j1 j2 Nothing) = f j <> go j1 <> go j2
+ go j@(IfElse _ j1 j2 (Just j3)) = f j <> go j1 <> go j2 <> go j3
+ go j@(Return _ j1) = f j <> go j1
+ go j@(Throw _ j1) = f j <> go j1
+ go j@(InstanceOf _ j1 j2) = f j <> go j1 <> go j2
+ go j@(Comment _ _ j1) = f j <> go j1
+ go other = f other
diff --git a/src/Language/PureScript/CoreImp/Optimizer.hs b/src/Language/PureScript/CoreImp/Optimizer.hs
new file mode 100644
index 0000000..cfdee15
--- /dev/null
+++ b/src/Language/PureScript/CoreImp/Optimizer.hs
@@ -0,0 +1,60 @@
+-- | This module optimizes code in the simplified-JavaScript intermediate representation.
+--
+-- The following optimizations are supported:
+--
+-- * Collapsing nested blocks
+--
+-- * Tail call elimination
+--
+-- * Inlining of (>>=) and ret for the Eff monad
+--
+-- * Removal of unnecessary thunks
+--
+-- * Eta conversion
+--
+-- * Inlining variables
+--
+-- * Inline Prelude.($), Prelude.(#), Prelude.(++), Prelude.(!!)
+--
+-- * Inlining primitive JavaScript operators
+module Language.PureScript.CoreImp.Optimizer (optimize) where
+
+import Prelude.Compat
+
+import Control.Monad.Supply.Class (MonadSupply)
+import Language.PureScript.CoreImp.AST
+import Language.PureScript.CoreImp.Optimizer.Blocks
+import Language.PureScript.CoreImp.Optimizer.Common
+import Language.PureScript.CoreImp.Optimizer.Inliner
+import Language.PureScript.CoreImp.Optimizer.MagicDo
+import Language.PureScript.CoreImp.Optimizer.TCO
+import Language.PureScript.CoreImp.Optimizer.Unused
+
+-- | Apply a series of optimizer passes to simplified JavaScript code
+optimize :: MonadSupply m => AST -> m AST
+optimize js = do
+ js' <- untilFixedPoint (inlineFnComposition . inlineUnsafePartial . tidyUp . applyAll
+ [ inlineCommonValues
+ , inlineCommonOperators
+ ]) js
+ untilFixedPoint (return . tidyUp) . tco . magicDo $ js'
+ where
+ tidyUp :: AST -> AST
+ tidyUp = applyAll
+ [ collapseNestedBlocks
+ , collapseNestedIfs
+ , removeCodeAfterReturnStatements
+ , removeUnusedArg
+ , removeUndefinedApp
+ , unThunk
+ , etaConvert
+ , evaluateIifes
+ , inlineVariables
+ ]
+
+untilFixedPoint :: (Monad m, Eq a) => (a -> m a) -> a -> m a
+untilFixedPoint f = go
+ where
+ go a = do
+ a' <- f a
+ if a' == a then return a' else go a'
diff --git a/src/Language/PureScript/CoreImp/Optimizer/Blocks.hs b/src/Language/PureScript/CoreImp/Optimizer/Blocks.hs
new file mode 100644
index 0000000..47b2373
--- /dev/null
+++ b/src/Language/PureScript/CoreImp/Optimizer/Blocks.hs
@@ -0,0 +1,28 @@
+-- | Optimizer steps for simplifying JavaScript blocks
+module Language.PureScript.CoreImp.Optimizer.Blocks
+ ( collapseNestedBlocks
+ , collapseNestedIfs
+ ) where
+
+import Prelude.Compat
+
+import Language.PureScript.CoreImp.AST
+
+-- | Collapse blocks which appear nested directly below another block
+collapseNestedBlocks :: AST -> AST
+collapseNestedBlocks = everywhere collapse
+ where
+ collapse :: AST -> AST
+ collapse (Block ss sts) = Block ss (concatMap go sts)
+ collapse js = js
+ go :: AST -> [AST]
+ go (Block _ sts) = sts
+ go s = [s]
+
+collapseNestedIfs :: AST -> AST
+collapseNestedIfs = everywhere collapse
+ where
+ collapse :: AST -> AST
+ collapse (IfElse s1 cond1 (Block _ [IfElse s2 cond2 body Nothing]) Nothing) =
+ IfElse s1 (Binary s2 And cond1 cond2) body Nothing
+ collapse js = js
diff --git a/src/Language/PureScript/CoreImp/Optimizer/Common.hs b/src/Language/PureScript/CoreImp/Optimizer/Common.hs
new file mode 100644
index 0000000..040995c
--- /dev/null
+++ b/src/Language/PureScript/CoreImp/Optimizer/Common.hs
@@ -0,0 +1,76 @@
+-- | Common functions used by the various optimizer phases
+module Language.PureScript.CoreImp.Optimizer.Common where
+
+import Prelude.Compat
+
+import Data.Text (Text)
+import Data.List (foldl')
+import Data.Maybe (fromMaybe)
+
+import Language.PureScript.Crash
+import Language.PureScript.CoreImp.AST
+import Language.PureScript.PSString (PSString)
+
+applyAll :: [a -> a] -> a -> a
+applyAll = foldl' (.) id
+
+replaceIdent :: Text -> AST -> AST -> AST
+replaceIdent var1 js = everywhere replace
+ where
+ replace (Var _ var2) | var1 == var2 = js
+ replace other = other
+
+replaceIdents :: [(Text, AST)] -> AST -> AST
+replaceIdents vars = everywhere replace
+ where
+ replace v@(Var _ var) = fromMaybe v $ lookup var vars
+ replace other = other
+
+isReassigned :: Text -> AST -> Bool
+isReassigned var1 = everything (||) check
+ where
+ check :: AST -> Bool
+ check (Function _ _ args _) | var1 `elem` args = True
+ check (VariableIntroduction _ arg _) | var1 == arg = True
+ check (Assignment _ (Var _ arg) _) | var1 == arg = True
+ check (For _ arg _ _ _) | var1 == arg = True
+ check (ForIn _ arg _ _) | var1 == arg = True
+ check _ = False
+
+isRebound :: AST -> AST -> Bool
+isRebound js d = any (\v -> isReassigned v d || isUpdated v d) (everything (++) variablesOf js)
+ where
+ variablesOf (Var _ var) = [var]
+ variablesOf _ = []
+
+isUsed :: Text -> AST -> Bool
+isUsed var1 = everything (||) check
+ where
+ check :: AST -> Bool
+ check (Var _ var2) | var1 == var2 = True
+ check (Assignment _ target _) | var1 == targetVariable target = True
+ check _ = False
+
+targetVariable :: AST -> Text
+targetVariable (Var _ var) = var
+targetVariable (Indexer _ _ tgt) = targetVariable tgt
+targetVariable _ = internalError "Invalid argument to targetVariable"
+
+isUpdated :: Text -> AST -> Bool
+isUpdated var1 = everything (||) check
+ where
+ check :: AST -> Bool
+ check (Assignment _ target _) | var1 == targetVariable target = True
+ check _ = False
+
+removeFromBlock :: ([AST] -> [AST]) -> AST -> AST
+removeFromBlock go (Block ss sts) = Block ss (go sts)
+removeFromBlock _ js = js
+
+isDict :: (Text, PSString) -> AST -> Bool
+isDict (moduleName, dictName) (Indexer _ (StringLiteral _ x) (Var _ y)) =
+ x == dictName && y == moduleName
+isDict _ _ = False
+
+isDict' :: [(Text, PSString)] -> AST -> Bool
+isDict' xs js = any (`isDict` js) xs
diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs b/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs
index deea258..0c091e6 100644
--- a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs
+++ b/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs
@@ -1,7 +1,5 @@
--- |
--- This module provides basic inlining capabilities
---
-module Language.PureScript.CodeGen.JS.Optimizer.Inliner
+-- | This module performs basic inlining of known functions
+module Language.PureScript.CoreImp.Optimizer.Inliner
( inlineVariables
, inlineCommonValues
, inlineCommonOperators
@@ -23,76 +21,76 @@ import Data.Text (Text)
import qualified Data.Text as T
import Language.PureScript.PSString (PSString)
-import Language.PureScript.CodeGen.JS.AST
-import Language.PureScript.CodeGen.JS.Optimizer.Common
+import Language.PureScript.CoreImp.AST
+import Language.PureScript.CoreImp.Optimizer.Common
import qualified Language.PureScript.Constants as C
-- TODO: Potential bug:
-- Shouldn't just inline this case: { var x = 0; x.toFixed(10); }
-- Needs to be: { 0..toFixed(10); }
-- Probably needs to be fixed in pretty-printer instead.
-shouldInline :: JS -> Bool
-shouldInline (JSVar _ _) = True
-shouldInline (JSNumericLiteral _ _) = True
-shouldInline (JSStringLiteral _ _) = True
-shouldInline (JSBooleanLiteral _ _) = True
-shouldInline (JSIndexer _ index val) = shouldInline index && shouldInline val
+shouldInline :: AST -> Bool
+shouldInline (Var _ _) = True
+shouldInline (NumericLiteral _ _) = True
+shouldInline (StringLiteral _ _) = True
+shouldInline (BooleanLiteral _ _) = True
+shouldInline (Indexer _ index val) = shouldInline index && shouldInline val
shouldInline _ = False
-etaConvert :: JS -> JS
-etaConvert = everywhereOnJS convert
+etaConvert :: AST -> AST
+etaConvert = everywhere convert
where
- convert :: JS -> JS
- convert (JSBlock ss [JSReturn _ (JSApp _ (JSFunction _ Nothing idents block@(JSBlock _ body)) args)])
+ convert :: AST -> AST
+ convert (Block ss [Return _ (App _ (Function _ Nothing idents block@(Block _ body)) args)])
| all shouldInline args &&
- not (any (`isRebound` block) (map (JSVar Nothing) idents)) &&
+ not (any (`isRebound` block) (map (Var Nothing) idents)) &&
not (any (`isRebound` block) args)
- = JSBlock ss (map (replaceIdents (zip idents args)) body)
- convert (JSFunction _ Nothing [] (JSBlock _ [JSReturn _ (JSApp _ fn [])])) = fn
+ = Block ss (map (replaceIdents (zip idents args)) body)
+ convert (Function _ Nothing [] (Block _ [Return _ (App _ fn [])])) = fn
convert js = js
-unThunk :: JS -> JS
-unThunk = everywhereOnJS convert
+unThunk :: AST -> AST
+unThunk = everywhere convert
where
- convert :: JS -> JS
- convert (JSBlock ss []) = JSBlock ss []
- convert (JSBlock ss jss) =
+ convert :: AST -> AST
+ convert (Block ss []) = Block ss []
+ convert (Block ss jss) =
case last jss of
- JSReturn _ (JSApp _ (JSFunction _ Nothing [] (JSBlock _ body)) []) -> JSBlock ss $ init jss ++ body
- _ -> JSBlock ss jss
+ Return _ (App _ (Function _ Nothing [] (Block _ body)) []) -> Block ss $ init jss ++ body
+ _ -> Block ss jss
convert js = js
-evaluateIifes :: JS -> JS
-evaluateIifes = everywhereOnJS convert
+evaluateIifes :: AST -> AST
+evaluateIifes = everywhere convert
where
- convert :: JS -> JS
- convert (JSApp _ (JSFunction _ Nothing [] (JSBlock _ [JSReturn _ ret])) []) = ret
- convert (JSApp _ (JSFunction _ Nothing idents (JSBlock _ [JSReturn ss ret])) [])
- | not (any (`isReassigned` ret) idents) = replaceIdents (map (, JSVar ss C.undefined) idents) ret
+ convert :: AST -> AST
+ convert (App _ (Function _ Nothing [] (Block _ [Return _ ret])) []) = ret
+ convert (App _ (Function _ Nothing idents (Block _ [Return ss ret])) [])
+ | not (any (`isReassigned` ret) idents) = replaceIdents (map (, Var ss C.undefined) idents) ret
convert js = js
-inlineVariables :: JS -> JS
-inlineVariables = everywhereOnJS $ removeFromBlock go
+inlineVariables :: AST -> AST
+inlineVariables = everywhere $ removeFromBlock go
where
- go :: [JS] -> [JS]
+ go :: [AST] -> [AST]
go [] = []
- go (JSVariableIntroduction _ var (Just js) : sts)
+ go (VariableIntroduction _ var (Just js) : sts)
| shouldInline js && not (any (isReassigned var) sts) && not (any (isRebound js) sts) && not (any (isUpdated var) sts) =
go (map (replaceIdent var js) sts)
go (s:sts) = s : go sts
-inlineCommonValues :: JS -> JS
-inlineCommonValues = everywhereOnJS convert
+inlineCommonValues :: AST -> AST
+inlineCommonValues = everywhere convert
where
- convert :: JS -> JS
- convert (JSApp ss fn [dict])
- | isDict' [semiringNumber, semiringInt] dict && isDict fnZero fn = JSNumericLiteral ss (Left 0)
- | isDict' [semiringNumber, semiringInt] dict && isDict fnOne fn = JSNumericLiteral ss (Left 1)
- | isDict boundedBoolean dict && isDict fnBottom fn = JSBooleanLiteral ss False
- | isDict boundedBoolean dict && isDict fnTop fn = JSBooleanLiteral ss True
- convert (JSApp ss (JSApp _ fn [dict]) [x])
- | isDict ringInt dict && isDict fnNegate fn = JSBinary ss BitwiseOr (JSUnary ss Negate x) (JSNumericLiteral ss (Left 0))
- convert (JSApp ss (JSApp _ (JSApp _ fn [dict]) [x]) [y])
+ convert :: AST -> AST
+ convert (App ss fn [dict])
+ | isDict' [semiringNumber, semiringInt] dict && isDict fnZero fn = NumericLiteral ss (Left 0)
+ | isDict' [semiringNumber, semiringInt] dict && isDict fnOne fn = NumericLiteral ss (Left 1)
+ | isDict boundedBoolean dict && isDict fnBottom fn = BooleanLiteral ss False
+ | isDict boundedBoolean dict && isDict fnTop fn = BooleanLiteral ss True
+ convert (App ss (App _ fn [dict]) [x])
+ | isDict ringInt dict && isDict fnNegate fn = Binary ss BitwiseOr (Unary ss Negate x) (NumericLiteral ss (Left 0))
+ convert (App ss (App _ (App _ fn [dict]) [x]) [y])
| isDict semiringInt dict && isDict fnAdd fn = intOp ss Add x y
| isDict semiringInt dict && isDict fnMultiply fn = intOp ss Multiply x y
| isDict euclideanRingInt dict && isDict fnDivide fn = intOp ss Divide x y
@@ -107,10 +105,10 @@ inlineCommonValues = everywhereOnJS convert
fnMultiply = (C.dataSemiring, C.mul)
fnSubtract = (C.dataRing, C.sub)
fnNegate = (C.dataRing, C.negate)
- intOp ss op x y = JSBinary ss BitwiseOr (JSBinary ss op x y) (JSNumericLiteral ss (Left 0))
+ intOp ss op x y = Binary ss BitwiseOr (Binary ss op x y) (NumericLiteral ss (Left 0))
-inlineCommonOperators :: JS -> JS
-inlineCommonOperators = everywhereOnJSTopDown $ applyAll $
+inlineCommonOperators :: AST -> AST
+inlineCommonOperators = everywhereTopDown $ applyAll $
[ binary semiringNumber opAdd Add
, binary semiringNumber opMul Multiply
@@ -166,114 +164,114 @@ inlineCommonOperators = everywhereOnJSTopDown $ applyAll $
, binary' C.dataIntBits C.zshr ZeroFillShiftRight
, unary' C.dataIntBits C.complement BitwiseNot
- , inlineNonClassFunction (isModFn (C.dataFunction, C.apply)) $ \f x -> JSApp Nothing f [x]
- , inlineNonClassFunction (isModFn (C.dataFunction, C.applyFlipped)) $ \x f -> JSApp Nothing f [x]
- , inlineNonClassFunction (isModFnWithDict (C.dataArray, C.unsafeIndex)) $ flip (JSIndexer Nothing)
+ , inlineNonClassFunction (isModFn (C.dataFunction, C.apply)) $ \f x -> App Nothing f [x]
+ , inlineNonClassFunction (isModFn (C.dataFunction, C.applyFlipped)) $ \x f -> App Nothing f [x]
+ , inlineNonClassFunction (isModFnWithDict (C.dataArray, C.unsafeIndex)) $ flip (Indexer Nothing)
] ++
[ fn | i <- [0..10], fn <- [ mkFn i, runFn i ] ]
where
- binary :: (Text, PSString) -> (Text, PSString) -> BinaryOperator -> JS -> JS
+ binary :: (Text, PSString) -> (Text, PSString) -> BinaryOperator -> AST -> AST
binary dict fns op = convert where
- convert :: JS -> JS
- convert (JSApp ss (JSApp _ (JSApp _ fn [dict']) [x]) [y]) | isDict dict dict' && isDict fns fn = JSBinary ss op x y
+ convert :: AST -> AST
+ convert (App ss (App _ (App _ fn [dict']) [x]) [y]) | isDict dict dict' && isDict fns fn = Binary ss op x y
convert other = other
- binary' :: Text -> PSString -> BinaryOperator -> JS -> JS
+ binary' :: Text -> PSString -> BinaryOperator -> AST -> AST
binary' moduleName opString op = convert where
- convert :: JS -> JS
- convert (JSApp ss (JSApp _ fn [x]) [y]) | isDict (moduleName, opString) fn = JSBinary ss op x y
+ convert :: AST -> AST
+ convert (App ss (App _ fn [x]) [y]) | isDict (moduleName, opString) fn = Binary ss op x y
convert other = other
- unary :: (Text, PSString) -> (Text, PSString) -> UnaryOperator -> JS -> JS
+ unary :: (Text, PSString) -> (Text, PSString) -> UnaryOperator -> AST -> AST
unary dicts fns op = convert where
- convert :: JS -> JS
- convert (JSApp ss (JSApp _ fn [dict']) [x]) | isDict dicts dict' && isDict fns fn = JSUnary ss op x
+ convert :: AST -> AST
+ convert (App ss (App _ fn [dict']) [x]) | isDict dicts dict' && isDict fns fn = Unary ss op x
convert other = other
- unary' :: Text -> PSString -> UnaryOperator -> JS -> JS
+ unary' :: Text -> PSString -> UnaryOperator -> AST -> AST
unary' moduleName fnName op = convert where
- convert :: JS -> JS
- convert (JSApp ss fn [x]) | isDict (moduleName, fnName) fn = JSUnary ss op x
+ convert :: AST -> AST
+ convert (App ss fn [x]) | isDict (moduleName, fnName) fn = Unary ss op x
convert other = other
- mkFn :: Int -> JS -> JS
+ mkFn :: Int -> AST -> AST
mkFn 0 = convert where
- convert :: JS -> JS
- convert (JSApp _ mkFnN [JSFunction s1 Nothing [_] (JSBlock s2 js)]) | isNFn C.mkFn 0 mkFnN =
- JSFunction s1 Nothing [] (JSBlock s2 js)
+ convert :: AST -> AST
+ convert (App _ mkFnN [Function s1 Nothing [_] (Block s2 js)]) | isNFn C.mkFn 0 mkFnN =
+ Function s1 Nothing [] (Block s2 js)
convert other = other
mkFn n = convert where
- convert :: JS -> JS
- convert orig@(JSApp ss mkFnN [fn]) | isNFn C.mkFn n mkFnN =
+ convert :: AST -> AST
+ convert orig@(App ss mkFnN [fn]) | isNFn C.mkFn n mkFnN =
case collectArgs n [] fn of
- Just (args, js) -> JSFunction ss Nothing args (JSBlock ss js)
+ Just (args, js) -> Function ss Nothing args (Block ss js)
Nothing -> orig
convert other = other
- collectArgs :: Int -> [Text] -> JS -> Maybe ([Text], [JS])
- collectArgs 1 acc (JSFunction _ Nothing [oneArg] (JSBlock _ js)) | length acc == n - 1 = Just (reverse (oneArg : acc), js)
- collectArgs m acc (JSFunction _ Nothing [oneArg] (JSBlock _ [JSReturn _ ret])) = collectArgs (m - 1) (oneArg : acc) ret
+ collectArgs :: Int -> [Text] -> AST -> Maybe ([Text], [AST])
+ collectArgs 1 acc (Function _ Nothing [oneArg] (Block _ js)) | length acc == n - 1 = Just (reverse (oneArg : acc), js)
+ collectArgs m acc (Function _ Nothing [oneArg] (Block _ [Return _ ret])) = collectArgs (m - 1) (oneArg : acc) ret
collectArgs _ _ _ = Nothing
- isNFn :: Text -> Int -> JS -> Bool
- isNFn prefix n (JSVar _ name) = name == (prefix <> T.pack (show n))
- isNFn prefix n (JSIndexer _ (JSStringLiteral _ name) (JSVar _ dataFunctionUncurried)) | dataFunctionUncurried == C.dataFunctionUncurried =
+ isNFn :: Text -> Int -> AST -> Bool
+ isNFn prefix n (Var _ name) = name == (prefix <> T.pack (show n))
+ isNFn prefix n (Indexer _ (StringLiteral _ name) (Var _ dataFunctionUncurried)) | dataFunctionUncurried == C.dataFunctionUncurried =
name == fromString (T.unpack prefix <> show n)
isNFn _ _ _ = False
- runFn :: Int -> JS -> JS
+ runFn :: Int -> AST -> AST
runFn n = convert where
- convert :: JS -> JS
+ convert :: AST -> AST
convert js = fromMaybe js $ go n [] js
- go :: Int -> [JS] -> JS -> Maybe JS
- go 0 acc (JSApp ss runFnN [fn]) | isNFn C.runFn n runFnN && length acc == n = Just (JSApp ss fn acc)
- go m acc (JSApp _ lhs [arg]) = go (m - 1) (arg : acc) lhs
+ go :: Int -> [AST] -> AST -> Maybe AST
+ go 0 acc (App ss runFnN [fn]) | isNFn C.runFn n runFnN && length acc == n = Just (App ss fn acc)
+ go m acc (App _ lhs [arg]) = go (m - 1) (arg : acc) lhs
go _ _ _ = Nothing
- inlineNonClassFunction :: (JS -> Bool) -> (JS -> JS -> JS) -> JS -> JS
+ inlineNonClassFunction :: (AST -> Bool) -> (AST -> AST -> AST) -> AST -> AST
inlineNonClassFunction p f = convert where
- convert :: JS -> JS
- convert (JSApp _ (JSApp _ op' [x]) [y]) | p op' = f x y
+ convert :: AST -> AST
+ convert (App _ (App _ op' [x]) [y]) | p op' = f x y
convert other = other
- isModFn :: (Text, PSString) -> JS -> Bool
- isModFn (m, op) (JSIndexer _ (JSStringLiteral _ op') (JSVar _ m')) =
+ isModFn :: (Text, PSString) -> AST -> Bool
+ isModFn (m, op) (Indexer _ (StringLiteral _ op') (Var _ m')) =
m == m' && op == op'
isModFn _ _ = False
- isModFnWithDict :: (Text, PSString) -> JS -> Bool
- isModFnWithDict (m, op) (JSApp _ (JSIndexer _ (JSStringLiteral _ op') (JSVar _ m')) [JSVar _ _]) =
+ isModFnWithDict :: (Text, PSString) -> AST -> Bool
+ isModFnWithDict (m, op) (App _ (Indexer _ (StringLiteral _ op') (Var _ m')) [Var _ _]) =
m == m' && op == op'
isModFnWithDict _ _ = False
-- (f <<< g $ x) = f (g x)
-- (f <<< g) = \x -> f (g x)
-inlineFnComposition :: forall m. MonadSupply m => JS -> m JS
-inlineFnComposition = everywhereOnJSTopDownM convert where
- convert :: JS -> m JS
- convert (JSApp s1 (JSApp s2 (JSApp _ (JSApp _ fn [dict']) [x]) [y]) [z])
- | isFnCompose dict' fn = return $ JSApp s1 x [JSApp s2 y [z]]
- | isFnComposeFlipped dict' fn = return $ JSApp s2 y [JSApp s1 x [z]]
- convert (JSApp ss (JSApp _ (JSApp _ fn [dict']) [x]) [y])
+inlineFnComposition :: forall m. MonadSupply m => AST -> m AST
+inlineFnComposition = everywhereTopDownM convert where
+ convert :: AST -> m AST
+ convert (App s1 (App s2 (App _ (App _ fn [dict']) [x]) [y]) [z])
+ | isFnCompose dict' fn = return $ App s1 x [App s2 y [z]]
+ | isFnComposeFlipped dict' fn = return $ App s2 y [App s1 x [z]]
+ convert (App ss (App _ (App _ fn [dict']) [x]) [y])
| isFnCompose dict' fn = do
arg <- freshName
- return $ JSFunction ss Nothing [arg] (JSBlock ss [JSReturn Nothing $ JSApp Nothing x [JSApp Nothing y [JSVar Nothing arg]]])
+ return $ Function ss Nothing [arg] (Block ss [Return Nothing $ App Nothing x [App Nothing y [Var Nothing arg]]])
| isFnComposeFlipped dict' fn = do
arg <- freshName
- return $ JSFunction ss Nothing [arg] (JSBlock ss [JSReturn Nothing $ JSApp Nothing y [JSApp Nothing x [JSVar Nothing arg]]])
+ return $ Function ss Nothing [arg] (Block ss [Return Nothing $ App Nothing y [App Nothing x [Var Nothing arg]]])
convert other = return other
- isFnCompose :: JS -> JS -> Bool
+ isFnCompose :: AST -> AST -> Bool
isFnCompose dict' fn = isDict semigroupoidFn dict' && isDict fnCompose fn
- isFnComposeFlipped :: JS -> JS -> Bool
+ isFnComposeFlipped :: AST -> AST -> Bool
isFnComposeFlipped dict' fn = isDict semigroupoidFn dict' && isDict fnComposeFlipped fn
fnCompose :: forall a b. (IsString a, IsString b) => (a, b)
fnCompose = (C.controlSemigroupoid, C.compose)
fnComposeFlipped :: forall a b. (IsString a, IsString b) => (a, b)
fnComposeFlipped = (C.controlSemigroupoid, C.composeFlipped)
-inlineUnsafePartial :: JS -> JS
-inlineUnsafePartial = everywhereOnJSTopDown convert where
- convert (JSApp ss (JSIndexer _ (JSStringLiteral _ unsafePartial) (JSVar _ partialUnsafe)) [ comp ])
+inlineUnsafePartial :: AST -> AST
+inlineUnsafePartial = everywhereTopDown convert where
+ convert (App ss (Indexer _ (StringLiteral _ unsafePartial) (Var _ partialUnsafe)) [ comp ])
| unsafePartial == C.unsafePartial && partialUnsafe == C.partialUnsafe
-- Apply to undefined here, the application should be optimized away
-- if it is safe to do so
- = JSApp ss comp [ JSVar ss C.undefined ]
+ = App ss comp [ Var ss C.undefined ]
convert other = other
semiringNumber :: forall a b. (IsString a, IsString b) => (a, b)
diff --git a/src/Language/PureScript/CoreImp/Optimizer/MagicDo.hs b/src/Language/PureScript/CoreImp/Optimizer/MagicDo.hs
new file mode 100644
index 0000000..cf03f41
--- /dev/null
+++ b/src/Language/PureScript/CoreImp/Optimizer/MagicDo.hs
@@ -0,0 +1,134 @@
+-- | 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.CoreImp.Optimizer.MagicDo (magicDo) where
+
+import Prelude.Compat
+import Protolude (ordNub)
+
+import Data.Maybe (fromJust, isJust)
+
+import Language.PureScript.CoreImp.AST
+import Language.PureScript.CoreImp.Optimizer.Common
+import Language.PureScript.PSString (mkString)
+import qualified Language.PureScript.Constants as C
+
+-- | Inline type class dictionaries for >>= and return for the Eff monad
+--
+-- E.g.
+--
+-- Prelude[">>="](dict)(m1)(function(x) {
+-- return ...;
+-- })
+--
+-- becomes
+--
+-- function __do {
+-- var x = m1();
+-- ...
+-- }
+magicDo :: AST -> AST
+magicDo = inlineST . everywhere undo . everywhereTopDown convert
+ where
+ -- The name of the function block which is added to denote a do block
+ fnName = "__do"
+ -- Desugar monomorphic calls to >>= and return for the Eff monad
+ convert :: AST -> AST
+ -- Desugar pure
+ convert (App _ (App _ pure' [val]) []) | isPure pure' = val
+ -- Desugar discard
+ convert (App _ (App _ bind [m]) [Function s1 Nothing [] (Block s2 js)]) | isDiscard bind =
+ Function s1 (Just fnName) [] $ Block s2 (App s2 m [] : map applyReturns js )
+ -- Desugar bind
+ convert (App _ (App _ bind [m]) [Function s1 Nothing [arg] (Block s2 js)]) | isBind bind =
+ Function s1 (Just fnName) [] $ Block s2 (VariableIntroduction s2 arg (Just (App s2 m [])) : map applyReturns js)
+ -- Desugar untilE
+ convert (App s1 (App _ f [arg]) []) | isEffFunc C.untilE f =
+ App s1 (Function s1 Nothing [] (Block s1 [ While s1 (Unary s1 Not (App s1 arg [])) (Block s1 []), Return s1 $ ObjectLiteral s1 []])) []
+ -- Desugar whileE
+ convert (App _ (App _ (App s1 f [arg1]) [arg2]) []) | isEffFunc C.whileE f =
+ App s1 (Function s1 Nothing [] (Block s1 [ While s1 (App s1 arg1 []) (Block s1 [ App s1 arg2 [] ]), Return s1 $ ObjectLiteral s1 []])) []
+ convert other = other
+ -- Check if an expression represents a monomorphic call to >>= for the Eff monad
+ isBind (App _ fn [dict]) | isDict (C.eff, C.bindEffDictionary) dict && isBindPoly fn = True
+ isBind _ = False
+ -- Check if an expression represents a call to @discard@
+ isDiscard (App _ (App _ fn [dict1]) [dict2])
+ | isDict (C.controlBind, C.discardUnitDictionary) dict1 &&
+ isDict (C.eff, C.bindEffDictionary) dict2 &&
+ isDiscardPoly fn = True
+ isDiscard _ = False
+ -- Check if an expression represents a monomorphic call to pure or return for the Eff applicative
+ isPure (App _ fn [dict]) | isDict (C.eff, C.applicativeEffDictionary) dict && isPurePoly fn = True
+ isPure _ = False
+ -- Check if an expression represents the polymorphic >>= function
+ isBindPoly = isDict (C.controlBind, C.bind)
+ -- Check if an expression represents the polymorphic pure function
+ isPurePoly = isDict (C.controlApplicative, C.pure')
+ -- Check if an expression represents the polymorphic discard function
+ isDiscardPoly = isDict (C.controlBind, C.discard)
+ -- Check if an expression represents a function in the Eff module
+ isEffFunc name (Indexer _ (StringLiteral _ name') (Var _ eff)) = eff == C.eff && name == name'
+ isEffFunc _ _ = False
+
+ -- Remove __do function applications which remain after desugaring
+ undo :: AST -> AST
+ undo (Return _ (App _ (Function _ (Just ident) [] body) [])) | ident == fnName = body
+ undo other = other
+
+ applyReturns :: AST -> AST
+ applyReturns (Return ss ret) = Return ss (App ss ret [])
+ applyReturns (Block ss jss) = Block ss (map applyReturns jss)
+ applyReturns (While ss cond js) = While ss cond (applyReturns js)
+ applyReturns (For ss v lo hi js) = For ss v lo hi (applyReturns js)
+ applyReturns (ForIn ss v xs js) = ForIn ss v xs (applyReturns js)
+ applyReturns (IfElse ss cond t f) = IfElse ss cond (applyReturns t) (applyReturns `fmap` f)
+ applyReturns other = other
+
+-- | Inline functions in the ST module
+inlineST :: AST -> AST
+inlineST = everywhere convertBlock
+ where
+ -- Look for runST blocks and inline the STRefs there.
+ -- If all STRefs are used in the scope of the same runST, only using { read, write, modify }STRef then
+ -- we can be more aggressive about inlining, and actually turn STRefs into local variables.
+ convertBlock (App _ f [arg]) | isSTFunc C.runST f =
+ let refs = ordNub . findSTRefsIn $ arg
+ usages = findAllSTUsagesIn arg
+ allUsagesAreLocalVars = all (\u -> let v = toVar u in isJust v && fromJust v `elem` refs) usages
+ localVarsDoNotEscape = all (\r -> length (r `appearingIn` arg) == length (filter (\u -> let v = toVar u in v == Just r) usages)) refs
+ in everywhere (convert (allUsagesAreLocalVars && localVarsDoNotEscape)) arg
+ convertBlock other = other
+ -- Convert a block in a safe way, preserving object wrappers of references,
+ -- or in a more aggressive way, turning wrappers into local variables depending on the
+ -- agg(ressive) parameter.
+ convert agg (App s1 f [arg]) | isSTFunc C.newSTRef f =
+ Function s1 Nothing [] (Block s1 [Return s1 $ if agg then arg else ObjectLiteral s1 [(mkString C.stRefValue, arg)]])
+ convert agg (App _ (App s1 f [ref]) []) | isSTFunc C.readSTRef f =
+ if agg then ref else Indexer s1 (StringLiteral s1 C.stRefValue) ref
+ convert agg (App _ (App _ (App s1 f [ref]) [arg]) []) | isSTFunc C.writeSTRef f =
+ if agg then Assignment s1 ref arg else Assignment s1 (Indexer s1 (StringLiteral s1 C.stRefValue) ref) arg
+ convert agg (App _ (App _ (App s1 f [ref]) [func]) []) | isSTFunc C.modifySTRef f =
+ if agg then Assignment s1 ref (App s1 func [ref]) else Assignment s1 (Indexer s1 (StringLiteral s1 C.stRefValue) ref) (App s1 func [Indexer s1 (StringLiteral s1 C.stRefValue) ref])
+ convert _ other = other
+ -- Check if an expression represents a function in the ST module
+ isSTFunc name (Indexer _ (StringLiteral _ name') (Var _ st)) = st == C.st && name == name'
+ isSTFunc _ _ = False
+ -- Find all ST Refs initialized in this block
+ findSTRefsIn = everything (++) isSTRef
+ where
+ isSTRef (VariableIntroduction _ ident (Just (App _ (App _ f [_]) []))) | isSTFunc C.newSTRef f = [ident]
+ isSTRef _ = []
+ -- Find all STRefs used as arguments to readSTRef, writeSTRef, modifySTRef
+ findAllSTUsagesIn = everything (++) isSTUsage
+ where
+ isSTUsage (App _ (App _ f [ref]) []) | isSTFunc C.readSTRef f = [ref]
+ isSTUsage (App _ (App _ (App _ f [ref]) [_]) []) | isSTFunc C.writeSTRef f || isSTFunc C.modifySTRef f = [ref]
+ isSTUsage _ = []
+ -- Find all uses of a variable
+ appearingIn ref = everything (++) isVar
+ where
+ isVar e@(Var _ v) | v == ref = [e]
+ isVar _ = []
+ -- Convert a AST value to a String if it is a Var
+ toVar (Var _ v) = Just v
+ toVar _ = Nothing
diff --git a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs
new file mode 100644
index 0000000..7d8518a
--- /dev/null
+++ b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs
@@ -0,0 +1,123 @@
+-- | This module implements tail call elimination.
+module Language.PureScript.CoreImp.Optimizer.TCO (tco) where
+
+import Prelude.Compat
+
+import Data.Text (Text)
+import Data.Monoid ((<>))
+import Language.PureScript.CoreImp.AST
+import Language.PureScript.AST.SourcePos (SourceSpan)
+
+-- | Eliminate tail calls
+tco :: AST -> AST
+tco = everywhere convert where
+ tcoVar :: Text -> Text
+ tcoVar arg = "__tco_" <> arg
+
+ copyVar :: Text -> Text
+ copyVar arg = "__copy_" <> arg
+
+ tcoDone :: Text
+ tcoDone = tcoVar "done"
+
+ tcoLoop :: Text
+ tcoLoop = tcoVar "loop"
+
+ tcoResult :: Text
+ tcoResult = tcoVar "result"
+
+ convert :: AST -> AST
+ convert (VariableIntroduction ss name (Just fn@Function {}))
+ | isTailRecursive name body'
+ = VariableIntroduction ss name (Just (replace (toLoop name allArgs body')))
+ where
+ (argss, body', replace) = collectAllFunctionArgs [] id fn
+ allArgs = concat $ reverse argss
+ convert js = js
+
+ collectAllFunctionArgs :: [[Text]] -> (AST -> AST) -> AST -> ([[Text]], AST, AST -> AST)
+ collectAllFunctionArgs allArgs f (Function s1 ident args (Block s2 (body@(Return _ _):_))) =
+ collectAllFunctionArgs (args : allArgs) (\b -> f (Function s1 ident (map copyVar args) (Block s2 [b]))) body
+ collectAllFunctionArgs allArgs f (Function ss ident args body@(Block _ _)) =
+ (args : allArgs, body, f . Function ss ident (map copyVar args))
+ collectAllFunctionArgs allArgs f (Return s1 (Function s2 ident args (Block s3 [body]))) =
+ collectAllFunctionArgs (args : allArgs) (\b -> f (Return s1 (Function s2 ident (map copyVar args) (Block s3 [b])))) body
+ collectAllFunctionArgs allArgs f (Return s1 (Function s2 ident args body@(Block _ _))) =
+ (args : allArgs, body, f . Return s1 . Function s2 ident (map copyVar args))
+ collectAllFunctionArgs allArgs f body = (allArgs, body, f)
+
+ isTailRecursive :: Text -> AST -> Bool
+ isTailRecursive ident js = countSelfReferences js > 0 && allInTailPosition js where
+ countSelfReferences = everything (+) match where
+ match :: AST -> Int
+ match (Var _ ident') | ident == ident' = 1
+ match _ = 0
+
+ allInTailPosition (Return _ expr)
+ | isSelfCall ident expr = countSelfReferences expr == 1
+ | otherwise = countSelfReferences expr == 0
+ allInTailPosition (While _ js1 body)
+ = countSelfReferences js1 == 0 && allInTailPosition body
+ allInTailPosition (For _ _ js1 js2 body)
+ = countSelfReferences js1 == 0 && countSelfReferences js2 == 0 && allInTailPosition body
+ allInTailPosition (ForIn _ _ js1 body)
+ = countSelfReferences js1 == 0 && allInTailPosition body
+ allInTailPosition (IfElse _ js1 body el)
+ = countSelfReferences js1 == 0 && allInTailPosition body && all allInTailPosition el
+ allInTailPosition (Block _ body)
+ = all allInTailPosition body
+ allInTailPosition (Throw _ js1)
+ = countSelfReferences js1 == 0
+ allInTailPosition _
+ = False
+
+ toLoop :: Text -> [Text] -> AST -> AST
+ toLoop ident allArgs js =
+ Block rootSS $
+ map (\arg -> VariableIntroduction rootSS arg (Just (Var rootSS (copyVar arg)))) allArgs ++
+ [ VariableIntroduction rootSS tcoDone (Just (BooleanLiteral rootSS False))
+ , VariableIntroduction rootSS tcoResult Nothing
+ ] ++
+ map (\arg ->
+ VariableIntroduction rootSS (tcoVar arg) Nothing) allArgs ++
+ [ Function rootSS (Just tcoLoop) allArgs (Block rootSS [loopify js])
+ , While rootSS (Unary rootSS Not (Var rootSS tcoDone))
+ (Block rootSS
+ (Assignment rootSS (Var rootSS tcoResult) (App rootSS (Var rootSS tcoLoop) (map (Var rootSS) allArgs))
+ : map (\arg ->
+ Assignment rootSS (Var rootSS arg) (Var rootSS (tcoVar arg))) allArgs))
+ , Return rootSS (Var rootSS tcoResult)
+ ]
+ where
+ rootSS = Nothing
+
+ loopify :: AST -> AST
+ loopify (Return ss ret)
+ | isSelfCall ident ret =
+ let
+ allArgumentValues = concat $ collectArgs [] ret
+ in
+ Block ss $
+ zipWith (\val arg ->
+ Assignment ss (Var ss (tcoVar arg)) val) allArgumentValues allArgs
+ ++ [ ReturnNoResult ss ]
+ | otherwise = Block ss [ markDone ss, Return ss ret ]
+ loopify (ReturnNoResult ss) = Block ss [ markDone ss, ReturnNoResult ss ]
+ loopify (While ss cond body) = While ss cond (loopify body)
+ loopify (For ss i js1 js2 body) = For ss i js1 js2 (loopify body)
+ loopify (ForIn ss i js1 body) = ForIn ss i js1 (loopify body)
+ loopify (IfElse ss cond body el) = IfElse ss cond (loopify body) (fmap loopify el)
+ loopify (Block ss body) = Block ss (map loopify body)
+ loopify other = other
+
+ markDone :: Maybe SourceSpan -> AST
+ markDone ss = Assignment ss (Var ss tcoDone) (BooleanLiteral ss True)
+
+ collectArgs :: [[AST]] -> AST -> [[AST]]
+ collectArgs acc (App _ fn args') = collectArgs (args' : acc) fn
+ collectArgs acc _ = acc
+
+ isSelfCall :: Text -> AST -> Bool
+ isSelfCall ident (App _ (Var _ ident') _) = ident == ident'
+ isSelfCall ident (App _ fn _) = isSelfCall ident fn
+ isSelfCall _ _ = False
diff --git a/src/Language/PureScript/CoreImp/Optimizer/Unused.hs b/src/Language/PureScript/CoreImp/Optimizer/Unused.hs
new file mode 100644
index 0000000..ff05c64
--- /dev/null
+++ b/src/Language/PureScript/CoreImp/Optimizer/Unused.hs
@@ -0,0 +1,34 @@
+-- | Removes unused variables
+module Language.PureScript.CoreImp.Optimizer.Unused
+ ( removeCodeAfterReturnStatements
+ , removeUnusedArg
+ , removeUndefinedApp
+ ) where
+
+import Prelude.Compat
+
+import Language.PureScript.CoreImp.AST
+import Language.PureScript.CoreImp.Optimizer.Common
+import qualified Language.PureScript.Constants as C
+
+removeCodeAfterReturnStatements :: AST -> AST
+removeCodeAfterReturnStatements = everywhere (removeFromBlock go)
+ where
+ go :: [AST] -> [AST]
+ go jss | not (any isReturn jss) = jss
+ | otherwise = let (body, ret : _) = break isReturn jss in body ++ [ret]
+ isReturn (Return _ _) = True
+ isReturn (ReturnNoResult _) = True
+ isReturn _ = False
+
+removeUnusedArg :: AST -> AST
+removeUnusedArg = everywhere convert
+ where
+ convert (Function ss name [arg] body) | arg == C.__unused = Function ss name [] body
+ convert js = js
+
+removeUndefinedApp :: AST -> AST
+removeUndefinedApp = everywhere convert
+ where
+ convert (App ss fn [Var _ arg]) | arg == C.undefined = App ss fn []
+ convert js = js
diff --git a/src/Language/PureScript/Docs/AsHtml.hs b/src/Language/PureScript/Docs/AsHtml.hs
index dd311e0..e99c5b6 100644
--- a/src/Language/PureScript/Docs/AsHtml.hs
+++ b/src/Language/PureScript/Docs/AsHtml.hs
@@ -55,7 +55,7 @@ data HtmlRenderContext = HtmlRenderContext
{ currentModuleName :: P.ModuleName
, buildDocLink :: Namespace -> Text -> ContainingModule -> Maybe DocLink
, renderDocLink :: DocLink -> Text
- , renderSourceLink :: P.SourceSpan -> Text
+ , renderSourceLink :: P.SourceSpan -> Maybe Text
}
-- |
@@ -65,7 +65,7 @@ nullRenderContext mn = HtmlRenderContext
{ currentModuleName = mn
, buildDocLink = const (const (const Nothing))
, renderDocLink = const ""
- , renderSourceLink = const ""
+ , renderSourceLink = const Nothing
}
packageAsHtml :: (P.ModuleName -> HtmlRenderContext) -> Package a -> HtmlOutput Html
@@ -155,8 +155,11 @@ declAsHtml r d@Declaration{..} = do
where
linkToSource :: HtmlRenderContext -> P.SourceSpan -> Html
linkToSource ctx srcspan =
- H.span ! A.class_ "decl__source" $
- a ! A.href (v (renderSourceLink ctx srcspan)) $ text "Source"
+ maybe (return ()) go (renderSourceLink ctx srcspan)
+ where
+ go href =
+ H.span ! A.class_ "decl__source" $
+ a ! A.href (v href) $ text "Source"
renderChildren :: HtmlRenderContext -> [ChildDeclaration] -> Html
renderChildren _ [] = return ()
diff --git a/src/Language/PureScript/Docs/Convert/ReExports.hs b/src/Language/PureScript/Docs/Convert/ReExports.hs
index 5946020..481fc60 100644
--- a/src/Language/PureScript/Docs/Convert/ReExports.hs
+++ b/src/Language/PureScript/Docs/Convert/ReExports.hs
@@ -455,7 +455,7 @@ handleEnv TypeClassEnv{..} =
++ T.unpack cdeclTitle)
addConstraint constraint =
- P.quantify . P.moveQuantifiersToFront . P.ConstrainedType [constraint]
+ P.quantify . P.moveQuantifiersToFront . P.ConstrainedType constraint
splitMap :: Map k (v1, v2) -> (Map k v1, Map k v2)
splitMap = fmap fst &&& fmap snd
diff --git a/src/Language/PureScript/Docs/Convert/Single.hs b/src/Language/PureScript/Docs/Convert/Single.hs
index 9e07126..84b0b62 100644
--- a/src/Language/PureScript/Docs/Convert/Single.hs
+++ b/src/Language/PureScript/Docs/Convert/Single.hs
@@ -99,7 +99,7 @@ basicDeclaration :: Text -> DeclarationInfo -> Maybe IntermediateDeclaration
basicDeclaration title info = Just $ Right $ mkDeclaration title info
convertDeclaration :: P.Declaration -> Text -> Maybe IntermediateDeclaration
-convertDeclaration (P.ValueDeclaration _ _ _ (Right (P.TypedValue _ _ ty))) title =
+convertDeclaration (P.ValueDeclaration _ _ _ [P.MkUnguarded (P.TypedValue _ _ ty)]) title =
basicDeclaration title (ValueDeclaration ty)
convertDeclaration P.ValueDeclaration{} title =
-- If no explicit type declaration was provided, insert a wildcard, so that
diff --git a/src/Language/PureScript/Docs/Prim.hs b/src/Language/PureScript/Docs/Prim.hs
index ba4d0e6..c2070b1 100644
--- a/src/Language/PureScript/Docs/Prim.hs
+++ b/src/Language/PureScript/Docs/Prim.hs
@@ -25,10 +25,10 @@ primDocsModule = Module
, partial
, fail
, warn
+ , union
, typeConcat
, typeString
, kindType
- , kindEffect
, kindSymbol
]
, modReExports = []
@@ -95,11 +95,6 @@ kindType = primKind "Type" $ T.unlines
, "For example the type `Boolean` has kind `Type`; denoted by `Boolean :: Type`."
]
-kindEffect :: Declaration
-kindEffect = primKind "Effect" $ T.unlines
- [ "`Effect` (also known as `!`) is the kind of all effect types."
- ]
-
kindSymbol :: Declaration
kindSymbol = primKind "Symbol" $ T.unlines
[ "`Symbol` is the kind of type-level strings."
@@ -234,6 +229,14 @@ warn = primClass "Warn" $ T.unlines
, "[the Custom Type Errors guide](https://github.com/purescript/documentation/blob/master/guides/Custom-Type-Errors.md)."
]
+union :: Declaration
+union = primClass "Union" $ T.unlines
+ [ "The Union type class is used to compute the union of two rows of types"
+ , "(left-biased, including duplicates)."
+ , ""
+ , "The third type argument represents the union of the first two."
+ ]
+
typeConcat :: Declaration
typeConcat = primType "TypeConcat" $ T.unlines
[ "The TypeConcat type constructor concatenates two Symbols in a custom type"
diff --git a/src/Language/PureScript/Docs/RenderedCode/RenderType.hs b/src/Language/PureScript/Docs/RenderedCode/RenderType.hs
index 0a697b8..e8dae46 100644
--- a/src/Language/PureScript/Docs/RenderedCode/RenderType.hs
+++ b/src/Language/PureScript/Docs/RenderedCode/RenderType.hs
@@ -62,17 +62,13 @@ renderConstraint (Constraint pn tys _) =
let instApp = foldl TypeApp (TypeConstructor (fmap coerceProperName pn)) tys
in renderType instApp
-renderConstraints :: [Constraint] -> RenderedCode -> RenderedCode
-renderConstraints deps ty =
+renderConstraints :: Constraint -> RenderedCode -> RenderedCode
+renderConstraints con ty =
mintersperse sp
- [ if length deps == 1
- then constraints
- else syntax "(" <> constraints <> syntax ")"
+ [ renderConstraint con
, syntax "=>"
, ty
]
- where
- constraints = mintersperse (syntax "," <> sp) (map renderConstraint deps)
-- |
-- Render code representing a Row
@@ -115,10 +111,10 @@ kinded = mkPattern match
match (KindedType t k) = Just (k, t)
match _ = Nothing
-constrained :: Pattern () Type ([Constraint], Type)
+constrained :: Pattern () Type (Constraint, Type)
constrained = mkPattern match
where
- match (ConstrainedType deps ty) = Just (deps, ty)
+ match (ConstrainedType con ty) = Just (con, ty)
match _ = Nothing
explicitParens :: Pattern () Type ((), Type)
diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs
index e69eb87..8190415 100644
--- a/src/Language/PureScript/Docs/Types.hs
+++ b/src/Language/PureScript/Docs/Types.hs
@@ -63,6 +63,8 @@ data NotYetKnown = NotYetKnown
type UploadedPackage = Package NotYetKnown
type VerifiedPackage = Package GithubUser
+type ManifestError = BowerError
+
verifyPackage :: GithubUser -> UploadedPackage -> VerifiedPackage
verifyPackage verifiedUser Package{..} =
Package pkgMeta
@@ -327,7 +329,7 @@ data PackageError
= CompilerTooOld Version Version
-- ^ Minimum allowable version for generating data with the current
-- parser, and actual version used.
- | ErrorInPackageMeta BowerError
+ | ErrorInPackageMeta ManifestError
| InvalidVersion
| InvalidDeclarationType Text
| InvalidChildDeclarationType Text
@@ -564,7 +566,7 @@ asReExport =
pOr :: Parse e a -> Parse e a -> Parse e a
p `pOr` q = catchError p (const q)
-asInPackage :: Parse BowerError a -> Parse BowerError (InPackage a)
+asInPackage :: Parse ManifestError a -> Parse ManifestError (InPackage a)
asInPackage inner =
build <$> key "package" (perhaps (withText parsePackageName))
<*> key "item" inner
@@ -684,7 +686,7 @@ asModuleMap =
-- This is here to preserve backwards compatibility with compilers which used
-- to generate a 'bookmarks' field in the JSON (i.e. up to 0.10.5). We should
-- remove this after the next breaking change to the JSON.
-bookmarksAsModuleMap :: Parse BowerError (Map P.ModuleName PackageName)
+bookmarksAsModuleMap :: Parse ManifestError (Map P.ModuleName PackageName)
bookmarksAsModuleMap =
convert <$>
eachInArray (asInPackage (nth 0 (P.moduleNameFromString <$> asText)))
diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs
index 86b3fec..1366a7b 100644
--- a/src/Language/PureScript/Environment.hs
+++ b/src/Language/PureScript/Environment.hs
@@ -1,26 +1,24 @@
-{-# LANGUAGE TemplateHaskell #-}
-
module Language.PureScript.Environment where
-import Prelude.Compat
+import Prelude.Compat
+import Protolude (ordNub)
-import Data.Aeson.TH
+import Data.Aeson ((.=), (.:))
import qualified Data.Aeson as A
import qualified Data.Map as M
import qualified Data.Set as S
-import Data.Maybe (fromMaybe, mapMaybe)
-import Data.Text (Text)
+import Data.Maybe (fromMaybe, mapMaybe)
+import Data.Text (Text)
import qualified Data.Text as T
-import Data.List (nub)
-import Data.Tree (Tree, rootLabel)
+import Data.Tree (Tree, rootLabel)
import qualified Data.Graph as G
-import Data.Foldable (toList)
+import Data.Foldable (toList)
-import Language.PureScript.Crash
-import Language.PureScript.Kinds
-import Language.PureScript.Names
-import Language.PureScript.TypeClassDictionaries
-import Language.PureScript.Types
+import Language.PureScript.Crash
+import Language.PureScript.Kinds
+import Language.PureScript.Names
+import Language.PureScript.TypeClassDictionaries
+import Language.PureScript.Types
import qualified Language.PureScript.Constants as C
-- | The @Environment@ defines all values and types which are currently in scope:
@@ -72,14 +70,23 @@ data FunctionalDependency = FunctionalDependency
-- ^ the determined type arguments
} deriving Show
--- |
--- The initial environment with no values and only the default javascript types defined
---
+instance A.FromJSON FunctionalDependency where
+ parseJSON = A.withObject "FunctionalDependency" $ \o ->
+ FunctionalDependency
+ <$> o .: "determiners"
+ <*> o .: "determined"
+
+instance A.ToJSON FunctionalDependency where
+ toJSON FunctionalDependency{..} =
+ A.object [ "determiners" .= fdDeterminers
+ , "determined" .= fdDetermined
+ ]
+
+-- | The initial environment with no values and only the default javascript types defined
initEnvironment :: Environment
initEnvironment = Environment M.empty primTypes M.empty M.empty M.empty primClasses primKinds
--- |
--- A constructor for TypeClassData that computes which type class arguments are fully determined
+-- | A constructor for TypeClassData that computes which type class arguments are fully determined
-- and argument covering sets.
-- Fully determined means that this argument cannot be used when selecting a type class instance.
-- A covering set is a minimal collection of arguments that can be used to find an instance and
@@ -119,7 +126,7 @@ makeTypeClassData args m s deps = TypeClassData args m s deps determinedArgs cov
(src, fdDetermined fd) : map (, []) (fdDetermined fd)
-- build a graph of which arguments determine other arguments
- (depGraph, fromVertex, fromKey) = G.graphFromEdges ((\(n, v) -> (n, n, nub v)) <$> M.toList contributingDeps)
+ (depGraph, fromVertex, fromKey) = G.graphFromEdges ((\(n, v) -> (n, n, ordNub v)) <$> M.toList contributingDeps)
-- do there exist any arguments that contribute to `arg` that `arg` doesn't contribute to
isFunDepDetermined :: Int -> Bool
@@ -151,77 +158,69 @@ makeTypeClassData args m s deps = TypeClassData args m s deps determinedArgs cov
coveringSets = let funDepSets = sequence (mapMaybe sccNonDetermined (G.scc depGraph))
in S.fromList (S.fromList <$> funDepSets)
--- |
--- The visibility of a name in scope
---
+-- | The visibility of a name in scope
data NameVisibility
- -- |
- -- The name is defined in the current binding group, but is not visible
- --
= Undefined
- -- |
- -- The name is defined in the another binding group, or has been made visible by a function binder
- --
- | Defined deriving (Show, Eq)
+ -- ^ The name is defined in the current binding group, but is not visible
+ | Defined
+ -- ^ The name is defined in the another binding group, or has been made visible by a function binder
+ deriving (Show, Eq)
--- |
--- A flag for whether a name is for an private or public value - only public values will be
+-- | A flag for whether a name is for an private or public value - only public values will be
-- included in a generated externs file.
---
data NameKind
- -- |
- -- A private value introduced as an artifact of code generation (class instances, class member
- -- accessors, etc.)
- --
= Private
- -- |
- -- A public value for a module member or foreing import declaration
- --
+ -- ^ A private value introduced as an artifact of code generation (class instances, class member
+ -- accessors, etc.)
| Public
- -- |
- -- A name for member introduced by foreign import
- --
+ -- ^ A public value for a module member or foreing import declaration
| External
+ -- ^ A name for member introduced by foreign import
deriving (Show, Eq)
--- |
--- The kinds of a type
---
+-- | The kinds of a type
data TypeKind
- -- |
- -- Data type
- --
= DataType [(Text, Maybe Kind)] [(ProperName 'ConstructorName, [Type])]
- -- |
- -- Type synonym
- --
+ -- ^ Data type
| TypeSynonym
- -- |
- -- Foreign data
- --
+ -- ^ Type synonym
| ExternData
- -- |
- -- A local type variable
- --
+ -- ^ Foreign data
| LocalTypeVariable
- -- |
- -- A scoped type variable
- --
+ -- ^ A local type variable
| ScopedTypeVar
+ -- ^ A scoped type variable
deriving (Show, Eq)
--- |
--- The type ('data' or 'newtype') of a data type declaration
---
+instance A.ToJSON TypeKind where
+ toJSON (DataType args ctors) =
+ A.object [ T.pack "DataType" .= A.object ["args" .= args, "ctors" .= ctors] ]
+ toJSON TypeSynonym = A.toJSON (T.pack "TypeSynonym")
+ toJSON ExternData = A.toJSON (T.pack "ExternData")
+ toJSON LocalTypeVariable = A.toJSON (T.pack "LocalTypeVariable")
+ toJSON ScopedTypeVar = A.toJSON (T.pack "ScopedTypeVar")
+
+instance A.FromJSON TypeKind where
+ parseJSON (A.Object o) = do
+ args <- o .: "DataType"
+ A.withObject "args" (\o1 ->
+ DataType <$> o1 .: "args"
+ <*> o1 .: "ctors") args
+ parseJSON (A.String s) =
+ case s of
+ "TypeSynonym" -> pure TypeSynonym
+ "ExternData" -> pure ExternData
+ "LocalTypeVariable" -> pure LocalTypeVariable
+ "ScopedTypeVar" -> pure ScopedTypeVar
+ _ -> fail "Unknown TypeKind"
+ parseJSON _ = fail "Invalid TypeKind"
+
+-- | The type ('data' or 'newtype') of a data type declaration
data DataDeclType
- -- |
- -- A standard data constructor
- --
= Data
- -- |
- -- A newtype constructor
- --
+ -- ^ A standard data constructor
| Newtype
+ -- ^ A newtype constructor
deriving (Show, Eq, Ord)
showDataDeclType :: DataDeclType -> Text
@@ -238,90 +237,61 @@ instance A.FromJSON DataDeclType where
"newtype" -> return Newtype
other -> fail $ "invalid type: '" ++ T.unpack other ++ "'"
--- |
--- Construct a ProperName in the Prim module
---
+-- | Construct a ProperName in the Prim module
primName :: Text -> Qualified (ProperName a)
primName = Qualified (Just $ ModuleName [ProperName C.prim]) . ProperName
primKind :: Text -> Kind
primKind = NamedKind . primName
--- |
--- Kinds in prim
---
+-- | Kind of ground types
kindType :: Kind
kindType = primKind C.typ
-kindEffect :: Kind
-kindEffect = primKind C.effect
-
kindSymbol :: Kind
kindSymbol = primKind C.symbol
--- |
--- Construct a type in the Prim module
---
+-- | Construct a type in the Prim module
primTy :: Text -> Type
primTy = TypeConstructor . primName
--- |
--- Type constructor for functions
---
+-- | Type constructor for functions
tyFunction :: Type
tyFunction = primTy "Function"
--- |
--- Type constructor for strings
---
+-- | Type constructor for strings
tyString :: Type
tyString = primTy "String"
--- |
--- Type constructor for strings
---
+-- | Type constructor for strings
tyChar :: Type
tyChar = primTy "Char"
--- |
--- Type constructor for numbers
---
+-- | Type constructor for numbers
tyNumber :: Type
tyNumber = primTy "Number"
--- |
--- Type constructor for integers
---
+-- | Type constructor for integers
tyInt :: Type
tyInt = primTy "Int"
--- |
--- Type constructor for booleans
---
+-- | Type constructor for booleans
tyBoolean :: Type
tyBoolean = primTy "Boolean"
--- |
--- Type constructor for arrays
---
+-- | Type constructor for arrays
tyArray :: Type
tyArray = primTy "Array"
--- |
--- Type constructor for records
---
+-- | Type constructor for records
tyRecord :: Type
tyRecord = primTy "Record"
--- |
--- Check whether a type is a record
---
+-- | Check whether a type is a record
isObject :: Type -> Bool
isObject = isTypeOrApplied tyRecord
--- |
--- Check whether a type is a function
---
+-- | Check whether a type is a function
isFunction :: Type -> Bool
isFunction = isTypeOrApplied tyFunction
@@ -329,27 +299,21 @@ isTypeOrApplied :: Type -> Type -> Bool
isTypeOrApplied t1 (TypeApp t2 _) = t1 == t2
isTypeOrApplied t1 t2 = t1 == t2
--- |
--- Smart constructor for function types
---
+-- | Smart constructor for function types
function :: Type -> Type -> Type
function t1 = TypeApp (TypeApp tyFunction t1)
--- |
--- The primitive kinds
+-- | The primitive kinds
primKinds :: S.Set (Qualified (ProperName 'KindName))
primKinds =
S.fromList
[ primName C.typ
- , primName C.effect
, primName C.symbol
]
--- |
--- The primitive types in the external javascript environment with their
+-- | The primitive types in the external javascript environment with their
-- associated kinds. There are also pseudo `Fail`, `Warn`, and `Partial` types
-- that correspond to the classes with the same names.
---
primTypes :: M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind)
primTypes =
M.fromList
@@ -362,46 +326,48 @@ primTypes =
, (primName "Int", (kindType, ExternData))
, (primName "Boolean", (kindType, ExternData))
, (primName "Partial", (kindType, ExternData))
+ , (primName "Union", (FunKind (Row kindType) (FunKind (Row kindType) (FunKind (Row kindType) kindType)), ExternData))
, (primName "Fail", (FunKind kindSymbol kindType, ExternData))
, (primName "Warn", (FunKind kindSymbol kindType, ExternData))
, (primName "TypeString", (FunKind kindType kindSymbol, ExternData))
, (primName "TypeConcat", (FunKind kindSymbol (FunKind kindSymbol kindSymbol), ExternData))
]
--- |
--- The primitive class map. This just contains the `Fail`, `Warn`, and `Partial`
+-- | The primitive class map. This just contains the `Fail`, `Warn`, and `Partial`
-- classes. `Partial` is used as a kind of magic constraint for partial
-- functions. `Fail` is used for user-defined type errors. `Warn` for
-- user-defined warnings.
---
primClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData
primClasses =
M.fromList
[ (primName "Partial", (makeTypeClassData [] [] [] []))
+ -- class Fail (message :: Symbol)
, (primName "Fail", (makeTypeClassData [("message", Just kindSymbol)] [] [] []))
+ -- class Warn (message :: Symbol)
, (primName "Warn", (makeTypeClassData [("message", Just kindSymbol)] [] [] []))
+ -- class Union (l :: # Type) (r :: # Type) (u :: # Type) | l r -> u, r u -> l, u l -> r
+ , (primName "Union", (makeTypeClassData
+ [ ("l", Just (Row kindType))
+ , ("r", Just (Row kindType))
+ , ("u", Just (Row kindType))
+ ] [] []
+ [ FunctionalDependency [0, 1] [2]
+ , FunctionalDependency [1, 2] [0]
+ , FunctionalDependency [2, 0] [1]
+ ]))
]
--- |
--- Finds information about data constructors from the current environment.
---
+-- | Finds information about data constructors from the current environment.
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.
---
+-- | Checks whether a data constructor is for a newtype.
isNewtypeConstructor :: Environment -> Qualified (ProperName 'ConstructorName) -> Bool
isNewtypeConstructor e ctor = case lookupConstructor e ctor of
(Newtype, _, _, _) -> True
(Data, _, _, _) -> False
--- |
--- Finds information about values from the current environment.
---
+-- | Finds information about values from the current environment.
lookupValue :: Environment -> Qualified Ident -> Maybe (Type, NameKind, NameVisibility)
lookupValue env ident = ident `M.lookup` names env
-
-$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''TypeKind)
-$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''FunctionalDependency)
diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs
index 11b9507..d0ca60d 100644
--- a/src/Language/PureScript/Errors.hs
+++ b/src/Language/PureScript/Errors.hs
@@ -7,6 +7,7 @@ module Language.PureScript.Errors
) where
import Prelude.Compat
+import Protolude (ordNub)
import Control.Arrow ((&&&))
import Control.Monad
@@ -14,10 +15,10 @@ import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.Trans.State.Lazy
import Control.Monad.Writer
import Data.Char (isSpace)
-import Data.Either (lefts, rights)
+import Data.Either (partitionEithers)
import Data.Foldable (fold)
import Data.Functor.Identity (Identity(..))
-import Data.List (transpose, nub, nubBy, sortBy, partition)
+import Data.List (transpose, nubBy, sortBy, partition, dropWhileEnd)
import Data.Maybe (maybeToList, fromMaybe, mapMaybe)
import Data.Ord (comparing)
import Data.String (fromString)
@@ -122,6 +123,8 @@ errorCode em = case unwrapErrorMessage em of
PossiblyInfiniteInstance{} -> "PossiblyInfiniteInstance"
CannotDerive{} -> "CannotDerive"
InvalidNewtypeInstance{} -> "InvalidNewtypeInstance"
+ InvalidDerivedInstance{} -> "InvalidDerivedInstance"
+ ExpectedTypeConstructor{} -> "ExpectedTypeConstructor"
CannotFindDerivingType{} -> "CannotFindDerivingType"
DuplicateLabel{} -> "DuplicateLabel"
DuplicateValueDeclaration{} -> "DuplicateValueDeclaration"
@@ -171,6 +174,7 @@ errorCode em = case unwrapErrorMessage em of
CannotUseBindWithDo{} -> "CannotUseBindWithDo"
ClassInstanceArityMismatch{} -> "ClassInstanceArityMismatch"
UserDefinedWarning{} -> "UserDefinedWarning"
+ UnusableDeclaration{} -> "UnusableDeclaration"
-- | A stack trace for an error
newtype MultipleErrors = MultipleErrors
@@ -260,10 +264,12 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse
gSimple (PossiblyInfiniteInstance cl ts) = PossiblyInfiniteInstance cl <$> traverse f ts
gSimple (CannotDerive cl ts) = CannotDerive cl <$> traverse f ts
gSimple (InvalidNewtypeInstance cl ts) = InvalidNewtypeInstance cl <$> traverse f ts
+ gSimple (InvalidDerivedInstance cl ts n) = InvalidDerivedInstance cl <$> traverse f ts <*> pure n
+ gSimple (ExpectedTypeConstructor cl ts ty) = ExpectedTypeConstructor cl <$> traverse f ts <*> f ty
gSimple (ExpectedType ty k) = ExpectedType <$> f ty <*> pure k
gSimple (OrphanInstance nm cl ts) = OrphanInstance nm cl <$> traverse f ts
gSimple (WildcardInferredType ty ctx) = WildcardInferredType <$> f ty <*> traverse (sndM f) ctx
- gSimple (HoleInferredType name ty ctx env) = HoleInferredType name <$> f ty <*> traverse (sndM f) ctx <*> gTypeSearch env
+ gSimple (HoleInferredType name ty ctx env) = HoleInferredType name <$> f ty <*> traverse (sndM f) ctx <*> onTypeSearchTypesM f env
gSimple (MissingTypeDeclaration nm ty) = MissingTypeDeclaration nm <$> f ty
gSimple (CannotGeneralizeRecursiveFunction nm ty) = CannotGeneralizeRecursiveFunction nm <$> f ty
gSimple other = pure other
@@ -277,9 +283,6 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse
gHint (ErrorSolvingConstraint con) = ErrorSolvingConstraint <$> overConstraintArgs (traverse f) con
gHint other = pure other
- gTypeSearch (TSBefore env) = pure (TSBefore env)
- gTypeSearch (TSAfter result) = TSAfter <$> traverse (traverse f) result
-
errorDocUri :: ErrorMessage -> Text
errorDocUri e = "https://github.com/purescript/documentation/blob/master/errors/" <> errorCode e <> ".md"
@@ -490,8 +493,8 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS
line $ "The type declaration for " <> markCode (showIdent nm) <> " should be followed by its definition."
renderSimpleErrorMessage (RedefinedIdent name) =
line $ "The value " <> markCode (showIdent name) <> " has been defined multiple times"
- renderSimpleErrorMessage (UnknownName name@(Qualified Nothing (IdentName (Ident "bind")))) =
- line $ "Unknown " <> printName name <> ". You're probably using do-notation, which the compiler replaces with calls to the " <> markCode "bind" <> " function. Please import " <> markCode "bind" <> " from module " <> markCode "Prelude"
+ renderSimpleErrorMessage (UnknownName name@(Qualified Nothing (IdentName (Ident i)))) | i `elem` [ C.bind, C.discard ] =
+ line $ "Unknown " <> printName name <> ". You're probably using do-notation, which the compiler replaces with calls to the " <> markCode i <> " function. Please import " <> markCode i <> " from module " <> markCode "Prelude"
renderSimpleErrorMessage (UnknownName name) =
line $ "Unknown " <> printName name
renderSimpleErrorMessage (UnknownImport mn name) =
@@ -544,11 +547,16 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS
paras [ line $ "Type synonym " <> markCode (showQualified runProperName name) <> " is partially applied."
, line "Type synonyms must be applied to all of their type arguments."
]
- renderSimpleErrorMessage (EscapedSkolem binding) =
- paras $ [ line "A type variable has escaped its scope." ]
- <> foldMap (\expr -> [ line "Relevant expression: "
- , markCodeBox $ indent $ prettyPrintValue valueDepth expr
- ]) binding
+ renderSimpleErrorMessage (EscapedSkolem name Nothing ty) =
+ paras [ line $ "The type variable " <> markCode name <> " has escaped its scope, appearing in the type"
+ , markCodeBox $ indent $ typeAsBox ty
+ ]
+ renderSimpleErrorMessage (EscapedSkolem name (Just srcSpan) ty) =
+ paras [ line $ "The type variable " <> markCode name <> ", bound at"
+ , indent $ line $ displaySourceSpan srcSpan
+ , line "has escaped its scope, appearing in the type"
+ , markCodeBox $ indent $ typeAsBox ty
+ ]
renderSimpleErrorMessage (TypesDoNotUnify u1 u2)
= let (sorted1, sorted2) = sortRows u1 u2
@@ -611,13 +619,19 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS
_
(Just (PartialConstraintData 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"
+ , line "The following additional cases are required to cover all inputs:"
, indent $ paras $
Box.hsep 1 Box.left
(map (paras . map (line . markCode)) (transpose bs))
: [line "..." | not b]
, line "Alternatively, add a Partial constraint to the type of the enclosing value."
]
+ renderSimpleErrorMessage (NoInstanceFound (Constraint C.Discard [ty] _)) =
+ paras [ line "A result of type"
+ , markCodeBox $ indent $ typeAsBox ty
+ , line "was implicitly discarded in a do notation block."
+ , line ("You can use " <> markCode "_ <- ..." <> " to explicitly discard the result.")
+ ]
renderSimpleErrorMessage (NoInstanceFound (Constraint nm ts _)) =
paras [ line "No type class instance was found for"
, markCodeBox $ indent $ Box.hsep 1 Box.left
@@ -653,6 +667,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS
[ line (showQualified runProperName nm)
, Box.vcat Box.left (map typeAtomAsBox ts)
]
+ , line "since instances of this type class are not derivable."
]
renderSimpleErrorMessage (InvalidNewtypeInstance nm ts) =
paras [ line "Cannot derive newtype instance for"
@@ -662,6 +677,32 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS
]
, line "Make sure this is a newtype."
]
+ renderSimpleErrorMessage (InvalidDerivedInstance nm ts argCount) =
+ paras [ line "Cannot derive the type class instance"
+ , markCodeBox $ indent $ Box.hsep 1 Box.left
+ [ line (showQualified runProperName nm)
+ , Box.vcat Box.left (map typeAtomAsBox ts)
+ ]
+ , line $ fold $
+ [ "because the "
+ , markCode (showQualified runProperName nm)
+ , " type class has "
+ , T.pack (show argCount)
+ , " type "
+ , if argCount == 1 then "argument" else "arguments"
+ , ", but the declaration specifies " <> T.pack (show (length ts)) <> "."
+ ]
+ ]
+ renderSimpleErrorMessage (ExpectedTypeConstructor nm ts ty) =
+ paras [ line "Cannot derive the type class instance"
+ , markCodeBox $ indent $ Box.hsep 1 Box.left
+ [ line (showQualified runProperName nm)
+ , Box.vcat Box.left (map typeAtomAsBox ts)
+ ]
+ , "because the type"
+ , markCodeBox $ indent $ typeAsBox ty
+ , line "is not of the required form T a_1 ... a_n, where T is a type constructor defined in the same module."
+ ]
renderSimpleErrorMessage (CannotFindDerivingType nm) =
line $ "Cannot derive a type class instance, because the type declaration for " <> markCode (runProperName nm) <> " could not be found."
renderSimpleErrorMessage (DuplicateLabel l expr) =
@@ -735,7 +776,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS
renderSimpleErrorMessage (ShadowedTypeVar tv) =
line $ "Type variable " <> markCode tv <> " was shadowed."
renderSimpleErrorMessage (UnusedTypeVar tv) =
- line $ "Type variable " <> markCode tv <> " was declared but not used."
+ line $ "Type variable " <> markCode tv <> " is ambiguous, since it is unused in the polymorphic type which introduces it."
renderSimpleErrorMessage (MisleadingEmptyTypeImport mn name) =
line $ "Importing type " <> markCode (runProperName name <> "(..)") <> " from " <> markCode (runModuleName mn) <> " is misleading as it has no exported data constructors."
renderSimpleErrorMessage (ImportHidingModule name) =
@@ -750,11 +791,11 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS
let
maxTSResults = 15
tsResult = case ts of
- (TSAfter idents) | not (null idents) ->
+ (TSAfter{tsAfterIdentifiers=idents}) | not (null idents) ->
let
formatTS (names, types) =
let
- idBoxes = Box.text . T.unpack . showQualified runIdent <$> names
+ idBoxes = Box.text . T.unpack . showQualified id <$> names
tyBoxes = (\t -> BoxHelpers.indented
(Box.text ":: " Box.<> typeAsBox t)) <$> types
longestId = maximum (map Box.cols idBoxes)
@@ -869,16 +910,18 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS
paras [ line $ "Expected a type wildcard (_) when deriving an instance for " <> markCode (runProperName tyName) <> "."
]
- renderSimpleErrorMessage CannotUseBindWithDo =
- paras [ line $ "The name " <> markCode "bind" <> " cannot be brought into scope in a do notation block, since do notation uses the same name."
+ renderSimpleErrorMessage (CannotUseBindWithDo name) =
+ paras [ line $ "The name " <> markCode (showIdent name) <> " cannot be brought into scope in a do notation block, since do notation uses the same name."
]
renderSimpleErrorMessage (ClassInstanceArityMismatch dictName className expected actual) =
paras [ line $ "The type class " <> markCode (showQualified runProperName className) <>
- " expects " <> T.pack (show expected) <> " argument(s)."
- , line $ "But the instance " <> markCode (showIdent dictName) <> " only provided " <>
- T.pack (show actual) <> "."
+ " expects " <> T.pack (show expected) <> " " <> argsMsg <> "."
+ , line $ "But the instance " <> markCode (showIdent dictName) <> mismatchMsg <> T.pack (show actual) <> "."
]
+ where
+ mismatchMsg = if actual > expected then " provided " else " only provided "
+ argsMsg = if expected > 1 then "arguments" else "argument"
renderSimpleErrorMessage (UserDefinedWarning msgTy) =
let msg = fromMaybe (typeAsBox msgTy) (toTypelevelString msgTy) in
@@ -886,6 +929,11 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS
, indent msg
]
+ renderSimpleErrorMessage (UnusableDeclaration ident) =
+ paras [ line $ "The declaration " <> markCode (showIdent ident) <> " is unusable."
+ , line $ "This happens when a constraint couldn't possibly have enough information to work out which instance is required."
+ ]
+
renderHint :: ErrorMessageHint -> Box.Box -> Box.Box
renderHint (ErrorUnifyingTypes t1 t2) detail =
paras [ detail
@@ -1242,7 +1290,7 @@ prettyPrintParseErrorMessages msgOr msgUnknown msgExpecting msgUnExpected msgEnd
separate _ [m] = m
separate sep (m:ms) = m ++ sep ++ separate sep ms
- clean = nub . filter (not . null)
+ clean = ordNub . filter (not . null)
-- | Indent to the right, and pad on top and bottom.
indent :: Box.Box -> Box.Box
@@ -1262,7 +1310,6 @@ renderBox = unlines
. lines
. Box.render
where
- dropWhileEnd p = reverse . dropWhile p . reverse
whiteSpace = all isSpace
toTypelevelString :: Type -> Maybe Box.Box
@@ -1278,7 +1325,7 @@ toTypelevelString t = (Box.text . decodeStringWithReplacement) <$> toTypelevelSt
-- | Rethrow an error with a more detailed error message in the case of failure
rethrow :: (MonadError e m) => (e -> e) -> m a -> m a
-rethrow f = flip catchError $ \e -> throwError (f e)
+rethrow f = flip catchError (throwError . f)
reifyErrors :: (MonadError e m) => m a -> m (Either e a)
reifyErrors ma = catchError (fmap Right ma) (return . Left)
@@ -1330,6 +1377,6 @@ parU xs f =
withError u = catchError (Right <$> u) (return . Left)
collectErrors :: [Either MultipleErrors b] -> m [b]
- collectErrors es = case lefts es of
- [] -> return $ rights es
- errs -> throwError $ fold errs
+ collectErrors es = case partitionEithers es of
+ ([], rs) -> return rs
+ (errs, _) -> throwError $ fold errs
diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs
index a75d094..7a72099 100644
--- a/src/Language/PureScript/Externs.hs
+++ b/src/Language/PureScript/Externs.hs
@@ -38,21 +38,22 @@ import Paths_purescript as Paths
-- | The data which will be serialized to an externs file
data ExternsFile = ExternsFile
- {
- -- | The externs version
- efVersion :: Text
- -- | Module name
+ { efVersion :: Text
+ -- ^ The externs version
, efModuleName :: ModuleName
- -- | List of module exports
+ -- ^ Module name
, efExports :: [DeclarationRef]
- -- | List of module imports
+ -- ^ List of module exports
, efImports :: [ExternsImport]
- -- | List of operators and their fixities
+ -- ^ List of module imports
, efFixities :: [ExternsFixity]
- -- | List of type operators and their fixities
+ -- ^ List of operators and their fixities
, efTypeFixities :: [ExternsTypeFixity]
- -- | List of type and value declaration
+ -- ^ List of type operators and their fixities
, efDeclarations :: [ExternsDeclaration]
+ -- ^ List of type and value declaration
+ , efSourceSpan :: SourceSpan
+ -- ^ Source span for error reporting
} deriving (Show)
-- | A module import in an externs file
@@ -165,7 +166,7 @@ applyExternsFileToEnvironment ExternsFile{..} = flip (foldl' applyDecl) efDeclar
-- | Generate an externs file for all declarations in a module
moduleToExternsFile :: Module -> Environment -> ExternsFile
moduleToExternsFile (Module _ _ _ _ Nothing) _ = internalError "moduleToExternsFile: module exports were not elaborated"
-moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..}
+moduleToExternsFile (Module ss _ mn ds (Just exps)) env = ExternsFile{..}
where
efVersion = T.pack (showVersion Paths.version)
efModuleName = mn
@@ -174,6 +175,7 @@ moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..}
efFixities = mapMaybe fixityDecl ds
efTypeFixities = mapMaybe typeFixityDecl ds
efDeclarations = concatMap toExternsDeclaration efExports
+ efSourceSpan = ss
fixityDecl :: Declaration -> Maybe ExternsFixity
fixityDecl (ValueFixityDeclaration (Fixity assoc prec) name op) =
diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs
index aaaccbd..020208e 100644
--- a/src/Language/PureScript/Ide.hs
+++ b/src/Language/PureScript/Ide.hs
@@ -67,7 +67,7 @@ handleCommand c = case c of
List AvailableModules ->
listAvailableModules
List (Imports fp) ->
- ImportList <$> getImportsForFile fp
+ ImportList <$> parseImportsFromFile fp
CaseSplit l b e wca t ->
caseSplit l b e wca t
AddClause l wca ->
diff --git a/src/Language/PureScript/Ide/Error.hs b/src/Language/PureScript/Ide/Error.hs
index 1be0f89..7fa4133 100644
--- a/src/Language/PureScript/Ide/Error.hs
+++ b/src/Language/PureScript/Ide/Error.hs
@@ -14,33 +14,62 @@
module Language.PureScript.Ide.Error
( IdeError(..)
+ , prettyPrintTypeSingleLine
) where
import Data.Aeson
+import qualified Data.Aeson.Types as Aeson
+import qualified Data.HashMap.Lazy as HM
+import qualified Data.Text as T
+import qualified Language.PureScript as P
import Language.PureScript.Errors.JSON
-import Language.PureScript.Ide.Types (ModuleIdent)
+import Language.PureScript.Ide.Types (ModuleIdent, Completion(..))
import Protolude
-import qualified Text.Parsec.Error as P
+import qualified Text.Parsec.Error as Parsec
data IdeError
= GeneralError Text
| NotFound Text
| ModuleNotFound ModuleIdent
| ModuleFileNotFound ModuleIdent
- | ParseError P.ParseError Text
- | RebuildError [JSONError]
- deriving (Show, Eq)
+ | ParseError Parsec.ParseError Text
+ | RebuildError P.MultipleErrors
+ deriving (Show)
instance ToJSON IdeError where
toJSON (RebuildError errs) = object
[ "resultType" .= ("error" :: Text)
- , "result" .= errs
+ , "result" .= encodeRebuildErrors errs
]
toJSON err = object
[ "resultType" .= ("error" :: Text)
, "result" .= textError err
]
+encodeRebuildErrors :: P.MultipleErrors -> Value
+encodeRebuildErrors = toJSON . map encodeRebuildError . P.runMultipleErrors
+ where
+ encodeRebuildError err = case err of
+ (P.ErrorMessage _
+ ((P.HoleInferredType name _ _
+ (P.TSAfter{tsAfterIdentifiers=idents, tsAfterRecordFields=fields})))) ->
+ insertTSCompletions name idents (fromMaybe [] fields) (toJSON (toJSONError False P.Error err))
+ _ ->
+ (toJSON . toJSONError False P.Error) err
+
+ insertTSCompletions name idents fields (Aeson.Object value) =
+ Aeson.Object
+ (HM.insert "pursIde"
+ (object [ "name" .= name
+ , "completions" .= (ordNub (map identCompletion idents ++ map fieldCompletion fields))
+ ]) value)
+ insertTSCompletions _ _ _ v = v
+
+ identCompletion (P.Qualified mn i, ty) =
+ Completion (maybe "" P.runModuleName mn) i (prettyPrintTypeSingleLine ty) (prettyPrintTypeSingleLine ty) Nothing Nothing
+ fieldCompletion (label, ty) =
+ Completion "" ("_." <> P.prettyPrintLabel label) (prettyPrintTypeSingleLine ty) (prettyPrintTypeSingleLine ty) Nothing Nothing
+
textError :: IdeError -> Text
textError (GeneralError msg) = msg
textError (NotFound ident) = "Symbol '" <> ident <> "' not found."
@@ -52,3 +81,6 @@ textError (ParseError parseError msg) = let escape = show
-- over the socket as a single line
in msg <> ": " <> escape parseError
textError (RebuildError err) = show err
+
+prettyPrintTypeSingleLine :: P.Type -> Text
+prettyPrintTypeSingleLine = T.unwords . map T.strip . T.lines . T.pack . P.prettyPrintTypeWithUnicode
diff --git a/src/Language/PureScript/Ide/Externs.hs b/src/Language/PureScript/Ide/Externs.hs
index 1ffe761..7797b61 100644
--- a/src/Language/PureScript/Ide/Externs.hs
+++ b/src/Language/PureScript/Ide/Externs.hs
@@ -144,9 +144,9 @@ annotateModule (defs, types) decls =
IdeDeclKind i ->
annotateKind (i ^. properNameT) (IdeDeclKind i)
where
- annotateFunction x = IdeDeclarationAnn (ann { annLocation = Map.lookup (IdeNSValue (P.runIdent x)) defs
- , annTypeAnnotation = Map.lookup x types
+ annotateFunction x = IdeDeclarationAnn (ann { _annLocation = Map.lookup (IdeNSValue (P.runIdent x)) defs
+ , _annTypeAnnotation = Map.lookup x types
})
- annotateValue x = IdeDeclarationAnn (ann {annLocation = Map.lookup (IdeNSValue x) defs})
- annotateType x = IdeDeclarationAnn (ann {annLocation = Map.lookup (IdeNSType x) defs})
- annotateKind x = IdeDeclarationAnn (ann {annLocation = Map.lookup (IdeNSKind x) defs})
+ annotateValue x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNSValue x) defs})
+ annotateType x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNSType x) defs})
+ annotateKind x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNSKind x) defs})
diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs
index 21158d8..ba18315 100644
--- a/src/Language/PureScript/Ide/Imports.hs
+++ b/src/Language/PureScript/Ide/Imports.hs
@@ -16,6 +16,7 @@ module Language.PureScript.Ide.Imports
( addImplicitImport
, addImportForIdentifier
, answerRequest
+ , parseImportsFromFile
-- for tests
, parseImport
, prettyPrintImportSection
@@ -29,7 +30,7 @@ module Language.PureScript.Ide.Imports
import Protolude
-import Control.Lens ((^.))
+import Control.Lens ((^.), (%~), ix)
import Data.List (findIndex, nubBy)
import qualified Data.Text as T
import qualified Language.PureScript as P
@@ -40,8 +41,9 @@ import Language.PureScript.Ide.State
import Language.PureScript.Ide.Types
import Language.PureScript.Ide.Util
import System.IO.UTF8 (writeUTF8FileT)
+import qualified Text.Parsec as Parsec
-data Import = Import P.ModuleName P.ImportDeclarationType (Maybe P.ModuleName)
+data Import = Import P.ModuleName P.ImportDeclarationType (Maybe P.ModuleName)
deriving (Eq, Show)
instance Ord Import where
@@ -65,86 +67,80 @@ compImport (Import n i q) (Import n' i' q')
| not (P.isExplicit i) && isNothing q' = GT
| otherwise = compare n n'
+-- | Reads a file and returns the parsed modulename as well as the parsed
+-- imports, while ignoring eventual parse errors that aren't relevant to the
+-- import section
+parseImportsFromFile
+ :: (MonadIO m, MonadError IdeError m)
+ => FilePath
+ -> m (P.ModuleName, [(P.ModuleName, P.ImportDeclarationType, Maybe P.ModuleName)])
+parseImportsFromFile file = do
+ (mn, _, imports, _) <- parseImportsFromFile' file
+ pure (mn, unwrapImport <$> imports)
+ where
+ unwrapImport (Import a b c) = (a, b, c)
+
-- | Reads a file and returns the (lines before the imports, the imports, the
-- lines after the imports)
-parseImportsFromFile :: (MonadIO m, MonadError IdeError m) =>
+parseImportsFromFile' :: (MonadIO m, MonadError IdeError m) =>
FilePath -> m (P.ModuleName, [Text], [Import], [Text])
-parseImportsFromFile fp = do
+parseImportsFromFile' fp = do
file <- ideReadFile fp
case sliceImportSection (T.lines file) of
Right res -> pure res
Left err -> throwError (GeneralError err)
-parseImportsWithModuleName :: [Text] -> Either Text (P.ModuleName, [Import])
-parseImportsWithModuleName ls = do
- (P.Module _ _ mn decls _) <- moduleParse ls
- pure (mn, concatMap mkImport (unwrapPositioned <$> decls))
+-- | @ImportParse@ holds the data we extract out of a partial parse of the
+-- sourcefile
+data ImportParse = ImportParse
+ { ipModuleName :: P.ModuleName
+ -- ^ the module name we parse
+ , ipStart :: P.SourcePos
+ -- ^ the beginning of the import section. If `import Prelude` was the first
+ -- import, this would point at `i`
+ , ipEnd :: P.SourcePos
+ -- ^ the end of the import section
+ , ipImports :: [Import]
+ -- ^ the extracted import declarations
+ }
+
+parseModuleHeader :: P.TokenParser ImportParse
+parseModuleHeader = do
+ _ <- P.readComments
+ (mn, _) <- P.parseModuleDeclaration
+ (ipStart, ipEnd, decls) <- P.withSourceSpan (\(P.SourceSpan _ start end) _ -> (start, end,))
+ (P.mark (Parsec.many (P.same *> P.parseImportDeclaration')))
+ pure (ImportParse mn ipStart ipEnd (map mkImport decls))
where
- mkImport (P.ImportDeclaration mn (P.Explicit refs) qual) =
- [Import mn (P.Explicit (unwrapPositionedRef <$> refs)) qual]
- mkImport (P.ImportDeclaration mn it qual) = [Import mn it qual]
- mkImport _ = []
+ mkImport (mn, (P.Explicit refs), qual) = Import mn (P.Explicit (unwrapPositionedRef <$> refs)) qual
+ mkImport (mn, it, qual) = Import mn it qual
sliceImportSection :: [Text] -> Either Text (P.ModuleName, [Text], [Import], [Text])
-sliceImportSection ts =
- case foldl step (ModuleHeader 0) (zip [0..] ts) of
- Res start end ->
- let
- (moduleHeader, (importSection, remainingFile)) =
- splitAt (succ (end - start)) `second` splitAt start ts
- in
- (\(mn, is) -> (mn, moduleHeader, is, remainingFile)) <$>
- parseImportsWithModuleName (moduleHeader <> importSection)
-
- -- If we don't find any imports, we insert a newline after the module
- -- declaration and begin a new importsection
- ModuleHeader ix ->
- let (moduleHeader, remainingFile) = splitAt (succ ix) ts
- in
- (\(mn, is) -> (mn, moduleHeader ++ [""], is, remainingFile)) <$>
- parseImportsWithModuleName moduleHeader
- _ -> Left "Failed to detect the import section"
-
-data ImportStateMachine = ModuleHeader Int | ImportSection Int Int | Res Int Int
-
--- | We start in the
---
--- * ModuleHeader state.
---
--- We skip every line we encounter, that doesn't start with "import". If we find
--- a line that starts with module we store that linenumber. Once we find a line
--- with "import" we store its linenumber as the start of the import section and
--- change into the
---
--- * ImportSection state
---
--- For any line that starts with import or whitespace(is thus indented) we
--- expand the end of the import section to that line and continue. If we
--- encounter a commented or empty line, we continue moving forward in the
--- ImportSection state but don't expand the import section end yet. This allows
--- us to exclude newlines or comments that directly follow the import section.
--- Once we encounter a line that is not a comment, newline, indentation or
--- import we switch into the
---
--- * Res state
---
--- , which just shortcuts to the end of the file and carries the detected import
--- section boundaries
-step :: ImportStateMachine -> (Int, Text) -> ImportStateMachine
-step (ModuleHeader mi) (ix, l)
- | T.isPrefixOf "module " l = ModuleHeader ix
- | T.isPrefixOf "import " l = ImportSection ix ix
- | otherwise = ModuleHeader mi
-step (ImportSection start lastImportLine) (ix, l)
- | any (`T.isPrefixOf` l) ["import", " "] = ImportSection start ix
- | T.isPrefixOf "--" l || l == "" = ImportSection start lastImportLine
- | otherwise = Res start lastImportLine
-step (Res start end) _ = Res start end
-
-moduleParse :: [Text] -> Either Text P.Module
-moduleParse t = first show $ do
- tokens <- P.lex "" (T.unlines t)
- P.runTokenParser "<psc-ide>" P.parseModule tokens
+sliceImportSection fileLines = first show $ do
+ tokens <- P.lexLenient "<psc-ide>" file
+ ImportParse{..} <- P.runTokenParser "<psc-ide>" parseModuleHeader tokens
+ pure ( ipModuleName
+ , sliceFile (P.SourcePos 1 1) (prevPos ipStart)
+ , ipImports
+ -- Not sure why I need to drop 1 here, but it makes the tests pass
+ , drop 1 (sliceFile (nextPos ipEnd) (P.SourcePos (length fileLines) (lineLength (length fileLines))))
+ )
+ where
+ prevPos (P.SourcePos l c)
+ | l == 1 && c == 1 = P.SourcePos l c
+ | c == 1 = P.SourcePos (l - 1) (lineLength (l - 1))
+ | otherwise = P.SourcePos l (c - 1)
+ nextPos (P.SourcePos l c)
+ | c == lineLength l = P.SourcePos (l + 1) 1
+ | otherwise = P.SourcePos l (c + 1)
+ file = T.unlines fileLines
+ lineLength l = T.length (fileLines ^. ix (l - 1))
+ sliceFile (P.SourcePos l1 c1) (P.SourcePos l2 c2) =
+ fileLines
+ & drop (l1 - 1)
+ & take (l2 - l1 + 1)
+ & ix 0 %~ T.drop (c1 - 1)
+ & ix (l2 - l1) %~ T.take c2
-- | Adds an implicit import like @import Prelude@ to a Sourcefile.
addImplicitImport :: (MonadIO m, MonadError IdeError m)
@@ -152,9 +148,9 @@ addImplicitImport :: (MonadIO m, MonadError IdeError m)
-> P.ModuleName -- ^ The module to import
-> m [Text]
addImplicitImport fp mn = do
- (_, pre, imports, post) <- parseImportsFromFile fp
+ (_, pre, imports, post) <- parseImportsFromFile' fp
let newImportSection = addImplicitImport' imports mn
- pure $ pre ++ newImportSection ++ post
+ pure (pre ++ newImportSection ++ post)
addImplicitImport' :: [Import] -> P.ModuleName -> [Text]
addImplicitImport' imports mn =
@@ -173,7 +169,7 @@ addImplicitImport' imports mn =
addExplicitImport :: (MonadIO m, MonadError IdeError m) =>
FilePath -> IdeDeclaration -> P.ModuleName -> m [Text]
addExplicitImport fp decl moduleName = do
- (mn, pre, imports, post) <- parseImportsFromFile fp
+ (mn, pre, imports, post) <- parseImportsFromFile' fp
let newImportSection =
-- TODO: Open an issue when this PR is merged, we should optimise this
-- so that this case does not write to disc
@@ -237,8 +233,8 @@ updateAtFirstOrPrepend :: (a -> Bool) -> (a -> a) -> a -> [a] -> [a]
updateAtFirstOrPrepend p t d l =
case findIndex p l of
Nothing -> d : l
- Just ix ->
- let (x, a : y) = splitAt ix l
+ Just i ->
+ let (x, a : y) = splitAt i l
in x ++ [t a] ++ y
-- | Looks up the given identifier in the currently loaded modules.
@@ -300,9 +296,6 @@ addImportForIdentifier fp ident filters = do
decideRedundantCase _ _ = Nothing
prettyPrintImport' :: Import -> Text
--- TODO: remove this clause once P.prettyPrintImport can properly handle PositionedRefs
-prettyPrintImport' (Import mn (P.Explicit refs) qual) =
- "import " <> P.prettyPrintImport mn (P.Explicit (unwrapPositionedRef <$> refs)) qual
prettyPrintImport' (Import mn idt qual) =
"import " <> P.prettyPrintImport mn idt qual
diff --git a/src/Language/PureScript/Ide/Pursuit.hs b/src/Language/PureScript/Ide/Pursuit.hs
index 1143a24..fd828b8 100644
--- a/src/Language/PureScript/Ide/Pursuit.hs
+++ b/src/Language/PureScript/Ide/Pursuit.hs
@@ -29,14 +29,11 @@ import Network.HTTP.Types.Header (hAccept)
import Pipes.HTTP
import qualified Pipes.Prelude as P
--- We need to remove trailing dots because Pursuit will return a 400 otherwise
--- TODO: remove this when the issue is fixed at Pursuit
queryPursuit :: Text -> IO ByteString
queryPursuit q = do
- let qClean = T.dropWhileEnd (== '.') q
req' <- parseRequest "https://pursuit.purescript.org/search"
let req = req'
- { queryString= "q=" <> (fromString . T.unpack) qClean
+ { queryString= "q=" <> (fromString . T.unpack) q
, requestHeaders=[(hAccept, "application/json")]
}
m <- newManager tlsManagerSettings
@@ -45,7 +42,6 @@ queryPursuit q = do
handler :: HttpException -> IO [a]
-handler StatusCodeException{} = pure []
handler _ = pure []
searchPursuitForDeclarations :: Text -> IO [PursuitResponse]
diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs
index b0fa8dd..2ad2cd8 100644
--- a/src/Language/PureScript/Ide/Rebuild.hs
+++ b/src/Language/PureScript/Ide/Rebuild.hs
@@ -15,12 +15,13 @@ import qualified Data.Map.Lazy as M
import Data.Maybe (fromJust)
import qualified Data.Set as S
import qualified Language.PureScript as P
-import Language.PureScript.Errors.JSON
import Language.PureScript.Ide.Error
import Language.PureScript.Ide.Logging
import Language.PureScript.Ide.State
import Language.PureScript.Ide.Types
import Language.PureScript.Ide.Util
+import System.Directory (getCurrentDirectory)
+import System.FilePath (makeRelative)
-- | Given a filepath performs the following steps:
--
@@ -47,12 +48,11 @@ rebuildFile
rebuildFile path runOpenBuild = do
input <- ideReadFile path
+ pwd <- liftIO getCurrentDirectory
- m <- case snd <$> P.parseModuleFromFile identity (path, input) of
- Left parseError -> throwError
- . RebuildError
- . toJSONErrors False P.Error
- $ P.MultipleErrors [P.toPositionedError parseError]
+ m <- case snd <$> P.parseModuleFromFile (makeRelative pwd) (path, input) of
+ Left parseError ->
+ throwError (RebuildError (P.MultipleErrors [P.toPositionedError parseError]))
Right m -> pure m
-- Externs files must be sorted ahead of time, so that they get applied
@@ -74,10 +74,10 @@ rebuildFile path runOpenBuild = do
. P.rebuildModule (buildMakeActions
>>= shushProgress $ makeEnv) externs $ m
case result of
- Left errors -> throwError (RebuildError (toJSONErrors False P.Error errors))
+ Left errors -> throwError (RebuildError errors)
Right _ -> do
runOpenBuild (rebuildModuleOpen makeEnv externs m)
- pure (RebuildSuccess (toJSONErrors False P.Warning warnings))
+ pure (RebuildSuccess warnings)
rebuildFileAsync
:: forall m. (Ide m, MonadLogger m, MonadError IdeError m)
@@ -171,7 +171,7 @@ sortExterns m ex = do
. M.delete (P.getModuleName m) $ ex
case sorted' of
Left err ->
- throwError (RebuildError (toJSONErrors False P.Error err))
+ throwError (RebuildError err)
Right (sorted, graph) -> do
let deps = fromJust (List.lookup (P.getModuleName m) graph)
pure $ mapMaybe getExtern (deps `inOrderOf` map P.getModuleName sorted)
diff --git a/src/Language/PureScript/Ide/Reexports.hs b/src/Language/PureScript/Ide/Reexports.hs
index 367fc0a..e26ee48 100644
--- a/src/Language/PureScript/Ide/Reexports.hs
+++ b/src/Language/PureScript/Ide/Reexports.hs
@@ -68,21 +68,24 @@ resolveReexports
resolveReexports reexportRefs modules =
Map.mapWithKey (\moduleName decls ->
maybe (ReexportResult decls [])
- (resolveReexports' modules decls)
+ (map (decls <>) . resolveReexports' modules)
(Map.lookup moduleName reexportRefs)) modules
resolveReexports'
:: ModuleMap [IdeDeclarationAnn]
- -> [IdeDeclarationAnn]
-> [(P.ModuleName, P.DeclarationRef)]
-> ReexportResult [IdeDeclarationAnn]
-resolveReexports' modules decls refs =
- ReexportResult (decls <> concat resolvedRefs) failedRefs
+resolveReexports' modules refs =
+ ReexportResult (concat resolvedRefs) failedRefs
where
(failedRefs, resolvedRefs) = partitionEithers (resolveRef' <$> refs)
resolveRef' x@(mn, r) = case Map.lookup mn modules of
Nothing -> Left x
- Just decls' -> first (mn,) (resolveRef decls' r)
+ Just decls' ->
+ let
+ setExportedFrom = set (idaAnnotation.annExportedFrom) . Just
+ in
+ bimap (mn,) (map (setExportedFrom mn)) (resolveRef decls' r)
resolveRef
:: [IdeDeclarationAnn]
diff --git a/src/Language/PureScript/Ide/SourceFile.hs b/src/Language/PureScript/Ide/SourceFile.hs
index e452236..bad912f 100644
--- a/src/Language/PureScript/Ide/SourceFile.hs
+++ b/src/Language/PureScript/Ide/SourceFile.hs
@@ -14,7 +14,6 @@
module Language.PureScript.Ide.SourceFile
( parseModule
- , getImportsForFile
, extractAstInformation
-- for tests
, extractSpans
@@ -28,43 +27,20 @@ import qualified Language.PureScript as P
import Language.PureScript.Ide.Error
import Language.PureScript.Ide.Types
import Language.PureScript.Ide.Util
+import System.Directory (getCurrentDirectory)
+import System.FilePath (makeRelative)
parseModule
:: (MonadIO m, MonadError IdeError m)
=> FilePath
-> m (Either FilePath (FilePath, P.Module))
parseModule path = do
+ pwd <- liftIO getCurrentDirectory
contents <- ideReadFile path
- case P.parseModuleFromFile identity (path, contents) of
+ case P.parseModuleFromFile (makeRelative pwd) (path, contents) of
Left _ -> pure (Left path)
Right m -> pure (Right m)
-getImports :: P.Module -> [(P.ModuleName, P.ImportDeclarationType, Maybe P.ModuleName)]
-getImports (P.Module _ _ _ declarations _) =
- mapMaybe isImport declarations
- where
- isImport (P.PositionedDeclaration _ _ (P.ImportDeclaration a b c)) = Just (a, b, c)
- isImport _ = Nothing
-
-getImportsForFile :: (MonadIO m, MonadError IdeError m) =>
- FilePath -> m [ModuleImport]
-getImportsForFile fp = do
- moduleE <- parseModule fp
- case moduleE of
- Left _ -> throwError (GeneralError "Failed to parse sourcefile.")
- Right (_, module') ->
- pure (mkModuleImport . unwrapPositionedImport <$> getImports module')
- where
- mkModuleImport (mn, importType', qualifier) =
- ModuleImport
- (P.runModuleName mn)
- importType'
- (P.runModuleName <$> qualifier)
- unwrapPositionedImport (mn, it, q) = (mn, unwrapImportType it, q)
- unwrapImportType (P.Explicit decls) = P.Explicit (map unwrapPositionedRef decls)
- unwrapImportType (P.Hiding decls) = P.Hiding (map unwrapPositionedRef decls)
- unwrapImportType P.Implicit = P.Implicit
-
-- | Extracts AST information from a parsed module
extractAstInformation
:: P.Module
diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs
index f8e75de..352b681 100644
--- a/src/Language/PureScript/Ide/Types.hs
+++ b/src/Language/PureScript/Ide/Types.hs
@@ -106,11 +106,12 @@ data IdeDeclarationAnn = IdeDeclarationAnn
data Annotation
= Annotation
- { annLocation :: Maybe P.SourceSpan
- , annExportedFrom :: Maybe P.ModuleName
- , annTypeAnnotation :: Maybe P.Type
+ { _annLocation :: Maybe P.SourceSpan
+ , _annExportedFrom :: Maybe P.ModuleName
+ , _annTypeAnnotation :: Maybe P.Type
} deriving (Show, Eq, Ord)
+makeLenses ''Annotation
makeLenses ''IdeDeclarationAnn
emptyAnn :: Annotation
@@ -184,7 +185,7 @@ data Completion = Completion
, complExpandedType :: Text
, complLocation :: Maybe P.SourceSpan
, complDocumentation :: Maybe Text
- } deriving (Show, Eq)
+ } deriving (Show, Eq, Ord)
instance ToJSON Completion where
toJSON (Completion {..}) =
@@ -196,34 +197,6 @@ instance ToJSON Completion where
, "documentation" .= complDocumentation
]
-data ModuleImport =
- ModuleImport
- { importModuleName :: ModuleIdent
- , importType :: P.ImportDeclarationType
- , importQualifier :: Maybe Text
- } deriving(Show)
-
-instance Eq ModuleImport where
- mi1 == mi2 =
- importModuleName mi1 == importModuleName mi2
- && importQualifier mi1 == importQualifier mi2
-
-instance ToJSON ModuleImport where
- toJSON (ModuleImport mn P.Implicit qualifier) =
- object $ [ "module" .= mn
- , "importType" .= ("implicit" :: Text)
- ] ++ map (\x -> "qualifier" .= x) (maybeToList qualifier)
- toJSON (ModuleImport mn (P.Explicit refs) qualifier) =
- object $ [ "module" .= mn
- , "importType" .= ("explicit" :: Text)
- , "identifiers" .= (identifierFromDeclarationRef <$> refs)
- ] ++ map (\x -> "qualifier" .= x) (maybeToList qualifier)
- toJSON (ModuleImport mn (P.Hiding refs) qualifier) =
- object $ [ "module" .= mn
- , "importType" .= ("hiding" :: Text)
- , "identifiers" .= (identifierFromDeclarationRef <$> refs)
- ] ++ map (\x -> "qualifier" .= x) (maybeToList qualifier)
-
identifierFromDeclarationRef :: P.DeclarationRef -> Text
identifierFromDeclarationRef (P.TypeRef name _) = P.runProperName name
identifierFromDeclarationRef (P.ValueRef ident) = P.runIdent ident
@@ -238,10 +211,10 @@ data Success =
| TextResult Text
| MultilineTextResult [Text]
| PursuitResult [PursuitResponse]
- | ImportList [ModuleImport]
+ | ImportList (P.ModuleName, [(P.ModuleName, P.ImportDeclarationType, Maybe P.ModuleName)])
| ModuleList [ModuleIdent]
- | RebuildSuccess [P.JSONError]
- deriving (Show, Eq)
+ | RebuildSuccess P.MultipleErrors
+ deriving (Show)
encodeSuccess :: (ToJSON a) => a -> Value
encodeSuccess res =
@@ -252,9 +225,28 @@ instance ToJSON Success where
toJSON (TextResult t) = encodeSuccess t
toJSON (MultilineTextResult ts) = encodeSuccess ts
toJSON (PursuitResult resp) = encodeSuccess resp
- toJSON (ImportList decls) = encodeSuccess decls
+ toJSON (ImportList (moduleName, imports)) = object [ "resultType" .= ("success" :: Text)
+ , "result" .= object [ "imports" .= map encodeImport imports
+ , "moduleName" .= moduleName]]
toJSON (ModuleList modules) = encodeSuccess modules
- toJSON (RebuildSuccess modules) = encodeSuccess modules
+ toJSON (RebuildSuccess warnings) = encodeSuccess (P.toJSONErrors False P.Warning warnings)
+
+encodeImport :: (P.ModuleName, P.ImportDeclarationType, Maybe P.ModuleName) -> Value
+encodeImport (P.runModuleName -> mn, importType, map P.runModuleName -> qualifier) = case importType of
+ P.Implicit ->
+ object $ [ "module" .= mn
+ , "importType" .= ("implicit" :: Text)
+ ] ++ map (\x -> "qualifier" .= x) (maybeToList qualifier)
+ P.Explicit refs ->
+ object $ [ "module" .= mn
+ , "importType" .= ("explicit" :: Text)
+ , "identifiers" .= (identifierFromDeclarationRef <$> refs)
+ ] ++ map (\x -> "qualifier" .= x) (maybeToList qualifier)
+ P.Hiding refs ->
+ object $ [ "module" .= mn
+ , "importType" .= ("hiding" :: Text)
+ , "identifiers" .= (identifierFromDeclarationRef <$> refs)
+ ] ++ map (\x -> "qualifier" .= x) (maybeToList qualifier)
newtype PursuitQuery = PursuitQuery Text
deriving (Show, Eq)
diff --git a/src/Language/PureScript/Ide/Util.hs b/src/Language/PureScript/Ide/Util.hs
index d8e7706..e6bbadd 100644
--- a/src/Language/PureScript/Ide/Util.hs
+++ b/src/Language/PureScript/Ide/Util.hs
@@ -24,7 +24,6 @@ module Language.PureScript.Ide.Util
, withEmptyAnn
, valueOperatorAliasT
, typeOperatorAliasT
- , prettyTypeT
, properNameT
, identT
, opNameT
@@ -41,10 +40,10 @@ import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8)
import qualified Language.PureScript as P
-import Language.PureScript.Ide.Error
+import Language.PureScript.Ide.Error (prettyPrintTypeSingleLine, IdeError(..))
import Language.PureScript.Ide.Logging
import Language.PureScript.Ide.Types
-import System.IO.UTF8 (readUTF8FileT)
+import System.IO.UTF8 (readUTF8FileT)
identifierFromIdeDeclaration :: IdeDeclaration -> Text
identifierFromIdeDeclaration d = case d of
@@ -71,22 +70,22 @@ completionFromMatch (Match (m, IdeDeclarationAnn ann decl)) =
Completion {..}
where
(complIdentifier, complExpandedType) = case decl of
- IdeDeclValue v -> (v ^. ideValueIdent . identT, v ^. ideValueType & prettyTypeT)
+ IdeDeclValue v -> (v ^. ideValueIdent . identT, v ^. ideValueType & prettyPrintTypeSingleLine)
IdeDeclType t -> (t ^. ideTypeName . properNameT, t ^. ideTypeKind & P.prettyPrintKind)
- IdeDeclTypeSynonym s -> (s ^. ideSynonymName . properNameT, s ^. ideSynonymType & prettyTypeT)
- IdeDeclDataConstructor d -> (d ^. ideDtorName . properNameT, d ^. ideDtorType & prettyTypeT)
+ IdeDeclTypeSynonym s -> (s ^. ideSynonymName . properNameT, s ^. ideSynonymType & prettyPrintTypeSingleLine)
+ IdeDeclDataConstructor d -> (d ^. ideDtorName . properNameT, d ^. ideDtorType & prettyPrintTypeSingleLine)
IdeDeclTypeClass d -> (d ^. ideTCName . properNameT, "type class")
IdeDeclValueOperator (IdeValueOperator op ref precedence associativity typeP) ->
- (P.runOpName op, maybe (showFixity precedence associativity (valueOperatorAliasT ref) op) prettyTypeT typeP)
+ (P.runOpName op, maybe (showFixity precedence associativity (valueOperatorAliasT ref) op) prettyPrintTypeSingleLine typeP)
IdeDeclTypeOperator (IdeTypeOperator op ref precedence associativity kind) ->
(P.runOpName op, maybe (showFixity precedence associativity (typeOperatorAliasT ref) op) P.prettyPrintKind kind)
IdeDeclKind k -> (P.runProperName k, "kind")
complModule = P.runModuleName m
- complType = maybe complExpandedType prettyTypeT (annTypeAnnotation ann)
+ complType = maybe complExpandedType prettyPrintTypeSingleLine (_annTypeAnnotation ann)
- complLocation = annLocation ann
+ complLocation = _annLocation ann
complDocumentation = Nothing
@@ -137,11 +136,3 @@ ideReadFile fp = do
(\_ -> throwError (GeneralError ("Couldn't find file at: " <> T.pack fp)))
pure
contents
-
-prettyTypeT :: P.Type -> Text
-prettyTypeT =
- T.unwords
- . map T.strip
- . T.lines
- . T.pack
- . P.prettyPrintTypeWithUnicode
diff --git a/src/Language/PureScript/Interactive.hs b/src/Language/PureScript/Interactive.hs
index db1cce7..f589536 100644
--- a/src/Language/PureScript/Interactive.hs
+++ b/src/Language/PureScript/Interactive.hs
@@ -11,8 +11,9 @@ module Language.PureScript.Interactive
import Prelude ()
import Prelude.Compat
+import Protolude (ordNub)
-import Data.List (nub, sort, find, foldl')
+import Data.List (sort, find, foldl')
import Data.Maybe (mapMaybe)
import qualified Data.Map as M
import Data.Monoid ((<>))
@@ -94,7 +95,8 @@ handleCommand
-> Command
-> m ()
handleCommand _ _ ShowHelp = liftIO $ putStrLn helpMessage
-handleCommand _ r ResetState = handleResetState r
+handleCommand _ r ReloadState = handleReloadState r
+handleCommand _ r ClearState = handleClearState r
handleCommand c _ (Expression val) = handleExpression c val
handleCommand _ _ (Import im) = handleImport im
handleCommand _ _ (Decls l) = handleDecls l
@@ -105,14 +107,13 @@ handleCommand _ _ (ShowInfo QueryLoaded) = handleShowLoadedModules
handleCommand _ _ (ShowInfo QueryImport) = handleShowImportedModules
handleCommand _ _ _ = P.internalError "handleCommand: unexpected command"
--- | Reset the application state
-handleResetState
+-- | Reload the application state
+handleReloadState
:: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m)
=> m ()
-> m ()
-handleResetState reload = do
- modify $ updateImportedModules (const [])
- . updateLets (const [])
+handleReloadState reload = do
+ modify $ updateLets (const [])
files <- asks psciLoadedFiles
e <- runExceptT $ do
modules <- ExceptT . liftIO $ loadAllModules files
@@ -124,6 +125,15 @@ handleResetState reload = do
modify (updateLoadedExterns (const (zip modules externs)))
reload
+-- | Clear the application state
+handleClearState
+ :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m)
+ => m ()
+ -> m ()
+handleClearState reload = do
+ modify $ updateImportedModules (const [])
+ handleReloadState reload
+
-- | Takes a value expression and evaluates it with the current state.
handleExpression
:: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m)
@@ -164,7 +174,7 @@ handleShowLoadedModules = do
loadedModules <- gets psciLoadedExterns
liftIO $ putStrLn (readModules loadedModules)
where
- readModules = unlines . sort . nub . map (T.unpack . P.runModuleName . P.getModuleName . fst)
+ readModules = unlines . sort . ordNub . map (T.unpack . P.runModuleName . P.getModuleName . fst)
-- | Show the imported modules in psci.
handleShowImportedModules
diff --git a/src/Language/PureScript/Interactive/Completion.hs b/src/Language/PureScript/Interactive/Completion.hs
index 7ab532a..5f891ae 100644
--- a/src/Language/PureScript/Interactive/Completion.hs
+++ b/src/Language/PureScript/Interactive/Completion.hs
@@ -6,13 +6,14 @@ module Language.PureScript.Interactive.Completion
) where
import Prelude.Compat
+import Protolude (ordNub)
import Control.Arrow (second)
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.State.Class (MonadState(..))
import Control.Monad.Trans.Reader (asks, runReaderT, ReaderT)
import Data.Function (on)
-import Data.List (nub, nubBy, isPrefixOf, sortBy, stripPrefix)
+import Data.List (nubBy, isPrefixOf, sortBy, stripPrefix)
import Data.Maybe (mapMaybe)
import Data.Text (Text)
import qualified Data.Text as T
@@ -120,7 +121,8 @@ completeDirective ws w =
directiveArg :: String -> Directive -> [CompletionContext]
directiveArg _ Browse = [CtxModule]
directiveArg _ Quit = []
-directiveArg _ Reset = []
+directiveArg _ Reload = []
+directiveArg _ Clear = []
directiveArg _ Help = []
directiveArg _ Paste = []
directiveArg _ Show = map CtxFixed replQueryStrings
@@ -169,7 +171,7 @@ getAllQualifications :: (a -> Text) -> P.Module -> (a, P.Declaration) -> Complet
getAllQualifications sho m (declName, decl) = do
imports <- getAllImportsOf m
let fullyQualified = qualifyWith (Just (P.getModuleName m))
- let otherQuals = nub (concatMap qualificationsUsing imports)
+ let otherQuals = ordNub (concatMap qualificationsUsing imports)
return $ fullyQualified : otherQuals
where
qualifyWith mMod = T.unpack (P.showQualified sho (P.Qualified mMod declName))
@@ -220,4 +222,4 @@ dctorNames = nubOnFst . concatMap go . P.exportedDeclarations
go _ = []
moduleNames :: [P.Module] -> [String]
-moduleNames = nub . map (T.unpack . P.runModuleName . P.getModuleName)
+moduleNames = ordNub . map (T.unpack . P.runModuleName . P.getModuleName)
diff --git a/src/Language/PureScript/Interactive/Directive.hs b/src/Language/PureScript/Interactive/Directive.hs
index 8f204a3..7f2f010 100644
--- a/src/Language/PureScript/Interactive/Directive.hs
+++ b/src/Language/PureScript/Interactive/Directive.hs
@@ -25,7 +25,8 @@ directiveStrings :: [(Directive, [String])]
directiveStrings =
[ (Help , ["?", "help"])
, (Quit , ["quit"])
- , (Reset , ["reset"])
+ , (Reload , ["reload"])
+ , (Clear , ["clear"])
, (Browse , ["browse"])
, (Type , ["type"])
, (Kind , ["kind"])
@@ -82,7 +83,8 @@ parseDirective = listToMaybe . directivesFor
hasArgument :: Directive -> Bool
hasArgument Help = False
hasArgument Quit = False
-hasArgument Reset = False
+hasArgument Reload = False
+hasArgument Clear = False
hasArgument Paste = False
hasArgument _ = True
@@ -93,7 +95,8 @@ help :: [(Directive, String, String)]
help =
[ (Help, "", "Show this help menu")
, (Quit, "", "Quit PSCi")
- , (Reset, "", "Discard all imported modules and declared bindings")
+ , (Reload, "", "Reload all imported modules while discarding bindings")
+ , (Clear, "", "Discard all imported modules and declared bindings")
, (Browse, "<module>", "See all functions in <module>")
, (Type, "<expr>", "Show the type of <expr>")
, (Kind, "<type>", "Show the kind of <type>")
diff --git a/src/Language/PureScript/Interactive/Message.hs b/src/Language/PureScript/Interactive/Message.hs
index e340da1..24a5b37 100644
--- a/src/Language/PureScript/Interactive/Message.hs
+++ b/src/Language/PureScript/Interactive/Message.hs
@@ -10,6 +10,10 @@ import Language.PureScript.Interactive.Types
-- Messages
+-- | The guide URL
+guideURL :: String
+guideURL = "https://github.com/purescript/documentation/blob/master/guides/PSCi.md"
+
-- | The help message.
helpMessage :: String
helpMessage = "The following commands are available:\n\n " ++
@@ -28,7 +32,7 @@ helpMessage = "The following commands are available:\n\n " ++
extraHelp =
"Further information is available on the PureScript documentation repository:\n" ++
- " --> https://github.com/purescript/documentation/blob/master/PSCi.md"
+ " --> " ++ guideURL
-- | The welcome prologue.
prologueMessage :: String
@@ -37,18 +41,17 @@ prologueMessage = unlines
, "Type :? for help"
]
+noInputMessage :: String
+noInputMessage = unlines
+ [ "purs repl: No input files; try running `pulp psci` instead."
+ , "For help getting started, visit " ++ guideURL
+ , "Usage: For basic information, try the `--help' option."
+ ]
+
supportModuleMessage :: String
supportModuleMessage = unlines
- [ "PSCi requires the psci-support package to be installed."
- , "You can install it using Bower as follows:"
- , ""
- , " bower i purescript-psci-support --save-dev"
- , ""
- , "Or using psc-package:"
- , ""
- , " psc-package install psci-support"
- , ""
- , "For help getting started, visit https://github.com/purescript/documentation/blob/master/PSCi.md"
+ [ "purs repl: PSCi requires the psci-support package."
+ , "For help getting started, visit " ++ guideURL
]
-- | The quit message.
diff --git a/src/Language/PureScript/Interactive/Module.hs b/src/Language/PureScript/Interactive/Module.hs
index 3b53646..34ac66c 100644
--- a/src/Language/PureScript/Interactive/Module.hs
+++ b/src/Language/PureScript/Interactive/Module.hs
@@ -5,7 +5,8 @@ import Prelude.Compat
import Control.Monad
import qualified Language.PureScript as P
import Language.PureScript.Interactive.Types
-import System.FilePath (pathSeparator)
+import System.Directory (getCurrentDirectory)
+import System.FilePath (pathSeparator, makeRelative)
import System.IO.UTF8 (readUTF8FileT)
-- * Support Module
@@ -20,23 +21,23 @@ supportModuleIsDefined = any ((== supportModuleName) . P.getModuleName)
-- * Module Management
--- |
--- Loads a file for use with imports.
---
+-- | Loads a file for use with imports.
loadModule :: FilePath -> IO (Either String [P.Module])
loadModule filename = do
+ pwd <- getCurrentDirectory
content <- readUTF8FileT filename
- return $ either (Left . P.prettyPrintMultipleErrors P.defaultPPEOptions) (Right . map snd) $ P.parseModulesFromFiles id [(filename, content)]
+ return $
+ either (Left . P.prettyPrintMultipleErrors P.defaultPPEOptions) (Right . map snd) $
+ P.parseModulesFromFiles (makeRelative pwd) [(filename, content)]
--- |
--- Load all modules.
---
+-- | Load all modules.
loadAllModules :: [FilePath] -> IO (Either P.MultipleErrors [(FilePath, P.Module)])
loadAllModules files = do
+ pwd <- getCurrentDirectory
filesAndContent <- forM files $ \filename -> do
content <- readUTF8FileT filename
return (filename, content)
- return $ P.parseModulesFromFiles id filesAndContent
+ return $ P.parseModulesFromFiles (makeRelative pwd) filesAndContent
-- |
-- Makes a volatile module to execute the current expression.
@@ -50,7 +51,7 @@ createTemporaryModule exec PSCiState{psciImportedModules = imports, psciLetBindi
supportImport = (supportModuleName, P.Implicit, Just (P.ModuleName [P.ProperName "$Support"]))
eval = P.Var (P.Qualified (Just (P.ModuleName [P.ProperName "$Support"])) (P.Ident "eval"))
mainValue = P.App eval (P.Var (P.Qualified Nothing (P.Ident "it")))
- itDecl = P.ValueDeclaration (P.Ident "it") P.Public [] $ Right val
+ itDecl = P.ValueDeclaration (P.Ident "it") P.Public [] [P.MkUnguarded val]
typeDecl = P.TypeDeclaration (P.Ident "$main")
(P.TypeApp
(P.TypeApp
@@ -58,7 +59,7 @@ createTemporaryModule exec PSCiState{psciImportedModules = imports, psciLetBindi
(P.Qualified (Just (P.ModuleName [P.ProperName "$Eff"])) (P.ProperName "Eff")))
(P.TypeWildcard internalSpan))
(P.TypeWildcard internalSpan))
- mainDecl = P.ValueDeclaration (P.Ident "$main") P.Public [] $ Right mainValue
+ mainDecl = P.ValueDeclaration (P.Ident "$main") P.Public [] [P.MkUnguarded mainValue]
decls = if exec then [itDecl, typeDecl, mainDecl] else [itDecl]
internalSpan = P.internalModuleSourceSpan "<internal>"
in
diff --git a/src/Language/PureScript/Interactive/Parser.hs b/src/Language/PureScript/Interactive/Parser.hs
index 160a04b..a29c110 100644
--- a/src/Language/PureScript/Interactive/Parser.hs
+++ b/src/Language/PureScript/Interactive/Parser.hs
@@ -7,6 +7,7 @@ module Language.PureScript.Interactive.Parser
import Prelude.Compat hiding (lex)
+import Data.Bifunctor (first)
import Data.Char (isSpace)
import Data.List (intercalate)
import qualified Data.Text as T
@@ -26,7 +27,7 @@ parseCommand cmdString =
_ -> parseRest psciCommand cmdString
parseRest :: P.TokenParser a -> String -> Either String a
-parseRest p s = either (Left . show) Right $ do
+parseRest p s = first show $ do
ts <- P.lex "" (T.pack s)
P.runTokenParser "" (p <* eof) ts
@@ -34,10 +35,10 @@ psciCommand :: P.TokenParser Command
psciCommand = choice (map try parsers)
where
parsers =
- [ psciLet
- , psciImport
- , psciOtherDeclaration
+ [ psciImport
+ , psciDeclaration
, psciExpression
+ , psciDeprecatedLet
]
trim :: String -> String
@@ -62,7 +63,8 @@ parseDirective cmd =
commandFor d = case d of
Help -> return ShowHelp
Quit -> return QuitPSCi
- Reset -> return ResetState
+ Reload -> return ReloadState
+ Clear -> return ClearState
Paste -> return PasteLines
Browse -> BrowseModule <$> parseRest P.moduleName arg
Show -> ShowInfo <$> parseReplQuery' (trim arg)
@@ -75,18 +77,6 @@ parseDirective cmd =
psciExpression :: P.TokenParser Command
psciExpression = Expression <$> P.parseValue
--- |
--- PSCI version of @let@.
--- This is essentially let from do-notation.
--- However, since we don't support the @Eff@ monad,
--- we actually want the normal @let@.
---
-psciLet :: P.TokenParser Command
-psciLet = Decls <$> (P.reserved "let" *> P.indented *> manyDecls)
- where
- manyDecls :: P.TokenParser [P.Declaration]
- manyDecls = mark (many1 (same *> P.parseLocalDeclaration))
-
-- | Imports must be handled separately from other declarations, so that
-- :show import works, for example.
psciImport :: P.TokenParser Command
@@ -94,10 +84,10 @@ 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).
-psciOtherDeclaration :: P.TokenParser Command
-psciOtherDeclaration = Decls . (:[]) <$> do
+-- | Any declaration that we don't need a 'special case' parser for
+-- (like import declarations).
+psciDeclaration :: P.TokenParser Command
+psciDeclaration = fmap Decls $ mark $ many1 $ same *> do
decl <- discardPositionInfo <$> P.parseDeclaration
if acceptable decl
then return decl
@@ -115,6 +105,8 @@ acceptable P.ExternDataDeclaration{} = True
acceptable P.TypeClassDeclaration{} = True
acceptable P.TypeInstanceDeclaration{} = True
acceptable P.ExternKindDeclaration{} = True
+acceptable P.TypeDeclaration{} = True
+acceptable P.ValueDeclaration{} = True
acceptable _ = False
parseReplQuery' :: String -> Either String ReplQuery
@@ -123,3 +115,13 @@ parseReplQuery' str =
Nothing -> Left ("Don't know how to show " ++ str ++ ". Try one of: " ++
intercalate ", " replQueryStrings ++ ".")
Just query -> Right query
+
+-- | To show error message when 'let' is used for declaration in PSCI,
+-- which is deprecated.
+psciDeprecatedLet :: P.TokenParser Command
+psciDeprecatedLet = do
+ P.reserved "let"
+ P.indented
+ _ <- mark (many1 (same *> P.parseLocalDeclaration))
+ notFollowedBy $ P.reserved "in"
+ fail "Declarations in PSCi no longer require \"let\", as of version 0.11.0"
diff --git a/src/Language/PureScript/Interactive/Types.hs b/src/Language/PureScript/Interactive/Types.hs
index 61dfe14..f54ee37 100644
--- a/src/Language/PureScript/Interactive/Types.hs
+++ b/src/Language/PureScript/Interactive/Types.hs
@@ -82,8 +82,10 @@ data Command
| BrowseModule P.ModuleName
-- | Exit PSCI
| QuitPSCi
- -- | Reset the state of the REPL
- | ResetState
+ -- | Reload all the imported modules of the REPL
+ | ReloadState
+ -- | Clear the state of the REPL
+ | ClearState
-- | Add some declarations to the current evaluation context
| Decls [P.Declaration]
-- | Find the type of an expression
@@ -94,6 +96,7 @@ data Command
| ShowInfo ReplQuery
-- | Paste multiple lines
| PasteLines
+ deriving Show
data ReplQuery
= QueryLoaded
@@ -119,7 +122,8 @@ parseReplQuery _ = Nothing
data Directive
= Help
| Quit
- | Reset
+ | Reload
+ | Clear
| Browse
| Type
| Kind
diff --git a/src/Language/PureScript/Kinds.hs b/src/Language/PureScript/Kinds.hs
index 93cabc9..696dd36 100644
--- a/src/Language/PureScript/Kinds.hs
+++ b/src/Language/PureScript/Kinds.hs
@@ -52,8 +52,6 @@ kindFromJSON = do
KUnknown <$> key "contents" (nth 0 asIntegral)
"Star" ->
pure kindType
- "Bang" ->
- pure kindEffect
"Row" ->
Row <$> key "contents" kindFromJSON
"FunKind" ->
@@ -78,7 +76,6 @@ kindFromJSON = do
primKind = NamedKind . primName
kindType = primKind "Type"
- kindEffect = primKind "Effect"
kindSymbol = primKind "Symbol"
instance A.FromJSON Kind where
diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs
index 4918c11..d26f361 100644
--- a/src/Language/PureScript/Linter.hs
+++ b/src/Language/PureScript/Linter.hs
@@ -4,10 +4,11 @@
module Language.PureScript.Linter (lint, module L) where
import Prelude.Compat
+import Protolude (ordNub)
import Control.Monad.Writer.Class
-import Data.List (nub, (\\))
+import Data.List ((\\))
import Data.Maybe (mapMaybe)
import Data.Monoid
import qualified Data.Set as S
@@ -28,7 +29,7 @@ lint :: forall m. (MonadWriter MultipleErrors m) => Module -> m ()
lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDeclaration ds
where
moduleNames :: S.Set Ident
- moduleNames = S.fromList (nub (mapMaybe getDeclIdent ds))
+ moduleNames = S.fromList (ordNub (mapMaybe getDeclIdent ds))
getDeclIdent :: Declaration -> Maybe Ident
getDeclIdent (PositionedDeclaration _ _ d) = getDeclIdent d
@@ -55,7 +56,7 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl
f' s dec = warningsInDecl moduleNames dec <> checkTypeVarsInDecl s dec
stepE :: S.Set Ident -> Expr -> MultipleErrors
- stepE s (Abs (Left name) _) | name `S.member` s = errorMessage (ShadowedName name)
+ stepE s (Abs (VarBinder name) _) | name `S.member` s = errorMessage (ShadowedName name)
stepE s (Let ds' _) = foldMap go ds'
where
go d | Just i <- getDeclIdent d
@@ -91,7 +92,7 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl
findUnused ty' =
let used = usedTypeVariables ty'
declared = everythingOnTypes (++) go ty'
- unused = nub declared \\ nub used
+ unused = ordNub declared \\ ordNub used
in foldl (<>) mempty $ map (errorMessage . UnusedTypeVar) unused
where
go :: Type -> [Text]
diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs
index 25c5bec..64db3b1 100644
--- a/src/Language/PureScript/Linter/Exhaustive.hs
+++ b/src/Language/PureScript/Linter/Exhaustive.hs
@@ -9,6 +9,7 @@ module Language.PureScript.Linter.Exhaustive
) where
import Prelude.Compat
+import Protolude (ordNub)
import Control.Applicative
import Control.Arrow (first, second)
@@ -17,7 +18,7 @@ import Control.Monad.Writer.Class
import Control.Monad.Supply.Class (MonadSupply, fresh, freshName)
import Data.Function (on)
-import Data.List (foldl', sortBy, nub)
+import Data.List (foldl', sortBy)
import Data.Maybe (fromMaybe)
import Data.Monoid ((<>))
import qualified Data.Map as M
@@ -202,17 +203,17 @@ missingCasesMultiple env mn = go
-- The function below say whether or not a guard has an `otherwise` expression
-- It is considered that `otherwise` is defined in Prelude
--
-isExhaustiveGuard :: Either [(Guard, Expr)] Expr -> Bool
-isExhaustiveGuard (Left gs) = not . null $ filter (\(g, _) -> isOtherwise g) gs
+isExhaustiveGuard :: [GuardedExpr] -> Bool
+isExhaustiveGuard [GuardedExpr [] _] = True
+isExhaustiveGuard gs =
+ not . null $ filter (\(GuardedExpr grd _) -> isExhaustive grd) gs
where
- isOtherwise :: Expr -> Bool
- isOtherwise (Literal (BooleanLiteral True)) = True
- isOtherwise (Var (Qualified (Just (ModuleName [ProperName "Prelude"])) (Ident "otherwise"))) = True
- isOtherwise (Var (Qualified (Just (ModuleName [ProperName "Data", ProperName "Boolean"])) (Ident "otherwise"))) = True
- isOtherwise (TypedValue _ e _) = isOtherwise e
- isOtherwise (PositionedValue _ _ e) = isOtherwise e
- isOtherwise _ = False
-isExhaustiveGuard (Right _) = True
+ checkGuard :: Guard -> Bool
+ checkGuard (ConditionGuard cond) = isTrueExpr cond
+ checkGuard (PatternGuard bind _) = isIrrefutable bind
+
+ isExhaustive :: [Guard] -> Bool
+ isExhaustive = all checkGuard
-- |
-- Returns the uncovered set of case alternatives
@@ -242,12 +243,12 @@ checkExhaustive
-> [CaseAlternative]
-> Expr
-> m Expr
-checkExhaustive env mn numArgs cas expr = makeResult . first nub $ foldl' step ([initialize numArgs], (pure True, [])) cas
+checkExhaustive env mn numArgs cas expr = makeResult . first ordNub $ foldl' step ([initialize numArgs], (pure True, [])) cas
where
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))
+ (missed', approx) = splitAt 10000 (ordNub (concat missed))
cond = or <$> sequenceA pr
in (missed', ( if null approx
then liftA2 (&&) cond nec
@@ -288,17 +289,19 @@ checkExhaustive env mn numArgs cas expr = makeResult . first nub $ foldl' step (
where
partial :: Text -> Text -> Declaration
partial var tyVar =
- ValueDeclaration (Ident C.__unused) Private [] $ Right $
- TypedValue
- True
- (Abs (Left (Ident var)) (Var (Qualified Nothing (Ident var))))
- (ty tyVar)
+ ValueDeclaration (Ident C.__unused) Private [] $
+ [MkUnguarded
+ (TypedValue
+ True
+ (Abs (VarBinder (Ident var)) (Var (Qualified Nothing (Ident var))))
+ (ty tyVar))
+ ]
ty :: Text -> Type
ty tyVar =
ForAll tyVar
( ConstrainedType
- [ Constraint C.Partial [] (Just constraintData) ]
+ (Constraint C.Partial [] (Just constraintData))
$ TypeApp (TypeApp tyFunction (TypeVar tyVar)) (TypeVar tyVar)
)
Nothing
@@ -321,7 +324,7 @@ checkExhaustiveExpr env mn = onExpr
where
onDecl :: Declaration -> m Declaration
onDecl (BindingGroupDeclaration bs) = BindingGroupDeclaration <$> mapM (thirdM onExpr) bs
- onDecl (ValueDeclaration name x y (Right e)) = ValueDeclaration name x y . Right <$> censor (addHint (ErrorInValueDeclaration name)) (onExpr e)
+ onDecl (ValueDeclaration name x y [MkUnguarded e]) = ValueDeclaration name x y . mkUnguardedExpr <$> censor (addHint (ErrorInValueDeclaration name)) (onExpr e)
onDecl (PositionedDeclaration pos x dec) = PositionedDeclaration pos x <$> censor (addHint (PositionedError pos)) (onDecl dec)
onDecl decl = return decl
@@ -344,5 +347,10 @@ checkExhaustiveExpr env mn = onExpr
onExpr expr = return expr
onCaseAlternative :: CaseAlternative -> m CaseAlternative
- onCaseAlternative (CaseAlternative x (Left es)) = CaseAlternative x . Left <$> mapM (\(e, g) -> (,) <$> onExpr e <*> onExpr g) es
- onCaseAlternative (CaseAlternative x (Right e)) = CaseAlternative x . Right <$> onExpr e
+ onCaseAlternative (CaseAlternative x [MkUnguarded e]) = CaseAlternative x . mkUnguardedExpr <$> onExpr e
+ onCaseAlternative (CaseAlternative x es) = CaseAlternative x <$> mapM onGuardedExpr es
+
+ onGuardedExpr :: GuardedExpr -> m GuardedExpr
+ onGuardedExpr (GuardedExpr guard rhs) = GuardedExpr guard <$> onExpr rhs
+
+ mkUnguardedExpr = pure . MkUnguarded
diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs
index 1dfcede..680ca09 100644
--- a/src/Language/PureScript/Linter/Imports.hs
+++ b/src/Language/PureScript/Linter/Imports.hs
@@ -5,13 +5,14 @@ module Language.PureScript.Linter.Imports
) where
import Prelude.Compat
+import Protolude (ordNub)
import Control.Monad (join, unless, foldM, (<=<))
import Control.Monad.Writer.Class
import Data.Function (on)
import Data.Foldable (for_)
-import Data.List (find, intersect, nub, groupBy, sortBy, (\\))
+import Data.List (find, intersect, groupBy, sortBy, (\\))
import Data.Maybe (mapMaybe, fromMaybe)
import Data.Monoid (Sum(..))
import Data.Traversable (forM)
@@ -71,16 +72,16 @@ lintImports (Module ss _ mn mdecls (Just mexports)) env usedImps = do
unless (isPrim mni) $
for_ decls $ \(ss', declType, qualifierName) ->
maybe id warnWithPosition ss' $ do
- let names = nub $ M.findWithDefault [] mni usedImps'
+ let names = ordNub $ M.findWithDefault [] mni usedImps'
lintImportDecl env mni qualifierName names declType allowImplicit
for_ (M.toAscList (byQual imports)) $ \(mnq, entries) -> do
- let mnis = nub $ map (\(_, _, mni) -> mni) entries
+ let mnis = ordNub $ map (\(_, _, mni) -> mni) entries
unless (length mnis == 1) $ do
let implicits = filter (\(_, declType, _) -> not $ isExplicit declType) entries
for_ implicits $ \(ss', _, mni) ->
maybe id warnWithPosition ss' $ do
- let names = nub $ M.findWithDefault [] mni usedImps'
+ let names = ordNub $ M.findWithDefault [] mni usedImps'
usedRefs = findUsedRefs env mni (Just mnq) names
unless (null usedRefs) $
tell $ errorMessage $ ImplicitQualifiedImport mni mnq usedRefs
@@ -147,7 +148,7 @@ lintImports (Module ss _ mn mdecls (Just mexports)) env usedImps = do
-- 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 $ mapMaybe extractModule mexports
+ exportedModules = ordNub $ mapMaybe extractModule mexports
where
extractModule (PositionedDeclarationRef _ _ r) = extractModule r
extractModule (ModuleRef mne) = Just mne
@@ -231,7 +232,7 @@ lintImportDecl env mni qualifierName names declType allowImplicit =
:: [DeclarationRef]
-> m Bool
checkExplicit declrefs = do
- let idents = nub (mapMaybe runDeclRef declrefs)
+ let idents = ordNub (mapMaybe runDeclRef declrefs)
dctors = mapMaybe (getDctorName <=< disqualifyFor qualifierName) names
usedNames = mapMaybe (matchName (typeForDCtor mni) <=< disqualifyFor qualifierName) names
diff = idents \\ usedNames
diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs
index a61e6dc..b385f7a 100644
--- a/src/Language/PureScript/Make.hs
+++ b/src/Language/PureScript/Make.hs
@@ -60,17 +60,18 @@ import Language.PureScript.Linter
import Language.PureScript.ModuleDependencies
import Language.PureScript.Names
import Language.PureScript.Options
-import Language.PureScript.Pretty
-import Language.PureScript.Pretty.Common(SMap(..))
+import Language.PureScript.Pretty.Common (SMap(..))
import Language.PureScript.Renamer
import Language.PureScript.Sugar
import Language.PureScript.TypeChecker
import qualified Language.JavaScript.Parser as JS
import qualified Language.PureScript.Bundle as Bundle
import qualified Language.PureScript.CodeGen.JS as J
+import Language.PureScript.CodeGen.JS.Printer
import qualified Language.PureScript.Constants as C
import qualified Language.PureScript.CoreFn as CF
import qualified Language.PureScript.CoreFn.ToJSON as CFJ
+import qualified Language.PureScript.CoreImp.AST as Imp
import qualified Language.PureScript.Parser as PSParser
import qualified Paths_purescript as Paths
import SourceMap
@@ -94,7 +95,7 @@ renderProgressMessage (CompilingModule mn) = "Compiling " ++ T.unpack (runModule
--
-- This type exists to make two things abstract:
--
--- * The particular backend being used (Javascript, C++11, etc.)
+-- * The particular backend being used (JavaScript, C++11, etc.)
--
-- * The details of how files are read/written etc.
data MakeActions m = MakeActions
@@ -351,7 +352,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
return Nothing
| otherwise -> do
checkForeignDecls m path
- return $ Just $ J.JSApp Nothing (J.JSVar Nothing "require") [J.JSStringLiteral Nothing "./foreign"]
+ return $ Just $ Imp.App Nothing (Imp.Var Nothing "require") [Imp.StringLiteral Nothing "./foreign"]
Nothing | requiresForeign m -> throwError . errorMessage $ MissingFFIModule mn
| otherwise -> return Nothing
rawJs <- J.moduleToJs m foreignInclude
@@ -363,7 +364,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
mapFile = outputDir </> filePath </> "index.js.map"
externsFile = outputDir </> filePath </> "externs.json"
foreignFile = outputDir </> filePath </> "foreign.js"
- prefix = ["Generated by psc version " <> T.pack (showVersion Paths.version) | usePrefix]
+ prefix = ["Generated by purs version " <> T.pack (showVersion Paths.version) | usePrefix]
js = T.unlines $ map ("// " <>) prefix ++ [pjs]
mapRef = if sourceMaps then "//# sourceMappingURL=index.js.map\n" else ""
lift $ do
diff --git a/src/Language/PureScript/ModuleDependencies.hs b/src/Language/PureScript/ModuleDependencies.hs
index 5766f0f..21885b0 100644
--- a/src/Language/PureScript/ModuleDependencies.hs
+++ b/src/Language/PureScript/ModuleDependencies.hs
@@ -27,8 +27,8 @@ sortModules
-> m ([Module], ModuleGraph)
sortModules ms = do
let mns = S.fromList $ map getModuleName ms
- verts <- mapM (toGraphNode mns) ms
- ms' <- mapM toModule $ stronglyConnComp verts
+ verts <- parU ms (toGraphNode mns)
+ ms' <- parU (stronglyConnComp verts) toModule
let (graph, fromVertex, toVertex) = graphFromEdges verts
moduleGraph = do (_, mn, _) <- verts
let v = fromMaybe (internalError "sortModules: vertex not found") (toVertex mn)
@@ -39,23 +39,23 @@ sortModules ms = do
where
toGraphNode :: S.Set ModuleName -> Module -> m (Module, ModuleName, [ModuleName])
toGraphNode mns m@(Module _ _ mn ds _) = do
- let deps = ordNub (concatMap usedModules ds)
- forM_ deps $ \dep ->
+ let deps = ordNub (mapMaybe usedModules ds)
+ void . parU deps $ \(dep, pos) ->
when (dep /= C.Prim && S.notMember dep mns) $
- throwError . addHint (ErrorInModule mn) . errorMessage $ ModuleNotFound dep
- pure (m, getModuleName m, deps)
+ throwError
+ . addHint (ErrorInModule mn)
+ . maybe identity (addHint . PositionedError) pos
+ . errorMessage
+ $ ModuleNotFound dep
+ pure (m, getModuleName m, map fst deps)
-- | Calculate a list of used modules based on explicit imports and qualified names.
-usedModules :: Declaration -> [ModuleName]
-usedModules d = f d where
- f :: Declaration -> [ModuleName]
- (f, _, _, _, _) = everythingOnValues (++) forDecls (const []) (const []) (const []) (const [])
-
- forDecls :: Declaration -> [ModuleName]
- -- Regardless of whether an imported module is qualified we still need to
- -- take into account its import to build an accurate list of dependencies.
- forDecls (ImportDeclaration mn _ _) = [mn]
- forDecls _ = []
+usedModules :: Declaration -> Maybe (ModuleName, Maybe SourceSpan)
+-- Regardless of whether an imported module is qualified we still need to
+-- take into account its import to build an accurate list of dependencies.
+usedModules (ImportDeclaration mn _ _) = pure (mn, Nothing)
+usedModules (PositionedDeclaration ss _ d) = fmap (second (const (Just ss))) (usedModules d)
+usedModules _ = Nothing
-- | Convert a strongly connected component of the module graph to a module
toModule :: MonadError MultipleErrors m => SCC Module -> m Module
diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs
index 8ca8fcc..0c50643 100644
--- a/src/Language/PureScript/Names.hs
+++ b/src/Language/PureScript/Names.hs
@@ -25,7 +25,7 @@ data Name
| TyClassName (ProperName 'ClassName)
| ModName ModuleName
| KiName (ProperName 'KindName)
- deriving (Eq, Show)
+ deriving (Eq, Ord, Show)
getIdentName :: Name -> Maybe Ident
getIdentName (IdentName name) = Just name
diff --git a/src/Language/PureScript/Options.hs b/src/Language/PureScript/Options.hs
index 62040a8..0e4e6d1 100644
--- a/src/Language/PureScript/Options.hs
+++ b/src/Language/PureScript/Options.hs
@@ -1,42 +1,20 @@
--- |
--- The data type of compiler options
---
+-- | The data type of compiler options
module Language.PureScript.Options where
import Prelude.Compat
--- |
--- The data type of compiler options
---
-data Options = Options {
- -- |
- -- Disable tail-call elimination
- optionsNoTco :: Bool
- -- |
- -- Disable inlining of calls to return and bind for the Eff monad
- , optionsNoMagicDo :: Bool
- -- |
- -- When specified, checks the type of `main` in the module, and generate a call to run main
- -- after the module definitions.
- , optionsMain :: Maybe String
- -- |
- -- Skip all optimizations
- , optionsNoOptimizations :: Bool
- -- |
- -- Verbose error message
- , optionsVerboseErrors :: Bool
- -- |
- -- Remove the comments from the generated js
+-- | The data type of compiler options
+data Options = Options
+ { optionsVerboseErrors :: Bool
+ -- ^ Verbose error message
, optionsNoComments :: Bool
- -- |
- -- Generate soure maps
+ -- ^ Remove the comments from the generated js
, optionsSourceMaps :: Bool
- -- |
- -- Dump CoreFn
+ -- ^ Generate source maps
, optionsDumpCoreFn :: Bool
+ -- ^ Dump CoreFn
} deriving Show
--- |
-- Default make options
defaultOptions :: Options
-defaultOptions = Options False False Nothing False False False False False
+defaultOptions = Options False False False False
diff --git a/src/Language/PureScript/Parser.hs b/src/Language/PureScript/Parser.hs
index 69dfd67..c7ac55a 100644
--- a/src/Language/PureScript/Parser.hs
+++ b/src/Language/PureScript/Parser.hs
@@ -1,23 +1,23 @@
--- |
--- A collection of parsers for core data types:
---
--- [@Language.PureScript.Parser.Kinds@] Parser for kinds
---
--- [@Language.PureScript.Parser.Values@] Parser for values
---
--- [@Language.PureScript.Parser.Types@] Parser for types
---
--- [@Language.PureScript.Parser.Declaration@] Parsers for declarations and modules
---
--- [@Language.PureScript.Parser.State@] Parser state, including indentation
---
--- [@Language.PureScript.Parser.Common@] Common parsing utility functions
---
-module Language.PureScript.Parser (module P) where
-
-import Language.PureScript.Parser.Common as P
-import Language.PureScript.Parser.Declarations as P
-import Language.PureScript.Parser.Kinds as P
-import Language.PureScript.Parser.Lexer as P
-import Language.PureScript.Parser.State as P
-import Language.PureScript.Parser.Types as P
+-- |
+-- A collection of parsers for core data types:
+--
+-- [@Language.PureScript.Parser.Kinds@] Parser for kinds
+--
+-- [@Language.PureScript.Parser.Values@] Parser for values
+--
+-- [@Language.PureScript.Parser.Types@] Parser for types
+--
+-- [@Language.PureScript.Parser.Declaration@] Parsers for declarations and modules
+--
+-- [@Language.PureScript.Parser.State@] Parser state, including indentation
+--
+-- [@Language.PureScript.Parser.Common@] Common parsing utility functions
+--
+module Language.PureScript.Parser (module P) where
+
+import Language.PureScript.Parser.Common as P
+import Language.PureScript.Parser.Declarations as P
+import Language.PureScript.Parser.Kinds as P
+import Language.PureScript.Parser.Lexer as P
+import Language.PureScript.Parser.State as P
+import Language.PureScript.Parser.Types as P
diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs
index 3ddd4fa..a66370c 100644
--- a/src/Language/PureScript/Parser/Declarations.hs
+++ b/src/Language/PureScript/Parser/Declarations.hs
@@ -1,7 +1,9 @@
-- | Parsers for module definitions and declarations
module Language.PureScript.Parser.Declarations
( parseDeclaration
+ , parseDeclarationRef
, parseModule
+ , parseModuleDeclaration
, parseModulesFromFiles
, parseModuleFromFile
, parseValue
@@ -17,7 +19,7 @@ import Prelude hiding (lex)
import Control.Applicative
import Control.Arrow ((+++))
-import Control.Monad (foldM)
+import Control.Monad (foldM, join)
import Control.Monad.Error.Class (MonadError(..))
import Control.Parallel.Strategies (withStrategy, parList, rseq)
import Data.Functor (($>))
@@ -63,27 +65,41 @@ parseTypeSynonymDeclaration =
<*> many (indented *> kindedIdent)
<*> (indented *> equals *> noWildcards parsePolyType)
+parseValueWithWhereClause :: TokenParser Expr
+parseValueWithWhereClause = do
+ indented
+ value <- parseValue
+ whereClause <- P.optionMaybe $ do
+ indented
+ reserved "where"
+ indented
+ mark $ P.many1 (same *> parseLocalDeclaration)
+ return $ maybe value (`Let` value) whereClause
+
+parseValueWithIdentAndBinders :: Ident -> [Binder] -> TokenParser Declaration
+parseValueWithIdentAndBinders ident bs = do
+ value <- indented *> (
+ (\v -> [MkUnguarded v]) <$> (equals *> withSourceSpan PositionedValue parseValueWithWhereClause) <|>
+ P.many1 (GuardedExpr <$> parseGuard
+ <*> (indented *> equals
+ *> withSourceSpan PositionedValue parseValueWithWhereClause))
+ )
+ return $ ValueDeclaration ident Public bs value
+
parseValueDeclaration :: TokenParser Declaration
parseValueDeclaration = do
- name <- parseIdent
+ ident <- parseIdent
binders <- P.many parseBinderNoParens
- value <- Left <$> (indented *>
- P.many1 ((,) <$> parseGuard
- <*> (indented *> equals *> parseValueWithWhereClause)
- ))
- <|> Right <$> (indented *> equals *> parseValueWithWhereClause)
- return $ ValueDeclaration name Public binders value
+ parseValueWithIdentAndBinders ident binders
+
+parseLocalValueDeclaration :: TokenParser Declaration
+parseLocalValueDeclaration = join $ go <$> parseBinder <*> (P.many parseBinderNoParens)
where
- parseValueWithWhereClause :: TokenParser Expr
- parseValueWithWhereClause = do
- indented
- value <- parseValue
- whereClause <- P.optionMaybe $ do
- indented
- reserved "where"
- indented
- mark $ P.many1 (same *> parseLocalDeclaration)
- return $ maybe value (`Let` value) whereClause
+ go :: Binder -> [Binder] -> TokenParser Declaration
+ go (VarBinder ident) bs = parseValueWithIdentAndBinders ident bs
+ go (PositionedBinder _ _ b) bs = go b bs
+ go binder [] = BoundValueDeclaration binder <$> (indented *> equals *> parseValueWithWhereClause)
+ go _ _ = P.unexpected $ "patterns in local value declaration"
parseExternDeclaration :: TokenParser Declaration
parseExternDeclaration = reserved "foreign" *> indented *> reserved "import" *> indented *> parseExternAlt where
@@ -119,7 +135,7 @@ parseFixityDeclaration = do
<*> (reserved "as" *> parseOperator)
valueFixity fixity =
ValueFixity fixity
- <$> parseQualified ((Left <$> parseIdent) <|> (Right <$> properName))
+ <$> parseQualified ((Left <$> parseIdent) <|> (Right <$> dataConstructorName))
<*> (reserved "as" *> parseOperator)
parseImportDeclaration :: TokenParser Declaration
@@ -154,7 +170,7 @@ parseDeclarationRef =
where
parseTypeRef = do
name <- typeName
- dctors <- P.optionMaybe $ parens (symbol' ".." *> pure Nothing <|> Just <$> commaSep properName)
+ dctors <- P.optionMaybe $ parens (symbol' ".." *> pure Nothing <|> Just <$> commaSep dataConstructorName)
return $ TypeRef name (fromMaybe (Just []) dctors)
parseTypeClassDeclaration :: TokenParser Declaration
@@ -230,19 +246,25 @@ parseDeclaration = positioned (P.choice
parseLocalDeclaration :: TokenParser Declaration
parseLocalDeclaration = positioned (P.choice
[ parseTypeDeclaration
- , parseValueDeclaration
+ , parseLocalValueDeclaration
] P.<?> "local declaration")
--- | Parse a module header and a collection of declarations
-parseModule :: TokenParser Module
-parseModule = do
- comments <- readComments
- start <- P.getPosition
+-- | Parse a module declaration and its export declarations
+parseModuleDeclaration :: TokenParser (ModuleName, Maybe [DeclarationRef])
+parseModuleDeclaration = do
reserved "module"
indented
name <- moduleName
exports <- P.optionMaybe $ parens $ commaSep1 parseDeclarationRef
reserved "where"
+ pure (name, exports)
+
+-- | Parse a module header and a collection of declarations
+parseModule :: TokenParser Module
+parseModule = do
+ comments <- readComments
+ start <- P.getPosition
+ (name, exports) <- parseModuleDeclaration
decls <- mark $ do
-- TODO: extract a module header structure here, and provide a
-- parseModuleHeader function. This should allow us to speed up rebuilds
@@ -326,7 +348,7 @@ parseIdentifierAndValue =
parseAbs :: TokenParser Expr
parseAbs = do
symbol' "\\"
- args <- P.many1 (indented *> (Abs <$> (Left <$> parseIdent <|> Right <$> parseBinderNoParens)))
+ args <- P.many1 (indented *> (Abs <$> parseBinderNoParens))
indented *> rarrow
value <- parseValue
return $ toFunction args value
@@ -346,11 +368,13 @@ parseCase = Case <$> P.between (reserved "case") (indented *> reserved "of") (co
parseCaseAlternative :: TokenParser CaseAlternative
parseCaseAlternative = CaseAlternative <$> commaSep1 parseBinder
- <*> (Left <$> (indented *>
- P.many1 ((,) <$> parseGuard
- <*> (indented *> rarrow *> parseValue)
- ))
- <|> Right <$> (indented *> rarrow *> parseValue))
+ <*> (indented *> (
+ (pure . MkUnguarded) <$> (rarrow *> parseValue)
+ <|> (P.many1 (GuardedExpr <$> parseGuard
+ <*> (indented
+ *> rarrow
+ *> parseValue)
+ ))))
P.<?> "case alternative"
parseIfThenElse :: TokenParser Expr
@@ -427,7 +451,7 @@ parseDoNotationBind :: TokenParser DoNotationElement
parseDoNotationBind = DoNotationBind <$> P.try (parseBinder <* indented <* larrow) <*> parseValue
parseDoNotationElement :: TokenParser DoNotationElement
-parseDoNotationElement = P.choice
+parseDoNotationElement = withSourceSpan PositionedDoNotationElement $ P.choice
[ parseDoNotationBind
, parseDoNotationLet
, DoNotationValue <$> parseValue
@@ -515,55 +539,61 @@ parseIdentifierAndBinder =
-- | Parse a binder
parseBinder :: TokenParser Binder
parseBinder =
- withSourceSpan
- PositionedBinder
- ( P.buildExpressionParser operators
- . buildPostfixParser postfixTable
- $ parseBinderAtom
- )
+ withSourceSpan
+ PositionedBinder
+ ( P.buildExpressionParser operators
+ . buildPostfixParser postfixTable
+ $ parseBinderAtom
+ )
where
- operators =
- [ [ P.Infix (P.try (indented *> parseOpBinder P.<?> "binder operator") >>= \op ->
- return (BinaryNoParensBinder op)) P.AssocRight
+ operators =
+ [ [ P.Infix (P.try (indented *> parseOpBinder P.<?> "binder operator") >>= \op ->
+ return (BinaryNoParensBinder op)) P.AssocRight
+ ]
]
- ]
- -- TODO: parsePolyType when adding support for polymorphic types
- postfixTable = [ \b -> flip TypedBinder b <$> (indented *> doubleColon *> parseType)
- ]
+ postfixTable = [ \b -> flip TypedBinder b <$> (indented *> doubleColon *> parsePolyType) ]
- parseOpBinder :: TokenParser Binder
- parseOpBinder = OpBinder <$> parseQualified parseOperator
+ parseOpBinder :: TokenParser Binder
+ parseOpBinder = OpBinder <$> parseQualified parseOperator
parseBinderAtom :: TokenParser Binder
-parseBinderAtom = P.choice
- [ parseNullBinder
- , LiteralBinder <$> parseCharLiteral
- , LiteralBinder <$> parseStringLiteral
- , LiteralBinder <$> parseBooleanLiteral
- , parseNumberLiteral
- , parseVarOrNamedBinder
- , parseConstructorBinder
- , parseObjectBinder
- , parseArrayBinder
- , ParensInBinder <$> parens parseBinder
- ] P.<?> "binder"
+parseBinderAtom = withSourceSpan PositionedBinder
+ (P.choice
+ [ parseNullBinder
+ , LiteralBinder <$> parseCharLiteral
+ , LiteralBinder <$> parseStringLiteral
+ , LiteralBinder <$> parseBooleanLiteral
+ , parseNumberLiteral
+ , parseVarOrNamedBinder
+ , parseConstructorBinder
+ , parseObjectBinder
+ , parseArrayBinder
+ , ParensInBinder <$> parens parseBinder
+ ] P.<?> "binder")
-- | Parse a binder as it would appear in a top level declaration
parseBinderNoParens :: TokenParser Binder
-parseBinderNoParens = P.choice
- [ parseNullBinder
- , LiteralBinder <$> parseCharLiteral
- , LiteralBinder <$> parseStringLiteral
- , LiteralBinder <$> parseBooleanLiteral
- , parseNumberLiteral
- , parseVarOrNamedBinder
- , parseNullaryConstructorBinder
- , parseObjectBinder
- , parseArrayBinder
- , ParensInBinder <$> parens parseBinder
- ] P.<?> "binder"
+parseBinderNoParens = withSourceSpan PositionedBinder
+ (P.choice
+ [ parseNullBinder
+ , LiteralBinder <$> parseCharLiteral
+ , LiteralBinder <$> parseStringLiteral
+ , LiteralBinder <$> parseBooleanLiteral
+ , parseNumberLiteral
+ , parseVarOrNamedBinder
+ , parseNullaryConstructorBinder
+ , parseObjectBinder
+ , parseArrayBinder
+ , ParensInBinder <$> parens parseBinder
+ ] P.<?> "binder")
-- | Parse a guard
-parseGuard :: TokenParser Guard
-parseGuard = pipe *> indented *> parseValue
+parseGuard :: TokenParser [Guard]
+parseGuard =
+ pipe *> indented *> P.sepBy1 (parsePatternGuard <|> parseConditionGuard) comma
+ where
+ parsePatternGuard =
+ PatternGuard <$> P.try (parseBinder <* indented <* larrow) <*> parseValue
+ parseConditionGuard =
+ ConditionGuard <$> parseValue
diff --git a/src/Language/PureScript/Parser/Kinds.hs b/src/Language/PureScript/Parser/Kinds.hs
index a0517bf..06c29f5 100644
--- a/src/Language/PureScript/Parser/Kinds.hs
+++ b/src/Language/PureScript/Parser/Kinds.hs
@@ -5,7 +5,6 @@ module Language.PureScript.Parser.Kinds (parseKind) where
import Prelude.Compat
-import Language.PureScript.Environment
import Language.PureScript.Kinds
import Language.PureScript.Parser.Common
import Language.PureScript.Parser.Lexer
@@ -14,21 +13,24 @@ import qualified Text.Parsec as P
import qualified Text.Parsec.Expr as P
parseStar :: TokenParser Kind
-parseStar = const kindType <$> symbol' "*"
+parseStar = symbol' "*" *>
+ P.parserFail "The `*` symbol is no longer used for the kind of types.\n The new equivalent is the named kind `Type`."
parseBang :: TokenParser Kind
-parseBang = const kindEffect <$> symbol' "!"
+parseBang = symbol' "!" *>
+ P.parserFail "The `!` symbol is no longer used for the kind of effects.\n The new equivalent is the named kind `Effect`, defined in `Control.Monad.Eff` in the `purescript-eff` library."
parseNamedKind :: TokenParser Kind
parseNamedKind = NamedKind <$> parseQualified kindName
parseKindAtom :: TokenParser Kind
-parseKindAtom = indented *> P.choice
- [ parseStar
- , parseBang
- , parseNamedKind
- , parens parseKind
- ]
+parseKindAtom =
+ indented *> P.choice
+ [ parseStar
+ , parseBang
+ , parseNamedKind
+ , parens parseKind
+ ]
-- |
-- Parse a kind
diff --git a/src/Language/PureScript/Parser/Lexer.hs b/src/Language/PureScript/Parser/Lexer.hs
index 744519c..9b62cc2 100644
--- a/src/Language/PureScript/Parser/Lexer.hs
+++ b/src/Language/PureScript/Parser/Lexer.hs
@@ -6,6 +6,7 @@ module Language.PureScript.Parser.Lexer
, Token()
, TokenParser()
, lex
+ , lexLenient
, anyToken
, token
, match
@@ -173,6 +174,14 @@ updatePositions (x:xs) = x : zipWith update (x:xs) xs
parseTokens :: Lexer u [PositionedToken]
parseTokens = whitespace *> P.many parsePositionedToken <* P.skipMany parseComment <* P.eof
+-- | Lexes the given file, and on encountering a parse error, returns the
+-- progress made up to that point, instead of returning an error
+lexLenient :: FilePath -> Text -> Either P.ParseError [PositionedToken]
+lexLenient f s = updatePositions <$> P.parse parseTokensLenient f s
+
+parseTokensLenient :: Lexer u [PositionedToken]
+parseTokensLenient = whitespace *> P.many parsePositionedToken <* P.skipMany parseComment
+
whitespace :: Lexer u ()
whitespace = P.skipMany (P.satisfy isSpace)
diff --git a/src/Language/PureScript/Parser/Types.hs b/src/Language/PureScript/Parser/Types.hs
index 403f8ff..2cf90da 100644
--- a/src/Language/PureScript/Parser/Types.hs
+++ b/src/Language/PureScript/Parser/Types.hs
@@ -9,6 +9,7 @@ import Prelude.Compat
import Control.Monad (when, unless)
import Control.Applicative ((<|>))
+import Data.Functor (($>))
import qualified Data.Text as T
import Language.PureScript.AST.SourcePos
@@ -68,13 +69,13 @@ parseTypeAtom = indented *> P.choice
, ParensInType <$> parens parsePolyType
]
-parseConstrainedType :: TokenParser Type
+parseConstrainedType :: TokenParser ([Constraint], Type)
parseConstrainedType = do
- constraints <- P.try (return <$> parseConstraint) <|> parens (commaSep1 parseConstraint)
+ constraints <- parens (commaSep1 parseConstraint) <|> pure <$> parseConstraint
_ <- rfatArrow
indented
ty <- parseType
- return $ ConstrainedType constraints ty
+ return (constraints, ty)
where
parseConstraint = do
className <- parseQualified properName
@@ -82,14 +83,34 @@ parseConstrainedType = do
ty <- P.many parseTypeAtom
return (Constraint className ty Nothing)
+-- This is here to improve the error message when the user
+-- tries to use the old style constraint contexts.
+-- TODO: Remove this before 1.0
+typeOrConstrainedType :: TokenParser Type
+typeOrConstrainedType = do
+ e <- P.try (Left <$> parseConstrainedType) <|> Right <$> parseTypeAtom
+ case e of
+ Left ([c], ty) -> pure (ConstrainedType c ty)
+ Left _ ->
+ P.unexpected $
+ unlines [ "comma in constraints."
+ , ""
+ , "Class constraints in type annotations can no longer be grouped in parentheses."
+ , "Each constraint should now be separated by `=>`, for example:"
+ , " `(Applicative f, Semigroup a) => a -> f a -> f a`"
+ , " would now be written as:"
+ , " `Applicative f => Semigroup a => a -> f a -> f a`."
+ ]
+ Right ty -> pure ty
+
parseAnyType :: TokenParser Type
-parseAnyType = P.buildExpressionParser operators (buildPostfixParser postfixTable (P.try parseConstrainedType <|> parseTypeAtom)) P.<?> "type"
+parseAnyType = P.buildExpressionParser operators (buildPostfixParser postfixTable typeOrConstrainedType) P.<?> "type"
where
operators = [ [ P.Infix (return TypeApp) P.AssocLeft ]
, [ P.Infix (P.try (parseQualified parseOperator) >>= \ident ->
return (BinaryNoParensType (TypeOp ident))) P.AssocRight
]
- , [ P.Infix (rarrow *> return function) P.AssocRight ]
+ , [ P.Infix (rarrow $> function) P.AssocRight ]
]
postfixTable = [ \t -> KindedType t <$> (indented *> doubleColon *> parseKind)
]
diff --git a/src/Language/PureScript/Pretty.hs b/src/Language/PureScript/Pretty.hs
index e9affc1..b993595 100644
--- a/src/Language/PureScript/Pretty.hs
+++ b/src/Language/PureScript/Pretty.hs
@@ -1,17 +1,12 @@
--- |
--- A collection of pretty printers for core data types:
+-- | A collection of pretty printers for core data types:
--
--- [@Language.PureScript.Pretty.Kinds@] Pretty printer for kinds
+-- * [@Language.PureScript.Pretty.Kinds@] Pretty printer for kinds
--
--- [@Language.PureScript.Pretty.Values@] Pretty printer for values
---
--- [@Language.PureScript.Pretty.Types@] Pretty printer for types
---
--- [@Language.PureScript.Pretty.JS@] Pretty printer for values, used for code generation
+-- * [@Language.PureScript.Pretty.Values@] Pretty printer for values
--
+-- * [@Language.PureScript.Pretty.Types@] Pretty printer for types
module Language.PureScript.Pretty (module P) where
-import Language.PureScript.Pretty.JS as P
import Language.PureScript.Pretty.Kinds as P
import Language.PureScript.Pretty.Types as P
import Language.PureScript.Pretty.Values as P
diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs
index a258199..bee62db 100644
--- a/src/Language/PureScript/Pretty/Types.hs
+++ b/src/Language/PureScript/Pretty/Types.hs
@@ -37,10 +37,9 @@ import Text.PrettyPrint.Boxes hiding ((<+>))
-- TODO(Christoph): get rid of T.unpack s
-constraintsAsBox :: TypeRenderOptions -> [Constraint] -> Box -> Box
-constraintsAsBox tro constraints ty = case constraints of
- [con] -> text "(" <> constraintAsBox con `before` (") " <> text doubleRightArrow <> " " <> ty)
- xs -> vcat left (zipWith (\i con -> text (if i == 0 then "( " else ", ") <> constraintAsBox con) [0 :: Int ..] xs) `before` (") " <> text doubleRightArrow <> " " <> ty)
+constraintsAsBox :: TypeRenderOptions -> Constraint -> Box -> Box
+constraintsAsBox tro con ty =
+ constraintAsBox con `before` (" " <> text doubleRightArrow <> " " <> ty)
where
doubleRightArrow = if troUnicode tro then "⇒" else "=>"
@@ -105,7 +104,7 @@ insertPlaceholders = everywhereOnTypesTopDown convertForAlls . everywhereOnTypes
go idents other = PrettyPrintForAll idents other
convertForAlls other = other
-constrained :: Pattern () Type ([Constraint], Type)
+constrained :: Pattern () Type (Constraint, Type)
constrained = mkPattern match
where
match (ConstrainedType deps ty) = Just (deps, ty)
diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs
index 4cff7ee..f48a83f 100644
--- a/src/Language/PureScript/Pretty/Values.hs
+++ b/src/Language/PureScript/Pretty/Values.hs
@@ -66,8 +66,7 @@ prettyPrintValue d (ObjectUpdateNested o ps) = prettyPrintValueAtom (d - 1) o `b
printNode (key, Leaf val) = prettyPrintUpdateEntry d key val
printNode (key, Branch val) = textT (prettyPrintObjectKey key) `beforeWithSpace` prettyPrintUpdate val
prettyPrintValue d (App val arg) = prettyPrintValueAtom (d - 1) val `beforeWithSpace` prettyPrintValueAtom (d - 1) arg
-prettyPrintValue d (Abs (Left arg) val) = text ('\\' : T.unpack (showIdent arg) ++ " -> ") // moveRight 2 (prettyPrintValue (d - 1) val)
-prettyPrintValue d (Abs (Right arg) val) = text ('\\' : T.unpack (prettyPrintBinder arg) ++ " -> ") // moveRight 2 (prettyPrintValue (d - 1) val)
+prettyPrintValue d (Abs arg val) = text ('\\' : T.unpack (prettyPrintBinder arg) ++ " -> ") // moveRight 2 (prettyPrintValue (d - 1) val)
prettyPrintValue d (TypeClassDictionaryConstructorApp className ps) =
text (T.unpack (runProperName (disqualify className)) ++ " ") <> prettyPrintValueAtom (d - 1) ps
prettyPrintValue d (Case values binders) =
@@ -125,12 +124,12 @@ prettyPrintDeclaration :: Int -> Declaration -> Box
prettyPrintDeclaration d _ | d < 0 = ellipsis
prettyPrintDeclaration _ (TypeDeclaration ident ty) =
text (T.unpack (showIdent ident) ++ " :: ") <> typeAsBox ty
-prettyPrintDeclaration d (ValueDeclaration ident _ [] (Right val)) =
+prettyPrintDeclaration d (ValueDeclaration ident _ [] [GuardedExpr [] val]) =
text (T.unpack (showIdent ident) ++ " = ") <> prettyPrintValue (d - 1) val
prettyPrintDeclaration d (BindingGroupDeclaration ds) =
vsep 1 left (map (prettyPrintDeclaration (d - 1) . toDecl) ds)
where
- toDecl (nm, t, e) = ValueDeclaration nm t [] (Right e)
+ toDecl (nm, t, e) = ValueDeclaration nm t [] [GuardedExpr [] e]
prettyPrintDeclaration d (PositionedDeclaration _ _ decl) = prettyPrintDeclaration d decl
prettyPrintDeclaration _ _ = internalError "Invalid argument to prettyPrintDeclaration"
@@ -139,18 +138,19 @@ prettyPrintCaseAlternative d _ | d < 0 = ellipsis
prettyPrintCaseAlternative d (CaseAlternative binders result) =
text (T.unpack (T.unwords (map prettyPrintBinderAtom binders))) <> prettyPrintResult result
where
- prettyPrintResult :: Either [(Guard, Expr)] Expr -> Box
- prettyPrintResult (Left gs) =
+ prettyPrintResult :: [GuardedExpr] -> Box
+ prettyPrintResult [GuardedExpr [] v] = text " -> " <> prettyPrintValue (d - 1) v
+ prettyPrintResult gs =
vcat left (map prettyPrintGuardedValue gs)
- prettyPrintResult (Right v) = text " -> " <> prettyPrintValue (d - 1) v
- prettyPrintGuardedValue :: (Guard, Expr) -> Box
- prettyPrintGuardedValue (grd, val) = foldl1 before
+ prettyPrintGuardedValue :: GuardedExpr -> Box
+ prettyPrintGuardedValue (GuardedExpr [ConditionGuard grd] val) = foldl1 before
[ text " | "
, prettyPrintValue (d - 1) grd
, text " -> "
, prettyPrintValue (d - 1) val
]
+ prettyPrintGuardedValue _ = internalError "There should only be ConditionGuards after desugaring cases"
prettyPrintDoNotationElement :: Int -> DoNotationElement -> Box
prettyPrintDoNotationElement d _ | d < 0 = ellipsis
diff --git a/src/Language/PureScript/Publish.hs b/src/Language/PureScript/Publish.hs
index 2af3f12..a1ec686 100644
--- a/src/Language/PureScript/Publish.hs
+++ b/src/Language/PureScript/Publish.hs
@@ -15,7 +15,7 @@ module Language.PureScript.Publish
, getGitWorkingTreeStatus
, checkCleanWorkingTree
, getVersionFromGitTag
- , getBowerRepositoryInfo
+ , getManifestRepositoryInfo
, getModules
, getResolvedDependencies
) where
@@ -24,29 +24,25 @@ import Protolude hiding (stdin)
import Control.Arrow ((***))
import Control.Category ((>>>))
-import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
import Control.Monad.Writer.Strict (MonadWriter, WriterT, runWriterT, tell)
-import Data.Aeson.BetterErrors (Parse, parse, keyMay, eachInObjectWithKey, eachInObject, key, keyOrDefault, asBool, asText)
+import Data.Aeson.BetterErrors (Parse, parse, keyMay, eachInObjectWithKey, eachInObject, key, keyOrDefault, asBool, asString, asText)
+import qualified Data.ByteString.Lazy as BL
import Data.Char (isSpace)
import Data.String (String, lines)
import Data.List (stripPrefix, (\\), nubBy)
import Data.List.NonEmpty (NonEmpty(..))
-import Data.List.Split (splitOn)
import qualified Data.Text as T
-import qualified Data.Text.Lazy as TL
-import qualified Data.Text.Lazy.Encoding as TL
import Data.Time.Clock (UTCTime)
+import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import Data.Version
import qualified Data.SPDX as SPDX
-import System.Directory (doesFileExist, findExecutable)
-import System.FilePath (pathSeparator)
+import System.Directory (doesFileExist)
+import System.FilePath.Glob (globDir1)
import System.Process (readProcess)
-import qualified System.FilePath.Glob as Glob
-import qualified System.Info
-import Web.Bower.PackageMeta (PackageMeta(..), BowerError(..), PackageName, runPackageName, parsePackageName, Repository(..))
+import Web.Bower.PackageMeta (PackageMeta(..), PackageName, parsePackageName, Repository(..))
import qualified Web.Bower.PackageMeta as Bower
import Language.PureScript.Publish.ErrorsWarnings
@@ -72,14 +68,16 @@ defaultPublishOptions = PublishOptions
-- | Attempt to retrieve package metadata from the current directory.
-- Calls exitFailure if no package metadata could be retrieved.
-unsafePreparePackage :: PublishOptions -> IO D.UploadedPackage
-unsafePreparePackage opts = either (\e -> printError e >> exitFailure) pure =<< preparePackage opts
+unsafePreparePackage :: FilePath -> FilePath -> PublishOptions -> IO D.UploadedPackage
+unsafePreparePackage manifestFile resolutionsFile opts =
+ either (\e -> printError e >> exitFailure) pure
+ =<< preparePackage manifestFile resolutionsFile opts
-- | Attempt to retrieve package metadata from the current directory.
-- Returns a PackageError on failure
-preparePackage :: PublishOptions -> IO (Either PackageError D.UploadedPackage)
-preparePackage opts =
- runPrepareM (preparePackage' opts)
+preparePackage :: FilePath -> FilePath -> PublishOptions -> IO (Either PackageError D.UploadedPackage)
+preparePackage manifestFile resolutionsFile opts =
+ runPrepareM (preparePackage' manifestFile resolutionsFile opts)
>>= either (pure . Left) (fmap Right . handleWarnings)
where
@@ -119,32 +117,36 @@ otherError = throwError . OtherError
catchLeft :: Applicative f => Either a b -> (a -> f b) -> f b
catchLeft a f = either f pure a
-preparePackage' :: PublishOptions -> PrepareM D.UploadedPackage
-preparePackage' opts = do
- unlessM (liftIO (doesFileExist "bower.json")) (userError BowerJSONNotFound)
+preparePackage' :: FilePath -> FilePath -> PublishOptions -> PrepareM D.UploadedPackage
+preparePackage' manifestFile resolutionsFile opts = do
+ unlessM (liftIO (doesFileExist manifestFile)) (userError PackageManifestNotFound)
checkCleanWorkingTree opts
- pkgMeta <- liftIO (Bower.decodeFile "bower.json")
- >>= flip catchLeft (userError . CouldntDecodeBowerJSON)
+ pkgMeta <- liftIO (Bower.decodeFile manifestFile)
+ >>= flip catchLeft (userError . CouldntDecodePackageManifest)
checkLicense pkgMeta
(pkgVersionTag, pkgVersion) <- publishGetVersion opts
pkgTagTime <- Just <$> publishGetTagTime opts pkgVersionTag
- pkgGithub <- getBowerRepositoryInfo pkgMeta
- (pkgModules, pkgModuleMap) <- getModules
+ pkgGithub <- getManifestRepositoryInfo pkgMeta
let declaredDeps = map fst (bowerDependencies pkgMeta ++
bowerDevDependencies pkgMeta)
- pkgResolvedDependencies <- getResolvedDependencies declaredDeps
+ resolvedDeps <- getResolvedDependencies resolutionsFile declaredDeps
+
+ (pkgModules, pkgModuleMap) <- getModules (map (second fst) resolvedDeps)
let pkgUploader = D.NotYetKnown
let pkgCompilerVersion = P.version
+ let pkgResolvedDependencies = map (second snd) resolvedDeps
return D.Package{..}
-getModules :: PrepareM ([D.Module], Map P.ModuleName PackageName)
-getModules = do
- (inputFiles, depsFiles) <- liftIO getInputAndDepsFiles
+getModules
+ :: [(PackageName, FilePath)]
+ -> PrepareM ([D.Module], Map P.ModuleName PackageName)
+getModules paths = do
+ (inputFiles, depsFiles) <- liftIO (getInputAndDepsFiles paths)
(modules', moduleMap) <- parseFilesInPackages inputFiles depsFiles
case runExcept (D.convertModulesInPackage modules' moduleMap) of
@@ -194,13 +196,13 @@ getVersionFromGitTag = do
-- | Given a git tag, get the time it was created.
getTagTime :: Text -> PrepareM UTCTime
getTagTime tag = do
- out <- readProcess' "git" ["show", T.unpack tag, "--no-patch", "--format=%aI"] ""
- case mapMaybe D.parseTime (lines out) of
- [t] -> pure t
+ out <- readProcess' "git" ["log", "-1", "--format=%ct", T.unpack tag] ""
+ case mapMaybe readMaybe (lines out) of
+ [t] -> pure . posixSecondsToUTCTime . fromInteger $ t
_ -> internalError (CouldntParseGitTagDate tag)
-getBowerRepositoryInfo :: PackageMeta -> PrepareM (D.GithubUser, D.GithubRepo)
-getBowerRepositoryInfo = either (userError . BadRepositoryField) return . tryExtract
+getManifestRepositoryInfo :: PackageMeta -> PrepareM (D.GithubUser, D.GithubRepo)
+getManifestRepositoryInfo = either (userError . BadRepositoryField) return . tryExtract
where
tryExtract pkgMeta =
case bowerRepository pkgMeta of
@@ -258,12 +260,9 @@ readProcess' prog args stdin = do
data DependencyStatus
= Missing
- -- ^ Listed in bower.json, but not installed.
+ -- ^ Listed in package manifest, but not installed.
| NoResolution
- -- ^ In the output of `bower list --json --offline`, there was no
- -- _resolution key. This can be caused by adding the dependency using
- -- `bower link`, or simply copying it into bower_components instead of
- -- installing it normally.
+ -- ^ In the resolutions file, there was no _resolution key.
| ResolvedOther Text
-- ^ Resolved, but to something other than a version. The Text argument
-- is the resolution type. The values it can take that I'm aware of are
@@ -273,10 +272,10 @@ data DependencyStatus
-- "v0.1.0").
deriving (Show, Eq)
--- Go through all bower dependencies which contain purescript code, and
+-- Go through all dependencies which contain purescript code, and
-- extract their versions.
--
--- In the case where a bower dependency is taken from a particular version,
+-- In the case where a dependency is taken from a particular version,
-- that's easy; take that version. In any other case (eg, a branch, or a commit
-- sha) we print a warning that documentation links will not work, and avoid
-- linking to documentation for any types from that package.
@@ -286,10 +285,10 @@ data DependencyStatus
-- probably for a reason. However, docs are only ever available for released
-- versions. Therefore there will probably be no version of the docs which is
-- appropriate to link to, and we should omit links.
-getResolvedDependencies :: [PackageName] -> PrepareM [(PackageName, Version)]
-getResolvedDependencies declaredDeps = do
- bower <- findBowerExecutable
- depsBS <- packUtf8 <$> readProcess' bower ["list", "--json", "--offline"] ""
+getResolvedDependencies :: FilePath -> [PackageName] -> PrepareM [(PackageName, (FilePath, Version))]
+getResolvedDependencies resolutionsFile declaredDeps = do
+ unlessM (liftIO (doesFileExist resolutionsFile)) (userError ResolutionsFileNotFound)
+ depsBS <- liftIO (BL.readFile resolutionsFile)
-- Check for undeclared dependencies
toplevels <- catchJSON (parse asToplevelDependencies depsBS)
@@ -299,111 +298,93 @@ getResolvedDependencies declaredDeps = do
handleDeps deps
where
- packUtf8 = TL.encodeUtf8 . TL.pack
- catchJSON = flip catchLeft (internalError . JSONError FromBowerList)
-
-findBowerExecutable :: PrepareM String
-findBowerExecutable = do
- mname <- liftIO . runMaybeT . msum . map (MaybeT . findExecutable) $ names
- maybe (userError (BowerExecutableNotFound names)) return mname
- where
- names = case System.Info.os of
- "mingw32" -> ["bower", "bower.cmd"]
- _ -> ["bower"]
+ catchJSON = flip catchLeft (internalError . JSONError FromResolutions)
--- | Extracts all dependencies and their versions from
--- `bower list --json --offline`
-asResolvedDependencies :: Parse BowerError [(PackageName, DependencyStatus)]
+-- | Extracts all dependencies and their versions from a "resolutions" file, which
+-- is based on the output of `bower list --json --offline`
+asResolvedDependencies :: Parse D.ManifestError [(PackageName, (Maybe FilePath, DependencyStatus))]
asResolvedDependencies = nubBy ((==) `on` fst) <$> go
where
go =
fmap (fromMaybe []) $
keyMay "dependencies" $
- (++) <$> eachInObjectWithKey parsePackageName asDependencyStatus
+ (++) <$> eachInObjectWithKey parsePackageName asDirectoryAndDependencyStatus
<*> (concatMap snd <$> eachInObject asResolvedDependencies)
--- | Extracts only the top level dependency names from the output of
--- `bower list --json --offline`
-asToplevelDependencies :: Parse BowerError [PackageName]
+-- | Extracts only the top level dependency names from a resolutions file.
+asToplevelDependencies :: Parse D.ManifestError [PackageName]
asToplevelDependencies =
fmap (map fst) $
key "dependencies" $
eachInObjectWithKey parsePackageName (return ())
-asDependencyStatus :: Parse e DependencyStatus
-asDependencyStatus = do
+asDirectoryAndDependencyStatus :: Parse e (Maybe FilePath, DependencyStatus)
+asDirectoryAndDependencyStatus = do
isMissing <- keyOrDefault "missing" False asBool
if isMissing
then
- return Missing
- else
- key "pkgMeta" $
+ return (Nothing, Missing)
+ else do
+ directory <- key "canonicalDir" asString
+ status <- key "pkgMeta" $
keyOrDefault "_resolution" NoResolution $ do
type_ <- key "type" asText
case type_ of
"version" -> ResolvedVersion <$> key "tag" asText
other -> return (ResolvedOther other)
+ return (Just directory, status)
warnUndeclared :: [PackageName] -> [PackageName] -> PrepareM ()
warnUndeclared declared actual =
traverse_ (warn . UndeclaredDependency) (actual \\ declared)
-handleDeps ::
- [(PackageName, DependencyStatus)] -> PrepareM [(PackageName, Version)]
+handleDeps
+ :: [(PackageName, (Maybe FilePath, DependencyStatus))]
+ -> PrepareM [(PackageName, (FilePath, Version))]
handleDeps deps = do
- let (missing, noVersion, installed) = partitionDeps deps
+ let (missing, noVersion, installed, missingPath) = partitionDeps deps
case missing of
(x:xs) ->
userError (MissingDependencies (x :| xs))
[] -> do
traverse_ (warn . NoResolvedVersion) noVersion
- withVersions <- catMaybes <$> traverse tryExtractVersion' installed
- filterM (liftIO . isPureScript . bowerDir . fst) withVersions
+ traverse_ (warn . MissingPath) missingPath
+ catMaybes <$> traverse tryExtractVersion' installed
where
- partitionDeps = foldr go ([], [], [])
- go (pkgName, d) (ms, os, is) =
+ partitionDeps = foldr go ([], [], [], [])
+ go (pkgName, (Nothing, _)) (ms, os, is, mp) =
+ (ms, os, is, pkgName : mp)
+ go (pkgName, (Just path, d)) (ms, os, is, mp) =
case d of
- Missing -> (pkgName : ms, os, is)
- NoResolution -> (ms, pkgName : os, is)
- ResolvedOther _ -> (ms, pkgName : os, is)
- ResolvedVersion v -> (ms, os, (pkgName, v) : is)
-
- bowerDir pkgName = T.unpack $ "bower_components/" <> runPackageName pkgName
+ Missing -> (pkgName : ms, os, is, mp)
+ NoResolution -> (ms, pkgName : os, is, mp)
+ ResolvedOther _ -> (ms, pkgName : os, is, mp)
+ ResolvedVersion v -> (ms, os, (pkgName, (path, v)) : is, mp)
-- Try to extract a version, and warn if unsuccessful.
- tryExtractVersion' :: (PackageName, Text) -> PrepareM (Maybe (PackageName, Version))
+ tryExtractVersion'
+ :: (PackageName, (extra, Text))
+ -> PrepareM (Maybe (PackageName, (extra, Version)))
tryExtractVersion' pair =
- maybe (warn (UnacceptableVersion pair) >> return Nothing)
+ maybe (warn (UnacceptableVersion (fmap snd pair)) >> return Nothing)
(return . Just)
(tryExtractVersion pair)
-tryExtractVersion :: (PackageName, Text) -> Maybe (PackageName, Version)
-tryExtractVersion (pkgName, tag) =
+tryExtractVersion
+ :: (PackageName, (extra, Text))
+ -> Maybe (PackageName, (extra, Version))
+tryExtractVersion (pkgName, (extra, tag)) =
let tag' = fromMaybe tag (T.stripPrefix "v" tag)
- in (pkgName,) <$> D.parseVersion' (T.unpack tag')
-
--- | Returns whether it looks like there is a purescript package checked out
--- in the given directory.
-isPureScript :: FilePath -> IO Bool
-isPureScript dir = do
- files <- Glob.globDir1 purescriptSourceFiles dir
- return (not (null files))
+ in (pkgName,) . (extra,) <$> D.parseVersion' (T.unpack tag')
-getInputAndDepsFiles :: IO ([FilePath], [(PackageName, FilePath)])
-getInputAndDepsFiles = do
+getInputAndDepsFiles
+ :: [(PackageName, FilePath)]
+ -> IO ([FilePath], [(PackageName, FilePath)])
+getInputAndDepsFiles depPaths = do
inputFiles <- globRelative purescriptSourceFiles
- depsFiles' <- globRelative purescriptDepsFiles
- return (inputFiles, mapMaybe withPackageName depsFiles')
-
-withPackageName :: FilePath -> Maybe (PackageName, FilePath)
-withPackageName fp = (,fp) <$> getPackageName fp
-
-getPackageName :: FilePath -> Maybe PackageName
-getPackageName fp = do
- let xs = splitOn [pathSeparator] fp
- ys <- stripPrefix ["bower_components"] xs
- y <- headMay ys
- case Bower.mkPackageName (T.pack y) of
- Right name -> Just name
- Left _ -> Nothing
+ let handleDep (pkgName, path) = do
+ depFiles <- globDir1 purescriptSourceFiles path
+ return (map (pkgName,) depFiles)
+ depFiles <- concat <$> traverse handleDep depPaths
+ return (inputFiles, depFiles)
diff --git a/src/Language/PureScript/Publish/ErrorsWarnings.hs b/src/Language/PureScript/Publish/ErrorsWarnings.hs
index c2f8225..e62b0a2 100644
--- a/src/Language/PureScript/Publish/ErrorsWarnings.hs
+++ b/src/Language/PureScript/Publish/ErrorsWarnings.hs
@@ -18,7 +18,7 @@ import Prelude.Compat
import Control.Exception (IOException)
import Data.Aeson.BetterErrors (ParseError, displayError)
-import Data.List (intersperse, intercalate)
+import Data.List (intersperse)
import Data.List.NonEmpty (NonEmpty(..))
import Data.Maybe
import Data.Monoid
@@ -27,10 +27,11 @@ import qualified Data.List.NonEmpty as NonEmpty
import Data.Text (Text)
import qualified Data.Text as T
+import Language.PureScript.Docs.Types (ManifestError)
import Language.PureScript.Publish.BoxesHelpers
import qualified Language.PureScript as P
-import Web.Bower.PackageMeta (BowerError, PackageName, runPackageName, showBowerError)
+import Web.Bower.PackageMeta (PackageName, runPackageName, showBowerError)
import qualified Web.Bower.PackageMeta as Bower
-- | An error which meant that it was not possible to retrieve metadata for a
@@ -46,13 +47,14 @@ data PackageWarning
| UndeclaredDependency PackageName
| UnacceptableVersion (PackageName, Text)
| DirtyWorkingTree_Warn
+ | MissingPath PackageName
deriving (Show)
-- | An error that should be fixed by the user.
data UserError
- = BowerJSONNotFound
- | BowerExecutableNotFound [String] -- list of executable names tried
- | CouldntDecodeBowerJSON (ParseError BowerError)
+ = PackageManifestNotFound
+ | ResolutionsFileNotFound
+ | CouldntDecodePackageManifest (ParseError ManifestError)
| TagMustBeCheckedOut
| AmbiguousVersions [Version] -- Invariant: should contain at least two elements
| BadRepositoryField RepositoryFieldError
@@ -72,13 +74,13 @@ data RepositoryFieldError
-- | An error that probably indicates a bug in this module.
data InternalError
- = JSONError JSONSource (ParseError BowerError)
+ = JSONError JSONSource (ParseError ManifestError)
| CouldntParseGitTagDate Text
deriving (Show)
data JSONSource
= FromFile FilePath
- | FromBowerList
+ | FromResolutions
deriving (Show)
data OtherError
@@ -121,24 +123,19 @@ renderError err =
displayUserError :: UserError -> Box
displayUserError e = case e of
- BowerJSONNotFound ->
+ PackageManifestNotFound ->
para (
- "The bower.json file was not found. Please create one, or run " ++
+ "The package manifest file was not found. Please create one, or run " ++
"`pulp init`."
)
- BowerExecutableNotFound names ->
- para (concat
- [ "The Bower executable was not found (tried: ", format names, "). Please"
- , " ensure that bower is installed and on your PATH."
- ])
- where
- format = intercalate ", " . map show
- CouldntDecodeBowerJSON err ->
+ ResolutionsFileNotFound ->
+ para "The resolutions file was not found."
+ CouldntDecodePackageManifest err ->
vcat
- [ para "There was a problem with your bower.json file:"
+ [ para "There was a problem with your package manifest file:"
, indented (vcat (map (para . T.unpack) (displayError showBowerError err)))
, spacer
- , para "Please ensure that your bower.json file is valid."
+ , para "Please ensure that your package manifest file is valid."
]
TagMustBeCheckedOut ->
vcat
@@ -174,7 +171,7 @@ displayUserError e = case e of
NoLicenseSpecified ->
vcat $
[ para (concat
- [ "No license is specified in bower.json. Please add one, using the "
+ [ "No license is specified in package manifest. Please add one, using the "
, "SPDX license expression format. For example, any of the "
, "following would be acceptable:"
])
@@ -195,7 +192,7 @@ displayUserError e = case e of
InvalidLicense ->
vcat $
[ para (concat
- [ "The license specified in bower.json is not a valid SPDX license "
+ [ "The license specified in package manifest is not a valid SPDX license "
, "expression. Please use the SPDX license expression format. For "
, "example, any of the following would be acceptable:"
])
@@ -207,20 +204,13 @@ displayUserError e = case e of
pl a b = if singular then b else a
do_ = pl "do" "does"
dependencies = pl "dependencies" "dependency"
- them = pl "them" "it"
in vcat $
[ para (concat
- [ "The following Bower ", dependencies, " ", do_, " not appear to be "
+ [ "The following ", dependencies, " ", do_, " not appear to be "
, "installed:"
])
] ++
bulletedListT runPackageName (NonEmpty.toList pkgs)
- ++
- [ spacer
- , para (concat
- [ "Please install ", them, " first, by running `bower install`."
- ])
- ]
CompileError err ->
vcat
[ para "Compile error:"
@@ -247,7 +237,7 @@ displayRepositoryError err = case err of
RepositoryFieldMissing ->
vcat
[ para (concat
- [ "The 'repository' field is not present in your bower.json file. "
+ [ "The 'repository' field is not present in your package manifest file. "
, "Without this information, Pursuit would not be able to generate "
, "source links in your package's documentation. Please add one - like "
, "this, for example:"
@@ -263,21 +253,21 @@ displayRepositoryError err = case err of
]
BadRepositoryType ty ->
para (concat
- [ "In your bower.json file, the repository type is currently listed as "
+ [ "In your package manifest file, the repository type is currently listed as "
, "\"" ++ T.unpack ty ++ "\". Currently, only git repositories are supported. "
, "Please publish your code in a git repository, and then update the "
- , "repository type in your bower.json file to \"git\"."
+ , "repository type in your package manifest file to \"git\"."
])
NotOnGithub ->
vcat
[ para (concat
- [ "The repository url in your bower.json file does not point to a "
+ [ "The repository url in your package manifest file does not point to a "
, "GitHub repository. Currently, Pursuit does not support packages "
, "which are not hosted on GitHub."
])
, spacer
, para (concat
- [ "Please update your bower.json file to point to a GitHub repository. "
+ [ "Please update your package manifest file to point to a GitHub repository. "
, "Alternatively, if you would prefer not to host your package on "
, "GitHub, please open an issue:"
])
@@ -298,8 +288,8 @@ displayJSONSource :: JSONSource -> String
displayJSONSource s = case s of
FromFile fp ->
"in file " ++ show fp
- FromBowerList ->
- "in the output of `bower list --json --offline`"
+ FromResolutions ->
+ "in resolutions file"
displayOtherError :: OtherError -> Box
displayOtherError e = case e of
@@ -317,23 +307,25 @@ data CollectedWarnings = CollectedWarnings
, undeclaredDependencies :: [PackageName]
, unacceptableVersions :: [(PackageName, Text)]
, dirtyWorkingTree :: Any
+ , missingPaths :: [PackageName]
}
deriving (Show, Eq, Ord)
instance Monoid CollectedWarnings where
- mempty = CollectedWarnings mempty mempty mempty mempty
- mappend (CollectedWarnings as bs cs d)
- (CollectedWarnings as' bs' cs' d') =
- CollectedWarnings (as <> as') (bs <> bs') (cs <> cs') (d <> d')
+ mempty = CollectedWarnings mempty mempty mempty mempty mempty
+ mappend (CollectedWarnings as bs cs d es)
+ (CollectedWarnings as' bs' cs' d' es') =
+ CollectedWarnings (as <> as') (bs <> bs') (cs <> cs') (d <> d') (es <> es')
collectWarnings :: [PackageWarning] -> CollectedWarnings
collectWarnings = foldMap singular
where
singular w = case w of
- NoResolvedVersion pn -> CollectedWarnings [pn] mempty mempty mempty
- UndeclaredDependency pn -> CollectedWarnings mempty [pn] mempty mempty
- UnacceptableVersion t -> CollectedWarnings mempty mempty [t] mempty
- DirtyWorkingTree_Warn -> CollectedWarnings mempty mempty mempty (Any True)
+ NoResolvedVersion pn -> CollectedWarnings [pn] mempty mempty mempty mempty
+ UndeclaredDependency pn -> CollectedWarnings mempty [pn] mempty mempty mempty
+ UnacceptableVersion t -> CollectedWarnings mempty mempty [t] mempty mempty
+ DirtyWorkingTree_Warn -> CollectedWarnings mempty mempty mempty (Any True) mempty
+ MissingPath pn -> CollectedWarnings mempty mempty mempty mempty [pn]
renderWarnings :: [PackageWarning] -> Box
renderWarnings warns =
@@ -345,6 +337,7 @@ renderWarnings warns =
, if getAny dirtyWorkingTree
then Just warnDirtyWorkingTree
else Nothing
+ , go warnMissingPaths missingPaths
]
in case catMaybes mboxes of
[] -> nullBox
@@ -370,9 +363,8 @@ warnNoResolvedVersions pkgNames =
[ spacer
, para (concat
["Links to types in ", anyOfThese, " ", packages, " will not work. In "
- , "order to make links work, edit your bower.json to specify a version"
- , " or a version range for ", these, " ", packages, ", and rerun "
- , "`bower install`."
+ , "order to make links work, edit your package manifest to specify a version"
+ , " or a version range for ", these, " ", packages, "."
])
]
@@ -386,8 +378,8 @@ warnUndeclaredDependencies pkgNames =
dependencies = pl "dependencies" "a dependency"
in vcat $
para (concat
- [ "The following Bower ", packages, " ", are, " installed, but not "
- , "declared as ", dependencies, " in your bower.json file:"
+ [ "The following ", packages, " ", are, " installed, but not "
+ , "declared as ", dependencies, " in your package manifest file:"
])
: bulletedListT runPackageName (NonEmpty.toList pkgNames)
@@ -403,7 +395,7 @@ warnUnacceptableVersions pkgs =
versions = pl "versions" "version"
in vcat $
[ para (concat
- [ "The following installed Bower ", packages', " ", versions, " could "
+ [ "The following installed ", packages', " ", versions, " could "
, "not be parsed:"
])
] ++
@@ -412,9 +404,8 @@ warnUnacceptableVersions pkgs =
[ spacer
, para (concat
["Links to types in ", anyOfThese, " ", packages, " will not work. In "
- , "order to make links work, edit your bower.json to specify an "
- , "acceptable version or version range for ", these, " ", packages, ", "
- , "and rerun `bower install`."
+ , "order to make links work, edit your package manifest to specify an "
+ , "acceptable version or version range for ", these, " ", packages, "."
])
]
where
@@ -427,5 +418,18 @@ warnDirtyWorkingTree =
++ "were not a dry run)"
)
+warnMissingPaths :: NonEmpty PackageName -> Box
+warnMissingPaths pkgs =
+ let singular = NonEmpty.length pkgs == 1
+ pl a b = if singular then b else a
+
+ packages = pl "packages" "package"
+ in vcat $
+ para (concat
+ [ "The following installed ", packages, " were "
+ , "missing path information in the resolutions file:"
+ ])
+ : bulletedListT runPackageName (NonEmpty.toList pkgs)
+
printWarnings :: [PackageWarning] -> IO ()
printWarnings = printToStderr . renderWarnings
diff --git a/src/Language/PureScript/Publish/Utils.hs b/src/Language/PureScript/Publish/Utils.hs
index a7a410c..46c736d 100644
--- a/src/Language/PureScript/Publish/Utils.hs
+++ b/src/Language/PureScript/Publish/Utils.hs
@@ -1,41 +1,14 @@
+module Language.PureScript.Publish.Utils where
-module Language.PureScript.Publish.Utils where
+import Prelude.Compat
-import Prelude.Compat
-
-import Data.Either (partitionEithers)
-import Data.List
-
-import System.Directory
-import System.Exit (exitFailure)
-import System.FilePath (pathSeparator)
-import System.IO (hPutStrLn, stderr)
-import qualified System.FilePath.Glob as Glob
+import System.Directory
+import System.FilePath.Glob (Pattern, compile, globDir1)
-- | Glob relative to the current directory, and produce relative pathnames.
-globRelative :: Glob.Pattern -> IO [FilePath]
-globRelative pat = do
- currentDir <- getCurrentDirectory
- filesAbsolute <- Glob.globDir1 pat currentDir
- let prefix = currentDir ++ [pathSeparator]
- let (fails, paths) = partitionEithers . map (stripPrefix' prefix) $ filesAbsolute
- if null fails
- then return paths
- else do
- let p = hPutStrLn stderr
- p "Internal error in Language.PureScript.Publish.Utils.globRelative"
- p "Unmatched files:"
- mapM_ p fails
- exitFailure
-
- where
- stripPrefix' prefix dir =
- maybe (Left dir) Right $ stripPrefix prefix dir
+globRelative :: Pattern -> IO [FilePath]
+globRelative pat = getCurrentDirectory >>= globDir1 pat
-- | Glob pattern for PureScript source files.
-purescriptSourceFiles :: Glob.Pattern
-purescriptSourceFiles = Glob.compile "src/**/*.purs"
-
--- | Glob pattern for PureScript dependency files.
-purescriptDepsFiles :: Glob.Pattern
-purescriptDepsFiles = Glob.compile "bower_components/*/src/**/*.purs"
+purescriptSourceFiles :: Pattern
+purescriptSourceFiles = compile "src/**/*.purs"
diff --git a/src/Language/PureScript/Sugar.hs b/src/Language/PureScript/Sugar.hs
index 0a1d272..2c7bf0d 100644
--- a/src/Language/PureScript/Sugar.hs
+++ b/src/Language/PureScript/Sugar.hs
@@ -18,6 +18,7 @@ import Language.PureScript.Externs
import Language.PureScript.Sugar.BindingGroups as S
import Language.PureScript.Sugar.CaseDeclarations as S
import Language.PureScript.Sugar.DoNotation as S
+import Language.PureScript.Sugar.LetPattern as S
import Language.PureScript.Sugar.Names as S
import Language.PureScript.Sugar.ObjectWildcards as S
import Language.PureScript.Sugar.Operators as S
@@ -57,7 +58,8 @@ desugar externs =
map desugarSignedLiterals
>>> traverse desugarObjectConstructors
>=> traverse desugarDoModule
- >=> traverse desugarCasesModule
+ >=> map desugarLetPatternModule
+ >>> traverse desugarCasesModule
>=> traverse desugarTypeDeclarationsModule
>=> desugarImports externs
>=> rebracket externs
@@ -65,3 +67,4 @@ desugar externs =
>=> traverse (deriveInstances externs)
>=> desugarTypeClasses externs
>=> traverse createBindingGroupsModule
+
diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs
index 4d0d7a5..df391fb 100644
--- a/src/Language/PureScript/Sugar/BindingGroups.hs
+++ b/src/Language/PureScript/Sugar/BindingGroups.hs
@@ -10,13 +10,14 @@ module Language.PureScript.Sugar.BindingGroups
) where
import Prelude.Compat
+import Protolude (ordNub)
import Control.Monad ((<=<))
import Control.Monad.Error.Class (MonadError(..))
import Data.Graph
-import Data.List (nub, intersect)
-import Data.Maybe (isJust, mapMaybe)
+import Data.List (intersect)
+import Data.Maybe (isJust)
import qualified Data.Set as S
import Language.PureScript.AST
@@ -92,7 +93,8 @@ collapseBindingGroups =
where
go (DataBindingGroupDeclaration ds) = ds
go (BindingGroupDeclaration ds) =
- map (\(ident, nameKind, val) -> ValueDeclaration ident nameKind [] (Right val)) ds
+ map (\(ident, nameKind, val) ->
+ ValueDeclaration ident nameKind [] [MkUnguarded val]) ds
go (PositionedDeclaration pos com d) =
map (PositionedDeclaration pos com) $ go d
go other = [other]
@@ -102,11 +104,11 @@ collapseBindingGroupsForValue (Let ds val) = Let (collapseBindingGroups ds) val
collapseBindingGroupsForValue other = other
usedIdents :: ModuleName -> Declaration -> [Ident]
-usedIdents moduleName = nub . usedIdents' S.empty . getValue
+usedIdents moduleName = ordNub . usedIdents' S.empty . getValue
where
def _ _ = []
- getValue (ValueDeclaration _ _ [] (Right val)) = val
+ getValue (ValueDeclaration _ _ [] [MkUnguarded val]) = val
getValue ValueDeclaration{} = internalError "Binders should have been desugared"
getValue (PositionedDeclaration _ _ d) = getValue d
getValue _ = internalError "Expected ValueDeclaration"
@@ -123,7 +125,7 @@ usedIdents moduleName = nub . usedIdents' S.empty . getValue
usedImmediateIdents :: ModuleName -> Declaration -> [Ident]
usedImmediateIdents moduleName =
let (f, _, _, _, _) = everythingWithContextOnValues True [] (++) def usedNamesE def def def
- in nub . f
+ in ordNub . f
where
def s _ = (s, [])
@@ -137,14 +139,14 @@ usedImmediateIdents moduleName =
usedTypeNames :: ModuleName -> Declaration -> [ProperName 'TypeName]
usedTypeNames moduleName =
let (f, _, _, _, _) = accumTypes (everythingOnTypes (++) usedNames)
- in nub . f
+ in ordNub . f
where
usedNames :: Type -> [ProperName 'TypeName]
- usedNames (ConstrainedType constraints _) =
- flip mapMaybe constraints $ \case
+ usedNames (ConstrainedType con _) =
+ case con of
(Constraint (Qualified (Just moduleName') name) _ _)
- | moduleName == moduleName' -> Just (coerceProperName name)
- _ -> Nothing
+ | moduleName == moduleName' -> [coerceProperName name]
+ _ -> []
usedNames (TypeConstructor (Qualified (Just moduleName') name))
| moduleName == moduleName' = [name]
usedNames _ = []
@@ -195,7 +197,7 @@ toBindingGroup moduleName (CyclicSCC ds') =
cycleError :: Declaration -> MultipleErrors
cycleError (PositionedDeclaration p _ d) = onErrorMessages (withPosition p) $ cycleError d
- cycleError (ValueDeclaration n _ _ (Right _)) = errorMessage $ CycleInDeclaration n
+ cycleError (ValueDeclaration n _ _ [MkUnguarded _]) = errorMessage $ CycleInDeclaration n
cycleError _ = internalError "cycleError: Expected ValueDeclaration"
toDataBindingGroup
@@ -216,7 +218,7 @@ isTypeSynonym (PositionedDeclaration _ _ d) = isTypeSynonym d
isTypeSynonym _ = Nothing
fromValueDecl :: Declaration -> (Ident, NameKind, Expr)
-fromValueDecl (ValueDeclaration ident nameKind [] (Right val)) = (ident, nameKind, val)
+fromValueDecl (ValueDeclaration ident nameKind [] [MkUnguarded val]) = (ident, nameKind, val)
fromValueDecl ValueDeclaration{} = internalError "Binders should have been desugared"
fromValueDecl (PositionedDeclaration _ _ d) = fromValueDecl d
fromValueDecl _ = internalError "Expected ValueDeclaration"
diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs
index 717b418..781f1ee 100644
--- a/src/Language/PureScript/Sugar/CaseDeclarations.hs
+++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs
@@ -8,12 +8,12 @@ module Language.PureScript.Sugar.CaseDeclarations
) where
import Prelude.Compat
+import Protolude (ordNub)
-import Data.Either (isLeft)
-import Data.List (nub, groupBy, foldl1')
+import Data.List (groupBy, foldl1')
import Data.Maybe (catMaybes, mapMaybe)
-import Control.Monad ((<=<), replicateM, join, unless)
+import Control.Monad ((<=<), forM, replicateM, join, unless)
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.Supply.Class
@@ -22,7 +22,6 @@ import Language.PureScript.Crash
import Language.PureScript.Environment
import Language.PureScript.Errors
import Language.PureScript.Names
-import Language.PureScript.Traversals
import Language.PureScript.TypeChecker.Monad (guardWith)
-- |
@@ -39,6 +38,222 @@ desugarCasesModule (Module ss coms name ds exps) =
<*> pure exps
-- |
+-- Desugar case with pattern guards and pattern clauses to a
+-- series of nested case expressions.
+--
+desugarCase :: forall m. (MonadSupply m)
+ => Expr
+ -> m Expr
+desugarCase (Case scrut alternatives)
+ | any (not . isTrivialExpr) scrut = do
+ -- in case the scrutinee is non trivial (e.g. not a Var or Literal)
+ -- we may evaluate the scrutinee more than once when a guard occurrs.
+ -- We bind the scrutinee to Vars here to mitigate this case.
+ (scrut', scrut_decls) <- unzip <$> forM scrut (\e -> do
+ scrut_id <- freshIdent'
+ pure ( Var (Qualified Nothing scrut_id)
+ , ValueDeclaration scrut_id Private [] [MkUnguarded e]
+ )
+ )
+ Let scrut_decls <$> desugarCase (Case scrut' alternatives)
+ where
+ isTrivialExpr (Var _) = True
+ isTrivialExpr (Literal _) = True
+ isTrivialExpr (Accessor _ e) = isTrivialExpr e
+ isTrivialExpr (Parens e) = isTrivialExpr e
+ isTrivialExpr (PositionedValue _ _ e) = isTrivialExpr e
+ isTrivialExpr _ = False
+
+desugarCase (Case scrut alternatives) =
+ let
+ -- Alternatives which do not have guards are
+ -- left as-is. Alternatives which
+ --
+ -- 1) have multiple clauses of the form
+ -- binder | g_1
+ -- , g_2
+ -- , ...
+ -- , g_n
+ -- -> expr
+ --
+ -- 2) and/or contain pattern guards of the form
+ -- binder | pat_bind <- e
+ -- , ...
+ --
+ -- are desugared to a sequence of nested case expressions.
+ --
+ -- Consider an example case expression:
+ --
+ -- case e of
+ -- (T s) | Just info <- Map.lookup s names
+ -- , is_used info
+ -- -> f info
+ --
+ -- We desugar this to
+ --
+ -- case e of
+ -- (T s) -> case Map.lookup s names of
+ -- Just info -> case is_used info of
+ -- True -> f info
+ -- (_ -> <partial>)
+ -- (_ -> <partial>)
+ --
+ -- Note that if the original case is partial the desugared
+ -- case is also partial.
+ --
+ -- Consider an exhaustive case expression:
+ --
+ -- case e of
+ -- (T s) | Just info <- Map.lookup s names
+ -- , is_used info
+ -- -> f info
+ -- _ -> Nothing
+ --
+ -- desugars to:
+ --
+ -- case e of
+ -- _ -> let
+ -- v _ = Nothing
+ -- in
+ -- case e of
+ -- (T s) -> case Map.lookup s names of
+ -- Just info -> f info
+ -- _ -> v true
+ -- _ -> v true
+ --
+ -- This might look strange but simplifies the algorithm a lot.
+ --
+ desugarAlternatives :: [CaseAlternative]
+ -> m [CaseAlternative]
+ desugarAlternatives [] = pure []
+
+ -- the trivial case: no guards
+ desugarAlternatives (a@(CaseAlternative _ [MkUnguarded _]) : as) =
+ (a :) <$> desugarAlternatives as
+
+ -- Special case: CoreFn understands single condition guards on
+ -- binders right hand side.
+ desugarAlternatives (CaseAlternative ab ge : as)
+ | not (null cond_guards) =
+ (CaseAlternative ab cond_guards :)
+ <$> desugarGuardedAlternative ab rest as
+ | otherwise = desugarGuardedAlternative ab ge as
+ where
+ (cond_guards, rest) = span isSingleCondGuard ge
+
+ isSingleCondGuard (GuardedExpr [ConditionGuard _] _) = True
+ isSingleCondGuard _ = False
+
+ desugarGuardedAlternative :: [Binder]
+ -> [GuardedExpr]
+ -> [CaseAlternative]
+ -> m [CaseAlternative]
+ desugarGuardedAlternative _vb [] rem_alts =
+ desugarAlternatives rem_alts
+
+ desugarGuardedAlternative vb (GuardedExpr gs e : ge) rem_alts = do
+ rhs <- desugarAltOutOfLine vb ge rem_alts $ \alt_fail ->
+ let
+ -- if the binder is a var binder we must not add
+ -- the fail case as it results in unreachable
+ -- alternative
+ alt_fail' | all isIrrefutable vb = []
+ | otherwise = alt_fail
+
+
+ -- we are here:
+ --
+ -- case scrut of
+ -- ...
+ -- _ -> let
+ -- v _ = <out of line case>
+ -- in case scrut of -- we are here
+ -- ...
+ --
+ in Case scrut
+ (CaseAlternative vb [MkUnguarded (desugarGuard gs e alt_fail)]
+ : alt_fail')
+
+ return [ CaseAlternative scrut_nullbinder [MkUnguarded rhs]]
+
+ desugarGuard :: [Guard] -> Expr -> [CaseAlternative] -> Expr
+ desugarGuard [] e _ = e
+ desugarGuard (ConditionGuard c : gs) e match_failed
+ | isTrueExpr c = desugarGuard gs e match_failed
+ | otherwise =
+ Case [c]
+ (CaseAlternative [LiteralBinder (BooleanLiteral True)]
+ [MkUnguarded (desugarGuard gs e match_failed)] : match_failed)
+
+ desugarGuard (PatternGuard vb g : gs) e match_failed =
+ Case [g]
+ (CaseAlternative [vb] [MkUnguarded (desugarGuard gs e match_failed)]
+ : match_failed')
+ where
+ -- don't consider match_failed case if the binder is irrefutable
+ match_failed' | isIrrefutable vb = []
+ | otherwise = match_failed
+
+ -- we generate a let-binding for the remaining guards
+ -- and alternatives. A CaseAlternative is passed (or in
+ -- fact the original case is partial non is passed) to
+ -- mk_body which branches to the generated let-binding.
+ desugarAltOutOfLine :: [Binder]
+ -> [GuardedExpr]
+ -> [CaseAlternative]
+ -> ([CaseAlternative] -> Expr)
+ -> m Expr
+ desugarAltOutOfLine alt_binder rem_guarded rem_alts mk_body
+ | Just rem_case <- mkCaseOfRemainingGuardsAndAlts = do
+
+ desugared <- desugarCase rem_case
+ rem_case_id <- freshIdent'
+
+ let
+ goto_rem_case :: Expr
+ goto_rem_case = Var (Qualified Nothing rem_case_id)
+ `App` Literal (BooleanLiteral True)
+ alt_fail = [CaseAlternative [NullBinder] [MkUnguarded goto_rem_case]]
+
+ pure $ Let [
+ ValueDeclaration rem_case_id Private [NullBinder]
+ [MkUnguarded desugared]
+ ] (mk_body alt_fail)
+
+ | otherwise
+ = pure $ mk_body []
+ where
+ mkCaseOfRemainingGuardsAndAlts
+ | not (null rem_guarded)
+ = Just $ Case scrut (CaseAlternative alt_binder rem_guarded : rem_alts)
+ | not (null rem_alts)
+ = Just $ Case scrut rem_alts
+ | otherwise
+ = Nothing
+
+ scrut_nullbinder :: [Binder]
+ scrut_nullbinder = replicate (length scrut) NullBinder
+
+ -- case expressions with a single alternative which have
+ -- a NullBinder occur frequently after desugaring
+ -- complex guards. This function removes these superflous
+ -- cases.
+ optimize :: Expr -> Expr
+ optimize (Case _ [CaseAlternative vb [MkUnguarded v]])
+ | all isNullBinder vb = v
+ where
+ isNullBinder NullBinder = True
+ isNullBinder (PositionedBinder _ _ b) = isNullBinder b
+ isNullBinder (TypedBinder _ b) = isNullBinder b
+ isNullBinder _ = False
+ optimize e = e
+ in do
+ alts' <- desugarAlternatives alternatives
+ return $ optimize (Case scrut alts')
+
+desugarCase v = pure v
+
+-- |
-- Validates that case head and binder lengths match.
--
validateCases :: forall m. (MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]
@@ -47,12 +262,12 @@ validateCases = flip parU f
(f, _, _) = everywhereOnValuesM return validate return
validate :: Expr -> m Expr
- validate c@(Case vs alts) = do
+ validate (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
+ desugarCase (Case vs alts)
validate other = return other
altError :: Int -> [Binder] -> ErrorMessage
@@ -72,11 +287,17 @@ desugarAbs = flip parU f
(f, _, _) = everywhereOnValuesM return replace return
replace :: Expr -> m Expr
- replace (Abs (Right binder) val) = do
+ replace (Abs (stripPositioned -> (VarBinder i)) val) =
+ pure (Abs (VarBinder i) val)
+ replace (Abs binder val) = do
ident <- freshIdent'
- return $ Abs (Left ident) $ Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] (Right val)]
+ return $ Abs (VarBinder ident) $ Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] [MkUnguarded val]]
replace other = return other
+stripPositioned :: Binder -> Binder
+stripPositioned (PositionedBinder _ _ binder) = stripPositioned binder
+stripPositioned binder = binder
+
-- |
-- Replace all top-level binders with case expressions.
--
@@ -88,8 +309,7 @@ desugarCases = desugarRest <=< fmap join . flip parU toDecls . groupBy inSameGro
(:) <$> (TypeInstanceDeclaration name constraints className tys <$> traverseTypeInstanceBody desugarCases ds) <*> desugarRest rest
desugarRest (ValueDeclaration name nameKind bs result : rest) =
let (_, f, _) = everywhereOnValuesTopDownM return go return
- f' (Left gs) = Left <$> mapM (pairM return f) gs
- f' (Right v) = Right <$> f v
+ f' = mapM (\(GuardedExpr gs e) -> GuardedExpr gs <$> f e)
in (:) <$> (ValueDeclaration name nameKind bs <$> f' result) <*> desugarRest rest
where
go (Let ds val') = Let <$> desugarCases ds <*> pure val'
@@ -107,30 +327,27 @@ inSameGroup d1 (PositionedDeclaration _ _ d2) = inSameGroup d1 d2
inSameGroup _ _ = False
toDecls :: forall m. (MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]
-toDecls [ValueDeclaration ident nameKind bs (Right val)] | all isVarBinder bs = do
+toDecls [ValueDeclaration ident nameKind bs [MkUnguarded val]] | all isIrrefutable bs = do
args <- mapM fromVarBinder bs
- let body = foldr (Abs . Left) val args
- guardWith (errorMessage (OverlappingArgNames (Just ident))) $ length (nub args) == length args
- return [ValueDeclaration ident nameKind [] (Right body)]
+ let body = foldr (Abs . VarBinder) val args
+ guardWith (errorMessage (OverlappingArgNames (Just ident))) $ length (ordNub args) == length args
+ return [ValueDeclaration ident nameKind [] [MkUnguarded body]]
where
- isVarBinder :: Binder -> Bool
- isVarBinder NullBinder = True
- isVarBinder (VarBinder _) = True
- isVarBinder (PositionedBinder _ _ b) = isVarBinder b
- isVarBinder (TypedBinder _ b) = isVarBinder b
- isVarBinder _ = False
-
fromVarBinder :: Binder -> m Ident
fromVarBinder NullBinder = freshIdent'
fromVarBinder (VarBinder name) = return name
fromVarBinder (PositionedBinder _ _ b) = fromVarBinder b
fromVarBinder (TypedBinder _ b) = fromVarBinder b
fromVarBinder _ = internalError "fromVarBinder: Invalid argument"
-toDecls ds@(ValueDeclaration ident _ bs result : _) = do
+toDecls ds@(ValueDeclaration ident _ bs (result : _) : _) = do
let tuples = map toTuple ds
+
+ isGuarded (MkUnguarded _) = False
+ isGuarded _ = True
+
unless (all ((== length bs) . length . fst) tuples) $
throwError . errorMessage $ ArgListLengthsDiffer ident
- unless (not (null bs) || isLeft result) $
+ unless (not (null bs) || isGuarded result) $
throwError . errorMessage $ DuplicateValueDeclaration ident
caseDecl <- makeCaseDeclaration ident tuples
return [caseDecl]
@@ -139,12 +356,12 @@ toDecls (PositionedDeclaration pos com d : ds) = do
return (PositionedDeclaration pos com d' : ds')
toDecls ds = return ds
-toTuple :: Declaration -> ([Binder], Either [(Guard, Expr)] Expr)
+toTuple :: Declaration -> ([Binder], [GuardedExpr])
toTuple (ValueDeclaration _ _ bs result) = (bs, result)
toTuple (PositionedDeclaration _ _ d) = toTuple d
toTuple _ = internalError "Not a value declaration"
-makeCaseDeclaration :: forall m. (MonadSupply m) => Ident -> [([Binder], Either [(Guard, Expr)] Expr)] -> m Declaration
+makeCaseDeclaration :: forall m. (MonadSupply m) => Ident -> [([Binder], [GuardedExpr])] -> m Declaration
makeCaseDeclaration ident alternatives = do
let namedArgs = map findName . fst <$> alternatives
argNames = foldl1 resolveNames namedArgs
@@ -153,8 +370,10 @@ makeCaseDeclaration ident alternatives = do
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)
+ case_ <- desugarCase (Case vars binders)
+ let value = foldr (Abs . VarBinder) case_ args
+
+ return $ ValueDeclaration ident Public [] [MkUnguarded value]
where
-- We will construct a table of potential names.
-- VarBinders will become Just _ which is a potential name.
@@ -167,8 +386,8 @@ makeCaseDeclaration ident alternatives = do
-- We still have to make sure the generated names are unique, or else
-- we will end up constructing an invalid function.
- allUnique :: (Eq a) => [a] -> Bool
- allUnique xs = length xs == length (nub xs)
+ allUnique :: (Ord a) => [a] -> Bool
+ allUnique xs = length xs == length (ordNub xs)
argName :: Maybe Ident -> m Ident
argName (Just name) = return name
diff --git a/src/Language/PureScript/Sugar/DoNotation.hs b/src/Language/PureScript/Sugar/DoNotation.hs
index b80b8e8..4acd0ba 100644
--- a/src/Language/PureScript/Sugar/DoNotation.hs
+++ b/src/Language/PureScript/Sugar/DoNotation.hs
@@ -1,31 +1,28 @@
--- |
--- This module implements the desugaring pass which replaces do-notation statements with
+-- | This module implements the desugaring pass which replaces do-notation statements with
-- appropriate calls to bind.
---
-module Language.PureScript.Sugar.DoNotation (desugarDoModule) where
-import Prelude.Compat
+{-# LANGUAGE PatternGuards #-}
+
+module Language.PureScript.Sugar.DoNotation (desugarDoModule) where
-import Control.Monad.Error.Class (MonadError(..))
-import Control.Monad.Supply.Class
+import Prelude.Compat
-import Language.PureScript.AST
-import Language.PureScript.Crash
-import Language.PureScript.Errors
-import Language.PureScript.Names
+import Control.Monad.Error.Class (MonadError(..))
+import Control.Monad.Supply.Class
+import Data.Monoid (First(..))
+import Language.PureScript.AST
+import Language.PureScript.Crash
+import Language.PureScript.Errors
+import Language.PureScript.Names
import qualified Language.PureScript.Constants as C
--- |
--- Replace all @DoNotationBind@ and @DoNotationValue@ constructors with
+-- | Replace all @DoNotationBind@ and @DoNotationValue@ constructors with
-- applications of the bind function in scope, and all @DoNotationLet@
-- constructors with let expressions.
---
desugarDoModule :: forall m. (MonadSupply m, MonadError MultipleErrors m) => Module -> m Module
desugarDoModule (Module ss coms mn ds exts) = Module ss coms mn <$> parU ds desugarDo <*> pure exts
--- |
--- Desugar a single do statement
---
+-- | Desugar a single do statement
desugarDo :: forall m. (MonadSupply m, MonadError MultipleErrors m) => Declaration -> m Declaration
desugarDo (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> rethrowWithPosition pos (desugarDo d)
desugarDo d =
@@ -35,6 +32,9 @@ desugarDo d =
bind :: Expr
bind = Var (Qualified Nothing (Ident C.bind))
+ discard :: Expr
+ discard = Var (Qualified Nothing (Ident C.discard))
+
replace :: Expr -> m Expr
replace (Do els) = go els
replace (PositionedValue pos com v) = PositionedValue pos com <$> rethrowWithPosition pos (replace v)
@@ -45,23 +45,25 @@ desugarDo d =
go [DoNotationValue val] = return val
go (DoNotationValue val : rest) = do
rest' <- go rest
- return $ App (App bind val) (Abs (Left (Ident C.__unused)) rest')
+ return $ App (App discard val) (Abs (VarBinder (Ident C.__unused)) rest')
go [DoNotationBind _ _] = throwError . errorMessage $ InvalidDoBind
- go (DoNotationBind NullBinder val : rest) = go (DoNotationValue val : rest)
- go (DoNotationBind b _ : _) | Ident C.bind `elem` binderNames b =
- throwError . errorMessage $ CannotUseBindWithDo
+ go (DoNotationBind b _ : _) | First (Just ident) <- foldMap fromIdent (binderNames b) =
+ throwError . errorMessage $ CannotUseBindWithDo (Ident ident)
+ where
+ fromIdent (Ident i) | i `elem` [ C.bind, C.discard ] = First (Just i)
+ fromIdent _ = mempty
go (DoNotationBind (VarBinder ident) val : rest) = do
rest' <- go rest
- return $ App (App bind val) (Abs (Left ident) rest')
+ return $ App (App bind val) (Abs (VarBinder ident) rest')
go (DoNotationBind binder val : rest) = do
rest' <- go rest
ident <- freshIdent'
- return $ App (App bind val) (Abs (Left ident) (Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] (Right rest')]))
+ return $ App (App bind val) (Abs (VarBinder ident) (Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] [MkUnguarded rest']]))
go [DoNotationLet _] = throwError . errorMessage $ InvalidDoLet
go (DoNotationLet ds : rest) = do
let checkBind :: Declaration -> m ()
- checkBind (ValueDeclaration (Ident name) _ _ _)
- | name == C.bind = throwError . errorMessage $ CannotUseBindWithDo
+ checkBind (ValueDeclaration i@(Ident name) _ _ _)
+ | name `elem` [ C.bind, C.discard ] = throwError . errorMessage $ CannotUseBindWithDo i
checkBind (PositionedDeclaration pos _ decl) = rethrowWithPosition pos (checkBind decl)
checkBind _ = pure ()
mapM_ checkBind ds
diff --git a/src/Language/PureScript/Sugar/LetPattern.hs b/src/Language/PureScript/Sugar/LetPattern.hs
new file mode 100644
index 0000000..901522b
--- /dev/null
+++ b/src/Language/PureScript/Sugar/LetPattern.hs
@@ -0,0 +1,47 @@
+-- |
+-- This module implements the desugaring pass which replaces patterns in let-in
+-- expressions with appropriate case expressions.
+--
+module Language.PureScript.Sugar.LetPattern (desugarLetPatternModule) where
+
+import Prelude.Compat
+
+import Language.PureScript.AST
+
+-- |
+-- Replace every @BoundValueDeclaration@ in @Let@ expressions with @Case@
+-- expressions.
+--
+desugarLetPatternModule :: Module -> Module
+desugarLetPatternModule (Module ss coms mn ds exts) = Module ss coms mn (map desugarLetPattern ds) exts
+
+-- |
+-- Desugar a single let expression
+--
+desugarLetPattern :: Declaration -> Declaration
+desugarLetPattern (PositionedDeclaration pos com d) = PositionedDeclaration pos com $ desugarLetPattern d
+desugarLetPattern decl =
+ let (f, _, _) = everywhereOnValues id replace id
+ in f decl
+ where
+ replace :: Expr -> Expr
+ replace (Let ds e) = go ds e
+ replace other = other
+
+ go :: [Declaration]
+ -- ^ Declarations to desugar
+ -> Expr
+ -- ^ The original let-in result expression
+ -> Expr
+ go [] e = e
+ go (pd@(PositionedDeclaration pos com d) : ds) e =
+ case d of
+ BoundValueDeclaration {} -> PositionedValue pos com $ go (d:ds) e
+ _ -> append pd $ go ds e
+ go (BoundValueDeclaration binder boundE : ds) e =
+ Case [boundE] [CaseAlternative [binder] [MkUnguarded $ go ds e]]
+ go (d:ds) e = append d $ go ds e
+
+ append :: Declaration -> Expr -> Expr
+ append d (Let ds e) = Let (d:ds) e
+ append d e = Let [d] e
diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs
index a0ffbfa..0fb49ed 100644
--- a/src/Language/PureScript/Sugar/Names.hs
+++ b/src/Language/PureScript/Sugar/Names.hs
@@ -9,6 +9,7 @@ module Language.PureScript.Sugar.Names
) where
import Prelude.Compat
+import Protolude (ordNub)
import Control.Arrow (first)
import Control.Monad
@@ -16,7 +17,6 @@ import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.State.Lazy
import Control.Monad.Writer (MonadWriter(..), censor)
-import Data.List (nub)
import Data.Maybe (fromMaybe, mapMaybe)
import qualified Data.Map as M
import qualified Data.Set as S
@@ -65,12 +65,11 @@ desugarImportsWithEnv externs modules = do
externsEnv :: Env -> ExternsFile -> m Env
externsEnv env ExternsFile{..} = do
let members = Exports{..}
- ss = internalModuleSourceSpan "<Externs>"
- env' = M.insert efModuleName (ss, primImports, members) env
+ env' = M.insert efModuleName (efSourceSpan, primImports, members) env
fromEFImport (ExternsImport mn mt qmn) = (mn, [(Nothing, Just mt, qmn)])
imps <- foldM (resolveModuleImport env') primImports (map fromEFImport efImports)
- exps <- resolveExports env' ss efModuleName imps members efExports
- return $ M.insert efModuleName (ss, imps, exps) env
+ exps <- resolveExports env' efSourceSpan efModuleName imps members efExports
+ return $ M.insert efModuleName (efSourceSpan, imps, exps) env
where
exportedTypes :: M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ModuleName)
@@ -202,11 +201,11 @@ renameInModule imports (Module ss coms mn decls exps) =
-> m ((Maybe SourceSpan, [Ident]), Expr)
updateValue (_, bound) v@(PositionedValue pos' _ _) =
return ((Just pos', bound), v)
- updateValue (pos, bound) (Abs (Left arg) val') =
- return ((pos, arg : bound), Abs (Left arg) val')
+ updateValue (pos, bound) (Abs (VarBinder arg) val') =
+ return ((pos, arg : bound), Abs (VarBinder arg) val')
updateValue (pos, bound) (Let ds val') = do
let args = mapMaybe letBoundVariable ds
- unless (length (nub args) == length args) $
+ unless (length (ordNub args) == length args) $
maybe id rethrowWithPosition pos $
throwError . errorMessage $ OverlappingNamesInLet
return ((pos, args ++ bound), Let ds val')
@@ -242,8 +241,16 @@ renameInModule imports (Module ss coms mn decls exps) =
:: (Maybe SourceSpan, [Ident])
-> CaseAlternative
-> m ((Maybe SourceSpan, [Ident]), CaseAlternative)
- updateCase (pos, bound) c@(CaseAlternative bs _) =
- return ((pos, concatMap binderNames bs ++ bound), c)
+ updateCase (pos, bound) c@(CaseAlternative bs gs) =
+ return ((pos, concatMap binderNames bs ++ updateGuard gs ++ bound), c)
+ where
+ updateGuard :: [GuardedExpr] -> [Ident]
+ updateGuard [] = []
+ updateGuard (GuardedExpr g _ : xs) =
+ concatMap updatePatGuard g ++ updateGuard xs
+ where
+ updatePatGuard (PatternGuard b _) = binderNames b
+ updatePatGuard _ = []
letBoundVariable :: Declaration -> Maybe Ident
letBoundVariable (ValueDeclaration ident _ _ _) = Just ident
@@ -269,7 +276,7 @@ renameInModule imports (Module ss coms mn decls exps) =
updateType :: Type -> m Type
updateType (TypeOp name) = TypeOp <$> updateTypeOpName name pos
updateType (TypeConstructor name) = TypeConstructor <$> updateTypeName name pos
- updateType (ConstrainedType cs t) = ConstrainedType <$> traverse updateInConstraint cs <*> pure t
+ updateType (ConstrainedType c t) = ConstrainedType <$> updateInConstraint c <*> pure t
updateType (KindedType t k) = KindedType t <$> updateKindsEverywhere pos k
updateType t = return t
updateInConstraint :: Constraint -> m Constraint
@@ -342,11 +349,8 @@ renameInModule imports (Module ss coms mn decls exps) =
-- in scope, we throw an error.
(Just options, _) -> do
(mnNew, mnOrig) <- checkImportConflicts mn toName options
- modify $ \result ->
- M.insert
- mnNew
- (maybe [fmap toName qname] (fmap toName qname :) (mnNew `M.lookup` result))
- result
+ modify $ \usedImports ->
+ M.insertWith (++) mnNew [fmap toName qname] usedImports
return $ Qualified (Just mnOrig) name
-- If the name wasn't found in our imports but was qualified then we need
diff --git a/src/Language/PureScript/Sugar/Names/Common.hs b/src/Language/PureScript/Sugar/Names/Common.hs
index 02c841b..a827041 100644
--- a/src/Language/PureScript/Sugar/Names/Common.hs
+++ b/src/Language/PureScript/Sugar/Names/Common.hs
@@ -1,12 +1,13 @@
module Language.PureScript.Sugar.Names.Common (warnDuplicateRefs) where
import Prelude.Compat
+import Protolude (ordNub)
import Control.Monad.Writer (MonadWriter(..))
import Data.Foldable (for_)
import Data.Function (on)
-import Data.List (nub, nubBy, (\\))
+import Data.List (nubBy, (\\))
import Data.Maybe (mapMaybe)
import Language.PureScript.AST
@@ -52,7 +53,7 @@ warnDuplicateRefs pos toError refs = do
extractCtors :: SourceSpan -> DeclarationRef -> Maybe [(SourceSpan, Name)]
extractCtors _ (PositionedDeclarationRef pos' _ ref) = extractCtors pos' ref
extractCtors pos' (TypeRef _ (Just dctors)) =
- let dupes = dctors \\ nub dctors
+ let dupes = dctors \\ ordNub dctors
in if null dupes then Nothing else Just $ ((pos',) . DctorName) <$> dupes
extractCtors _ _ = Nothing
diff --git a/src/Language/PureScript/Sugar/ObjectWildcards.hs b/src/Language/PureScript/Sugar/ObjectWildcards.hs
index 149939a..a46d6cc 100644
--- a/src/Language/PureScript/Sugar/ObjectWildcards.hs
+++ b/src/Language/PureScript/Sugar/ObjectWildcards.hs
@@ -37,27 +37,27 @@ desugarDecl other = fn other
| b' <- stripPositionInfo b
, BinaryNoParens op val u <- b'
, isAnonymousArgument u = do arg <- freshIdent'
- return $ Abs (Left arg) $ App (App op val) (Var (Qualified Nothing arg))
+ return $ Abs (VarBinder arg) $ App (App op val) (Var (Qualified Nothing arg))
| b' <- stripPositionInfo b
, BinaryNoParens op u val <- b'
, isAnonymousArgument u = do arg <- freshIdent'
- return $ Abs (Left arg) $ App (App op (Var (Qualified Nothing arg))) val
+ return $ Abs (VarBinder arg) $ App (App op (Var (Qualified Nothing arg))) val
desugarExpr (Literal (ObjectLiteral ps)) = wrapLambdaAssoc (Literal . ObjectLiteral) ps
desugarExpr (ObjectUpdateNested obj ps) = transformNestedUpdate obj ps
desugarExpr (Accessor prop u)
| Just props <- peelAnonAccessorChain u = do
arg <- freshIdent'
- return $ Abs (Left arg) $ foldr Accessor (argToExpr arg) (prop:props)
+ return $ Abs (VarBinder arg) $ foldr Accessor (argToExpr arg) (prop:props)
desugarExpr (Case args cas) | any isAnonymousArgument args = do
argIdents <- forM args freshIfAnon
let args' = zipWith (`maybe` argToExpr) args argIdents
- return $ foldr (Abs . Left) (Case args' cas) (catMaybes argIdents)
+ return $ foldr (Abs . VarBinder) (Case args' cas) (catMaybes argIdents)
desugarExpr (IfThenElse u t f) | any isAnonymousArgument [u, t, f] = do
u' <- freshIfAnon u
t' <- freshIfAnon t
f' <- freshIfAnon f
let if_ = IfThenElse (maybe u argToExpr u') (maybe t argToExpr t') (maybe f argToExpr f')
- return $ foldr (Abs . Left) if_ (catMaybes [u', t', f'])
+ return $ foldr (Abs . VarBinder) if_ (catMaybes [u', t', f'])
desugarExpr e = return e
transformNestedUpdate :: Expr -> PathTree Expr -> m Expr
@@ -67,10 +67,10 @@ desugarDecl other = fn other
val <- freshIdent'
let valExpr = argToExpr val
if isAnonymousArgument obj
- then Abs (Left val) <$> wrapLambda (buildUpdates valExpr) ps
+ then Abs (VarBinder val) <$> wrapLambda (buildUpdates valExpr) ps
else wrapLambda (buildLet val . buildUpdates valExpr) ps
where
- buildLet val = Let [ValueDeclaration val Public [] (Right obj)]
+ buildLet val = Let [ValueDeclaration val Public [] [MkUnguarded obj]]
-- recursively build up the nested `ObjectUpdate` expressions
buildUpdates :: Expr -> PathTree Expr -> Expr
@@ -87,7 +87,7 @@ desugarDecl other = fn other
wrapLambda :: forall t. Traversable t => (t Expr -> Expr) -> t Expr -> m Expr
wrapLambda mkVal ps = do
args <- traverse processExpr ps
- return $ foldr (Abs . Left) (mkVal (snd <$> args)) (catMaybes $ toList (fst <$> args))
+ return $ foldr (Abs . VarBinder) (mkVal (snd <$> args)) (catMaybes $ toList (fst <$> args))
where
processExpr :: Expr -> m (Maybe Ident, Expr)
processExpr e = do
diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs
index b20a066..73fe3d6 100644
--- a/src/Language/PureScript/Sugar/TypeClasses.hs
+++ b/src/Language/PureScript/Sugar/TypeClasses.hs
@@ -10,29 +10,26 @@ module Language.PureScript.Sugar.TypeClasses
import Prelude.Compat
-import Language.PureScript.Crash
-import Language.PureScript.Environment
-import Language.PureScript.Errors hiding (isExported)
-import Language.PureScript.Kinds
-import Language.PureScript.Names
-import Language.PureScript.Externs
-import Language.PureScript.Sugar.CaseDeclarations
-import Control.Monad.Supply.Class
-import Language.PureScript.Types
-import Language.PureScript.Label (Label(..))
-import Language.PureScript.PSString (mkString)
-
-import qualified Language.PureScript.Constants as C
-
-import Control.Arrow (first, second)
-import Control.Monad.Error.Class (MonadError(..))
-import Control.Monad.State
-import Data.List ((\\), find, sortBy)
-import Data.Maybe (catMaybes, mapMaybe, isJust)
+import Control.Arrow (first, second)
+import Control.Monad.Error.Class (MonadError(..))
+import Control.Monad.State
+import Control.Monad.Supply.Class
+import Data.List ((\\), find, sortBy)
import qualified Data.Map as M
-import Data.Monoid ((<>))
-import Data.Text (Text)
-import qualified Data.Text as T
+import Data.Maybe (catMaybes, mapMaybe, isJust)
+import Data.Text (Text)
+import qualified Language.PureScript.Constants as C
+import Language.PureScript.Crash
+import Language.PureScript.Environment
+import Language.PureScript.Errors hiding (isExported)
+import Language.PureScript.Externs
+import Language.PureScript.Kinds
+import Language.PureScript.Label (Label(..))
+import Language.PureScript.Names
+import Language.PureScript.PSString (mkString)
+import Language.PureScript.Sugar.CaseDeclarations
+import Language.PureScript.Types
+import Language.PureScript.TypeClassDictionaries (superclassName)
type MemberMap = M.Map (ModuleName, ProperName 'ClassName) TypeClassData
@@ -126,7 +123,7 @@ desugarModule _ = internalError "Exports should have been elaborated in name des
-- <TypeClassDeclaration Sub ...>
--
-- type Sub a = { sub :: a
--- , "__superclass_Foo_0" :: {} -> Foo a
+-- , "Foo0" :: {} -> Foo a
-- }
--
-- -- As with `foo` above, this type is unchecked at the declaration
@@ -135,7 +132,7 @@ desugarModule _ = internalError "Exports should have been elaborated in name des
--
-- subString :: {} -> Sub String
-- subString _ = { sub: "",
--- , "__superclass_Foo_0": \_ -> <DeferredDictionary Foo String>
+-- , "Foo0": \_ -> <DeferredDictionary Foo String>
-- }
--
-- and finally as the generated javascript:
@@ -158,8 +155,8 @@ desugarModule _ = internalError "Exports should have been elaborated in name des
-- return new Foo(map(foo(__dict_Foo_15)));
-- };
--
--- function Sub(__superclass_Foo_0, sub) {
--- this["__superclass_Foo_0"] = __superclass_Foo_0;
+-- function Sub(Foo0, sub) {
+-- this["Foo0"] = Foo0;
-- this.sub = sub;
-- };
--
@@ -189,8 +186,8 @@ desugarDecl mn exps = go
return (expRef name className tys, [d, dictDecl])
go d@(TypeInstanceDeclaration name deps className tys (NewtypeInstanceWithDictionary dict)) = do
let dictTy = foldl TypeApp (TypeConstructor (fmap coerceProperName className)) tys
- constrainedTy = quantify (if null deps then dictTy else ConstrainedType deps dictTy)
- return (expRef name className tys, [d, ValueDeclaration name Private [] (Right (TypedValue True dict constrainedTy))])
+ constrainedTy = quantify (foldr ConstrainedType dictTy deps)
+ return (expRef name className tys, [d, ValueDeclaration name Private [] [MkUnguarded (TypedValue True dict constrainedTy)]])
go (PositionedDeclaration pos com d) = do
(dr, ds) <- rethrowWithPosition pos $ desugarDecl mn exps d
return (dr, map (PositionedDeclaration pos com) ds)
@@ -252,9 +249,11 @@ typeClassMemberToDictionaryAccessor
-> Declaration
typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) =
let className = Qualified (Just mn) name
- in ValueDeclaration ident Private [] $ Right $
- TypedValue False (TypeClassDictionaryAccessor className ident) $
- moveQuantifiersToFront (quantify (ConstrainedType [Constraint className (map (TypeVar . fst) args) Nothing] ty))
+ in ValueDeclaration ident Private [] $
+ [MkUnguarded (
+ TypedValue False (TypeClassDictionaryAccessor className ident) $
+ moveQuantifiersToFront (quantify (ConstrainedType (Constraint className (map (TypeVar . fst) args) Nothing) ty))
+ )]
typeClassMemberToDictionaryAccessor mn name args (PositionedDeclaration pos com d) =
PositionedDeclaration pos com $ typeClassMemberToDictionaryAccessor mn name args d
typeClassMemberToDictionaryAccessor _ _ _ _ = internalError "Invalid declaration in type class definition"
@@ -294,16 +293,16 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =
-- The type is a record type, but depending on type instance dependencies, may be constrained.
-- The dictionary itself is a record literal.
let superclasses = superClassDictionaryNames typeClassSuperclasses `zip`
- [ Abs (Left (Ident C.__unused)) (DeferredDictionary superclass tyArgs)
+ [ Abs (VarBinder (Ident C.__unused)) (DeferredDictionary superclass tyArgs)
| (Constraint superclass suTyArgs _) <- typeClassSuperclasses
, let tyArgs = map (replaceAllTypeVars (zip (map fst typeClassArguments) tys)) suTyArgs
]
let props = Literal $ ObjectLiteral $ map (first mkString) (members ++ superclasses)
dictTy = foldl TypeApp (TypeConstructor (fmap coerceProperName className)) tys
- constrainedTy = quantify (if null deps then dictTy else ConstrainedType deps dictTy)
+ constrainedTy = quantify (foldr ConstrainedType dictTy deps)
dict = TypeClassDictionaryConstructorApp className props
- result = ValueDeclaration name Private [] (Right (TypedValue True dict constrainedTy))
+ result = ValueDeclaration name Private [] [MkUnguarded (TypedValue True dict constrainedTy)]
return result
where
@@ -315,7 +314,7 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =
declName _ = Nothing
memberToValue :: [(Ident, Type)] -> Declaration -> Desugar m Expr
- memberToValue tys' (ValueDeclaration ident _ [] (Right val)) = do
+ memberToValue tys' (ValueDeclaration ident _ [] [MkUnguarded val]) = do
_ <- maybe (throwError . errorMessage $ ExtraneousClassMember ident className) return $ lookup ident tys'
return val
memberToValue tys' (PositionedDeclaration pos com d) = rethrowWithPosition pos $ do
@@ -331,6 +330,6 @@ typeClassMemberName _ = internalError "typeClassMemberName: Invalid declaration
superClassDictionaryNames :: [Constraint] -> [Text]
superClassDictionaryNames supers =
- [ C.__superclass_ <> showQualified runProperName pn <> "_" <> T.pack (show (index :: Integer))
+ [ superclassName pn index
| (index, Constraint pn _ _) <- zip [0..] s