git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Merge master
commit474a886a7c8000b5ca1903f29b45d33f79784f5a authorPhil Freeman <paf31@cantab.net> dateSun 13 Mar 2016, 14:48 (11 years ago) parent3d84af6c89b9fd
216 files changed+11035−3908
compare with golang
unifiedsplit
.gitignore+2−1 .travis.yml+13−26 CONTRIBUTORS.md+10−4 INSTALL.md+4−8 LICENSE+34 bundle/README+9−6 bundle/build-stack.sh+50 bundle/build.sh+12−8 bundle/winbuild.sh+12−8 core-tests/test-everything.sh+5−3 examples/docs/bower.json+19 examples/docs/bower_components/purescript-prelude/src/Prelude.purs+8 examples/docs/src/Clash.purs+32 examples/docs/src/DuplicateNames.purs+9 examples/docs/src/Example.purs+7 examples/docs/src/Example2.purs+7 examples/docs/src/ExplicitTypeSignatures.purs+16 examples/docs/src/ImportedTwice.purs+27 examples/docs/src/MultiVirtual.purs+27 examples/docs/src/NewOperators.purs+12 examples/docs/src/NotAllCtors.purs+5 examples/docs/src/OldOperators.purs+10 examples/docs/src/ReExportedTypeClass.purs+5 examples/docs/src/SolitaryTypeClassMember.purs+6 examples/docs/src/SomeTypeClass.purs+5 examples/docs/src/Transitive1.purs+5 examples/docs/src/Transitive2.purs+5 examples/docs/src/Transitive3.purs+4 examples/docs/src/TypeClassWithoutMembers.purs+11 examples/docs/src/UTF8.purs+7 examples/docs/src/Virtual.purs+5 examples/failing/1733.purs+13 examples/failing/1825.purs+9 examples/failing/AnonArgument1.purs+5 examples/failing/AnonArgument2.purs+7 examples/failing/AnonArgument3.purs+5 examples/failing/ConflictingExports2.purs−13 examples/failing/ConflictingImports2.purs+8−4 examples/failing/DctorOperatorAliasExport.purs+6 examples/failing/IntOutOfRange.purs+1−1 examples/failing/InvalidOperatorInBinder.purs+12 examples/passing/DctorOperatorAlias.purs+35 examples/passing/Deriving.purs+31 examples/passing/ExplicitOperatorSections.purs+14 examples/passing/NegativeIntInRange.purs+8 examples/passing/OperatorAliasElsewhere.purs+14 examples/passing/ResolvableScopeConflict.purs+25 examples/passing/ResolvableScopeConflict2.purs+22 examples/passing/ResolvableScopeConflict3.purs+15 examples/passing/TCO.purs+20 examples/passing/UnicodeType.purs+23 hierarchy/Main.hs+2−1 psc-bundle/Main.hs+2−2 psc-docs/Main.hs+47−39 psc-ide-client/Main.hs+56 psc-ide-server/Main.hs+148 psc-ide-server/PROTOCOL.md+409 psc-ide-server/README.md+40 psc/JSON.hs+12−1 psc/Main.hs+10−4 psci/IO.hs−21 psci/PSCi.hs+141−449 psci/Completion.hs → psci/PSCi/Completion.hs+10−8 psci/Directive.hs → psci/PSCi/Directive.hs+6−2 psci/PSCi/IO.hs+68 psci/PSCi/Message.hs+53 psci/PSCi/Module.hs+106 psci/PSCi/Option.hs+57 psci/Parser.hs → psci/PSCi/Parser.hs+3−3 psci/PSCi/Printer.hs+131 psci/Types.hs → psci/PSCi/Types.hs+6−3 purescript.cabal+121−44 src/Control/Monad/Logger.hs+1−1 src/Control/Monad/Supply.hs+1−1 src/Language/PureScript.hs−1 src/Language/PureScript/AST.hs+4−14 src/Language/PureScript/AST/Binders.hs+28−39 src/Language/PureScript/AST/Declarations.hs+44−63 src/Language/PureScript/AST/Exported.hs+36−21 src/Language/PureScript/AST/Literals.hs+37 src/Language/PureScript/AST/Operators.hs+7−18 src/Language/PureScript/AST/SourcePos.hs+5−18 src/Language/PureScript/AST/Traversals.hs+211−123 src/Language/PureScript/Bundle.hs+16−13 src/Language/PureScript/CodeGen/JS.hs+167−133 src/Language/PureScript/CodeGen/JS/AST.hs+173−114 src/Language/PureScript/CodeGen/JS/Optimizer.hs+19−27 src/Language/PureScript/CodeGen/JS/Optimizer/Blocks.hs+4−4 src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs+30−27 src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs+223−171 src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs+43−74 src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs+33−31 src/Language/PureScript/CodeGen/JS/Optimizer/Unused.hs+3−3 src/Language/PureScript/Comments.hs+3−17 src/Language/PureScript/Constants.hs+104−23 src/Language/PureScript/CoreFn.hs+3−14 src/Language/PureScript/CoreFn/Binders.hs+15−21 src/Language/PureScript/CoreFn/Desugar.hs+67−50 src/Language/PureScript/CoreFn/Expr.hs+10−23 src/Language/PureScript/CoreFn/Literals.hs−50 src/Language/PureScript/CoreFn/Meta.hs+4−19 src/Language/PureScript/CoreFn/Module.hs+1−1 src/Language/PureScript/CoreFn/Traversals.hs+6−16 src/Language/PureScript/Docs.hs+1−1 src/Language/PureScript/Docs/AsMarkdown.hs+31−16 src/Language/PureScript/Docs/Convert.hs+160−193 src/Language/PureScript/Docs/Convert/ReExports.hs+477 src/Language/PureScript/Docs/Convert/Single.hs+236 src/Language/PureScript/Docs/ParseAndBookmark.hs+100 src/Language/PureScript/Docs/ParseAndDesugar.hs−136 src/Language/PureScript/Docs/Render.hs+19−7 src/Language/PureScript/Docs/RenderedCode/Render.hs+10−4 src/Language/PureScript/Docs/RenderedCode/Types.hs+6 src/Language/PureScript/Docs/Types.hs+92−17 src/Language/PureScript/Environment.hs+16−30 src/Language/PureScript/Errors.hs+264−128 src/Language/PureScript/Externs.hs+14−13 src/Language/PureScript/Ide.hs+199 src/Language/PureScript/Ide/CaseSplit.hs+148 src/Language/PureScript/Ide/CodecJSON.hs+13 src/Language/PureScript/Ide/Command.hs+101 src/Language/PureScript/Ide/Completion.hs+35 src/Language/PureScript/Ide/Error.hs+42 src/Language/PureScript/Ide/Externs.hs+102 src/Language/PureScript/Ide/Filter.hs+110 src/Language/PureScript/Ide/Matcher.hs+100 src/Language/PureScript/Ide/Pursuit.hs+65 src/Language/PureScript/Ide/Reexports.hs+75 src/Language/PureScript/Ide/SourceFile.hs+106 src/Language/PureScript/Ide/State.hs+80 src/Language/PureScript/Ide/Types.hs+238 src/Language/PureScript/Ide/Watcher.hs+40 src/Language/PureScript/Kinds.hs+3−18 src/Language/PureScript/Linter.hs+2−1 src/Language/PureScript/Linter/Exhaustive.hs+55−62 src/Language/PureScript/Linter/Imports.hs+251−93 src/Language/PureScript/Make.hs+42−8 src/Language/PureScript/ModuleDependencies.hs+8−4 src/Language/PureScript/Names.hs+46−26 src/Language/PureScript/Options.hs+4−1 src/Language/PureScript/Parser/Common.hs+3−15 src/Language/PureScript/Parser/Declarations.hs+63−63 src/Language/PureScript/Parser/JS.hs+1−1 src/Language/PureScript/Parser/Lexer.hs+6 src/Language/PureScript/Parser/Types.hs+1−1 src/Language/PureScript/Pretty.hs−3 src/Language/PureScript/Pretty/Common.hs+96−9 src/Language/PureScript/Pretty/JS.hs+118−105 src/Language/PureScript/Pretty/Types.hs+10−22 src/Language/PureScript/Pretty/Values.hs+49−36 src/Language/PureScript/Publish.hs+23−6 src/Language/PureScript/Publish/ErrorsWarnings.hs+4−15 src/Language/PureScript/Renamer.hs+9−9 src/Language/PureScript/Sugar.hs+1−1 src/Language/PureScript/Sugar/BindingGroups.hs+73−55 src/Language/PureScript/Sugar/CaseDeclarations.hs+15−24 src/Language/PureScript/Sugar/DoNotation.hs+2−2 src/Language/PureScript/Sugar/Names.hs+100−36 src/Language/PureScript/Sugar/Names/Env.hs+72−27 src/Language/PureScript/Sugar/Names/Exports.hs+38−15 src/Language/PureScript/Sugar/Names/Imports.hs+66−44 src/Language/PureScript/Sugar/ObjectWildcards.hs+41−16 src/Language/PureScript/Sugar/Operators.hs+99−86 src/Language/PureScript/Sugar/Operators/Binders.hs+43 src/Language/PureScript/Sugar/Operators/Common.hs+53 src/Language/PureScript/Sugar/Operators/Expr.hs+52 src/Language/PureScript/Sugar/TypeClasses.hs+64−39 src/Language/PureScript/Sugar/TypeClasses/Deriving.hs+337−149 src/Language/PureScript/Sugar/TypeDeclarations.hs+1−1 src/Language/PureScript/TypeChecker.hs+125−99 src/Language/PureScript/TypeChecker/Entailment.hs+14−27 src/Language/PureScript/TypeChecker/Kinds.hs+65−52 src/Language/PureScript/TypeChecker/Monad.hs+69−38 src/Language/PureScript/TypeChecker/Rows.hs+1−1 src/Language/PureScript/TypeChecker/Skolems.hs+1−1 src/Language/PureScript/TypeChecker/Subsumption.hs+2−2 src/Language/PureScript/TypeChecker/Synonyms.hs+1−1 src/Language/PureScript/TypeChecker/Types.hs+65−51 src/Language/PureScript/TypeChecker/Unify.hs+5−5 src/Language/PureScript/TypeClassDictionaries.hs+5−22 src/Language/PureScript/Types.hs+11−23 stack-lts-2.yaml−9 stack-lts-3.yaml−5 stack-lts-5.yaml+5 stack-nightly.yaml+2−2 stack.yaml+1−1 tests/Language/PureScript/Ide/FilterSpec.hs+59 tests/Language/PureScript/Ide/MatcherSpec.hs+31 tests/Language/PureScript/Ide/ReexportsSpec.hs+77 tests/Language/PureScript/IdeSpec.hs+35 tests/Main.hs+22−199 tests/PscIdeSpec.hs+1 tests/TestCompiler.hs+194 tests/TestDocs.hs+269 tests/TestPscIde.hs+7 tests/TestPscPublish.hs+12−11 psci/tests/Main.hs → tests/TestPsci.hs+8−11 tests/common/TestsSetup.hs → tests/TestUtils.hs+23−3 tests/support/flattened/Control-Monad-Eff-Class.purs+24 tests/support/flattened/Control-Monad-Eff-Console.js+18 tests/support/flattened/Control-Monad-Eff-Console.purs+18 tests/support/flattened/Control-Monad-Eff-Unsafe.js+8 tests/support/flattened/Control-Monad-Eff-Unsafe.purs+10 tests/support/flattened/Control-Monad-Eff.js+62 tests/support/flattened/Control-Monad-Eff.purs+67 tests/support/flattened/Control-Monad-ST.js+38 tests/support/flattened/Control-Monad-ST.purs+42 tests/support/flattened/Data-Function.js+233 tests/support/flattened/Data-Function.purs+113 tests/support/flattened/Prelude.js+228 tests/support/flattened/Prelude.purs+872 tests/support/flattened/Test-Assert.js+27 tests/support/flattened/Test-Assert.purs+46 psci/tests/data/Sample.purs → tests/support/psci/Sample.purs travis/after.sh+5−17 travis/configure.sh+1−1
.gitignore+2−1
@@ -14,5 +14,6 @@ bower_components/
1414node_modules
1515tmp/
1616.stack-work/
17−tests/support/flattened/
1817output
18+examples/docs/docs/
19+core-tests/full-core-docs.md
.travis.yml+13−26
@@ -1,36 +1,21 @@
11language: c
2−sudo: false
2+dist: trusty
3+sudo: required
34matrix:
45 include:
5− - env: GHCVER=7.8.4 COVERAGE_SUITE=tests
6− compiler: ": #GHC 7.8.4 - tests"
7− # ^ HACK before https://github.com/travis-ci/travis-ci/issues/4393 is resolved
8− addons: {apt: {packages: [cabal-install-1.22,ghc-7.8.4,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}}
9− - env: GHCVER=7.8.4 COVERAGE_SUITE=psci-tests
10− compiler: ": #GHC 7.8.4 - psci-tests"
11− addons: {apt: {packages: [cabal-install-1.22,ghc-7.8.4,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}}
12− - env: GHCVER=7.8.4 STACKAGE=lts-2.22
13− compiler: ": #GHC 7.8.4 - lts-2.22-1"
14− addons: {apt: {packages: [cabal-install-1.22,ghc-7.8.4,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}}
15− - env: GHCVER=7.6.3
16− compiler: ": #GHC 7.6.3"
17− addons: {apt: {packages: [cabal-install-1.22,ghc-7.6.3,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}}
18− - env: GHCVER=7.10.1 DEPLOY=yes
19− compiler: ": #GHC 7.10.1"
20− addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.1,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}}
21− - env: GHCVER=7.10.2 STACKAGE=lts=3.6 RUNSDISTTESTS=YES
22− compiler: ": #GHC 7.10.2 lts-3.6"
23− addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.2,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}}
24− - env: GHCVER=7.10.2 STACKAGE=nightly-2015-09-29
25− compiler: ": #GHC 7.10.2 nightly-2015-09-29"
26− addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.2,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}}
27− - env: GHCVER=7.10.3
6+ - env: GHCVER=7.10.3 CABALVER=1.22 STACKAGE=lts-5.4 RUNSDISTTESTS=YES
7+ compiler: ": #GHC 7.10.3 lts-5.4"
8+ addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}}
9+ - env: GHCVER=7.10.3 CABALVER=1.22 STACKAGE=nightly-2016-02-25
10+ compiler: ": #GHC 7.10.3 nightly-2016-02-25"
11+ addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}}
12+ - env: GHCVER=7.10.3 CABALVER=1.22 DEPLOY=yes
2813 compiler: ": #GHC 7.10.3"
2914 addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}}
3015before_install:
3116 - unset CC
3217 - export PATH="/opt/ghc/$GHCVER/bin:$PATH"
33− - export PATH="/opt/cabal/1.22/bin:$PATH"
18+ - export PATH="/opt/cabal/$CABALVER/bin:$PATH"
3419 - export PATH="$HOME/.cabal/bin:$PATH"
3520 - export PATH="/opt/happy/1.19.5/bin:/$PATH"
3621 - export PATH="/opt/alex/3.1.4/bin:/$PATH"
@@ -51,12 +36,14 @@ install:
5136 - mkdir -p .cabal-sandbox
5237 - cabal sandbox init --sandbox .cabal-sandbox
5338 # Download stackage cabal.config, not sure whether filtering is necessary
54− - if [ -n "$STACKAGE" ]; then curl http://www.stackage.org/$STACKAGE/cabal.config | grep -v purescript > cabal.config; fi
39+ - if [ -n "$STACKAGE" ]; then curl https://www.stackage.org/$STACKAGE/cabal.config | egrep -v 'purescript|sourcemap' > cabal.config; fi
5540 - cabal install --only-dependencies --enable-tests
5641 - cabal install hpc-coveralls
5742 # Snapshot state of the sandbox now, so we don't need to make new one for test install
5843 - rm -rf ~/cabal-sandboxes/$GHCVER-${STACKAGE:-none}
5944 - cp -r .cabal-sandbox ~/cabal-sandboxes/$GHCVER-${STACKAGE:-none}
45+ # Install bower globally (for psc-docs/psc-publish tests)
46+ - npm install -g bower
6047script:
6148 - ./travis/configure.sh
6249 - cabal build --ghc-options="-Werror"
CONTRIBUTORS.md+10−4
@@ -12,7 +12,11 @@ This file lists the contributors to the PureScript compiler project, and the ter
1212- [@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.
1313- [@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.
1414- [@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).
15+- [@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).
16+- [@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).
17+- [@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).
1518- [@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).
19+- [@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).
1620- [@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).
1721- [@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).
1822- [@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.
@@ -21,6 +25,7 @@ This file lists the contributors to the PureScript compiler project, and the ter
2125- [@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).
2226- [@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).
2327- [@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).
28+- [@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).
2429- [@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).
2530- [@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).
2631- [@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.
@@ -41,6 +46,7 @@ This file lists the contributors to the PureScript compiler project, and the ter
4146- [@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).
4247- [@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.
4348- [@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).
49+- [@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).
4450- [@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).
4551- [@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).
4652- [@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).
@@ -50,16 +56,16 @@ This file lists the contributors to the PureScript compiler project, and the ter
5056- [@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).
5157- [@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).
5258- [@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.
59+- [@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).
60+- [@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).
61+- [@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).
5362- [@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).
5463- [@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).
64+- [@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).
5565- [@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).
5666- [@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).
5767- [@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.
5868- [@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).
59−- [@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).
60−<http://opensource.org/licenses/MIT>.
61−- [@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).
62−- [@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).
6369
6470### Companies
6571
INSTALL.md+4−8
@@ -6,8 +6,8 @@ alternatively Stack Overflow.
66
77## Using prebuilt binaries
88
9−The prebuilt binaries are compiled with GHC 7.8.4, and therefore they should
10−run on any operating system supported by GHC 7.8.4, such as:
9+The prebuilt binaries are compiled with GHC 7.10.3, and therefore they should
10+run on any operating system supported by GHC 7.10.3, such as:
1111
1212* Windows 2000 or later,
1313* OS X 10.7 or later,
@@ -23,11 +23,11 @@ requirements.
2323
2424## Compiling from source
2525
26−GHC 7.6.1 or newer is required to compile from source. The easiest way is to
26+GHC 7.10.1 or newer is required to compile from source. The easiest way is to
2727use stack:
2828
2929```
30−$ stack install purescript
30+$ stack install --resolver=nightly purescript
3131```
3232
3333This will then copy the compiler and utilities into `~/.local/bin`.
@@ -39,10 +39,6 @@ If you don't have stack installed yet there are install instructions
3939If you don't have ghc installed yet, stack will prompt you to run `stack setup`
4040which will install ghc for you.
4141
42−The PureScript compiler has been known to run on OS X 10.6 when built with GHC
43−7.6.
44−
45−
4642## The "curses" library
4743
4844`psci` depends on the `curses` library (via the Haskell package `terminfo`). If
LICENSE+34
@@ -63,6 +63,7 @@ PureScript uses the following Haskell library packages. Their license files foll
6363 safe
6464 scientific
6565 semigroups
66+ sourcemap
6667 split
6768 stm
6869 syb
@@ -1589,6 +1590,39 @@ semigroups LICENSE file:
15891590 ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
15901591 POSSIBILITY OF SUCH DAMAGE.
15911592
1593+sourcemap LICENSE file:
1594+
1595+ Copyright (c) 2012, Chris Done
1596+
1597+ All rights reserved.
1598+
1599+ Redistribution and use in source and binary forms, with or without
1600+ modification, are permitted provided that the following conditions are met:
1601+
1602+ * Redistributions of source code must retain the above copyright
1603+ notice, this list of conditions and the following disclaimer.
1604+
1605+ * Redistributions in binary form must reproduce the above
1606+ copyright notice, this list of conditions and the following
1607+ disclaimer in the documentation and/or other materials provided
1608+ with the distribution.
1609+
1610+ * Neither the name of Chris Done nor the names of other
1611+ contributors may be used to endorse or promote products derived
1612+ from this software without specific prior written permission.
1613+
1614+ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
1615+ "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
1616+ LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
1617+ A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
1618+ OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
1619+ SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
1620+ LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
1621+ DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
1622+ THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
1623+ (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
1624+ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
1625+
15921626split LICENSE file:
15931627
15941628 Copyright (c) 2008 Brent Yorgey, Louis Wasserman
bundle/README+9−6
@@ -10,12 +10,15 @@ Installation Instructions
1010
1111This bundle contains the following executables:
1212
13−- psc The PureScript compiler
14−- psci The PureScript interactive REPL (requires NodeJS)
15−- psc-docs A Markdown documentation generator for PureScript code
16−- psc-bundle Bundles together CommonJS modules produced by `psc` into a
17− single JavaScript file; useful for running in the browser.
18−- psc-publish Generates documentation packages for uploading to Pursuit
13+- psc The PureScript compiler
14+- psci The PureScript interactive REPL (requires NodeJS)
15+- psc-docs A Markdown documentation generator for PureScript code
16+- psc-bundle Bundles together CommonJS modules produced by `psc` into a
17+ single JavaScript file; useful for running in the browser.
18+- psc-publish Generates documentation packages for uploading to Pursuit
19+- psc-ide-server Provides Editor Support in the form of type information and
20+ autocompletion
21+- psc-ide-client Utility to query psc-ide-server
1922
2023Copy these files anywhere on your PATH.
2124
bundle/build-stack.shnew file+50
@@ -0,0 +1,50 @@
1+set -e
2+
3+SCRIPTPATH=$( cd "$(dirname "$0")" ; pwd -P )
4+
5+OS=$1
6+
7+if [ -z $OS ]
8+then
9+ echo "Usage: build.sh osname"
10+ exit 1
11+fi
12+
13+pushd ${SCRIPTPATH} > /dev/null
14+
15+# Make the staging directory
16+mkdir -p build/purescript/
17+
18+# Strip the binaries
19+strip ~/.local/bin/psc
20+strip ~/.local/bin/psci
21+strip ~/.local/bin/psc-docs
22+strip ~/.local/bin/psc-publish
23+strip ~/.local/bin/psc-bundle
24+strip ~/.local/bin/psc-ide-server
25+strip ~/.local/bin/psc-ide-client
26+
27+# Copy files to staging directory
28+cp ~/.local/bin/psc build/purescript/
29+cp ~/.local/bin/psci build/purescript/
30+cp ~/.local/bin/psc-docs build/purescript/
31+cp ~/.local/bin/psc-publish build/purescript/
32+cp ~/.local/bin/psc-bundle build/purescript/
33+cp ~/.local/bin/psc-ide-server build/purescript/
34+cp ~/.local/bin/psc-ide-client build/purescript/
35+cp README build/purescript/
36+cp ../LICENSE build/purescript/
37+cp ../INSTALL.md build/purescript/
38+
39+# Make the binary bundle
40+pushd build > /dev/null
41+tar -zcvf ../$OS.tar.gz purescript
42+popd > /dev/null
43+
44+# Calculate the SHA hash
45+shasum $OS.tar.gz > $OS.sha
46+
47+# Remove the staging directory
48+rm -rf build/
49+
50+popd > /dev/null
bundle/build.sh+12−8
@@ -21,16 +21,20 @@ strip ../dist/build/psci/psci
2121strip ../dist/build/psc-docs/psc-docs
2222strip ../dist/build/psc-publish/psc-publish
2323strip ../dist/build/psc-bundle/psc-bundle
24+strip ../dist/build/psc-ide-server/psc-ide-server
25+strip ../dist/build/psc-ide-client/psc-ide-client
2426
2527# Copy files to staging directory
26−cp ../dist/build/psc/psc build/purescript/
27−cp ../dist/build/psci/psci build/purescript/
28−cp ../dist/build/psc-docs/psc-docs build/purescript/
29−cp ../dist/build/psc-publish/psc-publish build/purescript/
30−cp ../dist/build/psc-bundle/psc-bundle build/purescript/
31−cp README build/purescript/
32−cp ../LICENSE build/purescript/
33−cp ../INSTALL.md build/purescript/
28+cp ../dist/build/psc/psc build/purescript/
29+cp ../dist/build/psci/psci build/purescript/
30+cp ../dist/build/psc-docs/psc-docs build/purescript/
31+cp ../dist/build/psc-publish/psc-publish build/purescript/
32+cp ../dist/build/psc-bundle/psc-bundle build/purescript/
33+cp ../dist/build/psc-ide-server/psc-ide-server build/purescript/
34+cp ../dist/build/psc-ide-client/psc-ide-client build/purescript/
35+cp README build/purescript/
36+cp ../LICENSE build/purescript/
37+cp ../INSTALL.md build/purescript/
3438
3539# Make the binary bundle
3640pushd build > /dev/null
bundle/winbuild.sh+12−8
@@ -17,16 +17,20 @@ strip ../dist/build/psci/psci.exe
1717strip ../dist/build/psc-docs/psc-docs.exe
1818strip ../dist/build/psc-publish/psc-publish.exe
1919strip ../dist/build/psc-bundle/psc-bundle.exe
20+strip ../dist/build/psc-ide-server/psc-ide-server.exe
21+strip ../dist/build/psc-ide-client/psc-ide-client.exe
2022
2123# Copy files to staging directory
22−cp ../dist/build/psc/psc.exe build/purescript/
23−cp ../dist/build/psci/psci.exe build/purescript/
24−cp ../dist/build/psc-docs/psc-docs.exe build/purescript/
25−cp ../dist/build/psc-publish/psc-publish.exe build/purescript/
26−cp ../dist/build/psc-bundle/psc-bundle.exe build/purescript/
27−cp README build/purescript/
28−cp ../LICENSE build/purescript/
29−cp ../INSTALL.md build/purescript/
24+cp ../dist/build/psc/psc.exe build/purescript/
25+cp ../dist/build/psci/psci.exe build/purescript/
26+cp ../dist/build/psc-docs/psc-docs.exe build/purescript/
27+cp ../dist/build/psc-publish/psc-publish.exe build/purescript/
28+cp ../dist/build/psc-bundle/psc-bundle.exe build/purescript/
29+cp ../dist/build/psc-ide-server/psc-ide-server.exe build/purescript/
30+cp ../dist/build/psc-ide-client/psc-ide-client.exe build/purescript/
31+cp README build/purescript/
32+cp ../LICENSE build/purescript/
33+cp ../INSTALL.md build/purescript/
3034
3135# Make the binary bundle
3236pushd build
core-tests/test-everything.sh+5−3
@@ -18,9 +18,7 @@ if [ "$force_reinstall" = "true" ] && [ -d "bower_components" ]; then
1818 rm -r bower_components
1919fi
2020
21−npm install bower
22−
23−node_modules/.bin/bower i \
21+bower i \
2422 purescript-prelude \
2523 purescript-eff \
2624 purescript-st \
@@ -75,3 +73,7 @@ fi
7573../dist/build/psc/psc tests/*/*.purs \
7674 'bower_components/purescript-*/src/**/*.purs' \
7775 --ffi 'bower_components/purescript-*/src/**/*.js'
76+
77+../dist/build/psc-docs/psc-docs tests/*/*.purs \
78+ 'bower_components/purescript-*/src/**/*.purs' \
79+ > full-core-docs.md
examples/docs/bower.jsonnew file+19
@@ -0,0 +1,19 @@
1+{
2+ "name": "docs-test-package",
3+ "version": "1.0.0",
4+ "moduleType": [
5+ "node"
6+ ],
7+ "repository": {
8+ "type": "git",
9+ "url": "git://github.com/not-real/not-a-real-repo.git"
10+ },
11+ "ignore": [
12+ "**/.*",
13+ "node_modules",
14+ "bower_components",
15+ "output"
16+ ],
17+ "dependencies": {
18+ }
19+}
examples/docs/bower_components/purescript-prelude/src/Prelude.pursnew file+8
@@ -0,0 +1,8 @@
1+module Prelude where
2+
3+newtype Unit = Unit {}
4+
5+unit :: Unit
6+unit = Unit {}
7+
8+data Boolean2 = True | False
examples/docs/src/Clash.pursnew file+32
@@ -0,0 +1,32 @@
1+module Clash (module Clash1) where
2+
3+import Clash1 as Clash1
4+import Clash2 as Clash2
5+
6+module Clash1 (module Clash1a) where
7+
8+import Clash1a
9+
10+module Clash1a where
11+
12+value :: Int
13+value = 0
14+
15+type Type = Int
16+
17+class TypeClass a where
18+ typeClassMember :: a
19+
20+module Clash2 (module Clash2a) where
21+
22+import Clash2a
23+
24+module Clash2a where
25+
26+value :: String
27+value = "hello"
28+
29+type Type = String
30+
31+class TypeClass a b where
32+ typeClassMember :: a -> b
examples/docs/src/DuplicateNames.pursnew file+9
@@ -0,0 +1,9 @@
1+module DuplicateNames
2+ ( module DuplicateNames
3+ , module Prelude
4+ ) where
5+
6+import Prelude (Unit)
7+
8+unit :: Int
9+unit = 0
examples/docs/src/Example.pursnew file+7
@@ -0,0 +1,7 @@
1+module Example
2+ ( module Prelude
3+ , module Example2
4+ ) where
5+
6+import Prelude (Unit())
7+import Example2 (one)
examples/docs/src/Example2.pursnew file+7
@@ -0,0 +1,7 @@
1+module Example2 where
2+
3+one :: Int
4+one = 1
5+
6+two :: Int
7+two = 2
examples/docs/src/ExplicitTypeSignatures.pursnew file+16
@@ -0,0 +1,16 @@
1+
2+module ExplicitTypeSignatures where
3+
4+-- This should use the explicit type signature so that the type variable name
5+-- is preserved.
6+explicit :: forall something. something -> something
7+explicit x
8+ | true = x
9+ | false = x
10+
11+-- This should use the inferred type.
12+anInt :: _
13+anInt = 0
14+
15+-- This should infer a type.
16+aNumber = 1.0
examples/docs/src/ImportedTwice.pursnew file+27
@@ -0,0 +1,27 @@
1+-- See also an example in the wild: purescript-transformers v0.8.4.
2+-- Control.Monad.RWS.Trans re-exports `lift` from both Control.Monad.Trans
3+-- (where it is originally defined) and Control.Monad.RWS.Class (which
4+-- re-exports it from Control.Monad.Trans).
5+
6+module ImportedTwice
7+ ( module A
8+ , module B
9+ )
10+ where
11+
12+import A
13+import B
14+
15+module A
16+ ( module B )
17+ where
18+
19+import B
20+
21+bar :: Int
22+bar = 1
23+
24+module B where
25+
26+foo :: Int
27+foo = 0
examples/docs/src/MultiVirtual.pursnew file+27
@@ -0,0 +1,27 @@
1+module MultiVirtual
2+ ( module X )
3+ where
4+
5+import MultiVirtual1 as X
6+import MultiVirtual2 as X
7+
8+
9+module MultiVirtual1 where
10+
11+foo :: Int
12+foo = 1
13+
14+module MultiVirtual2
15+ ( module MultiVirtual2
16+ , module MultiVirtual3
17+ ) where
18+
19+import MultiVirtual3
20+
21+bar :: Int
22+bar = 2
23+
24+module MultiVirtual3 where
25+
26+baz :: Int
27+baz = 3
examples/docs/src/NewOperators.pursnew file+12
@@ -0,0 +1,12 @@
1+module NewOperators
2+ ( module NewOperators2 )
3+ where
4+
5+import NewOperators2
6+
7+module NewOperators2 where
8+
9+infixl 8 _compose as >>>
10+
11+_compose :: forall a b c. (b -> c) -> (a -> b) -> (a -> c)
12+_compose f g x = f (g x)
examples/docs/src/NotAllCtors.pursnew file+5
@@ -0,0 +1,5 @@
1+module NotAllCtors
2+ ( module Prelude )
3+ where
4+
5+import Prelude (Boolean2(True))
examples/docs/src/OldOperators.pursnew file+10
@@ -0,0 +1,10 @@
1+
2+-- Remove this after 0.9.
3+module OldOperators (module OldOperators2) where
4+
5+import OldOperators2
6+
7+module OldOperators2 where
8+
9+(>>) :: forall a. a -> a -> a
10+(>>) a b = b
examples/docs/src/ReExportedTypeClass.pursnew file+5
@@ -0,0 +1,5 @@
1+module ReExportedTypeClass
2+ ( module SomeTypeClass )
3+ where
4+
5+import SomeTypeClass
examples/docs/src/SolitaryTypeClassMember.pursnew file+6
@@ -0,0 +1,6 @@
1+module SolitaryTypeClassMember
2+ ( module SomeTypeClass )
3+ where
4+
5+import SomeTypeClass (member)
6+
examples/docs/src/SomeTypeClass.pursnew file+5
@@ -0,0 +1,5 @@
1+
2+module SomeTypeClass where
3+
4+class SomeClass a where
5+ member :: a
examples/docs/src/Transitive1.pursnew file+5
@@ -0,0 +1,5 @@
1+module Transitive1
2+ ( module Transitive2 )
3+ where
4+
5+import Transitive2
examples/docs/src/Transitive2.pursnew file+5
@@ -0,0 +1,5 @@
1+module Transitive2
2+ ( module Transitive3 )
3+ where
4+
5+import Transitive3
examples/docs/src/Transitive3.pursnew file+4
@@ -0,0 +1,4 @@
1+module Transitive3 where
2+
3+transitive3 :: Int
4+transitive3 = 0
examples/docs/src/TypeClassWithoutMembers.pursnew file+11
@@ -0,0 +1,11 @@
1+module TypeClassWithoutMembers
2+ ( module Intermediate )
3+ where
4+
5+import Intermediate
6+
7+module Intermediate
8+ ( module SomeTypeClass )
9+ where
10+
11+import SomeTypeClass (SomeClass)
examples/docs/src/UTF8.pursnew file+7
@@ -0,0 +1,7 @@
1+module UTF8 where
2+
3+import Prelude (Unit, unit)
4+
5+-- | üÜäÄ 😰
6+thing :: Unit
7+thing = unit
examples/docs/src/Virtual.pursnew file+5
@@ -0,0 +1,5 @@
1+module Virtual
2+ ( module VirtualPrelude )
3+ where
4+
5+import Prelude as VirtualPrelude
examples/failing/1733.pursnew file+13
@@ -0,0 +1,13 @@
1+-- @shouldFailWith UnknownValue
2+
3+module Main where
4+
5+import Thingy as Thing
6+
7+main = Thing.doesntExist "hi"
8+
9+module Thingy where
10+
11+foo :: Int
12+foo = 1
13+
examples/failing/1825.pursnew file+9
@@ -0,0 +1,9 @@
1+-- @shouldFailWith UnknownValue
2+
3+module Main where
4+
5+data W = X | Y | Z
6+
7+bad X a = a
8+bad Y _ = a
9+bad Z a = a
examples/failing/AnonArgument1.pursnew file+5
@@ -0,0 +1,5 @@
1+-- @shouldFailWith IncorrectAnonymousArgument
2+module Main where
3+
4+test :: Int -> Int
5+test = _
examples/failing/AnonArgument2.pursnew file+7
@@ -0,0 +1,7 @@
1+-- @shouldFailWith IncorrectAnonymousArgument
2+module Main where
3+
4+import Prelude
5+
6+test :: Int -> Int
7+test = 1 + 2 * _
examples/failing/AnonArgument3.pursnew file+5
@@ -0,0 +1,5 @@
1+-- @shouldFailWith IncorrectAnonymousArgument
2+module Main where
3+
4+test :: Int -> Int
5+test = 1 + _
examples/failing/ConflictingExports2.pursdeleted−13
@@ -1,13 +0,0 @@
1−-- @shouldFailWith ScopeConflict
2−module A where
3−
4− thing :: Int
5− thing = 1
6−
7−-- Fails here because re-exporting forces any scope conflicts to be resolved
8−module Main (thing, module A) where
9−
10− import A
11−
12− thing :: Int
13− thing = 2
examples/failing/ConflictingImports2.purs+8−4
@@ -4,13 +4,17 @@ module A where
44 thing :: Int
55 thing = 1
66
7−module Main where
8−
9− import A
7+module B where
108
119 thing :: Int
1210 thing = 2
1311
14− -- Error due to referencing `thing` which is in scope as A.thing and Main.thing
12+module Main where
13+
14+ import A (thing)
15+ import B (thing)
16+
17+ -- Error due to referencing `thing` which is explicitly in scope as A.thing
18+ -- and B.thing
1519 what :: Int
1620 what = thing
examples/failing/DctorOperatorAliasExport.pursnew file+6
@@ -0,0 +1,6 @@
1+-- @shouldFailWith TransitiveDctorExportError
2+module Data.List (List, (:)) where
3+
4+ data List a = Cons a (List a) | Nil
5+
6+ infixr 6 Cons as :
examples/failing/IntOutOfRange.purs+1−1
@@ -3,4 +3,4 @@
33module Main where
44
55n :: Int
6−n = 35028715023
6+n = 2147483648
examples/failing/InvalidOperatorInBinder.pursnew file+12
@@ -0,0 +1,12 @@
1+-- @shouldFailWith InvalidOperatorInBinder
2+module Main where
3+
4+data List a = Cons a (List a) | Nil
5+
6+cons ∷ ∀ a. a → List a → List a
7+cons = Cons
8+
9+infixl 6 cons as :
10+
11+get ∷ ∀ a. List a → a
12+get (_ : x : _) = x
examples/passing/DctorOperatorAlias.pursnew file+35
@@ -0,0 +1,35 @@
1+module Data.List where
2+
3+ data List a = Cons a (List a) | Nil
4+
5+ infixr 6 Cons as :
6+
7+module Main where
8+
9+ import Prelude (Unit, bind, (==))
10+ import Control.Monad.Eff (Eff)
11+ import Control.Monad.Eff.Console (CONSOLE, log)
12+ import Test.Assert (ASSERT, assert')
13+ import Data.List (List(..), (:))
14+
15+ infixl 6 Cons as !
16+
17+ get1 ∷ ∀ a. a → List a → a
18+ get1 y xs = case xs of
19+ _ : x : _ → x
20+ _ → y
21+
22+ get2 ∷ ∀ a. a → List a → a
23+ get2 _ (_ : x : _) = x
24+ get2 y _ = y
25+
26+ get3 ∷ ∀ a. a → List a → a
27+ get3 _ (_ ! (x ! _)) = x
28+ get3 y _ = y
29+
30+ main ∷ Eff (assert ∷ ASSERT, console ∷ CONSOLE) Unit
31+ main = do
32+ assert' "Incorrect result!" (get1 0 (1 : 2 : 3 : Nil) == 2)
33+ assert' "Incorrect result!" (get2 0 (1 ! (2 ! (3 ! Nil))) == 2)
34+ assert' "Incorrect result!" (get3 0.0 (1.0 : 2.0 : (3.0 ! Nil)) == 2.0)
35+ log "Done"
examples/passing/Deriving.pursnew file+31
@@ -0,0 +1,31 @@
1+module Main where
2+
3+import Prelude
4+import Test.Assert
5+
6+data V
7+
8+derive instance eqV :: Eq V
9+
10+derive instance ordV :: Ord V
11+
12+data X = X Int | Y String
13+
14+derive instance eqX :: Eq X
15+
16+derive instance ordX :: Ord X
17+
18+newtype Z = Z { left :: X, right :: X }
19+
20+derive instance eqZ :: Eq Z
21+
22+main = do
23+ assert $ X 0 == X 0
24+ assert $ X 0 /= X 1
25+ assert $ Y "Foo" == Y "Foo"
26+ assert $ Y "Foo" /= Y "Bar"
27+ assert $ X 0 < X 1
28+ assert $ X 0 < Y "Foo"
29+ assert $ Y "Bar" < Y "Baz"
30+ assert $ z == z where
31+ z = Z { left: X 0, right: Y "Foo" }
examples/passing/ExplicitOperatorSections.pursnew file+14
@@ -0,0 +1,14 @@
1+module Main where
2+
3+import Prelude
4+
5+subtractOne :: Int -> Int
6+subtractOne = (_ - 1)
7+
8+addOne :: Int -> Int
9+addOne = (1 + _)
10+
11+named :: Int -> Int
12+named = (_ `sub` 1)
13+
14+main = Control.Monad.Eff.Console.log "Done"
examples/passing/NegativeIntInRange.pursnew file+8
@@ -0,0 +1,8 @@
1+module Main where
2+
3+import Prelude
4+
5+n :: Int
6+n = -2147483648
7+
8+main = Control.Monad.Eff.Console.log "Done"
examples/passing/OperatorAliasElsewhere.pursnew file+14
@@ -0,0 +1,14 @@
1+module Def where
2+
3+what :: forall a b. a -> b -> a
4+what a _ = a
5+
6+module Main where
7+
8+import Prelude
9+import Def (what)
10+import Control.Monad.Eff.Console
11+
12+infixl 4 what as ?!
13+
14+main = log $ "Done" ?! true
examples/passing/ResolvableScopeConflict.pursnew file+25
@@ -0,0 +1,25 @@
1+module A where
2+
3+ thing :: Int
4+ thing = 1
5+
6+module B where
7+
8+ thing :: Int
9+ thing = 2
10+
11+ zing :: Int
12+ zing = 3
13+
14+module Main where
15+
16+ import A (thing)
17+ import B
18+
19+ -- Not an error as although we have `thing` in scope from both A and B, it is
20+ -- imported explicitly from A, giving it a resolvable solution.
21+ what :: Boolean -> Int
22+ what true = thing
23+ what false = zing
24+
25+ main = Control.Monad.Eff.Console.log "Done"
examples/passing/ResolvableScopeConflict2.pursnew file+22
@@ -0,0 +1,22 @@
1+module A where
2+
3+ thing :: Int
4+ thing = 2
5+
6+ zing :: Int
7+ zing = 3
8+
9+module Main where
10+
11+ import A
12+
13+ thing :: Int
14+ thing = 1
15+
16+ -- Not an error as although we have `thing` in scope from both Main and A,
17+ -- as the local declaration takes precedence over the implicit import
18+ what :: Boolean -> Int
19+ what true = thing
20+ what false = zing
21+
22+ main = Control.Monad.Eff.Console.log "Done"
examples/passing/ResolvableScopeConflict3.pursnew file+15
@@ -0,0 +1,15 @@
1+module A where
2+
3+ thing :: Int
4+ thing = 1
5+
6+module Main (thing, main, module A) where
7+
8+ import A
9+
10+ thing :: Int
11+ thing = 2
12+
13+ main = Control.Monad.Eff.Console.log "Done"
14+
15+
examples/passing/TCO.pursnew file+20
@@ -0,0 +1,20 @@
1+module Main where
2+
3+import Prelude
4+import Control.Monad.Eff.Console (print)
5+
6+main = do
7+ let f x = x + 1
8+ let v = 0
9+ print (applyN 0 f v)
10+ print (applyN 1 f v)
11+ print (applyN 2 f v)
12+ print (applyN 3 f v)
13+ print (applyN 4 f v)
14+
15+applyN :: forall a. Int -> (a -> a) -> a -> a
16+applyN = go id
17+ where
18+ go f n _ | n <= 0 = f
19+ go f n g = go (f >>> g) (n - 1) g
20+
examples/passing/UnicodeType.pursnew file+23
@@ -0,0 +1,23 @@
1+module Main where
2+
3+import Prelude
4+
5+class (Monad m) ⇐ Monad1 m where
6+ f1 :: Int
7+
8+class (Monad m) <= Monad2 m where
9+ f2 :: Int
10+
11+f ∷ ∀ m. Monad m ⇒ Int → m Int
12+f n = do
13+ n' ← return n
14+ return n'
15+
16+f' :: forall m. Monad m => Int -> m Int
17+f' n = do
18+ n' <- return n
19+ return n'
20+
21+(←→) a b = a ←→ b
22+
23+main = Control.Monad.Eff.Console.log "Done"
hierarchy/Main.hs+2−1
@@ -14,6 +14,7 @@
1414-----------------------------------------------------------------------------
1515
1616{-# LANGUAGE TupleSections #-}
17+{-# LANGUAGE DataKinds #-}
1718
1819module Main where
1920
@@ -38,7 +39,7 @@ data HierarchyOptions = HierarchyOptions
3839 , hierarchyOutput :: Maybe FilePath
3940 }
4041
41−newtype SuperMap = SuperMap { unSuperMap :: Either P.ProperName (P.ProperName, P.ProperName) }
42+newtype SuperMap = SuperMap { unSuperMap :: Either (P.ProperName 'P.ClassName) ((P.ProperName 'P.ClassName), (P.ProperName 'P.ClassName)) }
4243 deriving Eq
4344
4445instance Show SuperMap where
psc-bundle/Main.hs+2−2
@@ -51,7 +51,7 @@ data Options = Options
5151 } deriving Show
5252
5353-- | Given a filename, assuming it is in the correct place on disk, infer a ModuleIdentifier.
54−guessModuleIdentifier :: (Applicative m, MonadError ErrorMessage m) => FilePath -> m ModuleIdentifier
54+guessModuleIdentifier :: (MonadError ErrorMessage m) => FilePath -> m ModuleIdentifier
5555guessModuleIdentifier filename = ModuleIdentifier (takeFileName (takeDirectory filename)) <$> guessModuleType (takeFileName filename)
5656 where
5757 guessModuleType "index.js" = pure Regular
@@ -61,7 +61,7 @@ guessModuleIdentifier filename = ModuleIdentifier (takeFileName (takeDirectory f
6161-- | The main application function.
6262-- This function parses the input files, performs dead code elimination, filters empty modules
6363-- and generates and prints the final Javascript bundle.
64−app :: (Applicative m, MonadError ErrorMessage m, MonadIO m) => Options -> m String
64+app :: (MonadError ErrorMessage m, MonadIO m) => Options -> m String
6565app Options{..} = do
6666 inputFiles <- concat <$> mapM (liftIO . glob) optionsInputFiles
6767 when (null inputFiles) . liftIO $ do
psc-docs/Main.hs+47−39
@@ -16,6 +16,7 @@
1616module Main where
1717
1818import Control.Applicative
19+import Control.Monad.Trans.Except (runExceptT)
1920import Control.Arrow (first, second)
2021import Control.Category ((>>>))
2122import Control.Monad.Writer
@@ -68,61 +69,68 @@ docgen (PSCDocsOptions fmt inputGlob output) = do
6869 Etags -> dumpTags input dumpEtags
6970 Ctags -> dumpTags input dumpCtags
7071 Markdown -> do
71− e <- D.parseAndDesugar input [] (\_ ms -> return ms)
72− case e of
73− Left (D.ParseError err) -> do
74− hPutStrLn stderr $ show err
75− exitFailure
76− Left (D.SortModulesError err) -> do
77− hPutStrLn stderr $ P.prettyPrintMultipleErrors False err
78− exitFailure
79− Left (D.DesugarError err) -> do
80− hPutStrLn stderr $ P.prettyPrintMultipleErrors False err
81− exitFailure
82− Right ms' ->
83− case output of
84− EverythingToStdOut ->
85− putStrLn (D.renderModulesAsMarkdown ms')
86− ToStdOut names -> do
87− let (ms, missing) = takeModulesByName ms' names
88− guardMissing missing
89− putStrLn (D.renderModulesAsMarkdown ms)
90− ToFiles names -> do
91− let (ms, missing) = takeModulesByName' ms' names
92− guardMissing missing
93− let ms'' = groupBy ((==) `on` fst) . sortBy (compare `on` fst) $ map swap ms
94− forM_ ms'' $ \grp -> do
95− let fp = fst (head grp)
96− createDirectoryIfMissing True (takeDirectory fp)
97− writeFile fp (D.renderModulesAsMarkdown $ snd `map` grp)
72+ ms <- runExceptT (D.parseAndBookmark input []
73+ >>= (fst >>> D.convertModulesInPackage))
74+ >>= successOrExit
75+
76+ case output of
77+ EverythingToStdOut ->
78+ putStrLn (D.runDocs (D.modulesAsMarkdown ms))
79+ ToStdOut names -> do
80+ let (ms', missing) = takeByName ms names
81+ guardMissing missing
82+ putStrLn (D.runDocs (D.modulesAsMarkdown ms'))
83+ ToFiles names -> do
84+ let (ms', missing) = takeByName' ms names
85+ guardMissing missing
86+
87+ let ms'' = groupBy ((==) `on` fst) . sortBy (compare `on` fst) $ map swap ms'
88+ forM_ ms'' $ \grp -> do
89+ let fp = fst (head grp)
90+ createDirectoryIfMissing True (takeDirectory fp)
91+ writeFile fp (D.runDocs (D.modulesAsMarkdown (map snd grp)))
92+
9893 where
9994 guardMissing [] = return ()
10095 guardMissing [mn] = do
101− hPutStrLn stderr ("psc-docs: error: unknown module \"" ++ show mn ++ "\"")
96+ hPutStrLn stderr ("psc-docs: error: unknown module \"" ++ P.runModuleName mn ++ "\"")
10297 exitFailure
10398 guardMissing mns = do
10499 hPutStrLn stderr "psc-docs: error: unknown modules:"
105100 forM_ mns $ \mn ->
106− hPutStrLn stderr (" * " ++ show mn)
101+ hPutStrLn stderr (" * " ++ P.runModuleName mn)
107102 exitFailure
108103
104+ successOrExit :: Either P.MultipleErrors a -> IO a
105+ successOrExit act =
106+ case act of
107+ Right x ->
108+ return x
109+ Left err -> do
110+ hPutStrLn stderr $ P.prettyPrintMultipleErrors False err
111+ exitFailure
112+
113+ takeByName = takeModulesByName D.modName
114+ takeByName' = takeModulesByName' D.modName
115+
109116-- |
110117-- Given a list of module names and a list of modules, return a list of modules
111118-- whose names appeared in the given name list, together with a list of names
112119-- for which no module could be found in the module list.
113120--
114−takeModulesByName :: [P.Module] -> [P.ModuleName] -> ([P.Module], [P.ModuleName])
115−takeModulesByName modules names =
116− first (map fst) (takeModulesByName' modules (map (,()) names))
121+takeModulesByName :: (Eq n) => (m -> n) -> [m] -> [n] -> ([m], [n])
122+takeModulesByName getModuleName modules names =
123+ first (map fst) (takeModulesByName' getModuleName modules (map (,()) names))
117124
118125-- |
119−-- Like takeModulesByName but also keeps some extra data with the module.
126+-- Like takeModulesByName, but also keeps some extra information with each
127+-- module.
120128--
121−takeModulesByName' :: [P.Module] -> [(P.ModuleName, a)] -> ([(P.Module, a)], [P.ModuleName])
122−takeModulesByName' modules = foldl go ([], [])
129+takeModulesByName' :: (Eq n) => (m -> n) -> [m] -> [(n, a)] -> ([(m, a)], [n])
130+takeModulesByName' getModuleName modules = foldl go ([], [])
123131 where
124132 go (ms, missing) (name, x) =
125− case find ((== name) . P.getModuleName) modules of
133+ case find ((== name) . getModuleName) modules of
126134 Just m -> ((m, x) : ms, missing)
127135 Nothing -> (ms, name : missing)
128136
@@ -236,16 +244,16 @@ examples =
236244 PP.vcat $ map PP.text
237245 [ "Examples:"
238246 , " print documentation for Data.List to stdout:"
239− , " psc-docs src/**/*.purs bower_components/*/src/**/*.purs \\"
247+ , " psc-docs \"src/**/*.purs\" \"bower_components/*/src/**/*.purs\" \\"
240248 , " --docgen Data.List"
241249 , ""
242250 , " write documentation for Data.List to docs/Data.List.md:"
243− , " psc-docs src/**/*.purs bower_components/*/src/**/*.purs \\"
251+ , " psc-docs \"src/**/*.purs\" \"bower_components/*/src/**/*.purs\" \\"
244252 , " --docgen Data.List:docs/Data.List.md"
245253 , ""
246254 , " write documentation for Data.List to docs/Data.List.md, and"
247255 , " documentation for Data.List.Lazy to docs/Data.List.Lazy.md:"
248− , " psc-docs src/**/*.purs bower_components/*/src/**/*.purs \\"
256+ , " psc-docs \"src/**/*.purs\" \"bower_components/*/src/**/*.purs\" \\"
249257 , " --docgen Data.List:docs/Data.List.md \\"
250258 , " --docgen Data.List.Lazy:docs/Data.List.Lazy.md"
251259 ]
psc-ide-client/Main.hsnew file+56
@@ -0,0 +1,56 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module Main where
3+
4+import Prelude ()
5+import Prelude.Compat
6+
7+import Control.Exception
8+import Data.Text (Text)
9+import qualified Data.Text as T
10+import qualified Data.Text.IO as T
11+import Data.Version (showVersion)
12+import Network
13+import Options.Applicative
14+import System.Exit
15+import System.IO
16+
17+import qualified Paths_purescript as Paths
18+
19+data Options = Options
20+ { optionsPort :: PortID
21+ }
22+
23+main :: IO ()
24+main = do
25+ Options port <- execParser opts
26+ client port
27+ where
28+ parser =
29+ Options <$>
30+ (PortNumber . fromIntegral <$>
31+ option auto (long "port" <> short 'p' <> value (4242 :: Integer)))
32+ opts = info (version <*> helper <*> parser) mempty
33+ version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> help "Show the version number" <> hidden
34+
35+client :: PortID -> IO ()
36+client port = do
37+ h <-
38+ connectTo "localhost" port `catch`
39+ (\(SomeException e) ->
40+ putStrLn
41+ ("Couldn't connect to psc-ide-server on port: " ++
42+ show port ++ " Error: " ++ show e) >>
43+ exitFailure)
44+ cmd <- T.getLine
45+ -- Temporary fix for emacs windows bug
46+ let cleanedCmd = removeSurroundingTicks cmd
47+ --
48+ T.hPutStrLn h cleanedCmd
49+ res <- T.hGetLine h
50+ putStrLn (T.unpack res)
51+ hFlush stdout
52+ hClose h
53+
54+-- TODO: Fix this in the emacs plugin by using a real process over shellcommands
55+removeSurroundingTicks :: Text -> Text
56+removeSurroundingTicks = T.dropWhile (== '\'') . T.dropWhileEnd (== '\'')
psc-ide-server/Main.hsnew file+148
@@ -0,0 +1,148 @@
1+{-# LANGUAGE ConstraintKinds #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE MultiParamTypeClasses #-}
4+{-# LANGUAGE OverloadedStrings #-}
5+{-# LANGUAGE PackageImports #-}
6+{-# LANGUAGE TemplateHaskell #-}
7+module Main where
8+
9+import Prelude ()
10+import Prelude.Compat
11+
12+import Control.Concurrent (forkFinally)
13+import Control.Concurrent.STM
14+import Control.Exception (bracketOnError, catchJust)
15+import Control.Monad
16+import Control.Monad.Error.Class
17+import "monad-logger" Control.Monad.Logger
18+import Control.Monad.Reader
19+import Control.Monad.Trans.Except
20+import qualified Data.Text as T
21+import qualified Data.Text.IO as T
22+import Data.Version (showVersion)
23+import Language.PureScript.Ide
24+import Language.PureScript.Ide.CodecJSON
25+import Language.PureScript.Ide.Error
26+import Language.PureScript.Ide.Types
27+import Language.PureScript.Ide.Watcher
28+import Network hiding (socketPort)
29+import Network.BSD (getProtocolNumber)
30+import Network.Socket hiding (PortNumber, Type,
31+ accept, sClose)
32+import Options.Applicative
33+import System.Directory
34+import System.FilePath
35+import System.IO
36+import System.IO.Error (isEOFError)
37+
38+import qualified Paths_purescript as Paths
39+
40+-- "Borrowed" from the Idris Compiler
41+-- Copied from upstream impl of listenOn
42+-- bound to localhost interface instead of iNADDR_ANY
43+listenOnLocalhost :: PortID -> IO Socket
44+listenOnLocalhost (PortNumber port) = do
45+ proto <- getProtocolNumber "tcp"
46+ localhost <- inet_addr "127.0.0.1"
47+ bracketOnError
48+ (socket AF_INET Stream proto)
49+ sClose
50+ (\sock -> do
51+ setSocketOption sock ReuseAddr 1
52+ bindSocket sock (SockAddrInet port localhost)
53+ listen sock maxListenQueue
54+ pure sock)
55+listenOnLocalhost _ = error "Wrong Porttype"
56+
57+data Options = Options
58+ { optionsDirectory :: Maybe FilePath
59+ , optionsOutputPath :: FilePath
60+ , optionsPort :: PortID
61+ , optionsDebug :: Bool
62+ }
63+
64+main :: IO ()
65+main = do
66+ Options dir outputPath port debug <- execParser opts
67+ maybe (pure ()) setCurrentDirectory dir
68+ serverState <- newTVarIO emptyPscIdeState
69+ cwd <- getCurrentDirectory
70+ _ <- forkFinally (watcher serverState (cwd </> outputPath)) print
71+ let conf =
72+ Configuration
73+ {
74+ confDebug = debug
75+ , confOutputPath = outputPath
76+ }
77+ let env =
78+ PscIdeEnvironment
79+ {
80+ envStateVar = serverState
81+ , envConfiguration = conf
82+ }
83+ startServer port env
84+ where
85+ parser =
86+ Options <$>
87+ optional (strOption (long "directory" <> short 'd')) <*>
88+ strOption (long "output-directory" <> value "output/") <*>
89+ (PortNumber . fromIntegral <$>
90+ option auto (long "port" <> short 'p' <> value (4242 :: Integer))) <*>
91+ switch (long "debug")
92+ opts = info (version <*> helper <*> parser) mempty
93+ version = abortOption
94+ (InfoMsg (showVersion Paths.version))
95+ (long "version" <> help "Show the version number")
96+
97+startServer :: PortID -> PscIdeEnvironment -> IO ()
98+startServer port env = withSocketsDo $ do
99+ sock <- listenOnLocalhost port
100+ runLogger (runReaderT (forever (loop sock)) env)
101+ where
102+ runLogger = runStdoutLoggingT . filterLogger (\_ _ -> confDebug (envConfiguration env))
103+
104+ loop :: (PscIde m, MonadLogger m) => Socket -> m ()
105+ loop sock = do
106+ accepted <- runExceptT $ acceptCommand sock
107+ case accepted of
108+ Left err -> $(logDebug) err
109+ Right (cmd, h) -> do
110+ case decodeT cmd of
111+ Just cmd' -> do
112+ result <- runExceptT (handleCommand cmd')
113+ $(logDebug) ("Answer was: " <> T.pack (show result))
114+ liftIO (hFlush stdout)
115+ case result of
116+ -- What function can I use to clean this up?
117+ Right r -> liftIO $ T.hPutStrLn h (encodeT r)
118+ Left err -> liftIO $ T.hPutStrLn h (encodeT err)
119+ Nothing -> do
120+ $(logDebug) ("Parsing the command failed. Command: " <> cmd)
121+ liftIO $ do
122+ T.hPutStrLn h (encodeT (GeneralError "Error parsing Command."))
123+ hFlush stdout
124+ liftIO (hClose h)
125+
126+
127+acceptCommand :: (MonadIO m, MonadLogger m, MonadError T.Text m)
128+ => Socket -> m (T.Text, Handle)
129+acceptCommand sock = do
130+ h <- acceptConnection
131+ $(logDebug) "Accepted a connection"
132+ cmd' <- liftIO (catchJust
133+ -- this means that the connection was
134+ -- terminated without receiving any input
135+ (\e -> if isEOFError e then Just () else Nothing)
136+ (Just <$> T.hGetLine h)
137+ (const (pure Nothing)))
138+ case cmd' of
139+ Nothing -> throwError "Connection was closed before any input arrived"
140+ Just cmd -> do
141+ $(logDebug) cmd
142+ pure (cmd, h)
143+ where
144+ acceptConnection = liftIO $ do
145+ (h,_,_) <- accept sock
146+ hSetEncoding h utf8
147+ hSetBuffering h LineBuffering
148+ pure h
psc-ide-server/PROTOCOL.mdnew file+409
@@ -0,0 +1,409 @@
1+# Protocol
2+
3+Encode the following JSON formats into a single line string and pass them to
4+`psc-ide-client`s stdin. You can then read the result from `psc-ide-client`s
5+stdout as a single line. The result needs to be unwrapped from the "wrapper"
6+which separates success from failure. This wrapper is described at the end of
7+this document.
8+
9+## Command:
10+### Load
11+The `load` command "loads" the requested modules into the server
12+for completion and type info.
13+
14+**Params:**
15+ - `modules :: (optional) [ModuleName]`: A list of modules to load.
16+ psc-ide-server will try to parse all the declarations in these modules
17+ - `dependencies :: (optional) [ModuleName]`: A list of modules to load
18+ including their dependencies. In contrast to the `module` field, all the
19+ imports in these Modules will also be loaded.
20+
21+```json
22+{
23+ "command": "load",
24+ "params": {
25+ "modules": (optional)["Module.Name1", "Module.Name2"],
26+ "dependencies": (optional)["Module.Name3"]
27+ }
28+}
29+```
30+
31+**Result:**
32+
33+The Load Command returns a string.
34+
35+### Type
36+The `type` command looks up the type for a given identifier.
37+
38+**Params:**
39+ - `search :: String`: The identifier to look for. Only matches on equality.
40+ - `filters :: [Filter]`: These filters will be applied before looking for the
41+ identifier. These filters get combined with *AND*, so a candidate must match *ALL*
42+ of them to be eligible.
43+```json
44+{
45+ "command": "type",
46+ "params": {
47+ "search": "filterM",
48+ "filters": [Filter]
49+ }
50+}
51+```
52+
53+**Result:**
54+The possible types are returned in the same format as completions
55+
56+### Complete
57+The `complete` command looks up possible completions/corrections.
58+
59+**Params**:
60+ - `filters :: [Filter]`: The same as for the `type` command. A candidate must match
61+ all filters.
62+ - `matcher :: (optional) Matcher`: The strategy used for matching candidates after filtering.
63+ Results are scored internally and will be returned in the descending order where
64+ the nth element is better then the n+1-th.
65+
66+ If no matcher is given every candidate, that passes the filters, is returned in no
67+ particular order.
68+```json
69+{
70+ "command": "complete",
71+ "params": {
72+ "filters": [Filter],
73+ "matcher": (optional) Matcher
74+ }
75+}
76+```
77+
78+**Result:**
79+
80+The following format is returned as the Result:
81+
82+```json
83+[
84+ {
85+ "module": "Data.Array",
86+ "identifier": "filter",
87+ "type": "forall a. (a -> Boolean) -> Array a -> Array a"
88+ }
89+]
90+```
91+
92+
93+### CaseSplit
94+
95+The CaseSplit command takes a line of source code, an area in that line of code
96+and replaces it with all patterns for a given type. The parameter `annotations`
97+is used to turn type annotations on or off for the constructor fields.
98+
99+```json
100+{
101+ "command": "caseSplit",
102+ "params": {
103+ "line": "elem a as",
104+ "begin": 8,
105+ "end": 10,
106+ "annotations": true,
107+ "type": "List"
108+ }
109+}
110+```
111+
112+**Result:**
113+
114+The following format is returned as the Result:
115+
116+```json
117+[
118+ "elem a Nil",
119+ "elem a (Cons (_ :: a) (_ :: List a))"
120+]
121+```
122+You should then be able to replace the affected line of code in the editor with the new suggestions.
123+
124+### Add Clause
125+
126+The AddClause command takes a typedeclaration and generates a function template for the given type.
127+The `annotations` option turns type annotations on or off for the function arguments.
128+
129+```json
130+{
131+ "command": "addClause",
132+ "params": {
133+ "line": "elem :: forall a. (Eq a) => a -> List a",
134+ "annotations": true
135+ }
136+}
137+```
138+
139+**Result:**
140+
141+The following format is returned as the Result:
142+
143+```json
144+[
145+ "elem :: forall a. (Eq a) => a -> List a",
146+ "elem ( _ :: a) = ?elem"
147+]
148+```
149+You should then be able to replace the affected line of code in the editor with the new suggestions.
150+
151+### Pursuit
152+The `pursuit` command looks up the packages/completions for a given identifier from Pursuit.
153+
154+**Params:**
155+ - `query :: String`: With `type: "package"` this should be a module name. With
156+ `type: "completion"` this can be any string to look up.
157+ - `type :: String`: Takes the following values:
158+ - `package`: Looks for packages that contain the given module name.
159+ - `completion` Looks for declarations for the query from Pursuit.
160+
161+```json
162+{
163+ "command": "pursuit",
164+ "params": {
165+ "query": "Data.Array",
166+ "type": "package"
167+ }
168+}
169+```
170+
171+**Result:**
172+
173+`package` returns:
174+
175+```json
176+[
177+ {
178+ "module": "Module1.Name",
179+ "package": "purescript-packagename"
180+ }
181+]
182+```
183+
184+`completion` returns:
185+
186+```json
187+[
188+ {
189+ "module": "Data.Array",
190+ "identifier": "filter",
191+ "type": "forall a. (a -> Boolean) -> Array a -> Array a",
192+ "package": "purescript-arrays"
193+ }
194+]
195+```
196+
197+### List
198+
199+#### Loaded Modules
200+
201+`list` of type `loadedModules` lists all loaded modules (This means they can be searched for completions etc)
202+
203+```json
204+{
205+ "command": "list",
206+ "params": {
207+ "type": "loadedModules"
208+ }
209+}
210+```
211+
212+#### Response:
213+
214+The list loadedModules command returns a list of strings.
215+
216+#### Available Modules
217+
218+`list` of type `availableModules` lists all available modules. (This basically
219+means the contents of the `output/` folder.))
220+
221+```json
222+{
223+ "command": "list",
224+ "params": {
225+ "type": "availableModules"
226+ }
227+}
228+```
229+
230+#### Response:
231+
232+The list availableModules command returns a list of strings.
233+
234+#### Imports
235+
236+The list commmand can also list the imports for a given file.
237+
238+```json
239+{
240+ "command": "list",
241+ "params": {
242+ "type": "import",
243+ "file": "/home/kritzcreek/Documents/psc-ide/examples/Main.purs"
244+ }
245+}
246+```
247+
248+#### Response:
249+
250+The list import command returns a list of imports where imports are of the following form:
251+
252+Implicit Import(`import Data.Array`):
253+```json
254+[
255+ {
256+ "module": "Data.Array",
257+ "importType": "implicit"
258+ }
259+]
260+```
261+
262+Implicit qualified Import(`import qualified Data.Array as A`):
263+```json
264+[
265+ {
266+ "module": "Data.Array",
267+ "importType": "implicit",
268+ "qualifier": "A"
269+ }
270+]
271+```
272+
273+Explicit Import(`import Data.Array (filter, filterM, join)`):
274+```json
275+[
276+ {
277+ "module": "Data.Array",
278+ "importType": "explicit",
279+ "identifiers": ["filter", "filterM", "join"]
280+ }
281+]
282+```
283+
284+Hiding Import(`import Data.Array hiding (filter, filterM, join)`):
285+```json
286+[
287+ {
288+ "module": "Data.Array",
289+ "importType": "hiding",
290+ "identifiers": ["filter", "filterM", "join"]
291+ }
292+]
293+```
294+### Cwd/Quit
295+`cwd` returns the working directory of the server(should be your project root).
296+
297+`quit` quits the server.
298+
299+```json
300+{
301+ "command": "cwd|quit"
302+}
303+```
304+
305+**Result:**
306+These commands return strings.
307+
308+## Filter:
309+
310+### Exact filter
311+The Exact filter only keeps identifiers that are equal to the search term.
312+
313+```json
314+{
315+ "filter": "exact",
316+ "params": {
317+ "search": "filterM"
318+ }
319+}
320+```
321+### Prefix filter
322+The Prefix filter keeps identifiers/modules/data declarations that
323+are prefixed by the search term.
324+
325+```json
326+{
327+ "filter": "prefix",
328+ "params": {
329+ "search": "filt"
330+ }
331+}
332+```
333+
334+### Module filter
335+The Module filter only keeps identifiers that appear in the listed modules.
336+
337+```json
338+{
339+ "filter": "modules",
340+ "params": {
341+ "modules": ["My.Module"]
342+ }
343+}
344+```
345+
346+### Dependency filter
347+The Dependency filter only keeps identifiers that appear in the listed modules
348+and in any of their dependencies/imports.
349+
350+```json
351+{
352+ "filter": "dependencies",
353+ "params": {
354+ "modules": ["My.Module"]
355+ }
356+}
357+```
358+
359+## Matcher:
360+
361+### Flex matcher
362+Matches any occurence of the search string with intersections
363+
364+The scoring measures how far the matches span the string, where
365+closer is better. The matches then get sorted with highest score first.
366+
367+Examples:
368+- flMa matches **fl**ex**Ma**tcher. Score: 14.28
369+- sons matches **so**rtCompletio**ns**. Score: 6.25
370+```json
371+
372+{
373+ "matcher": "flex",
374+ "params": {
375+ "search": "filt"
376+ }
377+}
378+```
379+
380+### Distance Matcher
381+
382+The Distance matcher is meant to provide corrections for typos. It calculates
383+the edit distance in between the search and the loaded identifiers.
384+
385+```json
386+{
387+ "matcher": "distance",
388+ "params": {
389+ "search": "dilterM",
390+ "maximumDistance": 3
391+ }
392+}
393+```
394+
395+## Responses
396+
397+All Responses are wrapped in the following format:
398+
399+```json
400+{
401+ "resultType": "success|error",
402+ "result": Result|Error
403+}
404+```
405+
406+### Error
407+
408+Errors at this point are merely Error strings. Newlines are escaped like `\n`
409+and should be taken care of by the editor-plugin.
psc-ide-server/README.mdnew file+40
@@ -0,0 +1,40 @@
1+psc-ide
2+===
3+
4+A tool which provides editor support for the PureScript programming language.
5+
6+## Editor Integration
7+* [@epost](https://github.com/epost) wrote a plugin to integrate psc-ide with Emacs at https://github.com/epost/psc-ide-emacs.
8+* Atom integration is available with https://github.com/nwolverson/atom-ide-purescript.
9+* Visual Studio Code integration is available with https://github.com/nwolverson/vscode-ide-purescript.
10+* Vim integration is available here: https://github.com/FrigoEU/psc-ide-vim.
11+
12+## Running the Server
13+Start the server by running the `psc-ide-server` executable.
14+It supports the following options:
15+
16+- `-p / --port` specify a port. Defaults to 4242
17+- `-d / --directory` specify the toplevel directory of your project. Defaults to
18+ the current directory
19+- `--output-directory`: Specify where to look for compiled output inside your
20+ project directory. Defaults to `output/`, relative to either the current
21+ directory or the directory specified by `-d`.
22+- `--debug`: Enables some logging meant for debugging
23+- `--version`: Output psc-ide version
24+
25+## Issuing queries
26+
27+After you started the server you can start issuing requests using
28+`psc-ide-client`. Make sure you start by loading the modules before you try to
29+query them.
30+
31+`psc-ide-server` expects the build externs.purs inside the `output/` folder of
32+your project after running `pulp build` or `psc-make` respectively.
33+
34+(If you changed the port of the server you can change the port for
35+`psc-ide-client` by using the -p option accordingly)
36+
37+## Protocol
38+
39+For documentation about the protocol have a look at:
40+[PROTOCOL.md](PROTOCOL.md)
psc/JSON.hs+12−1
@@ -30,12 +30,16 @@ data ErrorPosition = ErrorPosition
3030 , endColumn :: Int
3131 }
3232
33+data ErrorSuggestion = ErrorSuggestion { replacement :: String }
34+
3335data JSONError = JSONError
3436 { position :: Maybe ErrorPosition
3537 , message :: String
3638 , errorCode :: String
39+ , errorLink :: String
3740 , filename :: Maybe String
3841 , moduleName :: Maybe String
42+ , suggestion :: Maybe ErrorSuggestion
3943 }
4044
4145data JSONResult = JSONResult
@@ -46,6 +50,8 @@ data JSONResult = JSONResult
4650$(A.deriveJSON A.defaultOptions ''ErrorPosition)
4751$(A.deriveJSON A.defaultOptions ''JSONError)
4852$(A.deriveJSON A.defaultOptions ''JSONResult)
53+$(A.deriveJSON A.defaultOptions ''ErrorSuggestion)
54+
4955
5056toJSONErrors :: Bool -> P.Level -> P.MultipleErrors -> [JSONError]
5157toJSONErrors verbose level = map (toJSONError verbose level) . P.runMultipleErrors
@@ -53,10 +59,12 @@ toJSONErrors verbose level = map (toJSONError verbose level) . P.runMultipleErro
5359toJSONError :: Bool -> P.Level -> P.ErrorMessage -> JSONError
5460toJSONError verbose level e =
5561 JSONError (toErrorPosition <$> sspan)
56− (P.renderBox (P.prettyPrintSingleError' verbose level (P.stripModuleAndSpan e)))
62+ (P.renderBox (P.prettyPrintSingleError verbose level False (P.stripModuleAndSpan e)))
5763 (P.errorCode e)
64+ (P.wikiUri e)
5865 (P.spanName <$> sspan)
5966 (P.runModuleName <$> P.errorModule e)
67+ (toSuggestion <$> (P.errorSuggestion $ P.unwrapErrorMessage e))
6068 where
6169 sspan :: Maybe P.SourceSpan
6270 sspan = P.errorSpan e
@@ -67,3 +75,6 @@ toJSONError verbose level e =
6775 (P.sourcePosColumn (P.spanStart ss))
6876 (P.sourcePosLine (P.spanEnd ss))
6977 (P.sourcePosColumn (P.spanEnd ss))
78+ toSuggestion :: P.ErrorSuggestion -> ErrorSuggestion
79+-- TODO: Adding a newline because source spans chomp everything up to the next character
80+ toSuggestion (P.ErrorSuggestion s) = ErrorSuggestion $ if null s then s else s ++ "\n"
psc/Main.hs+10−4
@@ -76,13 +76,13 @@ printWarningsAndErrors verbose True warnings errors = do
7676
7777compile :: PSCMakeOptions -> IO ()
7878compile PSCMakeOptions{..} = do
79− input <- globWarningOnMisses warnFileTypeNotFound pscmInput
80− when (null input) $ do
79+ input <- globWarningOnMisses (unless pscmJSONErrors . warnFileTypeNotFound) pscmInput
80+ when (null input && not pscmJSONErrors) $ do
8181 hPutStrLn stderr "psc: No input files."
8282 exitFailure
8383 let (jsFiles, pursFiles) = partition (isSuffixOf ".js") input
8484 moduleFiles <- readInput (InputOptions pursFiles)
85− inputForeign <- globWarningOnMisses warnFileTypeNotFound pscmForeignInput
85+ inputForeign <- globWarningOnMisses (unless pscmJSONErrors . warnFileTypeNotFound) pscmForeignInput
8686 foreignFiles <- forM (inputForeign ++ jsFiles) (\inFile -> (inFile,) <$> readUTF8File inFile)
8787 (makeErrors, makeWarnings) <- runMake pscmOpts $ do
8888 (ms, foreigns) <- parseInputs moduleFiles foreignFiles
@@ -107,7 +107,7 @@ globWarningOnMisses warn = concatMapM globWithWarning
107107readInput :: InputOptions -> IO [(Either P.RebuildPolicy FilePath, String)]
108108readInput InputOptions{..} = forM ioInputFiles $ \inFile -> (Right inFile, ) <$> readUTF8File inFile
109109
110−parseInputs :: (Functor m, Applicative m, MonadError P.MultipleErrors m, MonadWriter P.MultipleErrors m)
110+parseInputs :: (MonadError P.MultipleErrors m, MonadWriter P.MultipleErrors m)
111111 => [(Either P.RebuildPolicy FilePath, String)]
112112 -> [(FilePath, P.ForeignJS)]
113113 -> m ([(Either P.RebuildPolicy FilePath, P.Module)], M.Map P.ModuleName FilePath)
@@ -177,6 +177,11 @@ jsonErrors :: Parser Bool
177177jsonErrors = switch $
178178 long "json-errors"
179179 <> help "Print errors to stderr as JSON"
180+sourceMaps :: Parser Bool
181+sourceMaps = switch $
182+ long "source-maps"
183+ <> help "Generate source maps"
184+
180185
181186options :: Parser P.Options
182187options = P.Options <$> noTco
@@ -186,6 +191,7 @@ options = P.Options <$> noTco
186191 <*> verboseErrors
187192 <*> (not <$> comments)
188193 <*> requirePath
194+ <*> sourceMaps
189195
190196pscMakeOptions :: Parser PSCMakeOptions
191197pscMakeOptions = PSCMakeOptions <$> many inputFile
psci/IO.hsdeleted−21
@@ -1,21 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : IO
4−-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−--
13−-----------------------------------------------------------------------------
14−
15−module IO where
16−
17−import System.Directory (createDirectoryIfMissing)
18−import System.FilePath (takeDirectory)
19−
20−mkdirp :: FilePath -> IO ()
21−mkdirp = createDirectoryIfMissing True . takeDirectory
psci/PSCi.hs+141−449
@@ -2,20 +2,19 @@
22{-# LANGUAGE GeneralizedNewtypeDeriving #-}
33{-# LANGUAGE RecordWildCards #-}
44{-# LANGUAGE TupleSections #-}
5+{-# LANGUAGE DataKinds #-}
56
67-- |
78-- PureScript Compiler Interactive.
89--
9−module PSCi where
10+module PSCi (runPSCi) where
1011
1112import Prelude ()
1213import Prelude.Compat
1314
1415import Data.Foldable (traverse_)
15−import Data.Maybe (mapMaybe)
16−import Data.List (intersperse, intercalate, nub, sort)
16+import Data.List (intercalate, nub, sort, find)
1717import Data.Tuple (swap)
18−import Data.Version (showVersion)
1918import qualified Data.Map as M
2019
2120import Control.Arrow (first)
@@ -23,102 +22,87 @@ import Control.Monad
2322import Control.Monad.Error.Class (MonadError(..))
2423import Control.Monad.Trans.Class
2524import Control.Monad.Trans.Except (ExceptT(), runExceptT)
26−import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
2725import Control.Monad.Trans.State.Strict
2826import Control.Monad.IO.Class (liftIO)
2927import Control.Monad.Writer.Strict (Writer(), runWriter)
3028
31−import Options.Applicative as Opts
32−
3329import System.Console.Haskeline
34−import System.Directory (doesFileExist, findExecutable, getHomeDirectory, getCurrentDirectory)
30+import System.Directory (doesFileExist, getHomeDirectory, getCurrentDirectory)
3531import System.Exit
36−import System.FilePath (pathSeparator, (</>), isPathSeparator)
32+import System.FilePath ((</>))
3733import System.FilePath.Glob (glob)
3834import System.Process (readProcessWithExitCode)
3935import System.IO.Error (tryIOError)
40−import qualified Text.PrettyPrint.Boxes as Box
4136
4237import qualified Language.PureScript as P
4338import qualified Language.PureScript.Names as N
44−import qualified Paths_purescript as Paths
45−
46−import qualified Directive as D
47−import Completion (completion)
48−import IO (mkdirp)
49−import Parser (parseCommand)
50−import Types
51−
52−-- | The name of the PSCI support module
53−supportModuleName :: P.ModuleName
54−supportModuleName = P.ModuleName [P.ProperName "$PSCI", P.ProperName "Support"]
55−
56−-- | Support module, contains code to evaluate terms
57−supportModule :: P.Module
58−supportModule =
59− case P.parseModulesFromFiles id [("", code)] of
60− Right [(_, P.Module ss cs _ ds exps)] -> P.Module ss cs supportModuleName ds exps
61− _ -> P.internalError "Support module could not be parsed"
62− where
63− code :: String
64− code = unlines
65− [ "module S where"
66− , ""
67− , "import Prelude"
68− , "import Control.Monad.Eff"
69− , "import Control.Monad.Eff.Console"
70− , "import Control.Monad.Eff.Unsafe"
71− , ""
72− , "class Eval a where"
73− , " eval :: a -> Eff (console :: CONSOLE) Unit"
74− , ""
75− , "instance evalShow :: (Show a) => Eval a where"
76− , " eval = print"
77− , ""
78− , "instance evalEff :: (Eval a) => Eval (Eff eff a) where"
79− , " eval x = unsafeInterleaveEff x >>= eval"
80− ]
81−
82−-- File helpers
83−
84−onFirstFileMatching :: Monad m => (b -> m (Maybe a)) -> [b] -> m (Maybe a)
85−onFirstFileMatching f pathVariants = runMaybeT . msum $ map (MaybeT . f) pathVariants
8639
87−-- |
88−-- Locates the node executable.
89−-- Checks for either @nodejs@ or @node@.
90−--
91−findNodeProcess :: IO (Maybe String)
92−findNodeProcess = onFirstFileMatching findExecutable names
93− where names = ["nodejs", "node"]
40+import PSCi.Completion (completion)
41+import PSCi.Parser (parseCommand)
42+import PSCi.Option
43+import PSCi.Types
44+import PSCi.Message
45+import PSCi.IO
46+import PSCi.Printer
47+import PSCi.Module
9448
9549-- |
96−-- Grabs the filename where the history is stored.
50+-- PSCI monad
9751--
98−getHistoryFilename :: IO FilePath
99−getHistoryFilename = do
100− home <- getHomeDirectory
101− let filename = home </> ".purescript" </> "psci_history"
102− mkdirp filename
103− return filename
52+newtype PSCI a = PSCI { runPSCI :: InputT (StateT PSCiState IO) a } deriving (Functor, Applicative, Monad)
53+
54+psciIO :: IO a -> PSCI a
55+psciIO io = PSCI . lift $ lift io
10456
10557-- |
106−-- Loads a file for use with imports.
58+-- The runner
10759--
108−loadModule :: FilePath -> IO (Either String [P.Module])
109−loadModule filename = do
110− content <- readFile filename
111− return $ either (Left . P.prettyPrintMultipleErrors False) (Right . map snd) $ P.parseModulesFromFiles id [(filename, content)]
60+runPSCi :: IO ()
61+runPSCi = getOpt >>= loop
11262
11363-- |
114−-- Load all modules.
64+-- The PSCI main loop.
11565--
116−loadAllModules :: [FilePath] -> IO (Either P.MultipleErrors [(FilePath, P.Module)])
117−loadAllModules files = do
118− filesAndContent <- forM files $ \filename -> do
119− content <- readFile filename
120− return (filename, content)
121− return $ P.parseModulesFromFiles id filesAndContent
66+loop :: PSCiOptions -> IO ()
67+loop PSCiOptions{..} = do
68+ config <- loadUserConfig
69+ inputFiles <- concat <$> traverse glob psciInputFile
70+ foreignFiles <- concat <$> traverse glob psciForeignInputFiles
71+ modulesOrFirstError <- loadAllModules inputFiles
72+ case modulesOrFirstError of
73+ Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> exitFailure
74+ Right modules -> do
75+ historyFilename <- getHistoryFilename
76+ let settings = defaultSettings { historyFile = Just historyFilename }
77+ foreignsOrError <- runMake $ do
78+ foreignFilesContent <- forM foreignFiles (\inFile -> (inFile,) <$> makeIO (const (P.ErrorMessage [] $ P.CannotReadFile inFile)) (readFile inFile))
79+ P.parseForeignModulesFromFiles foreignFilesContent
80+ case foreignsOrError of
81+ Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> exitFailure
82+ Right foreigns ->
83+ flip evalStateT (mkPSCiState [] modules foreigns [] psciInputNodeFlags) . runInputT (setComplete completion settings) $ do
84+ outputStrLn prologueMessage
85+ traverse_ (traverse_ (runPSCI . handleCommand)) config
86+ modules' <- lift $ gets psciLoadedModules
87+ unless (consoleIsDefined (map snd modules')) . outputStrLn $ unlines
88+ [ "PSCi requires the purescript-console module to be installed."
89+ , "For help getting started, visit http://wiki.purescript.org/PSCi"
90+ ]
91+ go
92+ where
93+ go :: InputT (StateT PSCiState IO) ()
94+ go = do
95+ c <- getCommand (not psciMultiLineMode)
96+ case c of
97+ Left err -> outputStrLn err >> go
98+ Right Nothing -> go
99+ Right (Just QuitPSCi) -> outputStrLn quitMessage
100+ Right (Just c') -> do
101+ handleInterrupt (outputStrLn "Interrupted.")
102+ (withInterrupt (runPSCI (loadAllImportedModules >> handleCommand c')))
103+ go
104+
105+-- Compile the module
122106
123107-- |
124108-- Load all modules, updating the application state
@@ -128,116 +112,9 @@ loadAllImportedModules = do
128112 files <- PSCI . lift $ fmap psciImportedFilenames get
129113 modulesOrFirstError <- psciIO $ loadAllModules files
130114 case modulesOrFirstError of
131− Left errs -> printErrors errs
115+ Left errs -> PSCI $ printErrors errs
132116 Right modules -> PSCI . lift . modify $ updateModules modules
133117
134−-- |
135−-- Expands tilde in path.
136−--
137−expandTilde :: FilePath -> IO FilePath
138−expandTilde ('~':p:rest) | isPathSeparator p = (</> rest) <$> getHomeDirectory
139−expandTilde p = return p
140−
141−-- Messages
142−
143−-- |
144−-- The help message.
145−--
146−helpMessage :: String
147−helpMessage = "The following commands are available:\n\n " ++
148− intercalate "\n " (map line D.help) ++
149− "\n\n" ++ extraHelp
150− where
151− line :: (Directive, String, String) -> String
152− line (dir, arg, desc) =
153− let cmd = ':' : D.stringFor dir
154− in unwords [ cmd
155− , replicate (11 - length cmd) ' '
156− , arg
157− , replicate (11 - length arg) ' '
158− , desc
159− ]
160−
161− extraHelp =
162− "Further information is available on the PureScript wiki:\n" ++
163− " --> https://github.com/purescript/purescript/wiki/psci"
164−
165−
166−-- |
167−-- The welcome prologue.
168−--
169−prologueMessage :: String
170−prologueMessage = intercalate "\n"
171− [ " ____ ____ _ _ "
172− , "| _ \\ _ _ _ __ ___/ ___| ___ _ __(_)_ __ | |_ "
173− , "| |_) | | | | '__/ _ \\___ \\ / __| '__| | '_ \\| __|"
174− , "| __/| |_| | | | __/___) | (__| | | | |_) | |_ "
175− , "|_| \\__,_|_| \\___|____/ \\___|_| |_| .__/ \\__|"
176− , " |_| "
177− , ""
178− , ":? shows help"
179− ]
180−
181−-- |
182−-- The quit message.
183−--
184−quitMessage :: String
185−quitMessage = "See ya!"
186−
187−-- |
188−-- PSCI monad
189−--
190−newtype PSCI a = PSCI { runPSCI :: InputT (StateT PSCiState IO) a } deriving (Functor, Applicative, Monad)
191−
192−psciIO :: IO a -> PSCI a
193−psciIO io = PSCI . lift $ lift io
194−
195−-- |
196−-- Makes a volatile module to execute the current expression.
197−--
198−createTemporaryModule :: Bool -> PSCiState -> P.Expr -> P.Module
199−createTemporaryModule exec PSCiState{psciImportedModules = imports, psciLetBindings = lets} val =
200− let
201− moduleName = P.ModuleName [P.ProperName "$PSCI"]
202− trace = P.Var (P.Qualified (Just supportModuleName) (P.Ident "eval"))
203− mainValue = P.App trace (P.Var (P.Qualified Nothing (P.Ident "it")))
204− itDecl = P.ValueDeclaration (P.Ident "it") P.Public [] $ Right val
205− mainDecl = P.ValueDeclaration (P.Ident "$main") P.Public [] $ Right mainValue
206− decls = if exec then [itDecl, mainDecl] else [itDecl]
207− in
208− P.Module (P.internalModuleSourceSpan "<internal>") [] moduleName ((importDecl `map` imports) ++ lets ++ decls) Nothing
209−
210−
211−-- |
212−-- Makes a volatile module to hold a non-qualified type synonym for a fully-qualified data type declaration.
213−--
214−createTemporaryModuleForKind :: PSCiState -> P.Type -> P.Module
215−createTemporaryModuleForKind PSCiState{psciImportedModules = imports, psciLetBindings = lets} typ =
216− let
217− moduleName = P.ModuleName [P.ProperName "$PSCI"]
218− itDecl = P.TypeSynonymDeclaration (P.ProperName "IT") [] typ
219− in
220− P.Module (P.internalModuleSourceSpan "<internal>") [] moduleName ((importDecl `map` imports) ++ lets ++ [itDecl]) Nothing
221−
222−-- |
223−-- Makes a volatile module to execute the current imports.
224−--
225−createTemporaryModuleForImports :: PSCiState -> P.Module
226−createTemporaryModuleForImports PSCiState{psciImportedModules = imports} =
227− let
228− moduleName = P.ModuleName [P.ProperName "$PSCI"]
229− in
230− P.Module (P.internalModuleSourceSpan "<internal>") [] moduleName (importDecl `map` imports) Nothing
231−
232−importDecl :: ImportedModule -> P.Declaration
233−importDecl (mn, declType, asQ) = P.ImportDeclaration mn declType asQ False
234−
235−indexFile :: FilePath
236−indexFile = ".psci_modules" ++ pathSeparator : "index.js"
237−
238−modulesDir :: FilePath
239−modulesDir = ".psci_modules" ++ pathSeparator : "node_modules"
240−
241118-- | This is different than the runMake in 'Language.PureScript.Make' in that it specifies the
242119-- options and ignores the warning messages.
243120runMake :: P.Make a -> IO (Either P.MultipleErrors a)
@@ -257,6 +134,58 @@ make st@PSCiState{..} ms = P.make actions' (map snd loadedModules ++ ms)
257134 loadedModules = psciLoadedModules st
258135 allModules = map (first Right) loadedModules ++ map (Left P.RebuildAlways,) ms
259136
137+
138+-- Commands
139+
140+-- |
141+-- Parses the input and returns either a Metacommand, or an error as a string.
142+--
143+getCommand :: Bool -> InputT (StateT PSCiState IO) (Either String (Maybe Command))
144+getCommand singleLineMode = handleInterrupt (return (Right Nothing)) $ do
145+ firstLine <- withInterrupt $ getInputLine "> "
146+ case firstLine of
147+ Nothing -> return (Right (Just QuitPSCi)) -- Ctrl-D when input is empty
148+ Just "" -> return (Right Nothing)
149+ Just s | singleLineMode || head s == ':' -> return .fmap Just $ parseCommand s
150+ Just s -> fmap Just . parseCommand <$> go [s]
151+ where
152+ go :: [String] -> InputT (StateT PSCiState IO) String
153+ go ls = maybe (return . unlines $ reverse ls) (go . (:ls)) =<< getInputLine " "
154+
155+-- |
156+-- Performs an action for each meta-command given, and also for expressions.
157+--
158+handleCommand :: Command -> PSCI ()
159+handleCommand (Expression val) = handleExpression val
160+handleCommand ShowHelp = PSCI $ outputStrLn helpMessage
161+handleCommand (Import im) = handleImport im
162+handleCommand (Decls l) = handleDecls l
163+handleCommand (LoadFile filePath) = PSCI $ whenFileExists filePath $ \absPath -> do
164+ m <- lift . lift $ loadModule absPath
165+ case m of
166+ Left err -> outputStrLn err
167+ Right mods -> lift $ modify (updateModules (map (absPath,) mods))
168+handleCommand (LoadForeign filePath) = PSCI $ whenFileExists filePath $ \absPath -> do
169+ foreignsOrError <- lift . lift . runMake $ do
170+ foreignFile <- makeIO (const (P.ErrorMessage [] $ P.CannotReadFile absPath)) (readFile absPath)
171+ P.parseForeignModulesFromFiles [(absPath, foreignFile)]
172+ case foreignsOrError of
173+ Left err -> outputStrLn $ P.prettyPrintMultipleErrors False err
174+ Right foreigns -> lift $ modify (updateForeignFiles foreigns)
175+handleCommand ResetState = do
176+ PSCI . lift . modify $ \st ->
177+ st { psciImportedModules = []
178+ , psciLetBindings = []
179+ }
180+ loadAllImportedModules
181+handleCommand (TypeOf val) = handleTypeOf val
182+handleCommand (KindOf typ) = handleKindOf typ
183+handleCommand (BrowseModule moduleName) = handleBrowse moduleName
184+handleCommand (ShowInfo QueryLoaded) = handleShowLoadedModules
185+handleCommand (ShowInfo QueryImport) = handleShowImportedModules
186+handleCommand QuitPSCi = P.internalError "`handleCommand QuitPSCi` was called. This is a bug."
187+
188+
260189-- |
261190-- Takes a value expression and evaluates it with the current state.
262191--
@@ -267,7 +196,7 @@ handleExpression val = do
267196 let nodeArgs = psciNodeFlags st ++ [indexFile]
268197 e <- psciIO . runMake $ make st [supportModule, m]
269198 case e of
270− Left errs -> printErrors errs
199+ Left errs -> PSCI $ printErrors errs
271200 Right _ -> do
272201 psciIO $ writeFile indexFile "require('$PSCI')['$main']();"
273202 process <- psciIO findNodeProcess
@@ -285,10 +214,10 @@ handleDecls :: [P.Declaration] -> PSCI ()
285214handleDecls ds = do
286215 st <- PSCI $ lift get
287216 let st' = updateLets ds st
288− let m = createTemporaryModule False st' (P.ObjectLiteral [])
217+ let m = createTemporaryModule False st' (P.Literal (P.ObjectLiteral []))
289218 e <- psciIO . runMake $ make st' [m]
290219 case e of
291− Left err -> printErrors err
220+ Left err -> PSCI $ printErrors err
292221 Right _ -> PSCI $ lift (put st')
293222
294223-- |
@@ -317,8 +246,7 @@ handleShowImportedModules = do
317246 Just mn' -> "qualified " ++ N.runModuleName mn ++ " as " ++ N.runModuleName mn'
318247 Nothing -> N.runModuleName mn ++ " " ++ showDeclType declType
319248
320− showDeclType (P.Implicit True) = " (..)"
321− showDeclType (P.Implicit False) = ""
249+ showDeclType P.Implicit = ""
322250 showDeclType (P.Explicit refs) = refsList refs
323251 showDeclType (P.Hiding refs) = " hiding " ++ refsList refs
324252 refsList refs = " (" ++ commaList (map showRef refs) ++ ")"
@@ -327,7 +255,7 @@ handleShowImportedModules = do
327255 showRef (P.TypeRef pn dctors) = N.runProperName pn ++ "(" ++ maybe ".." (commaList . map N.runProperName) dctors ++ ")"
328256 showRef (P.ValueRef ident) = N.runIdent ident
329257 showRef (P.TypeClassRef pn) = N.runProperName pn
330− showRef (P.ProperRef pn) = N.runProperName pn
258+ showRef (P.ProperRef pn) = pn
331259 showRef (P.TypeInstanceRef ident) = N.runIdent ident
332260 showRef (P.ModuleRef name) = "module " ++ N.runModuleName name
333261 showRef (P.PositionedDeclarationRef _ _ ref) = showRef ref
@@ -344,7 +272,7 @@ handleImport im = do
344272 let m = createTemporaryModuleForImports st
345273 e <- psciIO . runMake $ make st [m]
346274 case e of
347− Left errs -> printErrors errs
275+ Left errs -> PSCI $ printErrors errs
348276 Right _ -> do
349277 PSCI $ lift $ put st
350278 return ()
@@ -358,115 +286,12 @@ handleTypeOf val = do
358286 let m = createTemporaryModule False st val
359287 e <- psciIO . runMake $ make st [m]
360288 case e of
361− Left errs -> printErrors errs
289+ Left errs -> PSCI $ printErrors errs
362290 Right env' ->
363291 case M.lookup (P.ModuleName [P.ProperName "$PSCI"], P.Ident "it") (P.names env') of
364292 Just (ty, _, _) -> PSCI . outputStrLn . P.prettyPrintType $ ty
365293 Nothing -> PSCI $ outputStrLn "Could not find type"
366294
367−-- |
368−-- Pretty print a module's signatures
369−--
370−printModuleSignatures :: P.ModuleName -> P.Environment -> PSCI ()
371−printModuleSignatures moduleName (P.Environment {..}) =
372− PSCI $
373− -- get relevant components of a module from environment
374− let moduleNamesIdent = (filter ((== moduleName) . fst) . M.keys) names
375− moduleTypeClasses = (filter (\(P.Qualified maybeName _) -> maybeName == Just moduleName) . M.keys) typeClasses
376− moduleTypes = (filter (\(P.Qualified maybeName _) -> maybeName == Just moduleName) . M.keys) types
377−
378− in
379− -- print each component
380− (outputStr . unlines . map trimEnd . lines . Box.render . Box.vsep 1 Box.left)
381− [ printModule's (mapMaybe (showTypeClass . findTypeClass typeClasses)) moduleTypeClasses -- typeClasses
382− , printModule's (mapMaybe (showType typeClasses dataConstructors typeSynonyms . findType types)) moduleTypes -- types
383− , printModule's (map (showNameType . findNameType names)) moduleNamesIdent -- functions
384− ]
385−
386− where printModule's showF = Box.vsep 1 Box.left . showF
387−
388− findNameType :: M.Map (P.ModuleName, P.Ident) (P.Type, P.NameKind, P.NameVisibility) -> (P.ModuleName, P.Ident) -> (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility))
389− findNameType envNames m@(_, mIdent) = (mIdent, M.lookup m envNames)
390−
391− showNameType :: (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility)) -> Box.Box
392− showNameType (mIdent, Just (mType, _, _)) = Box.text (P.showIdent mIdent ++ " :: ") Box.<> P.typeAsBox mType
393− showNameType _ = P.internalError "The impossible happened in printModuleSignatures."
394−
395− findTypeClass :: M.Map (P.Qualified P.ProperName) ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint]) -> P.Qualified P.ProperName -> (P.Qualified P.ProperName, Maybe ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint]))
396− findTypeClass envTypeClasses name = (name, M.lookup name envTypeClasses)
397−
398− showTypeClass :: (P.Qualified P.ProperName, Maybe ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint])) -> Maybe Box.Box
399− showTypeClass (_, Nothing) = Nothing
400− showTypeClass (P.Qualified _ name, Just (vars, body, constrs)) =
401− let constraints =
402− if null constrs
403− then Box.text ""
404− else Box.text "("
405− Box.<> Box.hcat Box.left (intersperse (Box.text ", ") $ map (\(P.Qualified _ pn, lt) -> Box.text (P.runProperName pn) Box.<+> Box.hcat Box.left (map P.typeAtomAsBox lt)) constrs)
406− Box.<> Box.text ") <= "
407− className =
408− Box.text (P.runProperName name)
409− Box.<> Box.text (concatMap ((' ':) . fst) vars)
410− classBody =
411− Box.vcat Box.top (map (\(i, t) -> Box.text (P.showIdent i ++ " ::") Box.<+> P.typeAsBox t) body)
412−
413− in
414− Just $
415− (Box.text "class "
416− Box.<> constraints
417− Box.<> className
418− Box.<+> if null body then Box.text "" else Box.text "where")
419− Box.// Box.moveRight 2 classBody
420−
421−
422− findType :: M.Map (P.Qualified P.ProperName) (P.Kind, P.TypeKind) -> P.Qualified P.ProperName -> (P.Qualified P.ProperName, Maybe (P.Kind, P.TypeKind))
423− findType envTypes name = (name, M.lookup name envTypes)
424−
425− showType :: M.Map (P.Qualified P.ProperName) ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint])
426− -> M.Map (P.Qualified P.ProperName) (P.DataDeclType, P.ProperName, P.Type, [P.Ident])
427− -> M.Map (P.Qualified P.ProperName) ([(String, Maybe P.Kind)], P.Type)
428− -> (P.Qualified P.ProperName, Maybe (P.Kind, P.TypeKind))
429− -> Maybe Box.Box
430− showType typeClassesEnv dataConstructorsEnv typeSynonymsEnv (n@(P.Qualified modul name), typ) =
431− case (typ, M.lookup n typeSynonymsEnv) of
432− (Just (_, P.TypeSynonym), Just (typevars, dtType)) ->
433− if M.member n typeClassesEnv
434− then
435− Nothing
436− else
437− Just $
438− Box.text ("type " ++ P.runProperName name ++ concatMap ((' ':) . fst) typevars)
439− Box.// Box.moveRight 2 (Box.text "=" Box.<+> P.typeAsBox dtType)
440−
441− (Just (_, P.DataType typevars pt), _) ->
442− let prefix =
443− case pt of
444− [(dtProperName,_)] ->
445− case M.lookup (P.Qualified modul dtProperName) dataConstructorsEnv of
446− Just (dataDeclType, _, _, _) -> P.showDataDeclType dataDeclType
447− _ -> "data"
448− _ -> "data"
449−
450− in
451− Just $ Box.text (prefix ++ " " ++ P.runProperName name ++ concatMap ((' ':) . fst) typevars) Box.// printCons pt
452−
453− _ ->
454− Nothing
455−
456− where printCons pt =
457− Box.moveRight 2 $
458− Box.vcat Box.left $
459− mapFirstRest (Box.text "=" Box.<+>) (Box.text "|" Box.<+>) $
460− map (\(cons,idents) -> (Box.text (P.runProperName cons) Box.<> Box.hcat Box.left (map prettyPrintType idents))) pt
461−
462− prettyPrintType t = Box.text " " Box.<> P.typeAtomAsBox t
463−
464− mapFirstRest _ _ [] = []
465− mapFirstRest f g (x:xs) = f x : map g xs
466−
467− trimEnd = reverse . dropWhile (== ' ') . reverse
468−
469−
470295-- |
471296-- Browse a module and displays its signature (if module exists).
472297--
@@ -475,15 +300,24 @@ handleBrowse moduleName = do
475300 st <- PSCI $ lift get
476301 env <- psciIO . runMake $ make st []
477302 case env of
478− Left errs -> printErrors errs
303+ Left errs -> PSCI $ printErrors errs
479304 Right env' ->
480− if moduleName `notElem` (nub . map ((\ (P.Module _ _ modName _ _ ) -> modName) . snd)) (psciLoadedModules st)
481− then PSCI $ outputStrLn $ "Module '" ++ N.runModuleName moduleName ++ "' is not valid."
482− else printModuleSignatures moduleName env'
483−
484−-- | Pretty-print errors
485−printErrors :: P.MultipleErrors -> PSCI ()
486−printErrors = PSCI . outputStrLn . P.prettyPrintMultipleErrors False
305+ if isModInEnv moduleName st
306+ then PSCI $ printModuleSignatures moduleName env'
307+ else case lookupUnQualifiedModName moduleName st of
308+ Just unQualifiedName ->
309+ if isModInEnv unQualifiedName st
310+ then PSCI $ printModuleSignatures unQualifiedName env'
311+ else failNotInEnv moduleName
312+ Nothing ->
313+ failNotInEnv moduleName
314+ where
315+ isModInEnv modName =
316+ any ((== modName) . P.getModuleName . snd) . psciLoadedModules
317+ failNotInEnv modName =
318+ PSCI $ outputStrLn $ "Module '" ++ N.runModuleName modName ++ "' is not valid."
319+ lookupUnQualifiedModName quaModName st =
320+ (\(modName,_,_) -> modName) <$> find ( \(_, _, mayQuaName) -> mayQuaName == Just quaModName) (psciImportedModules st)
487321
488322-- |
489323-- Takes a value and prints its kind
@@ -495,7 +329,7 @@ handleKindOf typ = do
495329 mName = P.ModuleName [P.ProperName "$PSCI"]
496330 e <- psciIO . runMake $ make st [m]
497331 case e of
498− Left errs -> printErrors errs
332+ Left errs -> PSCI $ printErrors errs
499333 Right env' ->
500334 case M.lookup (P.Qualified (Just mName) $ P.ProperName "IT") (P.typeSynonyms env') of
501335 Just (_, typ') -> do
@@ -509,63 +343,7 @@ handleKindOf typ = do
509343 Right (kind, _) -> PSCI . outputStrLn . P.prettyPrintKind $ kind
510344 Nothing -> PSCI $ outputStrLn "Could not find kind"
511345
512−-- Commands
513−
514−-- |
515−-- Parses the input and returns either a Metacommand, or an error as a string.
516−--
517−getCommand :: Bool -> InputT (StateT PSCiState IO) (Either String (Maybe Command))
518−getCommand singleLineMode = handleInterrupt (return (Right Nothing)) $ do
519− firstLine <- withInterrupt $ getInputLine "> "
520− case firstLine of
521− Nothing -> return (Right (Just QuitPSCi)) -- Ctrl-D when input is empty
522− Just "" -> return (Right Nothing)
523− Just s | singleLineMode || head s == ':' -> return .fmap Just $ parseCommand s
524− Just s -> fmap Just . parseCommand <$> go [s]
525− where
526− go :: [String] -> InputT (StateT PSCiState IO) String
527− go ls = maybe (return . unlines $ reverse ls) (go . (:ls)) =<< getInputLine " "
528−
529−-- |
530−-- Performs an action for each meta-command given, and also for expressions.
531−--
532−handleCommand :: Command -> PSCI ()
533−handleCommand (Expression val) = handleExpression val
534−handleCommand ShowHelp = PSCI $ outputStrLn helpMessage
535−handleCommand (Import im) = handleImport im
536−handleCommand (Decls l) = handleDecls l
537−handleCommand (LoadFile filePath) = whenFileExists filePath $ \absPath -> do
538− m <- psciIO $ loadModule absPath
539− case m of
540− Left err -> PSCI $ outputStrLn err
541− Right mods -> PSCI . lift $ modify (updateModules (map (absPath,) mods))
542−handleCommand (LoadForeign filePath) = whenFileExists filePath $ \absPath -> do
543− foreignsOrError <- psciIO . runMake $ do
544− foreignFile <- makeIO (const (P.ErrorMessage [] $ P.CannotReadFile absPath)) (readFile absPath)
545− P.parseForeignModulesFromFiles [(absPath, foreignFile)]
546− case foreignsOrError of
547− Left err -> PSCI $ outputStrLn $ P.prettyPrintMultipleErrors False err
548− Right foreigns -> PSCI . lift $ modify (updateForeignFiles foreigns)
549−handleCommand ResetState = do
550− PSCI . lift . modify $ \st ->
551− st { psciImportedModules = []
552− , psciLetBindings = []
553− }
554− loadAllImportedModules
555−handleCommand (TypeOf val) = handleTypeOf val
556−handleCommand (KindOf typ) = handleKindOf typ
557−handleCommand (BrowseModule moduleName) = handleBrowse moduleName
558−handleCommand (ShowInfo QueryLoaded) = handleShowLoadedModules
559−handleCommand (ShowInfo QueryImport) = handleShowImportedModules
560−handleCommand QuitPSCi = P.internalError "`handleCommand QuitPSCi` was called. This is a bug."
561−
562−whenFileExists :: FilePath -> (FilePath -> PSCI ()) -> PSCI ()
563−whenFileExists filePath f = do
564− absPath <- psciIO $ expandTilde filePath
565− exists <- psciIO $ doesFileExist absPath
566− if exists
567− then f absPath
568− else PSCI . outputStrLn $ "Couldn't locate: " ++ filePath
346+-- Misc
569347
570348-- |
571349-- Attempts to read initial commands from '.psci' in the present working
@@ -588,92 +366,6 @@ loadUserConfig = onFirstFileMatching readCommands pathGetters
588366 else
589367 return Nothing
590368
591−
592369-- | Checks if the Console module is defined
593370consoleIsDefined :: [P.Module] -> Bool
594371consoleIsDefined = any ((== P.ModuleName (map P.ProperName [ "Control", "Monad", "Eff", "Console" ])) . P.getModuleName)
595−
596−-- |
597−-- The PSCI main loop.
598−--
599−loop :: PSCiOptions -> IO ()
600−loop PSCiOptions{..} = do
601− config <- loadUserConfig
602− inputFiles <- concat <$> traverse glob psciInputFile
603− foreignFiles <- concat <$> traverse glob psciForeignInputFiles
604− modulesOrFirstError <- loadAllModules inputFiles
605− case modulesOrFirstError of
606− Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> exitFailure
607− Right modules -> do
608− historyFilename <- getHistoryFilename
609− let settings = defaultSettings { historyFile = Just historyFilename }
610− foreignsOrError <- runMake $ do
611− foreignFilesContent <- forM foreignFiles (\inFile -> (inFile,) <$> makeIO (const (P.ErrorMessage [] $ P.CannotReadFile inFile)) (readFile inFile))
612− P.parseForeignModulesFromFiles foreignFilesContent
613− case foreignsOrError of
614− Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> exitFailure
615− Right foreigns ->
616− flip evalStateT (mkPSCiState [] modules foreigns [] psciInputNodeFlags) . runInputT (setComplete completion settings) $ do
617− outputStrLn prologueMessage
618− traverse_ (traverse_ (runPSCI . handleCommand)) config
619− modules' <- lift $ gets psciLoadedModules
620− unless (consoleIsDefined (map snd modules')) . outputStrLn $ unlines
621− [ "PSCi requires the purescript-console module to be installed."
622− , "For help getting started, visit http://wiki.purescript.org/PSCi"
623− ]
624− go
625− where
626− go :: InputT (StateT PSCiState IO) ()
627− go = do
628− c <- getCommand (not psciMultiLineMode)
629− case c of
630− Left err -> outputStrLn err >> go
631− Right Nothing -> go
632− Right (Just QuitPSCi) -> outputStrLn quitMessage
633− Right (Just c') -> do
634− handleInterrupt (outputStrLn "Interrupted.")
635− (withInterrupt (runPSCI (loadAllImportedModules >> handleCommand c')))
636− go
637−
638−multiLineMode :: Parser Bool
639−multiLineMode = switch $
640− long "multi-line-mode"
641− <> short 'm'
642− <> Opts.help "Run in multi-line mode (use ^D to terminate commands)"
643−
644−inputFile :: Parser FilePath
645−inputFile = strArgument $
646− metavar "FILE"
647− <> Opts.help "Optional .purs files to load on start"
648−
649−inputForeignFile :: Parser FilePath
650−inputForeignFile = strOption $
651− short 'f'
652− <> long "ffi"
653− <> help "The input .js file(s) providing foreign import implementations"
654−
655−nodeFlagsFlag :: Parser [String]
656−nodeFlagsFlag = option parser $
657− long "node-opts"
658− <> metavar "NODE_OPTS"
659− <> value []
660− <> Opts.help "Flags to pass to node, separated by spaces"
661− where
662− parser = words <$> str
663−
664−psciOptions :: Parser PSCiOptions
665−psciOptions = PSCiOptions <$> multiLineMode
666− <*> many inputFile
667− <*> many inputForeignFile
668− <*> nodeFlagsFlag
669−
670−runPSCi :: IO ()
671−runPSCi = execParser opts >>= loop
672− where
673− opts = info (version <*> helper <*> psciOptions) infoModList
674− infoModList = fullDesc <> headerInfo <> footerInfo
675− headerInfo = header "psci - Interactive mode for PureScript"
676− footerInfo = footer $ "psci " ++ showVersion Paths.version
677−
678− version :: Parser (a -> a)
679− version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> Opts.help "Show the version number" <> hidden
psci/Completion.hs → psci/PSCi/Completion.hsrenamed+10−8
@@ -1,4 +1,6 @@
1−module Completion where
1+{-# LANGUAGE DataKinds #-}
2+
3+module PSCi.Completion where
24
35import Prelude ()
46import Prelude.Compat
@@ -17,8 +19,8 @@ import System.Console.Haskeline
1719import qualified Language.PureScript as P
1820import qualified Language.PureScript.Names as N
1921
20−import qualified Directive as D
21−import Types
22+import qualified PSCi.Directive as D
23+import PSCi.Types
2224
2325-- Completions may read the state, but not modify it.
2426type CompletionM = ReaderT PSCiState IO
@@ -171,7 +173,7 @@ getAllQualifications sho m (declName, decl) = do
171173 qualificationsUsing (_, importType, asQ') =
172174 let q = qualifyWith asQ'
173175 in case importType of
174− P.Implicit _ -> [q]
176+ P.Implicit -> [q]
175177 P.Explicit refs -> [q | referencedBy refs]
176178 P.Hiding refs -> [q | not $ referencedBy refs]
177179
@@ -184,10 +186,10 @@ getAllImportsOf = asks . allImportsOf
184186nubOnFst :: Eq a => [(a, b)] -> [(a, b)]
185187nubOnFst = nubBy ((==) `on` fst)
186188
187−typeDecls :: P.Module -> [(N.ProperName, P.Declaration)]
189+typeDecls :: P.Module -> [(N.ProperName 'N.TypeName, P.Declaration)]
188190typeDecls = mapMaybe getTypeName . filter P.isDataDecl . P.exportedDeclarations
189191 where
190− getTypeName :: P.Declaration -> Maybe (N.ProperName, P.Declaration)
192+ getTypeName :: P.Declaration -> Maybe (N.ProperName 'N.TypeName, P.Declaration)
191193 getTypeName d@(P.TypeSynonymDeclaration name _ _) = Just (name, d)
192194 getTypeName d@(P.DataDeclaration _ name _ _) = Just (name, d)
193195 getTypeName (P.PositionedDeclaration _ _ d) = getTypeName d
@@ -204,10 +206,10 @@ identNames = nubOnFst . concatMap getDeclNames . P.exportedDeclarations
204206 getDeclNames (P.PositionedDeclaration _ _ d) = getDeclNames d
205207 getDeclNames _ = []
206208
207−dctorNames :: P.Module -> [(N.ProperName, P.Declaration)]
209+dctorNames :: P.Module -> [(N.ProperName 'N.ConstructorName, P.Declaration)]
208210dctorNames = nubOnFst . concatMap go . P.exportedDeclarations
209211 where
210− go :: P.Declaration -> [(N.ProperName, P.Declaration)]
212+ go :: P.Declaration -> [(N.ProperName 'N.ConstructorName, P.Declaration)]
211213 go decl@(P.DataDeclaration _ _ _ ctors) = map (\n -> (n, decl)) (map fst ctors)
212214 go (P.PositionedDeclaration _ _ d) = go d
213215 go _ = []
psci/Directive.hs → psci/PSCi/Directive.hsrenamed+6−2
@@ -13,13 +13,17 @@
1313--
1414-----------------------------------------------------------------------------
1515
16−module Directive where
16+module PSCi.Directive where
17+
18+import Prelude ()
19+import Prelude.Compat
20+
1721
1822import Data.Maybe (fromJust, listToMaybe)
1923import Data.List (isPrefixOf)
2024import Data.Tuple (swap)
2125
22−import Types
26+import PSCi.Types
2327
2428-- |
2529-- List of all avaliable directives.
psci/PSCi/IO.hsnew file+68
@@ -0,0 +1,68 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : IO
4+-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+module PSCi.IO where
16+
17+import Prelude ()
18+import Prelude.Compat
19+
20+import System.Directory (createDirectoryIfMissing, getHomeDirectory, findExecutable, doesFileExist)
21+import System.FilePath (takeDirectory, (</>), isPathSeparator)
22+import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
23+import Control.Monad (msum)
24+import Control.Monad.IO.Class (MonadIO, liftIO)
25+import System.Console.Haskeline (outputStrLn, InputT)
26+
27+mkdirp :: FilePath -> IO ()
28+mkdirp = createDirectoryIfMissing True . takeDirectory
29+
30+-- File helpers
31+
32+onFirstFileMatching :: Monad m => (b -> m (Maybe a)) -> [b] -> m (Maybe a)
33+onFirstFileMatching f pathVariants = runMaybeT . msum $ map (MaybeT . f) pathVariants
34+
35+-- |
36+-- Locates the node executable.
37+-- Checks for either @nodejs@ or @node@.
38+--
39+findNodeProcess :: IO (Maybe String)
40+findNodeProcess = onFirstFileMatching findExecutable names
41+ where names = ["nodejs", "node"]
42+
43+-- |
44+-- Grabs the filename where the history is stored.
45+--
46+getHistoryFilename :: IO FilePath
47+getHistoryFilename = do
48+ home <- getHomeDirectory
49+ let filename = home </> ".purescript" </> "psci_history"
50+ mkdirp filename
51+ return filename
52+
53+
54+-- |
55+-- Expands tilde in path.
56+--
57+expandTilde :: FilePath -> IO FilePath
58+expandTilde ('~':p:rest) | isPathSeparator p = (</> rest) <$> getHomeDirectory
59+expandTilde p = return p
60+
61+
62+whenFileExists :: MonadIO m => FilePath -> (FilePath -> InputT m ()) -> InputT m ()
63+whenFileExists filePath f = do
64+ absPath <- liftIO $ expandTilde filePath
65+ exists <- liftIO $ doesFileExist absPath
66+ if exists
67+ then f absPath
68+ else outputStrLn $ "Couldn't locate: " ++ filePath
psci/PSCi/Message.hsnew file+53
@@ -0,0 +1,53 @@
1+module PSCi.Message where
2+
3+
4+import Data.List (intercalate)
5+import qualified PSCi.Directive as D
6+import PSCi.Types
7+
8+-- Messages
9+
10+-- |
11+-- The help message.
12+--
13+helpMessage :: String
14+helpMessage = "The following commands are available:\n\n " ++
15+ intercalate "\n " (map line D.help) ++
16+ "\n\n" ++ extraHelp
17+ where
18+ line :: (Directive, String, String) -> String
19+ line (dir, arg, desc) =
20+ let cmd = ':' : D.stringFor dir
21+ in unwords [ cmd
22+ , replicate (11 - length cmd) ' '
23+ , arg
24+ , replicate (11 - length arg) ' '
25+ , desc
26+ ]
27+
28+ extraHelp =
29+ "Further information is available on the PureScript wiki:\n" ++
30+ " --> https://github.com/purescript/purescript/wiki/psci"
31+
32+
33+-- |
34+-- The welcome prologue.
35+--
36+prologueMessage :: String
37+prologueMessage = intercalate "\n"
38+ [ " ____ ____ _ _ "
39+ , "| _ \\ _ _ _ __ ___/ ___| ___ _ __(_)_ __ | |_ "
40+ , "| |_) | | | | '__/ _ \\___ \\ / __| '__| | '_ \\| __|"
41+ , "| __/| |_| | | | __/___) | (__| | | | |_) | |_ "
42+ , "|_| \\__,_|_| \\___|____/ \\___|_| |_| .__/ \\__|"
43+ , " |_| "
44+ , ""
45+ , ":? shows help"
46+ ]
47+
48+-- |
49+-- The quit message.
50+--
51+quitMessage :: String
52+quitMessage = "See ya!"
53+
psci/PSCi/Module.hsnew file+106
@@ -0,0 +1,106 @@
1+module PSCi.Module where
2+
3+import Prelude ()
4+import Prelude.Compat
5+
6+import qualified Language.PureScript as P
7+import PSCi.Types
8+import System.FilePath (pathSeparator)
9+import Control.Monad
10+
11+-- | The name of the PSCI support module
12+supportModuleName :: P.ModuleName
13+supportModuleName = P.ModuleName [P.ProperName "$PSCI", P.ProperName "Support"]
14+
15+-- | Support module, contains code to evaluate terms
16+supportModule :: P.Module
17+supportModule =
18+ case P.parseModulesFromFiles id [("", code)] of
19+ Right [(_, P.Module ss cs _ ds exps)] -> P.Module ss cs supportModuleName ds exps
20+ _ -> P.internalError "Support module could not be parsed"
21+ where
22+ code :: String
23+ code = unlines
24+ [ "module S where"
25+ , ""
26+ , "import Prelude"
27+ , "import Control.Monad.Eff"
28+ , "import Control.Monad.Eff.Console"
29+ , "import Control.Monad.Eff.Unsafe"
30+ , ""
31+ , "class Eval a where"
32+ , " eval :: a -> Eff (console :: CONSOLE) Unit"
33+ , ""
34+ , "instance evalShow :: (Show a) => Eval a where"
35+ , " eval = print"
36+ , ""
37+ , "instance evalEff :: (Eval a) => Eval (Eff eff a) where"
38+ , " eval x = unsafeInterleaveEff x >>= eval"
39+ ]
40+
41+-- Module Management
42+
43+-- |
44+-- Loads a file for use with imports.
45+--
46+loadModule :: FilePath -> IO (Either String [P.Module])
47+loadModule filename = do
48+ content <- readFile filename
49+ return $ either (Left . P.prettyPrintMultipleErrors False) (Right . map snd) $ P.parseModulesFromFiles id [(filename, content)]
50+
51+-- |
52+-- Load all modules.
53+--
54+loadAllModules :: [FilePath] -> IO (Either P.MultipleErrors [(FilePath, P.Module)])
55+loadAllModules files = do
56+ filesAndContent <- forM files $ \filename -> do
57+ content <- readFile filename
58+ return (filename, content)
59+ return $ P.parseModulesFromFiles id filesAndContent
60+
61+
62+-- |
63+-- Makes a volatile module to execute the current expression.
64+--
65+createTemporaryModule :: Bool -> PSCiState -> P.Expr -> P.Module
66+createTemporaryModule exec PSCiState{psciImportedModules = imports, psciLetBindings = lets} val =
67+ let
68+ moduleName = P.ModuleName [P.ProperName "$PSCI"]
69+ trace = P.Var (P.Qualified (Just supportModuleName) (P.Ident "eval"))
70+ mainValue = P.App trace (P.Var (P.Qualified Nothing (P.Ident "it")))
71+ itDecl = P.ValueDeclaration (P.Ident "it") P.Public [] $ Right val
72+ mainDecl = P.ValueDeclaration (P.Ident "$main") P.Public [] $ Right mainValue
73+ decls = if exec then [itDecl, mainDecl] else [itDecl]
74+ in
75+ P.Module (P.internalModuleSourceSpan "<internal>") [] moduleName ((importDecl `map` imports) ++ lets ++ decls) Nothing
76+
77+
78+-- |
79+-- Makes a volatile module to hold a non-qualified type synonym for a fully-qualified data type declaration.
80+--
81+createTemporaryModuleForKind :: PSCiState -> P.Type -> P.Module
82+createTemporaryModuleForKind PSCiState{psciImportedModules = imports, psciLetBindings = lets} typ =
83+ let
84+ moduleName = P.ModuleName [P.ProperName "$PSCI"]
85+ itDecl = P.TypeSynonymDeclaration (P.ProperName "IT") [] typ
86+ in
87+ P.Module (P.internalModuleSourceSpan "<internal>") [] moduleName ((importDecl `map` imports) ++ lets ++ [itDecl]) Nothing
88+
89+-- |
90+-- Makes a volatile module to execute the current imports.
91+--
92+createTemporaryModuleForImports :: PSCiState -> P.Module
93+createTemporaryModuleForImports PSCiState{psciImportedModules = imports} =
94+ let
95+ moduleName = P.ModuleName [P.ProperName "$PSCI"]
96+ in
97+ P.Module (P.internalModuleSourceSpan "<internal>") [] moduleName (importDecl `map` imports) Nothing
98+
99+importDecl :: ImportedModule -> P.Declaration
100+importDecl (mn, declType, asQ) = P.ImportDeclaration mn declType asQ False
101+
102+indexFile :: FilePath
103+indexFile = ".psci_modules" ++ pathSeparator : "index.js"
104+
105+modulesDir :: FilePath
106+modulesDir = ".psci_modules" ++ pathSeparator : "node_modules"
psci/PSCi/Option.hsnew file+57
@@ -0,0 +1,57 @@
1+module PSCi.Option (
2+ getOpt
3+) where
4+
5+import Prelude ()
6+import Prelude.Compat
7+
8+import Options.Applicative as Opts
9+import Data.Version (showVersion)
10+
11+import PSCi.Types
12+import qualified Paths_purescript as Paths
13+
14+-- Parse Command line option
15+
16+multiLineMode :: Parser Bool
17+multiLineMode = switch $
18+ long "multi-line-mode"
19+ <> short 'm'
20+ <> Opts.help "Run in multi-line mode (use ^D to terminate commands)"
21+
22+inputFile :: Parser FilePath
23+inputFile = strArgument $
24+ metavar "FILE"
25+ <> Opts.help "Optional .purs files to load on start"
26+
27+inputForeignFile :: Parser FilePath
28+inputForeignFile = strOption $
29+ short 'f'
30+ <> long "ffi"
31+ <> help "The input .js file(s) providing foreign import implementations"
32+
33+nodeFlagsFlag :: Parser [String]
34+nodeFlagsFlag = option parser $
35+ long "node-opts"
36+ <> metavar "NODE_OPTS"
37+ <> value []
38+ <> Opts.help "Flags to pass to node, separated by spaces"
39+ where
40+ parser = words <$> str
41+
42+psciOptions :: Parser PSCiOptions
43+psciOptions = PSCiOptions <$> multiLineMode
44+ <*> many inputFile
45+ <*> many inputForeignFile
46+ <*> nodeFlagsFlag
47+
48+version :: Parser (a -> a)
49+version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> Opts.help "Show the version number" <> hidden
50+
51+getOpt :: IO PSCiOptions
52+getOpt = execParser opts
53+ where
54+ opts = info (version <*> helper <*> psciOptions) infoModList
55+ infoModList = fullDesc <> headerInfo <> footerInfo
56+ headerInfo = header "psci - Interactive mode for PureScript"
57+ footerInfo = footer $ "psci " ++ showVersion Paths.version
psci/Parser.hs → psci/PSCi/Parser.hsrenamed+3−3
@@ -13,7 +13,7 @@
1313--
1414-----------------------------------------------------------------------------
1515
16−module Parser
16+module PSCi.Parser
1717 ( parseCommand
1818 ) where
1919
@@ -28,8 +28,8 @@ import Text.Parsec hiding ((<|>))
2828import qualified Language.PureScript as P
2929import Language.PureScript.Parser.Common (mark, same)
3030
31−import qualified Directive as D
32−import Types
31+import qualified PSCi.Directive as D
32+import PSCi.Types
3333
3434-- |
3535-- Parses PSCI metacommands or expressions input from the user.
psci/PSCi/Printer.hsnew file+131
@@ -0,0 +1,131 @@
1+{-# LANGUAGE RecordWildCards #-}
2+{-# LANGUAGE DataKinds #-}
3+
4+module PSCi.Printer where
5+
6+import Prelude ()
7+import Prelude.Compat
8+
9+import qualified Language.PureScript as P
10+import qualified Text.PrettyPrint.Boxes as Box
11+import qualified Data.Map as M
12+import System.Console.Haskeline
13+import Data.Maybe (mapMaybe)
14+import Data.List (intersperse)
15+import Control.Monad.IO.Class (MonadIO)
16+
17+-- Printers
18+
19+-- |
20+-- Pretty print a module's signatures
21+--
22+printModuleSignatures :: MonadIO m => P.ModuleName -> P.Environment -> InputT m ()
23+printModuleSignatures moduleName (P.Environment {..}) =
24+ -- get relevant components of a module from environment
25+ let moduleNamesIdent = (filter ((== moduleName) . fst) . M.keys) names
26+ moduleTypeClasses = (filter (\(P.Qualified maybeName _) -> maybeName == Just moduleName) . M.keys) typeClasses
27+ moduleTypes = (filter (\(P.Qualified maybeName _) -> maybeName == Just moduleName) . M.keys) types
28+
29+ in
30+ -- print each component
31+ (outputStr . unlines . map trimEnd . lines . Box.render . Box.vsep 1 Box.left)
32+ [ printModule's (mapMaybe (showTypeClass . findTypeClass typeClasses)) moduleTypeClasses -- typeClasses
33+ , printModule's (mapMaybe (showType typeClasses dataConstructors typeSynonyms . findType types)) moduleTypes -- types
34+ , printModule's (map (showNameType . findNameType names)) moduleNamesIdent -- functions
35+ ]
36+
37+ where printModule's showF = Box.vsep 1 Box.left . showF
38+
39+ findNameType :: M.Map (P.ModuleName, P.Ident) (P.Type, P.NameKind, P.NameVisibility) -> (P.ModuleName, P.Ident) -> (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility))
40+ findNameType envNames m@(_, mIdent) = (mIdent, M.lookup m envNames)
41+
42+ showNameType :: (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility)) -> Box.Box
43+ showNameType (mIdent, Just (mType, _, _)) = Box.text (P.showIdent mIdent ++ " :: ") Box.<> P.typeAsBox mType
44+ showNameType _ = P.internalError "The impossible happened in printModuleSignatures."
45+
46+ findTypeClass
47+ :: M.Map (P.Qualified (P.ProperName 'P.ClassName)) ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint])
48+ -> P.Qualified (P.ProperName 'P.ClassName)
49+ -> (P.Qualified (P.ProperName 'P.ClassName), Maybe ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint]))
50+ findTypeClass envTypeClasses name = (name, M.lookup name envTypeClasses)
51+
52+ showTypeClass
53+ :: (P.Qualified (P.ProperName 'P.ClassName), Maybe ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint]))
54+ -> Maybe Box.Box
55+ showTypeClass (_, Nothing) = Nothing
56+ showTypeClass (P.Qualified _ name, Just (vars, body, constrs)) =
57+ let constraints =
58+ if null constrs
59+ then Box.text ""
60+ else Box.text "("
61+ Box.<> Box.hcat Box.left (intersperse (Box.text ", ") $ map (\(P.Qualified _ pn, lt) -> Box.text (P.runProperName pn) Box.<+> Box.hcat Box.left (map P.typeAtomAsBox lt)) constrs)
62+ Box.<> Box.text ") <= "
63+ className =
64+ Box.text (P.runProperName name)
65+ Box.<> Box.text (concatMap ((' ':) . fst) vars)
66+ classBody =
67+ Box.vcat Box.top (map (\(i, t) -> Box.text (P.showIdent i ++ " ::") Box.<+> P.typeAsBox t) body)
68+
69+ in
70+ Just $
71+ (Box.text "class "
72+ Box.<> constraints
73+ Box.<> className
74+ Box.<+> if null body then Box.text "" else Box.text "where")
75+ Box.// Box.moveRight 2 classBody
76+
77+
78+ findType
79+ :: M.Map (P.Qualified (P.ProperName 'P.TypeName)) (P.Kind, P.TypeKind)
80+ -> P.Qualified (P.ProperName 'P.TypeName)
81+ -> (P.Qualified (P.ProperName 'P.TypeName), Maybe (P.Kind, P.TypeKind))
82+ findType envTypes name = (name, M.lookup name envTypes)
83+
84+ showType
85+ :: M.Map (P.Qualified (P.ProperName 'P.ClassName)) ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint])
86+ -> M.Map (P.Qualified (P.ProperName 'P.ConstructorName)) (P.DataDeclType, P.ProperName 'P.TypeName, P.Type, [P.Ident])
87+ -> M.Map (P.Qualified (P.ProperName 'P.TypeName)) ([(String, Maybe P.Kind)], P.Type)
88+ -> (P.Qualified (P.ProperName 'P.TypeName), Maybe (P.Kind, P.TypeKind))
89+ -> Maybe Box.Box
90+ showType typeClassesEnv dataConstructorsEnv typeSynonymsEnv (n@(P.Qualified modul name), typ) =
91+ case (typ, M.lookup n typeSynonymsEnv) of
92+ (Just (_, P.TypeSynonym), Just (typevars, dtType)) ->
93+ if M.member (fmap P.coerceProperName n) typeClassesEnv
94+ then
95+ Nothing
96+ else
97+ Just $
98+ Box.text ("type " ++ P.runProperName name ++ concatMap ((' ':) . fst) typevars)
99+ Box.// Box.moveRight 2 (Box.text "=" Box.<+> P.typeAsBox dtType)
100+
101+ (Just (_, P.DataType typevars pt), _) ->
102+ let prefix =
103+ case pt of
104+ [(dtProperName,_)] ->
105+ case M.lookup (P.Qualified modul dtProperName) dataConstructorsEnv of
106+ Just (dataDeclType, _, _, _) -> P.showDataDeclType dataDeclType
107+ _ -> "data"
108+ _ -> "data"
109+
110+ in
111+ Just $ Box.text (prefix ++ " " ++ P.runProperName name ++ concatMap ((' ':) . fst) typevars) Box.// printCons pt
112+
113+ _ ->
114+ Nothing
115+
116+ where printCons pt =
117+ Box.moveRight 2 $
118+ Box.vcat Box.left $
119+ mapFirstRest (Box.text "=" Box.<+>) (Box.text "|" Box.<+>) $
120+ map (\(cons,idents) -> (Box.text (P.runProperName cons) Box.<> Box.hcat Box.left (map prettyPrintType idents))) pt
121+
122+ prettyPrintType t = Box.text " " Box.<> P.typeAtomAsBox t
123+
124+ mapFirstRest _ _ [] = []
125+ mapFirstRest f g (x:xs) = f x : map g xs
126+
127+ trimEnd = reverse . dropWhile (== ' ') . reverse
128+
129+-- | Pretty-print errors
130+printErrors :: MonadIO m => P.MultipleErrors -> InputT m ()
131+printErrors = outputStrLn . P.prettyPrintMultipleErrors False
psci/Types.hs → psci/PSCi/Types.hsrenamed+6−3
@@ -13,7 +13,10 @@
1313--
1414-----------------------------------------------------------------------------
1515
16−module Types where
16+module PSCi.Types where
17+
18+import Prelude ()
19+import Prelude.Compat
1720
1821import Control.Arrow (second)
1922import Data.Map (Map)
@@ -51,11 +54,11 @@ mkPSCiState :: [ImportedModule]
5154 -> [P.Declaration]
5255 -> [String]
5356 -> PSCiState
54−mkPSCiState imported loaded foreign lets nodeFlags =
57+mkPSCiState imported loaded foreigns lets nodeFlags =
5558 (initialPSCiState
5659 |> each imported updateImportedModules
5760 |> updateModules loaded)
58− { psciForeignFiles = foreign
61+ { psciForeignFiles = foreigns
5962 , psciLetBindings = lets
6063 , psciNodeFlags = nodeFlags
6164 }
purescript.cabal+121−44
@@ -1,5 +1,5 @@
11name: purescript
2−version: 0.8.0.0
2+version: 0.8.2.0
33cabal-version: >=1.8
44build-type: Simple
55license: MIT
@@ -14,20 +14,29 @@ Homepage: http://www.purescript.org/
1414author: Phil Freeman <paf31@cantab.net>,
1515 Gary Burgess <gary.burgess@gmail.com>,
1616 Hardy Jones <jones3.hardy@gmail.com>,
17− Harry Garrood <harry@garrood.me>
17+ Harry Garrood <harry@garrood.me>,
18+ Christoph Hegemann <christoph.hegemann1337@gmail.com>
1819
19−tested-with: GHC==7.8
20+tested-with: GHC==7.10.3
2021
2122extra-source-files: examples/passing/*.purs
2223 , examples/failing/*.purs
24+ , examples/docs/bower_components/purescript-prelude/src/*.purs
25+ , examples/docs/bower.json
26+ , examples/docs/src/*.purs
2327 , tests/support/setup.js
2428 , tests/support/package.json
29+ , tests/support/prelude/bower.json
30+ , tests/support/prelude/src/*.purs
31+ , tests/support/prelude/src/*.js
32+ , tests/support/prelude/LICENSE
2533 , tests/support/bower.json
2634 , tests/support/setup-win.cmd
27− , psci/tests/data/Sample.purs
35+ , tests/support/flattened/*.purs
36+ , tests/support/flattened/*.js
37+ , tests/support/psci/*.purs
2838 , stack.yaml
29− , stack-lts-2.yaml
30− , stack-lts-3.yaml
39+ , stack-lts-5.yaml
3140 , stack-nightly.yaml
3241 , README.md
3342 , INSTALL.md
@@ -39,7 +48,7 @@ source-repository head
3948 location: https://github.com/purescript/purescript.git
4049
4150library
42− build-depends: base >=4.6 && <5,
51+ build-depends: base >=4.8 && <5,
4352 base-compat >=0.6.0,
4453 lifted-base >= 0.2.3 && < 0.2.4,
4554 monad-control >= 1.0.0.0 && < 1.1,
@@ -51,13 +60,13 @@ library
5160 filepath -any,
5261 mtl >= 2.1.0 && < 2.3.0,
5362 parsec -any,
54− transformers >= 0.3.0 && < 0.5,
63+ transformers >= 0.3.0 && < 0.6,
5564 transformers-compat >= 0.3.0,
5665 utf8-string >= 1 && < 2,
5766 pattern-arrows >= 0.0.2 && < 0.1,
5867 time -any,
5968 boxes >= 0.1.4 && < 0.2.0,
60− aeson >= 0.8 && < 0.11,
69+ aeson >= 0.8 && < 0.12,
6170 vector -any,
6271 bower-json >= 0.7,
6372 aeson-better-errors >= 0.8,
@@ -67,16 +76,26 @@ library
6776 language-javascript == 0.5.*,
6877 syb -any,
6978 Glob >= 0.7 && < 0.8,
70− process >= 1.2.0 && < 1.4,
79+ process >= 1.2.0 && < 1.5,
7180 safe >= 0.3.9 && < 0.4,
7281 semigroups >= 0.16.2 && < 0.19,
73− parallel >= 3.2 && < 3.3
82+ parallel >= 3.2 && < 3.3,
83+ sourcemap >= 0.1.6,
84+ stm >= 0.2.4.0,
85+ regex-tdfa -any,
86+ edit-distance -any,
87+ fsnotify >= 0.2.1,
88+ monad-logger >= 0.3 && < 0.4,
89+ pipes >= 4.0.0 && < 4.2.0 ,
90+ pipes-http -any,
91+ http-types -any
7492
7593 exposed-modules: Language.PureScript
7694 Language.PureScript.AST
7795 Language.PureScript.AST.Binders
7896 Language.PureScript.AST.Declarations
7997 Language.PureScript.AST.Operators
98+ Language.PureScript.AST.Literals
8099 Language.PureScript.AST.SourcePos
81100 Language.PureScript.AST.Traversals
82101 Language.PureScript.AST.Exported
@@ -100,7 +119,6 @@ library
100119 Language.PureScript.CoreFn.Binders
101120 Language.PureScript.CoreFn.Desugar
102121 Language.PureScript.CoreFn.Expr
103− Language.PureScript.CoreFn.Literals
104122 Language.PureScript.CoreFn.Meta
105123 Language.PureScript.CoreFn.Module
106124 Language.PureScript.CoreFn.Traversals
@@ -140,6 +158,9 @@ library
140158 Language.PureScript.Sugar.Names.Exports
141159 Language.PureScript.Sugar.ObjectWildcards
142160 Language.PureScript.Sugar.Operators
161+ Language.PureScript.Sugar.Operators.Common
162+ Language.PureScript.Sugar.Operators.Expr
163+ Language.PureScript.Sugar.Operators.Binders
143164 Language.PureScript.Sugar.TypeClasses
144165 Language.PureScript.Sugar.TypeClasses.Deriving
145166 Language.PureScript.Sugar.TypeDeclarations
@@ -159,13 +180,15 @@ library
159180
160181 Language.PureScript.Docs
161182 Language.PureScript.Docs.Convert
183+ Language.PureScript.Docs.Convert.Single
184+ Language.PureScript.Docs.Convert.ReExports
162185 Language.PureScript.Docs.Render
163186 Language.PureScript.Docs.Types
164187 Language.PureScript.Docs.RenderedCode
165188 Language.PureScript.Docs.RenderedCode.Types
166189 Language.PureScript.Docs.RenderedCode.Render
167190 Language.PureScript.Docs.AsMarkdown
168− Language.PureScript.Docs.ParseAndDesugar
191+ Language.PureScript.Docs.ParseAndBookmark
169192 Language.PureScript.Docs.Utils.MonoidExtras
170193
171194 Language.PureScript.Publish
@@ -173,11 +196,29 @@ library
173196 Language.PureScript.Publish.ErrorsWarnings
174197 Language.PureScript.Publish.BoxesHelpers
175198
199+ Language.PureScript.Ide
200+ Language.PureScript.Ide.Command
201+ Language.PureScript.Ide.Externs
202+ Language.PureScript.Ide.Error
203+ Language.PureScript.Ide.CodecJSON
204+ Language.PureScript.Ide.Pursuit
205+ Language.PureScript.Ide.Completion
206+ Language.PureScript.Ide.Matcher
207+ Language.PureScript.Ide.Filter
208+ Language.PureScript.Ide.Types
209+ Language.PureScript.Ide.State
210+ Language.PureScript.Ide.CaseSplit
211+ Language.PureScript.Ide.SourceFile
212+ Language.PureScript.Ide.Watcher
213+ Language.PureScript.Ide.Reexports
214+
176215 Control.Monad.Logger
177216 Control.Monad.Supply
178217 Control.Monad.Supply.Class
179218
180219 System.IO.UTF8
220+
221+ extensions: DataKinds
181222 exposed: True
182223 buildable: True
183224 hs-source-dirs: src
@@ -187,18 +228,18 @@ library
187228executable psc
188229 build-depends: base >=4 && <5, base-compat >=0.6.0,
189230 containers -any, directory -any, filepath -any,
190− mtl -any, optparse-applicative >= 0.10.0, parsec -any, purescript -any,
231+ mtl -any, optparse-applicative >= 0.12.1, parsec -any, purescript -any,
191232 time -any, transformers -any, transformers-compat -any, Glob >= 0.7 && < 0.8,
192− aeson >= 0.8 && < 0.11, bytestring -any, utf8-string >= 1 && < 2
233+ aeson >= 0.8 && < 0.12, bytestring -any, utf8-string >= 1 && < 2
193234 main-is: Main.hs
194235 buildable: True
195236 hs-source-dirs: psc
196− other-modules: JSON
237+ other-modules: JSON, Paths_purescript
197238 ghc-options: -Wall -O2 -fno-warn-unused-do-bind -threaded -rtsopts "-with-rtsopts=-N"
198239
199240executable psci
200241 build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,
201− mtl -any, optparse-applicative >= 0.10.0, parsec -any,
242+ mtl -any, optparse-applicative >= 0.12.1, parsec -any,
202243 haskeline >= 0.7.0.0, purescript -any, transformers -any,
203244 transformers-compat -any, process -any, time -any, Glob -any, base-compat >=0.6.0,
204245 boxes >= 0.1.4 && < 0.2.0
@@ -206,20 +247,27 @@ executable psci
206247 main-is: Main.hs
207248 buildable: True
208249 hs-source-dirs: psci psci/main
209− other-modules: Types
210− Parser
211− Directive
212− Completion
213− PSCi
214− IO
250+ other-modules: PSCi
251+ PSCi.Types
252+ PSCi.Parser
253+ PSCi.Directive
254+ PSCi.Completion
255+ PSCi.IO
256+ PSCi.Message
257+ PSCi.Option
258+ PSCi.Module
259+ PSCi.Printer
260+ Paths_purescript
215261 ghc-options: -Wall -O2
216262
217263executable psc-docs
218264 build-depends: base >=4 && <5, purescript -any,
219− optparse-applicative >= 0.10.0, process -any, mtl -any,
265+ optparse-applicative >= 0.12.1, process -any, mtl -any,
220266 split -any, ansi-wl-pprint -any, directory -any,
221− filepath -any, Glob -any
267+ filepath -any, Glob -any, transformers -any,
268+ transformers-compat -any
222269 main-is: Main.hs
270+ other-modules: Paths_purescript
223271 buildable: True
224272 hs-source-dirs: psc-docs
225273 other-modules: Ctags
@@ -230,15 +278,17 @@ executable psc-docs
230278executable psc-publish
231279 build-depends: base >=4 && <5, purescript -any, bytestring -any, aeson -any, optparse-applicative -any
232280 main-is: Main.hs
281+ other-modules: Paths_purescript
233282 buildable: True
234283 hs-source-dirs: psc-publish
235284 ghc-options: -Wall -O2
236285
237286executable psc-hierarchy
238− build-depends: base >=4 && <5, purescript -any, optparse-applicative >= 0.10.0,
287+ build-depends: base >=4 && <5, purescript -any, optparse-applicative >= 0.12.1,
239288 process -any, mtl -any, parsec -any, filepath -any, directory -any,
240289 Glob -any
241290 main-is: Main.hs
291+ other-modules: Paths_purescript
242292 buildable: True
243293 hs-source-dirs: hierarchy
244294 other-modules:
@@ -246,7 +296,7 @@ executable psc-hierarchy
246296
247297executable psc-bundle
248298 main-is: Main.hs
249− other-modules:
299+ other-modules: Paths_purescript
250300 other-extensions:
251301 build-depends: base >=4 && <5,
252302 purescript -any,
@@ -255,33 +305,60 @@ executable psc-bundle
255305 mtl -any,
256306 transformers -any,
257307 transformers-compat -any,
258− optparse-applicative >= 0.10.0,
308+ optparse-applicative >= 0.12.1,
259309 Glob -any
260310 ghc-options: -Wall -O2
261311 hs-source-dirs: psc-bundle
262312
313+executable psc-ide-server
314+ main-is: Main.hs
315+ other-modules:
316+ other-extensions:
317+ build-depends: base >=4 && <5
318+ , purescript -any
319+ , directory -any
320+ , filepath -any
321+ , monad-logger -any
322+ , mtl -any
323+ , transformers -any
324+ , transformers-compat -any
325+ , network -any
326+ , optparse-applicative >= 0.12.1
327+ , stm -any
328+ , text -any
329+ , base-compat >=0.6.0
330+ ghc-options: -Wall -O2 -threaded
331+ hs-source-dirs: psc-ide-server
332+
333+executable psc-ide-client
334+ main-is: Main.hs
335+ other-modules:
336+ other-extensions:
337+ build-depends: base >=4 && <5
338+ , mtl -any
339+ , text -any
340+ , optparse-applicative >= 0.12.1
341+ , network -any
342+ , base-compat >=0.6.0
343+ ghc-options: -Wall -O2
344+ hs-source-dirs: psc-ide-client
345+
263346test-suite tests
264347 build-depends: base >=4 && <5, containers -any, directory -any,
265348 filepath -any, mtl -any, parsec -any, purescript -any,
266349 transformers -any, process -any, transformers-compat -any, time -any,
267350 Glob -any, aeson-better-errors -any, bytestring -any, aeson -any,
268− base-compat -any
351+ base-compat -any, haskeline >= 0.7.0.0, optparse-applicative -any,
352+ boxes -any, HUnit -any, hspec -any, hspec-discover -any, stm -any, text -any
353+ ghc-options: -Wall
269354 type: exitcode-stdio-1.0
270355 main-is: Main.hs
271− other-modules: TestsSetup
356+ other-modules: TestUtils
357+ TestCompiler
358+ TestDocs
272359 TestPscPublish
360+ TestPsci
361+ TestPscIde
362+ PscIdeSpec
273363 buildable: True
274− hs-source-dirs: tests tests/common
275−
276−test-suite psci-tests
277− build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,
278− mtl -any, optparse-applicative >= 0.10.0, parsec -any,
279− haskeline >= 0.7.0.0, purescript -any, transformers -any,
280− transformers-compat -any, process -any, HUnit -any, time -any,
281− Glob -any, base-compat >=0.6.0, boxes >= 0.1.4 && < 0.2.0
282− type: exitcode-stdio-1.0
283− main-is: Main.hs
284− other-modules: TestsSetup
285− buildable: True
286− hs-source-dirs: psci psci/tests tests/common
287− ghc-options: -Wall
364+ hs-source-dirs: tests psci
src/Control/Monad/Logger.hs+1−1
@@ -30,7 +30,7 @@ import Control.Monad.Base (MonadBase(..))
3030import Control.Monad.Trans.Control (MonadBaseControl(..))
3131
3232-- | A replacement for WriterT IO which uses mutable references.
33−data Logger w a = Logger { runLogger :: IORef w -> IO a }
33+newtype Logger w a = Logger { runLogger :: IORef w -> IO a }
3434
3535-- | Run a Logger computation, starting with an empty log.
3636runLogger' :: (Monoid w) => Logger w a -> IO (a, w)
src/Control/Monad/Supply.hs+1−1
@@ -27,7 +27,7 @@ import Control.Monad.Error.Class (MonadError(..))
2727import Control.Monad.Reader
2828import Control.Monad.Writer
2929
30−newtype SupplyT m a = SupplyT { unSupplyT :: StateT Integer m a }
30+newtype SupplyT m a = SupplyT { unSupplyT :: StateT Integer m a }
3131 deriving (Functor, Applicative, Monad, MonadTrans, MonadError e, MonadWriter w, MonadReader r)
3232
3333runSupplyT :: Integer -> SupplyT m a -> m (a, Integer)
src/Language/PureScript.hs−1
@@ -13,7 +13,6 @@
1313--
1414-----------------------------------------------------------------------------
1515
16−{-# LANGUAGE DataKinds #-}
1716{-# LANGUAGE FlexibleContexts #-}
1817{-# LANGUAGE ScopedTypeVariables #-}
1918
src/Language/PureScript/AST.hs+4−14
@@ -1,24 +1,14 @@
1−-----------------------------------------------------------------------------
1+-- |
2+-- The initial PureScript AST
23--
3−-- Module : Language.PureScript.AST
4−-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- | The initial PureScript AST
12−--
13−-----------------------------------------------------------------------------
14−
154module Language.PureScript.AST (
165 module AST
176) where
187
198import Language.PureScript.AST.Binders as AST
209import Language.PureScript.AST.Declarations as AST
10+import Language.PureScript.AST.Exported as AST
11+import Language.PureScript.AST.Literals as AST
2112import Language.PureScript.AST.Operators as AST
2213import Language.PureScript.AST.SourcePos as AST
2314import Language.PureScript.AST.Traversals as AST
24−import Language.PureScript.AST.Exported as AST
src/Language/PureScript/AST/Binders.hs+28−39
@@ -1,24 +1,10 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.AST.Binders
4−-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- | Case binders
1+-- |
2+-- Case binders
123--
13−-----------------------------------------------------------------------------
14−
15−{-# LANGUAGE DeriveDataTypeable #-}
16−
174module Language.PureScript.AST.Binders where
185
19−import qualified Data.Data as D
20−
216import Language.PureScript.AST.SourcePos
7+import Language.PureScript.AST.Literals
228import Language.PureScript.Names
239import Language.PureScript.Comments
2410import Language.PureScript.Types
@@ -32,21 +18,9 @@ data Binder
3218 --
3319 = NullBinder
3420 -- |
35− -- A binder which matches a boolean literal
36− --
37− | BooleanBinder Bool
38− -- |
39− -- A binder which matches a string literal
40− --
41− | StringBinder String
42− -- |
43− -- A binder which matches a character literal
44− --
45− | CharBinder Char
46− -- |
47− -- A binder which matches a numeric literal
21+ -- A binder which matches a literal
4822 --
49− | NumberBinder (Either Integer Double)
23+ | LiteralBinder (Literal Binder)
5024 -- |
5125 -- A binder which binds an identifier
5226 --
@@ -54,15 +28,25 @@ data Binder
5428 -- |
5529 -- A binder which matches a data constructor
5630 --
57− | ConstructorBinder (Qualified ProperName) [Binder]
31+ | ConstructorBinder (Qualified (ProperName 'ConstructorName)) [Binder]
32+ -- |
33+ -- A operator alias binder. During the rebracketing phase of desugaring,
34+ -- this data constructor will be removed.
35+ --
36+ | OpBinder (Qualified Ident)
5837 -- |
59− -- A binder which matches a record and binds its properties
38+ -- Binary operator application. During the rebracketing phase of desugaring,
39+ -- this data constructor will be removed.
6040 --
61− | ObjectBinder [(String, Binder)]
41+ | BinaryNoParensBinder Binder Binder Binder
6242 -- |
63− -- A binder which matches an array and binds its elements
43+ -- Explicit parentheses. During the rebracketing phase of desugaring, this
44+ -- data constructor will be removed.
45+ --
46+ -- Note: although it seems this constructor is not used, it _is_ useful,
47+ -- since it prevents certain traversals from matching.
6448 --
65− | ArrayBinder [Binder]
49+ | ParensInBinder Binder
6650 -- |
6751 -- A binder which binds its input to an identifier
6852 --
@@ -74,7 +58,8 @@ data Binder
7458 -- |
7559 -- A binder with a type annotation
7660 --
77− | TypedBinder Type Binder deriving (Show, Read, Eq, D.Data, D.Typeable)
61+ | TypedBinder Type Binder
62+ deriving (Show, Read, Eq)
7863
7964-- |
8065-- Collect all names introduced in binders in an expression
@@ -82,11 +67,15 @@ data Binder
8267binderNames :: Binder -> [Ident]
8368binderNames = go []
8469 where
70+ go ns (LiteralBinder b) = lit ns b
8571 go ns (VarBinder name) = name : ns
8672 go ns (ConstructorBinder _ bs) = foldl go ns bs
87− go ns (ObjectBinder bs) = foldl go ns (map snd bs)
88− go ns (ArrayBinder bs) = foldl go ns bs
73+ go ns (BinaryNoParensBinder b1 b2 b3) = foldl go ns [b1, b2, b3]
74+ go ns (ParensInBinder b) = go ns b
8975 go ns (NamedBinder name b) = go (name : ns) b
9076 go ns (PositionedBinder _ _ b) = go ns b
9177 go ns (TypedBinder _ b) = go ns b
9278 go ns _ = ns
79+ lit ns (ObjectLiteral bs) = foldl go ns (map snd bs)
80+ lit ns (ArrayLiteral bs) = foldl go ns bs
81+ lit ns _ = ns
src/Language/PureScript/AST/Declarations.hs+44−63
@@ -1,4 +1,3 @@
1−{-# LANGUAGE DeriveDataTypeable #-}
21{-# LANGUAGE ScopedTypeVariables #-}
32{-# LANGUAGE TemplateHaskell #-}
43{-# LANGUAGE LambdaCase #-}
@@ -15,12 +14,12 @@ import Data.Aeson.TH
1514import Data.List (nub, (\\))
1615import Data.Maybe (mapMaybe)
1716
18−import qualified Data.Data as D
1917import qualified Data.Map as M
2018
2119import Control.Monad.Identity
2220
2321import Language.PureScript.AST.Binders
22+import Language.PureScript.AST.Literals
2423import Language.PureScript.AST.Operators
2524import Language.PureScript.AST.SourcePos
2625import Language.PureScript.Types
@@ -35,7 +34,8 @@ import Language.PureScript.Environment
3534-- a list of declarations, and a list of the declarations that are
3635-- explicitly exported. If the export list is Nothing, everything is exported.
3736--
38−data Module = Module SourceSpan [Comment] ModuleName [Declaration] (Maybe [DeclarationRef]) deriving (Show, Read, D.Data, D.Typeable)
37+data Module = Module SourceSpan [Comment] ModuleName [Declaration] (Maybe [DeclarationRef])
38+ deriving (Show, Read)
3939
4040-- | Return a module's name.
4141getModuleName :: Module -> ModuleName
@@ -47,7 +47,7 @@ getModuleName (Module _ _ name _ _) = name
4747addDefaultImport :: ModuleName -> Module -> Module
4848addDefaultImport toImport m@(Module ss coms mn decls exps) =
4949 if isExistingImport `any` decls || mn == toImport then m
50− else Module ss coms mn (ImportDeclaration toImport (Implicit True) Nothing False : decls) exps
50+ else Module ss coms mn (ImportDeclaration toImport Implicit Nothing False : decls) exps
5151 where
5252 isExistingImport (ImportDeclaration mn' _ _ _) | mn' == toImport = True
5353 isExistingImport (PositionedDeclaration _ _ d) = isExistingImport d
@@ -60,7 +60,7 @@ data DeclarationRef
6060 -- |
6161 -- A type constructor with data constructors
6262 --
63− = TypeRef ProperName (Maybe [ProperName])
63+ = TypeRef (ProperName 'TypeName) (Maybe [ProperName 'ConstructorName])
6464 -- |
6565 -- A value
6666 --
@@ -68,7 +68,7 @@ data DeclarationRef
6868 -- |
6969 -- A type class
7070 --
71− | TypeClassRef ProperName
71+ | TypeClassRef (ProperName 'ClassName)
7272 -- |
7373 -- A type class instance, created during typeclass desugaring (name, class name, instance types)
7474 --
@@ -80,12 +80,12 @@ data DeclarationRef
8080 -- |
8181 -- An unspecified ProperName ref. This will be replaced with a TypeClassRef
8282 -- or TypeRef during name desugaring.
83− | ProperRef ProperName
83+ | ProperRef String
8484 -- |
8585 -- A declaration reference with source position information
8686 --
8787 | PositionedDeclarationRef SourceSpan [Comment] DeclarationRef
88− deriving (Show, Read, D.Data, D.Typeable)
88+ deriving (Show, Read)
8989
9090instance Eq DeclarationRef where
9191 (TypeRef name dctors) == (TypeRef name' dctors') = name == name' && dctors == dctors'
@@ -108,7 +108,7 @@ isModuleRef _ = False
108108-- are the duplicate refs with data constructors elided, and then a separate
109109-- list of duplicate data constructors.
110110--
111−findDuplicateRefs :: [DeclarationRef] -> ([DeclarationRef], [ProperName])
111+findDuplicateRefs :: [DeclarationRef] -> ([DeclarationRef], [ProperName 'ConstructorName])
112112findDuplicateRefs refs =
113113 let positionless = stripPosInfo `map` refs
114114 simplified = simplifyTypeRefs `map` positionless
@@ -130,11 +130,9 @@ findDuplicateRefs refs =
130130--
131131data ImportDeclarationType
132132 -- |
133− -- An import with no explicit list: `import M`. The boolean signifies whether
134− -- the import was imported with `(..)` or not. Without `(..)` a warning is
135− -- raised for each member implicitly imported.
133+ -- An import with no explicit list: `import M`.
136134 --
137− = Implicit Bool
135+ = Implicit
138136 -- |
139137 -- An import with an explicit list of references to import: `import M (foo)`
140138 --
@@ -143,12 +141,16 @@ data ImportDeclarationType
143141 -- An import with a list of references to hide: `import M hiding (foo)`
144142 --
145143 | Hiding [DeclarationRef]
146− deriving (Eq, Show, Read, D.Data, D.Typeable)
144+ deriving (Eq, Show, Read)
147145
148146isImplicit :: ImportDeclarationType -> Bool
149−isImplicit (Implicit _) = True
147+isImplicit Implicit = True
150148isImplicit _ = False
151149
150+isExplicit :: ImportDeclarationType -> Bool
151+isExplicit (Explicit _) = True
152+isExplicit _ = False
153+
152154-- |
153155-- The data type of declarations
154156--
@@ -156,7 +158,7 @@ data Declaration
156158 -- |
157159 -- A data type declaration (data or newtype, name, arguments, data constructors)
158160 --
159− = DataDeclaration DataDeclType ProperName [(String, Maybe Kind)] [(ProperName, [Type])]
161+ = DataDeclaration DataDeclType (ProperName 'TypeName) [(String, Maybe Kind)] [(ProperName 'ConstructorName, [Type])]
160162 -- |
161163 -- A minimal mutually recursive set of data type declarations
162164 --
@@ -164,7 +166,7 @@ data Declaration
164166 -- |
165167 -- A type synonym declaration (name, arguments, type)
166168 --
167− | TypeSynonymDeclaration ProperName [(String, Maybe Kind)] Type
169+ | TypeSynonymDeclaration (ProperName 'TypeName) [(String, Maybe Kind)] Type
168170 -- |
169171 -- A type declaration for a value (name, ty)
170172 --
@@ -184,11 +186,11 @@ data Declaration
184186 -- |
185187 -- A data type foreign import (name, kind)
186188 --
187− | ExternDataDeclaration ProperName Kind
189+ | ExternDataDeclaration (ProperName 'TypeName) Kind
188190 -- |
189191 -- A fixity declaration (fixity data, operator name, value the operator is an alias for)
190192 --
191− | FixityDeclaration Fixity String (Maybe Ident)
193+ | FixityDeclaration Fixity String (Maybe (Either (Qualified Ident) (Qualified (ProperName 'ConstructorName))))
192194 -- |
193195 -- A module import (module name, qualified/unqualified/hiding, optional "qualified as" name)
194196 -- TODO: also a boolean specifying whether the old `qualified` syntax was used, so a warning can be raised in desugaring (remove for 0.9)
@@ -197,17 +199,17 @@ data Declaration
197199 -- |
198200 -- A type class declaration (name, argument, implies, member declarations)
199201 --
200− | TypeClassDeclaration ProperName [(String, Maybe Kind)] [Constraint] [Declaration]
202+ | TypeClassDeclaration (ProperName 'ClassName) [(String, Maybe Kind)] [Constraint] [Declaration]
201203 -- |
202204 -- A type instance declaration (name, dependencies, class name, instance types, member
203205 -- declarations)
204206 --
205− | TypeInstanceDeclaration Ident [Constraint] (Qualified ProperName) [Type] TypeInstanceBody
207+ | TypeInstanceDeclaration Ident [Constraint] (Qualified (ProperName 'ClassName)) [Type] TypeInstanceBody
206208 -- |
207209 -- A declaration with source position information
208210 --
209211 | PositionedDeclaration SourceSpan [Comment] Declaration
210− deriving (Show, Read, D.Data, D.Typeable)
212+ deriving (Show, Read)
211213
212214-- | The members of a type class instance declaration
213215data TypeInstanceBody
@@ -215,7 +217,7 @@ data TypeInstanceBody
215217 = DerivedInstance
216218 -- | This is a regular (explicit) instance
217219 | ExplicitInstance [Declaration]
218− deriving (Show, Read, D.Data, D.Typeable)
220+ deriving (Show, Read)
219221
220222mapTypeInstanceBody :: ([Declaration] -> [Declaration]) -> TypeInstanceBody -> TypeInstanceBody
221223mapTypeInstanceBody f = runIdentity . traverseTypeInstanceBody (Identity . f)
@@ -308,21 +310,9 @@ type Guard = Expr
308310--
309311data Expr
310312 -- |
311− -- A numeric literal
312− --
313− = NumericLiteral (Either Integer Double)
314− -- |
315− -- A string literal
316− --
317− | StringLiteral String
318− -- |
319− -- A character literal
313+ -- A literal value
320314 --
321− | CharLiteral Char
322− -- |
323− -- A boolean literal
324− --
325− | BooleanLiteral Bool
315+ = Literal (Literal Expr)
326316 -- |
327317 -- A prefix -, will be desugared
328318 --
@@ -336,6 +326,9 @@ data Expr
336326 -- Explicit parentheses. During the rebracketing phase of desugaring, this data constructor
337327 -- will be removed.
338328 --
329+ -- Note: although it seems this constructor is not used, it _is_ useful, since it prevents
330+ -- certain traversals from matching.
331+ --
339332 | Parens Expr
340333 -- |
341334 -- Operator section. This will be removed during desugaring and replaced with a partially applied
@@ -343,19 +336,6 @@ data Expr
343336 --
344337 | OperatorSection Expr (Either Expr Expr)
345338 -- |
346− -- An array literal
347− --
348− | ArrayLiteral [Expr]
349− -- |
350− -- An object literal
351− --
352− | ObjectLiteral [(String, Expr)]
353− -- |
354− -- An object constructor (object literal with underscores). This will be removed during
355− -- desugaring and expanded into a lambda that returns an object literal.
356− --
357− | ObjectConstructor [(String, Maybe Expr)]
358− -- |
359339 -- An object property getter (e.g. `_.x`). This will be removed during
360340 -- desugaring and expanded into a lambda that reads a property from an object.
361341 --
@@ -369,11 +349,6 @@ data Expr
369349 --
370350 | ObjectUpdate Expr [(String, Expr)]
371351 -- |
372− -- Partial record updater. This will be removed during desugaring and
373− -- expanded into a lambda that returns an object update.
374− --
375− | ObjectUpdater (Maybe Expr) [(String, Maybe Expr)]
376− -- |
377352 -- Function introduction
378353 --
379354 | Abs (Either Ident Binder) Expr
@@ -392,7 +367,7 @@ data Expr
392367 -- |
393368 -- A data constructor
394369 --
395− | Constructor (Qualified ProperName)
370+ | Constructor (Qualified (ProperName 'ConstructorName))
396371 -- |
397372 -- A case expression. During the case expansion phase of desugaring, top-level binders will get
398373 -- desugared into case expressions, hence the need for guards and multiple binders per branch here.
@@ -414,7 +389,7 @@ data Expr
414389 -- An application of a typeclass dictionary constructor. The value should be
415390 -- an ObjectLiteral.
416391 --
417− | TypeClassDictionaryConstructorApp (Qualified ProperName) Expr
392+ | TypeClassDictionaryConstructorApp (Qualified (ProperName 'ClassName)) Expr
418393 -- |
419394 -- A placeholder for a type class dictionary to be inserted later. At the end of type checking, these
420395 -- placeholders will be replaced with actual expressions representing type classes dictionaries which
@@ -422,19 +397,24 @@ data Expr
422397 -- at superclass implementations when searching for a dictionary, the type class name and
423398 -- instance type, and the type class dictionaries in scope.
424399 --
425− | TypeClassDictionary Constraint (M.Map (Maybe ModuleName) (M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope)))
400+ | TypeClassDictionary Constraint (M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope)))
426401 -- |
427402 -- A typeclass dictionary accessor, the implementation is left unspecified until CoreFn desugaring.
428403 --
429− | TypeClassDictionaryAccessor (Qualified ProperName) Ident
404+ | TypeClassDictionaryAccessor (Qualified (ProperName 'ClassName)) Ident
430405 -- |
431406 -- A placeholder for a superclass dictionary to be turned into a TypeClassDictionary during typechecking
432407 --
433− | SuperClassDictionary (Qualified ProperName) [Type]
408+ | SuperClassDictionary (Qualified (ProperName 'ClassName)) [Type]
409+ -- |
410+ -- A placeholder for an anonymous function argument
411+ --
412+ | AnonymousArgument
434413 -- |
435414 -- A value with source position information
436415 --
437− | PositionedValue SourceSpan [Comment] Expr deriving (Show, Read, D.Data, D.Typeable)
416+ | PositionedValue SourceSpan [Comment] Expr
417+ deriving (Show, Read)
438418
439419-- |
440420-- An alternative in a case statement
@@ -448,7 +428,7 @@ data CaseAlternative = CaseAlternative
448428 -- The result expression or a collect of guarded expressions
449429 --
450430 , caseAlternativeResult :: Either [(Guard, Expr)] Expr
451− } deriving (Show, Read, D.Data, D.Typeable)
431+ } deriving (Show, Read)
452432
453433-- |
454434-- A statement in a do-notation block
@@ -469,7 +449,8 @@ data DoNotationElement
469449 -- |
470450 -- A do notation element with source position information
471451 --
472− | PositionedDoNotationElement SourceSpan [Comment] DoNotationElement deriving (Show, Read, D.Data, D.Typeable)
452+ | PositionedDoNotationElement SourceSpan [Comment] DoNotationElement
453+ deriving (Show, Read)
473454
474455$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''DeclarationRef)
475456$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ImportDeclarationType)
src/Language/PureScript/AST/Exported.hs+36−21
@@ -1,8 +1,7 @@
1−
2−module Language.PureScript.AST.Exported (
3− exportedDeclarations,
4− isExported
5−) where
1+module Language.PureScript.AST.Exported
2+ ( exportedDeclarations
3+ , isExported
4+ ) where
65
76import Control.Category ((>>>))
87import Data.Maybe (mapMaybe)
@@ -23,12 +22,12 @@ import Language.PureScript.Names
2322-- instances will be incorrectly removed in some cases.
2423--
2524exportedDeclarations :: Module -> [Declaration]
26−exportedDeclarations (Module _ _ _ decls exps) = go decls
25+exportedDeclarations (Module _ _ mn decls exps) = go decls
2726 where
2827 go = flattenDecls
2928 >>> filter (isExported exps)
3029 >>> map (filterDataConstructors exps)
31− >>> filterInstances exps
30+ >>> filterInstances mn exps
3231
3332-- |
3433-- Filter out all data constructors from a declaration which are not exported.
@@ -52,10 +51,15 @@ filterDataConstructors _ other = other
5251-- produce incorrect results if this is not the case - for example, type class
5352-- instances will be incorrectly removed in some cases.
5453--
55−filterInstances :: Maybe [DeclarationRef] -> [Declaration] -> [Declaration]
56−filterInstances Nothing = id
57−filterInstances (Just exps) =
58− let refs = mapMaybe typeName exps ++ mapMaybe typeClassName exps
54+filterInstances
55+ :: ModuleName
56+ -> Maybe [DeclarationRef]
57+ -> [Declaration]
58+ -> [Declaration]
59+filterInstances _ Nothing = id
60+filterInstances mn (Just exps) =
61+ let refs = Left `map` mapMaybe typeClassName exps
62+ ++ Right `map` mapMaybe typeName exps
5963 in filter (all (visibleOutside refs) . typeInstanceConstituents)
6064 where
6165 -- Given a Qualified ProperName, and a list of all exported types and type
@@ -65,13 +69,24 @@ filterInstances (Just exps) =
6569 -- * the name is defined in the same module and is exported,
6670 -- * the name is defined in a different module (and must be exported from
6771 -- that module; the code would fail to compile otherwise).
68− visibleOutside _ (Qualified (Just _) _) = True
69− visibleOutside refs (Qualified Nothing n) = n `elem` refs
70−
72+ visibleOutside
73+ :: [Either (ProperName 'ClassName) (ProperName 'TypeName)]
74+ -> Either (Qualified (ProperName 'ClassName)) (Qualified (ProperName 'TypeName))
75+ -> Bool
76+ visibleOutside refs q
77+ | either checkQual checkQual q = True
78+ | otherwise = either (Left . disqualify) (Right . disqualify) q `elem` refs
79+
80+ -- Check that a qualified name is qualified for a different module
81+ checkQual :: Qualified a -> Bool
82+ checkQual q = isQualified q && not (isQualifiedWith mn q)
83+
84+ typeName :: DeclarationRef -> Maybe (ProperName 'TypeName)
7185 typeName (TypeRef n _) = Just n
7286 typeName (PositionedDeclarationRef _ _ r) = typeName r
7387 typeName _ = Nothing
7488
89+ typeClassName :: DeclarationRef -> Maybe (ProperName 'ClassName)
7590 typeClassName (TypeClassRef n) = Just n
7691 typeClassName (PositionedDeclarationRef _ _ r) = typeClassName r
7792 typeClassName _ = Nothing
@@ -79,17 +94,17 @@ filterInstances (Just exps) =
7994-- |
8095-- Get all type and type class names referenced by a type instance declaration.
8196--
82−typeInstanceConstituents :: Declaration -> [Qualified ProperName]
97+typeInstanceConstituents :: Declaration -> [Either (Qualified (ProperName 'ClassName)) (Qualified (ProperName 'TypeName))]
8398typeInstanceConstituents (TypeInstanceDeclaration _ constraints className tys _) =
84− className : (concatMap fromConstraint constraints ++ concatMap fromType tys)
99+ Left className : (concatMap fromConstraint constraints ++ concatMap fromType tys)
85100 where
86101
87− fromConstraint (name, tys') = name : concatMap fromType tys'
102+ fromConstraint (name, tys') = Left name : concatMap fromType tys'
88103 fromType = everythingOnTypes (++) go
89104
90105 -- Note that type synonyms are disallowed in instance declarations, so
91106 -- we don't need to handle them here.
92− go (TypeConstructor n) = [n]
107+ go (TypeConstructor n) = [Right n]
93108 go (ConstrainedType cs _) = concatMap fromConstraint cs
94109 go _ = []
95110
@@ -118,8 +133,8 @@ isExported (Just exps) decl = any (matches decl) exps
118133 matches (TypeSynonymDeclaration ident _ _) (TypeRef ident' _) = ident == ident'
119134 matches (TypeClassDeclaration ident _ _ _) (TypeClassRef ident') = ident == ident'
120135
121− matches (DataDeclaration _ ident _ _) (ProperRef ident') = ident == ident'
122− matches (TypeClassDeclaration ident _ _ _) (ProperRef ident') = ident == ident'
136+ matches (DataDeclaration _ ident _ _) (ProperRef ident') = runProperName ident == ident'
137+ matches (TypeClassDeclaration ident _ _ _) (ProperRef ident') = runProperName ident == ident'
123138
124139 matches (PositionedDeclaration _ _ d) r = d `matches` r
125140 matches d (PositionedDeclarationRef _ _ r) = d `matches` r
@@ -129,7 +144,7 @@ isExported (Just exps) decl = any (matches decl) exps
129144-- Test if a data constructor for a given type is exported, given a module's
130145-- export list. Prefer 'exportedDeclarations' to this function, where possible.
131146--
132−isDctorExported :: ProperName -> Maybe [DeclarationRef] -> ProperName -> Bool
147+isDctorExported :: ProperName 'TypeName -> Maybe [DeclarationRef] -> ProperName 'ConstructorName -> Bool
133148isDctorExported _ Nothing _ = True
134149isDctorExported ident (Just exps) ctor = test `any` exps
135150 where
src/Language/PureScript/AST/Literals.hsnew file+37
@@ -0,0 +1,37 @@
1+{-# LANGUAGE DeriveFunctor #-}
2+
3+-- |
4+-- The core functional representation for literal values.
5+--
6+module Language.PureScript.AST.Literals where
7+
8+-- |
9+-- Data type for literal values. Parameterised so it can be used for Exprs and
10+-- Binders.
11+--
12+data Literal a
13+ -- |
14+ -- A numeric literal
15+ --
16+ = NumericLiteral (Either Integer Double)
17+ -- |
18+ -- A string literal
19+ --
20+ | StringLiteral String
21+ -- |
22+ -- A character literal
23+ --
24+ | CharLiteral Char
25+ -- |
26+ -- A boolean literal
27+ --
28+ | BooleanLiteral Bool
29+ -- |
30+ -- An array literal
31+ --
32+ | ArrayLiteral [a]
33+ -- |
34+ -- An object literal
35+ --
36+ | ObjectLiteral [(String, a)]
37+ deriving (Eq, Ord, Show, Read, Functor)
src/Language/PureScript/AST/Operators.hs+7−18
@@ -1,23 +1,10 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.AST.Operators
4−-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- | Operators fixity and associativity
12−--
13−-----------------------------------------------------------------------------
14−
151{-# LANGUAGE OverloadedStrings #-}
16−{-# LANGUAGE DeriveDataTypeable #-}
172
3+-- |
4+-- Operators fixity and associativity
5+--
186module Language.PureScript.AST.Operators where
197
20−import qualified Data.Data as D
218import Data.Aeson ((.=))
229import qualified Data.Aeson as A
2310
@@ -31,7 +18,8 @@ type Precedence = Integer
3118-- |
3219-- Associativity for infix operators
3320--
34−data Associativity = Infixl | Infixr | Infix deriving (Show, Read, Eq, Ord, D.Data, D.Typeable)
21+data Associativity = Infixl | Infixr | Infix
22+ deriving (Show, Read, Eq, Ord)
3523
3624showAssoc :: Associativity -> String
3725showAssoc Infixl = "infixl"
@@ -53,7 +41,8 @@ instance A.FromJSON Associativity where
5341-- |
5442-- Fixity data for infix operators
5543--
56−data Fixity = Fixity Associativity Precedence deriving (Show, Read, Eq, Ord, D.Data, D.Typeable)
44+data Fixity = Fixity Associativity Precedence
45+ deriving (Show, Read, Eq, Ord)
5746
5847instance A.ToJSON Fixity where
5948 toJSON (Fixity associativity precedence) =
src/Language/PureScript/AST/SourcePos.hs+5−18
@@ -1,28 +1,15 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.AST.SourcePos
4−-- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
5−-- License : MIT (http://opensource.org/licenses/MIT)
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- | Source position information
12−--
13−-----------------------------------------------------------------------------
14−
15−{-# LANGUAGE DeriveDataTypeable #-}
161{-# LANGUAGE ScopedTypeVariables #-}
172{-# LANGUAGE RecordWildCards #-}
183{-# LANGUAGE OverloadedStrings #-}
194
5+-- |
6+-- Source position information
7+--
208module Language.PureScript.AST.SourcePos where
219
2210import Prelude ()
2311import Prelude.Compat
2412
25−import qualified Data.Data as D
2613import Data.Aeson ((.=), (.:))
2714import qualified Data.Aeson as A
2815
@@ -38,7 +25,7 @@ data SourcePos = SourcePos
3825 -- Column number
3926 --
4027 , sourcePosColumn :: Int
41− } deriving (Show, Read, Eq, Ord, D.Data, D.Typeable)
28+ } deriving (Show, Read, Eq, Ord)
4229
4330displaySourcePos :: SourcePos -> String
4431displaySourcePos sp =
@@ -66,7 +53,7 @@ data SourceSpan = SourceSpan
6653 -- End of the span
6754 --
6855 , spanEnd :: SourcePos
69− } deriving (Show, Read, Eq, Ord, D.Data, D.Typeable)
56+ } deriving (Show, Read, Eq, Ord)
7057
7158displayStartEndPos :: SourceSpan -> String
7259displayStartEndPos sp =
src/Language/PureScript/AST/Traversals.hs+211−123
@@ -1,17 +1,8 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.AST.Traversals
4−-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- | AST traversal helpers
12−--
13−-----------------------------------------------------------------------------
1+{-# LANGUAGE ScopedTypeVariables #-}
142
3+-- |
4+-- AST traversal helpers
5+--
156module Language.PureScript.AST.Traversals where
167
178import Prelude ()
@@ -23,18 +14,23 @@ import Data.Foldable (fold)
2314import qualified Data.Set as S
2415
2516import Control.Monad
26−import Control.Arrow ((***), (+++), second)
17+import Control.Arrow ((***), (+++))
2718
2819import Language.PureScript.AST.Binders
20+import Language.PureScript.AST.Literals
2921import Language.PureScript.AST.Declarations
3022import Language.PureScript.Types
3123import Language.PureScript.Traversals
3224import Language.PureScript.Names
3325
34−everywhereOnValues :: (Declaration -> Declaration) ->
35− (Expr -> Expr) ->
36− (Binder -> Binder) ->
37− (Declaration -> Declaration, Expr -> Expr, Binder -> Binder)
26+everywhereOnValues
27+ :: (Declaration -> Declaration)
28+ -> (Expr -> Expr)
29+ -> (Binder -> Binder)
30+ -> ( Declaration -> Declaration
31+ , Expr -> Expr
32+ , Binder -> Binder
33+ )
3834everywhereOnValues f g h = (f', g', h')
3935 where
4036 f' :: Declaration -> Declaration
@@ -47,18 +43,15 @@ everywhereOnValues f g h = (f', g', h')
4743 f' other = f other
4844
4945 g' :: Expr -> Expr
46+ g' (Literal l) = g (Literal (lit g' l))
5047 g' (UnaryMinus v) = g (UnaryMinus (g' v))
5148 g' (BinaryNoParens op v1 v2) = g (BinaryNoParens (g' op) (g' v1) (g' v2))
5249 g' (Parens v) = g (Parens (g' v))
5350 g' (OperatorSection op (Left v)) = g (OperatorSection (g' op) (Left $ g' v))
5451 g' (OperatorSection op (Right v)) = g (OperatorSection (g' op) (Right $ g' v))
55− g' (ArrayLiteral vs) = g (ArrayLiteral (map g' vs))
56− g' (ObjectLiteral vs) = g (ObjectLiteral (map (fmap g') vs))
57− g' (ObjectConstructor vs) = g (ObjectConstructor (map (second (fmap g')) vs))
5852 g' (TypeClassDictionaryConstructorApp name v) = g (TypeClassDictionaryConstructorApp name (g' v))
5953 g' (Accessor prop v) = g (Accessor prop (g' v))
6054 g' (ObjectUpdate obj vs) = g (ObjectUpdate (g' obj) (map (fmap g') vs))
61− g' (ObjectUpdater obj vs) = g (ObjectUpdater (fmap g' obj) (map (second (fmap g')) vs))
6255 g' (Abs name v) = g (Abs name (g' v))
6356 g' (App v1 v2) = g (App (g' v1) (g' v2))
6457 g' (IfThenElse v1 v2 v3) = g (IfThenElse (g' v1) (g' v2) (g' v3))
@@ -71,13 +64,19 @@ everywhereOnValues f g h = (f', g', h')
7164
7265 h' :: Binder -> Binder
7366 h' (ConstructorBinder ctor bs) = h (ConstructorBinder ctor (map h' bs))
74− h' (ObjectBinder bs) = h (ObjectBinder (map (fmap h') bs))
75− h' (ArrayBinder bs) = h (ArrayBinder (map h' bs))
67+ h' (BinaryNoParensBinder b1 b2 b3) = h (BinaryNoParensBinder (h' b1) (h' b2) (h' b3))
68+ h' (ParensInBinder b) = h (ParensInBinder (h' b))
69+ h' (LiteralBinder l) = h (LiteralBinder (lit h' l))
7670 h' (NamedBinder name b) = h (NamedBinder name (h' b))
7771 h' (PositionedBinder pos com b) = h (PositionedBinder pos com (h' b))
7872 h' (TypedBinder t b) = h (TypedBinder t (h' b))
7973 h' other = h other
8074
75+ lit :: (a -> a) -> Literal a -> Literal a
76+ lit go (ArrayLiteral as) = ArrayLiteral (map go as)
77+ lit go (ObjectLiteral as) = ObjectLiteral (map (fmap go) as)
78+ lit _ other = other
79+
8180 handleCaseAlternative :: CaseAlternative -> CaseAlternative
8281 handleCaseAlternative ca =
8382 ca { caseAlternativeBinders = map h' (caseAlternativeBinders ca)
@@ -90,13 +89,20 @@ everywhereOnValues f g h = (f', g', h')
9089 handleDoNotationElement (DoNotationLet ds) = DoNotationLet (map f' ds)
9190 handleDoNotationElement (PositionedDoNotationElement pos com e) = PositionedDoNotationElement pos com (handleDoNotationElement e)
9291
93−everywhereOnValuesTopDownM :: (Functor m, Applicative m, Monad m) =>
94− (Declaration -> m Declaration) ->
95− (Expr -> m Expr) ->
96− (Binder -> m Binder) ->
97− (Declaration -> m Declaration, Expr -> m Expr, Binder -> m Binder)
92+everywhereOnValuesTopDownM
93+ :: forall m
94+ . (Monad m)
95+ => (Declaration -> m Declaration)
96+ -> (Expr -> m Expr)
97+ -> (Binder -> m Binder)
98+ -> ( Declaration -> m Declaration
99+ , Expr -> m Expr
100+ , Binder -> m Binder
101+ )
98102everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)
99103 where
104+
105+ f' :: Declaration -> m Declaration
100106 f' (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> traverse (f' <=< f) ds
101107 f' (ValueDeclaration name nameKind bs val) = ValueDeclaration name nameKind <$> traverse (h' <=< h) bs <*> eitherM (traverse (pairM (g' <=< g) (g' <=< g))) (g' <=< g) val
102108 f' (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> traverse (\(name, nameKind, val) -> (,,) name nameKind <$> (g val >>= g')) ds
@@ -105,18 +111,16 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)
105111 f' (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> (f d >>= f')
106112 f' other = f other
107113
114+ g' :: Expr -> m Expr
115+ g' (Literal l) = Literal <$> lit (g >=> g') l
108116 g' (UnaryMinus v) = UnaryMinus <$> (g v >>= g')
109117 g' (BinaryNoParens op v1 v2) = BinaryNoParens <$> (g op >>= g') <*> (g v1 >>= g') <*> (g v2 >>= g')
110118 g' (Parens v) = Parens <$> (g v >>= g')
111119 g' (OperatorSection op (Left v)) = OperatorSection <$> (g op >>= g') <*> (Left <$> (g v >>= g'))
112120 g' (OperatorSection op (Right v)) = OperatorSection <$> (g op >>= g') <*> (Right <$> (g v >>= g'))
113− g' (ArrayLiteral vs) = ArrayLiteral <$> traverse (g' <=< g) vs
114− g' (ObjectLiteral vs) = ObjectLiteral <$> traverse (sndM (g' <=< g)) vs
115− g' (ObjectConstructor vs) = ObjectConstructor <$> traverse (sndM $ maybeM (g' <=< g)) vs
116121 g' (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> (g v >>= g')
117122 g' (Accessor prop v) = Accessor prop <$> (g v >>= g')
118123 g' (ObjectUpdate obj vs) = ObjectUpdate <$> (g obj >>= g') <*> traverse (sndM (g' <=< g)) vs
119− g' (ObjectUpdater obj vs) = ObjectUpdater <$> (maybeM g obj >>= maybeM g') <*> traverse (sndM $ maybeM (g' <=< g)) vs
120124 g' (Abs name v) = Abs name <$> (g v >>= g')
121125 g' (App v1 v2) = App <$> (g v1 >>= g') <*> (g v2 >>= g')
122126 g' (IfThenElse v1 v2 v3) = IfThenElse <$> (g v1 >>= g') <*> (g v2 >>= g') <*> (g v3 >>= g')
@@ -127,29 +131,47 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)
127131 g' (PositionedValue pos com v) = PositionedValue pos com <$> (g v >>= g')
128132 g' other = g other
129133
134+ h' :: Binder -> m Binder
135+ h' (LiteralBinder l) = LiteralBinder <$> lit (h >=> h') l
130136 h' (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> traverse (h' <=< h) bs
131− h' (ObjectBinder bs) = ObjectBinder <$> traverse (sndM (h' <=< h)) bs
132− h' (ArrayBinder bs) = ArrayBinder <$> traverse (h' <=< h) bs
137+ h' (BinaryNoParensBinder b1 b2 b3) = BinaryNoParensBinder <$> (h b1 >>= h') <*> (h b2 >>= h') <*> (h b3 >>= h')
138+ h' (ParensInBinder b) = ParensInBinder <$> (h b >>= h')
133139 h' (NamedBinder name b) = NamedBinder name <$> (h b >>= h')
134140 h' (PositionedBinder pos com b) = PositionedBinder pos com <$> (h b >>= h')
135141 h' (TypedBinder t b) = TypedBinder t <$> (h b >>= h')
136142 h' other = h other
137143
138− handleCaseAlternative (CaseAlternative bs val) = CaseAlternative <$> traverse (h' <=< h) bs
139− <*> eitherM (traverse (pairM (g' <=< g) (g' <=< g))) (g' <=< g) val
144+ lit :: (a -> m a) -> Literal a -> m (Literal a)
145+ lit go (ObjectLiteral as) = ObjectLiteral <$> traverse (sndM go) as
146+ lit go (ArrayLiteral as) = ArrayLiteral <$> traverse go as
147+ lit _ other = pure other
140148
149+ handleCaseAlternative :: CaseAlternative -> m CaseAlternative
150+ handleCaseAlternative (CaseAlternative bs val) =
151+ CaseAlternative
152+ <$> traverse (h' <=< h) bs
153+ <*> eitherM (traverse (pairM (g' <=< g) (g' <=< g))) (g' <=< g) val
154+
155+ handleDoNotationElement :: DoNotationElement -> m DoNotationElement
141156 handleDoNotationElement (DoNotationValue v) = DoNotationValue <$> (g' <=< g) v
142157 handleDoNotationElement (DoNotationBind b v) = DoNotationBind <$> (h' <=< h) b <*> (g' <=< g) v
143158 handleDoNotationElement (DoNotationLet ds) = DoNotationLet <$> traverse (f' <=< f) ds
144159 handleDoNotationElement (PositionedDoNotationElement pos com e) = PositionedDoNotationElement pos com <$> handleDoNotationElement e
145160
146−everywhereOnValuesM :: (Functor m, Applicative m, Monad m) =>
147− (Declaration -> m Declaration) ->
148− (Expr -> m Expr) ->
149− (Binder -> m Binder) ->
150− (Declaration -> m Declaration, Expr -> m Expr, Binder -> m Binder)
161+everywhereOnValuesM
162+ :: forall m
163+ . (Monad m)
164+ => (Declaration -> m Declaration)
165+ -> (Expr -> m Expr)
166+ -> (Binder -> m Binder)
167+ -> ( Declaration -> m Declaration
168+ , Expr -> m Expr
169+ , Binder -> m Binder
170+ )
151171everywhereOnValuesM f g h = (f', g', h')
152172 where
173+
174+ f' :: Declaration -> m Declaration
153175 f' (DataBindingGroupDeclaration ds) = (DataBindingGroupDeclaration <$> traverse f' ds) >>= f
154176 f' (ValueDeclaration name nameKind bs val) = (ValueDeclaration name nameKind <$> traverse h' bs <*> eitherM (traverse (pairM g' g')) g' val) >>= f
155177 f' (BindingGroupDeclaration ds) = (BindingGroupDeclaration <$> traverse (\(name, nameKind, val) -> (,,) name nameKind <$> g' val) ds) >>= f
@@ -158,18 +180,16 @@ everywhereOnValuesM f g h = (f', g', h')
158180 f' (PositionedDeclaration pos com d) = (PositionedDeclaration pos com <$> f' d) >>= f
159181 f' other = f other
160182
183+ g' :: Expr -> m Expr
184+ g' (Literal l) = (Literal <$> lit g' l) >>= g
161185 g' (UnaryMinus v) = (UnaryMinus <$> g' v) >>= g
162186 g' (BinaryNoParens op v1 v2) = (BinaryNoParens <$> g' op <*> g' v1 <*> g' v2) >>= g
163187 g' (Parens v) = (Parens <$> g' v) >>= g
164188 g' (OperatorSection op (Left v)) = (OperatorSection <$> g' op <*> (Left <$> g' v)) >>= g
165189 g' (OperatorSection op (Right v)) = (OperatorSection <$> g' op <*> (Right <$> g' v)) >>= g
166− g' (ArrayLiteral vs) = (ArrayLiteral <$> traverse g' vs) >>= g
167− g' (ObjectLiteral vs) = (ObjectLiteral <$> traverse (sndM g') vs) >>= g
168− g' (ObjectConstructor vs) = (ObjectConstructor <$> traverse (sndM $ maybeM g') vs) >>= g
169190 g' (TypeClassDictionaryConstructorApp name v) = (TypeClassDictionaryConstructorApp name <$> g' v) >>= g
170191 g' (Accessor prop v) = (Accessor prop <$> g' v) >>= g
171192 g' (ObjectUpdate obj vs) = (ObjectUpdate <$> g' obj <*> traverse (sndM g') vs) >>= g
172− g' (ObjectUpdater obj vs) = (ObjectUpdater <$> maybeM g' obj <*> traverse (sndM $ maybeM g') vs) >>= g
173193 g' (Abs name v) = (Abs name <$> g' v) >>= g
174194 g' (App v1 v2) = (App <$> g' v1 <*> g' v2) >>= g
175195 g' (IfThenElse v1 v2 v3) = (IfThenElse <$> g' v1 <*> g' v2 <*> g' v3) >>= g
@@ -180,31 +200,51 @@ everywhereOnValuesM f g h = (f', g', h')
180200 g' (PositionedValue pos com v) = (PositionedValue pos com <$> g' v) >>= g
181201 g' other = g other
182202
203+ h' :: Binder -> m Binder
204+ h' (LiteralBinder l) = (LiteralBinder <$> lit h' l) >>= h
183205 h' (ConstructorBinder ctor bs) = (ConstructorBinder ctor <$> traverse h' bs) >>= h
184− h' (ObjectBinder bs) = (ObjectBinder <$> traverse (sndM h') bs) >>= h
185− h' (ArrayBinder bs) = (ArrayBinder <$> traverse h' bs) >>= h
206+ h' (BinaryNoParensBinder b1 b2 b3) = (BinaryNoParensBinder <$> h' b1 <*> h' b2 <*> h' b3) >>= h
207+ h' (ParensInBinder b) = (ParensInBinder <$> h' b) >>= h
186208 h' (NamedBinder name b) = (NamedBinder name <$> h' b) >>= h
187209 h' (PositionedBinder pos com b) = (PositionedBinder pos com <$> h' b) >>= h
188210 h' (TypedBinder t b) = (TypedBinder t <$> h' b) >>= h
189211 h' other = h other
190212
191− handleCaseAlternative (CaseAlternative bs val) = CaseAlternative <$> traverse h' bs
192− <*> eitherM (traverse (pairM g' g')) g' val
213+ lit :: (a -> m a) -> Literal a -> m (Literal a)
214+ lit go (ObjectLiteral as) = ObjectLiteral <$> traverse (sndM go) as
215+ lit go (ArrayLiteral as) = ArrayLiteral <$> traverse go as
216+ lit _ other = pure other
193217
218+ handleCaseAlternative :: CaseAlternative -> m CaseAlternative
219+ handleCaseAlternative (CaseAlternative bs val) =
220+ CaseAlternative
221+ <$> traverse h' bs
222+ <*> eitherM (traverse (pairM g' g')) g' val
223+
224+ handleDoNotationElement :: DoNotationElement -> m DoNotationElement
194225 handleDoNotationElement (DoNotationValue v) = DoNotationValue <$> g' v
195226 handleDoNotationElement (DoNotationBind b v) = DoNotationBind <$> h' b <*> g' v
196227 handleDoNotationElement (DoNotationLet ds) = DoNotationLet <$> traverse f' ds
197228 handleDoNotationElement (PositionedDoNotationElement pos com e) = PositionedDoNotationElement pos com <$> handleDoNotationElement e
198229
199−everythingOnValues :: (r -> r -> r) ->
200− (Declaration -> r) ->
201− (Expr -> r) ->
202− (Binder -> r) ->
203− (CaseAlternative -> r) ->
204− (DoNotationElement -> r) ->
205− (Declaration -> r, Expr -> r, Binder -> r, CaseAlternative -> r, DoNotationElement -> r)
230+everythingOnValues
231+ :: forall r
232+ . (r -> r -> r)
233+ -> (Declaration -> r)
234+ -> (Expr -> r)
235+ -> (Binder -> r)
236+ -> (CaseAlternative -> r)
237+ -> (DoNotationElement -> r)
238+ -> ( Declaration -> r
239+ , Expr -> r
240+ , Binder -> r
241+ , CaseAlternative -> r
242+ , DoNotationElement -> r
243+ )
206244everythingOnValues (<>) f g h i j = (f', g', h', i', j')
207245 where
246+
247+ f' :: Declaration -> r
208248 f' d@(DataBindingGroupDeclaration ds) = foldl (<>) (f d) (map f' ds)
209249 f' d@(ValueDeclaration _ _ bs (Right val)) = foldl (<>) (f d) (map h' bs) <> g' val
210250 f' d@(ValueDeclaration _ _ bs (Left gs)) = foldl (<>) (f d) (map h' bs ++ concatMap (\(grd, val) -> [g' grd, g' val]) gs)
@@ -214,18 +254,16 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j')
214254 f' d@(PositionedDeclaration _ _ d1) = f d <> f' d1
215255 f' d = f d
216256
257+ g' :: Expr -> r
258+ g' v@(Literal l) = lit (g v) g' l
217259 g' v@(UnaryMinus v1) = g v <> g' v1
218260 g' v@(BinaryNoParens op v1 v2) = g v <> g' op <> g' v1 <> g' v2
219261 g' v@(Parens v1) = g v <> g' v1
220262 g' v@(OperatorSection op (Left v1)) = g v <> g' op <> g' v1
221263 g' v@(OperatorSection op (Right v1)) = g v <> g' op <> g' v1
222− g' v@(ArrayLiteral vs) = foldl (<>) (g v) (map g' vs)
223− g' v@(ObjectLiteral vs) = foldl (<>) (g v) (map (g' . snd) vs)
224− g' v@(ObjectConstructor vs) = foldl (<>) (g v) (map g' (mapMaybe snd vs))
225264 g' v@(TypeClassDictionaryConstructorApp _ v1) = g v <> g' v1
226265 g' v@(Accessor _ v1) = g v <> g' v1
227266 g' v@(ObjectUpdate obj vs) = foldl (<>) (g v <> g' obj) (map (g' . snd) vs)
228− g' v@(ObjectUpdater obj vs) = foldl (<>) (maybe (g v) (\x -> g v <> g' x) obj) (map g' (mapMaybe snd vs))
229267 g' v@(Abs _ v1) = g v <> g' v1
230268 g' v@(App v1 v2) = g v <> g' v1 <> g' v2
231269 g' v@(IfThenElse v1 v2 v3) = g v <> g' v1 <> g' v2 <> g' v3
@@ -236,40 +274,53 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j')
236274 g' v@(PositionedValue _ _ v1) = g v <> g' v1
237275 g' v = g v
238276
277+ h' :: Binder -> r
278+ h' b@(LiteralBinder l) = lit (h b) h' l
239279 h' b@(ConstructorBinder _ bs) = foldl (<>) (h b) (map h' bs)
240− h' b@(ObjectBinder bs) = foldl (<>) (h b) (map (h' . snd) bs)
241− h' b@(ArrayBinder bs) = foldl (<>) (h b) (map h' bs)
280+ h' b@(BinaryNoParensBinder b1 b2 b3) = h b <> h' b1 <> h' b2 <> h' b3
281+ h' b@(ParensInBinder b1) = h b <> h' b1
242282 h' b@(NamedBinder _ b1) = h b <> h' b1
243283 h' b@(PositionedBinder _ _ b1) = h b <> h' b1
244284 h' b@(TypedBinder _ b1) = h b <> h' b1
245285 h' b = h b
246286
287+ lit :: r -> (a -> r) -> Literal a -> r
288+ lit r go (ArrayLiteral as) = foldl (<>) r (map go as)
289+ lit r go (ObjectLiteral as) = foldl (<>) r (map (go . snd) as)
290+ lit r _ _ = r
291+
292+ i' :: CaseAlternative -> r
247293 i' ca@(CaseAlternative bs (Right val)) = foldl (<>) (i ca) (map h' bs) <> g' val
248294 i' ca@(CaseAlternative bs (Left gs)) = foldl (<>) (i ca) (map h' bs ++ concatMap (\(grd, val) -> [g' grd, g' val]) gs)
249295
296+ j' :: DoNotationElement -> r
250297 j' e@(DoNotationValue v) = j e <> g' v
251298 j' e@(DoNotationBind b v) = j e <> h' b <> g' v
252299 j' e@(DoNotationLet ds) = foldl (<>) (j e) (map f' ds)
253300 j' e@(PositionedDoNotationElement _ _ e1) = j e <> j' e1
254301
255−everythingWithContextOnValues ::
256− s ->
257− r ->
258− (r -> r -> r) ->
259− (s -> Declaration -> (s, r)) ->
260− (s -> Expr -> (s, r)) ->
261− (s -> Binder -> (s, r)) ->
262− (s -> CaseAlternative -> (s, r)) ->
263− (s -> DoNotationElement -> (s, r)) ->
264− ( Declaration -> r
265− , Expr -> r
266− , Binder -> r
267− , CaseAlternative -> r
268− , DoNotationElement -> r)
302+everythingWithContextOnValues
303+ :: forall s r
304+ . s
305+ -> r
306+ -> (r -> r -> r)
307+ -> (s -> Declaration -> (s, r))
308+ -> (s -> Expr -> (s, r))
309+ -> (s -> Binder -> (s, r))
310+ -> (s -> CaseAlternative -> (s, r))
311+ -> (s -> DoNotationElement -> (s, r))
312+ -> ( Declaration -> r
313+ , Expr -> r
314+ , Binder -> r
315+ , CaseAlternative -> r
316+ , DoNotationElement -> r)
269317everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j'' s0)
270318 where
319+
320+ f'' :: s -> Declaration -> r
271321 f'' s d = let (s', r) = f s d in r <> f' s' d
272322
323+ f' :: s -> Declaration -> r
273324 f' s (DataBindingGroupDeclaration ds) = foldl (<>) r0 (map (f'' s) ds)
274325 f' s (ValueDeclaration _ _ bs (Right val)) = foldl (<>) r0 (map (h'' s) bs) <> g'' s val
275326 f' s (ValueDeclaration _ _ bs (Left gs)) = foldl (<>) r0 (map (h'' s) bs ++ concatMap (\(grd, val) -> [g'' s grd, g'' s val]) gs)
@@ -279,20 +330,19 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'
279330 f' s (PositionedDeclaration _ _ d1) = f'' s d1
280331 f' _ _ = r0
281332
333+ g'' :: s -> Expr -> r
282334 g'' s v = let (s', r) = g s v in r <> g' s' v
283335
336+ g' :: s -> Expr -> r
337+ g' s (Literal l) = lit g'' s l
284338 g' s (UnaryMinus v1) = g'' s v1
285339 g' s (BinaryNoParens op v1 v2) = g'' s op <> g'' s v1 <> g'' s v2
286340 g' s (Parens v1) = g'' s v1
287341 g' s (OperatorSection op (Left v)) = g'' s op <> g'' s v
288342 g' s (OperatorSection op (Right v)) = g'' s op <> g'' s v
289− g' s (ArrayLiteral vs) = foldl (<>) r0 (map (g'' s) vs)
290− g' s (ObjectLiteral vs) = foldl (<>) r0 (map (g'' s . snd) vs)
291− g' s (ObjectConstructor vs) = foldl (<>) r0 (map (g'' s) (mapMaybe snd vs))
292343 g' s (TypeClassDictionaryConstructorApp _ v1) = g'' s v1
293344 g' s (Accessor _ v1) = g'' s v1
294345 g' s (ObjectUpdate obj vs) = foldl (<>) (g'' s obj) (map (g'' s . snd) vs)
295− g' s (ObjectUpdater obj vs) = foldl (<>) (maybe r0 (g'' s) obj) (map (g'' s) (mapMaybe snd vs))
296346 g' s (Abs _ v1) = g'' s v1
297347 g' s (App v1 v2) = g'' s v1 <> g'' s v2
298348 g' s (IfThenElse v1 v2 v3) = g'' s v1 <> g'' s v2 <> g'' s v3
@@ -303,40 +353,54 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'
303353 g' s (PositionedValue _ _ v1) = g'' s v1
304354 g' _ _ = r0
305355
356+ h'' :: s -> Binder -> r
306357 h'' s b = let (s', r) = h s b in r <> h' s' b
307358
359+ h' :: s -> Binder -> r
360+ h' s (LiteralBinder l) = lit h'' s l
308361 h' s (ConstructorBinder _ bs) = foldl (<>) r0 (map (h'' s) bs)
309− h' s (ObjectBinder bs) = foldl (<>) r0 (map (h'' s . snd) bs)
310− h' s (ArrayBinder bs) = foldl (<>) r0 (map (h'' s) bs)
362+ h' s (BinaryNoParensBinder b1 b2 b3) = h'' s b1 <> h'' s b2 <> h'' s b3
363+ h' s (ParensInBinder b) = h'' s b
311364 h' s (NamedBinder _ b1) = h'' s b1
312365 h' s (PositionedBinder _ _ b1) = h'' s b1
313366 h' s (TypedBinder _ b1) = h'' s b1
314367 h' _ _ = r0
315368
369+ lit :: (s -> a -> r) -> s -> Literal a -> r
370+ lit go s (ArrayLiteral as) = foldl (<>) r0 (map (go s) as)
371+ lit go s (ObjectLiteral as) = foldl (<>) r0 (map (go s . snd) as)
372+ lit _ _ _ = r0
373+
374+ i'' :: s -> CaseAlternative -> r
316375 i'' s ca = let (s', r) = i s ca in r <> i' s' ca
317376
377+ i' :: s -> CaseAlternative -> r
318378 i' s (CaseAlternative bs (Right val)) = foldl (<>) r0 (map (h'' s) bs) <> g'' s val
319379 i' s (CaseAlternative bs (Left gs)) = foldl (<>) r0 (map (h'' s) bs ++ concatMap (\(grd, val) -> [g'' s grd, g'' s val]) gs)
320380
381+ j'' :: s -> DoNotationElement -> r
321382 j'' s e = let (s', r) = j s e in r <> j' s' e
322383
384+ j' :: s -> DoNotationElement -> r
323385 j' s (DoNotationValue v) = g'' s v
324386 j' s (DoNotationBind b v) = h'' s b <> g'' s v
325387 j' s (DoNotationLet ds) = foldl (<>) r0 (map (f'' s) ds)
326388 j' s (PositionedDoNotationElement _ _ e1) = j'' s e1
327389
328−everywhereWithContextOnValuesM :: (Functor m, Applicative m, Monad m) =>
329− s ->
330− (s -> Declaration -> m (s, Declaration)) ->
331− (s -> Expr -> m (s, Expr)) ->
332− (s -> Binder -> m (s, Binder)) ->
333− (s -> CaseAlternative -> m (s, CaseAlternative)) ->
334− (s -> DoNotationElement -> m (s, DoNotationElement)) ->
335− ( Declaration -> m Declaration
336− , Expr -> m Expr
337− , Binder -> m Binder
338− , CaseAlternative -> m CaseAlternative
339− , DoNotationElement -> m DoNotationElement)
390+everywhereWithContextOnValuesM
391+ :: forall m s
392+ . (Monad m)
393+ => s
394+ -> (s -> Declaration -> m (s, Declaration))
395+ -> (s -> Expr -> m (s, Expr))
396+ -> (s -> Binder -> m (s, Binder))
397+ -> (s -> CaseAlternative -> m (s, CaseAlternative))
398+ -> (s -> DoNotationElement -> m (s, DoNotationElement))
399+ -> ( Declaration -> m Declaration
400+ , Expr -> m Expr
401+ , Binder -> m Binder
402+ , CaseAlternative -> m CaseAlternative
403+ , DoNotationElement -> m DoNotationElement)
340404everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j'' s0)
341405 where
342406 f'' s = uncurry f' <=< f s
@@ -351,18 +415,15 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j
351415
352416 g'' s = uncurry g' <=< g s
353417
418+ g' s (Literal l) = Literal <$> lit g'' s l
354419 g' s (UnaryMinus v) = UnaryMinus <$> g'' s v
355420 g' s (BinaryNoParens op v1 v2) = BinaryNoParens <$> g'' s op <*> g'' s v1 <*> g'' s v2
356421 g' s (Parens v) = Parens <$> g'' s v
357422 g' s (OperatorSection op (Left v)) = OperatorSection <$> g'' s op <*> (Left <$> g'' s v)
358423 g' s (OperatorSection op (Right v)) = OperatorSection <$> g'' s op <*> (Right <$> g'' s v)
359− g' s (ArrayLiteral vs) = ArrayLiteral <$> traverse (g'' s) vs
360− g' s (ObjectLiteral vs) = ObjectLiteral <$> traverse (sndM (g'' s)) vs
361− g' s (ObjectConstructor vs) = ObjectConstructor <$> traverse (sndM $ maybeM (g'' s)) vs
362424 g' s (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> g'' s v
363425 g' s (Accessor prop v) = Accessor prop <$> g'' s v
364426 g' s (ObjectUpdate obj vs) = ObjectUpdate <$> g'' s obj <*> traverse (sndM (g'' s)) vs
365− g' s (ObjectUpdater obj vs) = ObjectUpdater <$> maybeM (g'' s) obj <*> traverse (sndM $ maybeM (g'' s)) vs
366427 g' s (Abs name v) = Abs name <$> g'' s v
367428 g' s (App v1 v2) = App <$> g'' s v1 <*> g'' s v2
368429 g' s (IfThenElse v1 v2 v3) = IfThenElse <$> g'' s v1 <*> g'' s v2 <*> g'' s v3
@@ -375,14 +436,20 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j
375436
376437 h'' s = uncurry h' <=< h s
377438
439+ h' s (LiteralBinder l) = LiteralBinder <$> lit h'' s l
378440 h' s (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> traverse (h'' s) bs
379− h' s (ObjectBinder bs) = ObjectBinder <$> traverse (sndM (h'' s)) bs
380− h' s (ArrayBinder bs) = ArrayBinder <$> traverse (h'' s) bs
441+ h' s (BinaryNoParensBinder b1 b2 b3) = BinaryNoParensBinder <$> h'' s b1 <*> h'' s b2 <*> h'' s b3
442+ h' s (ParensInBinder b) = ParensInBinder <$> h'' s b
381443 h' s (NamedBinder name b) = NamedBinder name <$> h'' s b
382444 h' s (PositionedBinder pos com b) = PositionedBinder pos com <$> h'' s b
383445 h' s (TypedBinder t b) = TypedBinder t <$> h'' s b
384446 h' _ other = return other
385447
448+ lit :: (s -> a -> m a) -> s -> Literal a -> m (Literal a)
449+ lit go s (ArrayLiteral as) = ArrayLiteral <$> traverse (go s) as
450+ lit go s (ObjectLiteral as) = ObjectLiteral <$> traverse (sndM (go s)) as
451+ lit _ _ other = return other
452+
386453 i'' s = uncurry i' <=< i s
387454
388455 i' s (CaseAlternative bs val) = CaseAlternative <$> traverse (h'' s) bs <*> eitherM (traverse (pairM (g'' s) (g'' s))) (g'' s) val
@@ -394,25 +461,29 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j
394461 j' s (DoNotationLet ds) = DoNotationLet <$> traverse (f'' s) ds
395462 j' s (PositionedDoNotationElement pos com e1) = PositionedDoNotationElement pos com <$> j'' s e1
396463
397−everythingWithScope ::
398− (Monoid r) =>
399− (S.Set Ident -> Declaration -> r) ->
400− (S.Set Ident -> Expr -> r) ->
401− (S.Set Ident -> Binder -> r) ->
402− (S.Set Ident -> CaseAlternative -> r) ->
403− (S.Set Ident -> DoNotationElement -> r) ->
404− ( S.Set Ident -> Declaration -> r
405− , S.Set Ident -> Expr -> r
406− , S.Set Ident -> Binder -> r
407− , S.Set Ident -> CaseAlternative -> r
408− , S.Set Ident -> DoNotationElement -> r)
464+everythingWithScope
465+ :: forall r
466+ . (Monoid r)
467+ => (S.Set Ident -> Declaration -> r)
468+ -> (S.Set Ident -> Expr -> r)
469+ -> (S.Set Ident -> Binder -> r)
470+ -> (S.Set Ident -> CaseAlternative -> r)
471+ -> (S.Set Ident -> DoNotationElement -> r)
472+ -> ( S.Set Ident -> Declaration -> r
473+ , S.Set Ident -> Expr -> r
474+ , S.Set Ident -> Binder -> r
475+ , S.Set Ident -> CaseAlternative -> r
476+ , S.Set Ident -> DoNotationElement -> r
477+ )
409478everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)
410479 where
411480 -- Avoid importing Data.Monoid and getting shadowed names above
412481 (<>) = mappend
413482
483+ f'' :: S.Set Ident -> Declaration -> r
414484 f'' s a = f s a <> f' s a
415485
486+ f' :: S.Set Ident -> Declaration -> r
416487 f' s (DataBindingGroupDeclaration ds) =
417488 let s' = S.union s (S.fromList (mapMaybe getDeclIdent ds))
418489 in foldMap (f'' s') ds
@@ -431,20 +502,19 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)
431502 f' s (PositionedDeclaration _ _ d) = f'' s d
432503 f' _ _ = mempty
433504
505+ g'' :: S.Set Ident -> Expr -> r
434506 g'' s a = g s a <> g' s a
435507
508+ g' :: S.Set Ident -> Expr -> r
509+ g' s (Literal l) = lit g'' s l
436510 g' s (UnaryMinus v1) = g'' s v1
437511 g' s (BinaryNoParens op v1 v2) = g' s op <> g' s v1 <> g' s v2
438512 g' s (Parens v1) = g'' s v1
439513 g' s (OperatorSection op (Left v)) = g'' s op <> g'' s v
440514 g' s (OperatorSection op (Right v)) = g'' s op <> g'' s v
441− g' s (ArrayLiteral vs) = foldMap (g'' s) vs
442− g' s (ObjectLiteral vs) = foldMap (g'' s . snd) vs
443− g' s (ObjectConstructor vs) = foldMap (g'' s) (mapMaybe snd vs)
444515 g' s (TypeClassDictionaryConstructorApp _ v1) = g'' s v1
445516 g' s (Accessor _ v1) = g'' s v1
446517 g' s (ObjectUpdate obj vs) = g'' s obj <> foldMap (g'' s . snd) vs
447− g' s (ObjectUpdater obj vs) = foldMap (g'' s) obj <> foldMap (g'' s) (mapMaybe snd vs)
448518 g' s (Abs (Left name) v1) =
449519 let s' = S.insert name s
450520 in g'' s' v1
@@ -462,20 +532,28 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)
462532 g' s (PositionedValue _ _ v1) = g'' s v1
463533 g' _ _ = mempty
464534
535+ h'' :: S.Set Ident -> Binder -> r
465536 h'' s a = h s a <> h' s a
466537
538+ h' :: S.Set Ident -> Binder -> r
539+ h' s (LiteralBinder l) = lit h'' s l
467540 h' s (ConstructorBinder _ bs) = foldMap (h'' s) bs
468− h' s (ObjectBinder bs) = foldMap (h'' s . snd) bs
469− h' s (ArrayBinder bs) = foldMap (h'' s) bs
470− h' s (NamedBinder name b1) =
471− let s' = S.insert name s
472− in h'' s' b1
541+ h' s (BinaryNoParensBinder b1 b2 b3) = foldMap (h'' s) [b1, b2, b3]
542+ h' s (ParensInBinder b) = h'' s b
543+ h' s (NamedBinder name b1) = h'' (S.insert name s) b1
473544 h' s (PositionedBinder _ _ b1) = h'' s b1
474545 h' s (TypedBinder _ b1) = h'' s b1
475546 h' _ _ = mempty
476547
548+ lit :: (S.Set Ident -> a -> r) -> S.Set Ident -> Literal a -> r
549+ lit go s (ArrayLiteral as) = foldMap (go s) as
550+ lit go s (ObjectLiteral as) = foldMap (go s . snd) as
551+ lit _ _ _ = mempty
552+
553+ i'' :: S.Set Ident -> CaseAlternative -> r
477554 i'' s a = i s a <> i' s a
478555
556+ i' :: S.Set Ident -> CaseAlternative -> r
479557 i' s (CaseAlternative bs (Right val)) =
480558 let s' = S.union s (S.fromList (concatMap binderNames bs))
481559 in foldMap (h'' s) bs <> g'' s' val
@@ -483,8 +561,10 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)
483561 let s' = S.union s (S.fromList (concatMap binderNames bs))
484562 in foldMap (h'' s) bs <> foldMap (\(grd, val) -> g'' s' grd <> g'' s' val) gs
485563
564+ j'' :: S.Set Ident -> DoNotationElement -> (S.Set Ident, r)
486565 j'' s a = let (s', r) = j' s a in (s', j s a <> r)
487566
567+ j' :: S.Set Ident -> DoNotationElement -> (S.Set Ident, r)
488568 j' s (DoNotationValue v) = (s, g'' s v)
489569 j' s (DoNotationBind b v) =
490570 let s' = S.union (S.fromList (binderNames b)) s
@@ -500,7 +580,15 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)
500580 getDeclIdent (TypeDeclaration ident _) = Just ident
501581 getDeclIdent _ = Nothing
502582
503−accumTypes :: (Monoid r) => (Type -> r) -> (Declaration -> r, Expr -> r, Binder -> r, CaseAlternative -> r, DoNotationElement -> r)
583+accumTypes
584+ :: (Monoid r)
585+ => (Type -> r)
586+ -> ( Declaration -> r
587+ , Expr -> r
588+ , Binder -> r
589+ , CaseAlternative -> r
590+ , DoNotationElement -> r
591+ )
504592accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (const mempty) (const mempty)
505593 where
506594 forDecls (DataDeclaration _ _ _ dctors) = mconcat (concatMap (map f . snd) dctors)
src/Language/PureScript/Bundle.hs+16−13
@@ -95,7 +95,7 @@ data ExportType
9595-- Each is labelled with the original AST node which generated it, so that we can dump it back
9696-- into the output during codegen.
9797data ModuleElement
98− = Require JSNode String ModuleIdentifier
98+ = Require JSNode String (Either String ModuleIdentifier)
9999 | Member JSNode Bool String [JSNode] [Key]
100100 | ExportsList [(ExportType, String, JSNode, [Key])]
101101 | Other JSNode
@@ -137,13 +137,13 @@ node (NN n) = n
137137node (NT n _ _) = n
138138
139139-- | Calculate the ModuleIdentifier which a require(...) statement imports.
140−checkImportPath :: Maybe FilePath -> String -> ModuleIdentifier -> S.Set String -> Maybe ModuleIdentifier
140+checkImportPath :: Maybe FilePath -> String -> ModuleIdentifier -> S.Set String -> Either String ModuleIdentifier
141141checkImportPath _ "./foreign" m _ =
142− Just (ModuleIdentifier (moduleName m) Foreign)
142+ Right (ModuleIdentifier (moduleName m) Foreign)
143143checkImportPath requirePath name _ names
144144 | Just name' <- stripPrefix (fromMaybe "" requirePath) name
145− , name' `S.member` names = Just (ModuleIdentifier name' Regular)
146−checkImportPath _ _ _ _ = Nothing
145+ , name' `S.member` names = Right (ModuleIdentifier name' Regular)
146+checkImportPath _ name _ _ = Left name
147147
148148-- | Compute the dependencies of all elements in a module, and add them to the tree.
149149--
@@ -166,7 +166,7 @@ withDeps (Module modulePath es) = Module modulePath (map expandDeps es)
166166 imports = mapMaybe toImport es
167167 where
168168 toImport :: ModuleElement -> Maybe (String, ModuleIdentifier)
169− toImport (Require _ nm mid) = Just (nm, mid)
169+ toImport (Require _ nm (Right mid)) = Just (nm, mid)
170170 toImport _ = Nothing
171171
172172 -- | Collects all member names in scope, so that we can identify dependencies of the second type.
@@ -209,7 +209,7 @@ withDeps (Module modulePath es) = Module modulePath (map expandDeps es)
209209--
210210-- Each type of module element is matched using pattern guards, and everything else is bundled into the
211211-- Other constructor.
212−toModule :: forall m. (Applicative m, MonadError ErrorMessage m) => Maybe FilePath -> S.Set String -> ModuleIdentifier -> JSNode -> m Module
212+toModule :: forall m. (MonadError ErrorMessage m) => Maybe FilePath -> S.Set String -> ModuleIdentifier -> JSNode -> m Module
213213toModule requirePath mids mid top
214214 | JSSourceElementsTop ns <- node top = Module mid <$> traverse toModuleElement ns
215215 | otherwise = err InvalidTopLevel
@@ -226,7 +226,7 @@ toModule requirePath mids mid top
226226 , JSIdentifier "require" <- node req
227227 , JSArguments _ [ impS ] _ <- node impP
228228 , JSStringLiteral _ importPath <- node impS
229− , Just importPath' <- checkImportPath requirePath importPath mid mids
229+ , importPath' <- checkImportPath requirePath importPath mid mids
230230 = pure (Require n importName importPath')
231231 toModuleElement n
232232 | JSVariables var [ varIntro ] _ <- node n
@@ -371,7 +371,7 @@ sortModules modules = map (\v -> case nodeFor v of (n, _, _) -> n) (reverse (top
371371 return (m, mid, mapMaybe getKey els)
372372
373373 getKey :: ModuleElement -> Maybe ModuleIdentifier
374− getKey (Require _ _ mi) = Just mi
374+ getKey (Require _ _ (Right mi)) = Just mi
375375 getKey _ = Nothing
376376
377377-- | A module is empty if it contains no exported members (in other words,
@@ -416,9 +416,7 @@ codeGen optionsMainModule optionsNamespace ms = renderToString (NN (JSSourceElem
416416 declToJS (Require _ nm req) =
417417 [ NN (JSVariables (NT (JSLiteral "var") tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n " ])
418418 [ NN (JSVarDecl (sp (JSIdentifier nm))
419− [ sp (JSLiteral "=")
420− , moduleReference sp (moduleName req)
421− ])
419+ (sp (JSLiteral "=") : either require (return . moduleReference sp . moduleName) req))
422420 ]
423421 (nt (JSLiteral ";"))) ]
424422 declToJS (ExportsList exps) = map toExport exps
@@ -467,6 +465,11 @@ codeGen optionsMainModule optionsNamespace ms = renderToString (NN (JSSourceElem
467465 , lf
468466 ]
469467
468+ require :: String -> [JSNode]
469+ require mn = [ sp (JSIdentifier "require")
470+ , NN (JSArguments (nt (JSLiteral "(")) [ nt (JSStringLiteral '"' mn) ] (nt (JSLiteral ")")))
471+ ]
472+
470473 moduleReference :: (Node -> JSNode) -> String -> JSNode
471474 moduleReference f mn =
472475 NN (JSMemberSquare [ f (JSIdentifier optionsNamespace) ]
@@ -530,7 +533,7 @@ codeGen optionsMainModule optionsNamespace ms = renderToString (NN (JSSourceElem
530533-- | The bundling function.
531534-- This function performs dead code elimination, filters empty modules
532535-- and generates and prints the final Javascript bundle.
533−bundle :: (Applicative m, MonadError ErrorMessage m)
536+bundle :: (MonadError ErrorMessage m)
534537 => [(ModuleIdentifier, String)] -- ^ The input modules. Each module should be javascript rendered from 'Language.PureScript.Make' or @psc@.
535538 -> [ModuleIdentifier] -- ^ Entry points. These module identifiers are used as the roots for dead-code elimination
536539 -> Maybe String -- ^ An optional main module.
src/Language/PureScript/CodeGen/JS.hs+167−133
@@ -10,7 +10,6 @@ module Language.PureScript.CodeGen.JS
1010 ( module AST
1111 , module Common
1212 , moduleToJs
13− , mainCall
1413 ) where
1514
1615import Prelude ()
@@ -19,10 +18,11 @@ import Prelude.Compat
1918import Data.List ((\\), delete, intersect)
2019import Data.Maybe (isNothing, fromMaybe)
2120import qualified Data.Map as M
22−import qualified Data.Traversable as T (traverse)
21+import qualified Data.Foldable as F
22+import qualified Data.Traversable as T
2323
2424import Control.Arrow ((&&&))
25−import Control.Monad (replicateM, forM)
25+import Control.Monad (replicateM, forM, void)
2626import Control.Monad.Error.Class (MonadError(..))
2727import Control.Monad.Reader (MonadReader, asks)
2828import Control.Monad.Supply.Class
@@ -45,26 +45,31 @@ import System.FilePath.Posix ((</>))
4545-- Generate code in the simplified Javascript intermediate representation for all declarations in a
4646-- module.
4747--
48−moduleToJs :: forall m. (Applicative m, Monad m, MonadReader Options m, MonadSupply m, MonadError MultipleErrors m)
49− => Module Ann -> Maybe JS -> m [JS]
48+moduleToJs
49+ :: forall m
50+ . (Monad m, MonadReader Options m, MonadSupply m, MonadError MultipleErrors m)
51+ => Module Ann
52+ -> Maybe JS
53+ -> m [JS]
5054moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
5155 rethrow (addHint (ErrorInModule mn)) $ do
5256 let usedNames = concatMap getNames decls
5357 let mnLookup = renameImports usedNames imps
54− jsImports <- T.traverse (importToJs mnLookup) . delete (ModuleName [ProperName C.prim]) . (\\ [mn]) $ imps
58+ jsImports <- T.traverse (importToJs mnLookup) . delete (ModuleName [ProperName C.prim]) . (\\ [mn]) $ map snd $ imps
5559 let decls' = renameModules mnLookup decls
5660 jsDecls <- mapM bindToJs decls'
5761 optimized <- T.traverse (T.traverse optimize) jsDecls
62+ F.traverse_ (F.traverse_ checkIntegers) optimized
5863 comments <- not <$> asks optionsNoComments
59− let strict = JSStringLiteral "use strict"
60− let header = if comments && not (null coms) then JSComment coms strict else strict
61− let foreign' = [JSVariableIntroduction "$foreign" foreign_ | not $ null foreigns || isNothing foreign_]
64+ let strict = JSStringLiteral Nothing "use strict"
65+ let header = if comments && not (null coms) then JSComment Nothing coms strict else strict
66+ let foreign' = [JSVariableIntroduction Nothing "$foreign" foreign_ | not $ null foreigns || isNothing foreign_]
6267 let moduleBody = header : foreign' ++ jsImports ++ concat optimized
6368 let foreignExps = exps `intersect` (fst `map` foreigns)
6469 let standardExps = exps \\ foreignExps
65− let exps' = JSObjectLiteral $ map (runIdent &&& JSVar . identToJs) standardExps
70+ let exps' = JSObjectLiteral Nothing $ map (runIdent &&& (JSVar Nothing) . identToJs) standardExps
6671 ++ map (runIdent &&& foreignIdent) foreignExps
67− return $ moduleBody ++ [JSAssignment (JSAccessor "exports" (JSVar "module")) exps']
72+ return $ moduleBody ++ [JSAssignment Nothing (JSAccessor Nothing "exports" (JSVar Nothing "module")) exps']
6873
6974 where
7075
@@ -72,23 +77,23 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
7277 -- Extracts all declaration names from a binding group.
7378 --
7479 getNames :: Bind Ann -> [Ident]
75− getNames (NonRec ident _) = [ident]
76− getNames (Rec vals) = map fst vals
80+ getNames (NonRec _ ident _) = [ident]
81+ getNames (Rec vals) = map (snd . fst) vals
7782
7883 -- |
7984 -- Creates alternative names for each module to ensure they don't collide
8085 -- with declaration names.
8186 --
82− renameImports :: [Ident] -> [ModuleName] -> M.Map ModuleName ModuleName
87+ renameImports :: [Ident] -> [(Ann, ModuleName)] -> M.Map ModuleName (Ann, ModuleName)
8388 renameImports ids mns = go M.empty ids mns
8489 where
85− go :: M.Map ModuleName ModuleName -> [Ident] -> [ModuleName] -> M.Map ModuleName ModuleName
86− go acc used (mn' : mns') =
90+ go :: M.Map ModuleName (Ann, ModuleName) -> [Ident] -> [(Ann, ModuleName)] -> M.Map ModuleName (Ann, ModuleName)
91+ go acc used ((ann, mn') : mns') =
8792 let mni = Ident $ runModuleName mn'
88− in if mni `elem` used
93+ in if mn' /= mn && mni `elem` used
8994 then let newName = freshModuleName 1 mn' used
90− in go (M.insert mn' newName acc) (Ident (runModuleName newName) : used) mns'
91− else go (M.insert mn' mn' acc) (mni : used) mns'
95+ in go (M.insert mn' (ann, newName) acc) (Ident (runModuleName newName) : used) mns'
96+ else go (M.insert mn' (ann, mn') acc) (mni : used) mns'
9297 go acc _ [] = acc
9398
9499 freshModuleName :: Integer -> ModuleName -> [Ident] -> ModuleName
@@ -102,18 +107,18 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
102107 -- Generates Javascript code for a module import, binding the required module
103108 -- to the alternative
104109 --
105− importToJs :: M.Map ModuleName ModuleName -> ModuleName -> m JS
110+ importToJs :: M.Map ModuleName (Ann, ModuleName) -> ModuleName -> m JS
106111 importToJs mnLookup mn' = do
107112 path <- asks optionsRequirePath
108− let mnSafe = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup
109− let moduleBody = JSApp (JSVar "require") [JSStringLiteral (maybe id (</>) path $ runModuleName mn')]
110− return $ JSVariableIntroduction (moduleNameToJs mnSafe) (Just moduleBody)
113+ let ((ss, _, _, _), mnSafe) = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup
114+ let moduleBody = JSApp Nothing (JSVar Nothing "require") [JSStringLiteral Nothing (maybe id (</>) path $ runModuleName mn')]
115+ withPos ss $ JSVariableIntroduction Nothing (moduleNameToJs mnSafe) (Just moduleBody)
111116
112117 -- |
113118 -- Replaces the `ModuleName`s in the AST so that the generated code refers to
114119 -- the collision-avoiding renamed module imports.
115120 --
116− renameModules :: M.Map ModuleName ModuleName -> [Bind Ann] -> [Bind Ann]
121+ renameModules :: M.Map ModuleName (Ann, ModuleName) -> [Bind Ann] -> [Bind Ann]
117122 renameModules mnLookup binds =
118123 let (f, _, _) = everywhereOnValues id goExpr goBinder
119124 in map f binds
@@ -126,7 +131,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
126131 goBinder b = b
127132 renameQual :: Qualified a -> Qualified a
128133 renameQual (Qualified (Just mn') a) =
129− let mnSafe = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup
134+ let (_,mnSafe) = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup
130135 in Qualified (Just mnSafe) a
131136 renameQual q = q
132137
@@ -134,8 +139,8 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
134139 -- Generate code in the simplified Javascript intermediate representation for a declaration
135140 --
136141 bindToJs :: Bind Ann -> m [JS]
137− bindToJs (NonRec ident val) = return <$> nonRecToJS ident val
138− bindToJs (Rec vals) = forM vals (uncurry nonRecToJS)
142+ bindToJs (NonRec ann ident val) = return <$> nonRecToJS ann ident val
143+ bindToJs (Rec vals) = forM vals (uncurry . uncurry $ nonRecToJS)
139144
140145 -- |
141146 -- Generate code in the simplified Javascript intermediate representation for a single non-recursive
@@ -143,22 +148,30 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
143148 --
144149 -- The main purpose of this function is to handle code generation for comments.
145150 --
146− nonRecToJS :: Ident -> Expr Ann -> m JS
147− nonRecToJS i e@(extractAnn -> (_, com, _, _)) | not (null com) = do
151+ nonRecToJS :: Ann -> Ident -> Expr Ann -> m JS
152+ nonRecToJS a i e@(extractAnn -> (_, com, _, _)) | not (null com) = do
148153 withoutComment <- asks optionsNoComments
149154 if withoutComment
150− then nonRecToJS i (modifyAnn removeComments e)
151− else JSComment com <$> nonRecToJS i (modifyAnn removeComments e)
152− nonRecToJS ident val = do
155+ then nonRecToJS a i (modifyAnn removeComments e)
156+ else JSComment Nothing com <$> nonRecToJS a i (modifyAnn removeComments e)
157+ nonRecToJS (ss, _, _, _) ident val = do
153158 js <- valueToJs val
154− return $ JSVariableIntroduction (identToJs ident) (Just js)
159+ withPos ss $ JSVariableIntroduction Nothing (identToJs ident) (Just js)
160+
161+ withPos :: Maybe SourceSpan -> JS -> m JS
162+ withPos (Just ss) js = do
163+ withSM <- asks optionsSourceMaps
164+ return $ if withSM
165+ then withSourceSpan ss js
166+ else js
167+ withPos Nothing js = return js
155168
156169 -- |
157170 -- Generate code in the simplified Javascript intermediate representation for a variable based on a
158171 -- PureScript identifier.
159172 --
160173 var :: Ident -> JS
161− var = JSVar . identToJs
174+ var = JSVar Nothing . identToJs
162175
163176 -- |
164177 -- Generate code in the simplified Javascript intermediate representation for an accessor based on
@@ -167,107 +180,106 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
167180 --
168181 accessor :: Ident -> JS -> JS
169182 accessor (Ident prop) = accessorString prop
170− accessor (Op op) = JSIndexer (JSStringLiteral op)
183+ accessor (Op op) = JSIndexer Nothing (JSStringLiteral Nothing op)
171184 accessor (GenIdent _ _) = internalError "GenIdent in accessor"
172185
173186 accessorString :: String -> JS -> JS
174− accessorString prop | identNeedsEscaping prop = JSIndexer (JSStringLiteral prop)
175− | otherwise = JSAccessor prop
187+ accessorString prop | identNeedsEscaping prop = JSIndexer Nothing (JSStringLiteral Nothing prop)
188+ | otherwise = JSAccessor Nothing prop
176189
177190 -- |
178191 -- Generate code in the simplified Javascript intermediate representation for a value or expression.
179192 --
180193 valueToJs :: Expr Ann -> m JS
181− valueToJs (Literal (pos, _, _, _) l) =
194+ valueToJs e =
195+ let (ss, _, _, _) = extractAnn e in
196+ withPos ss =<< valueToJs' e
197+
198+ valueToJs' :: Expr Ann -> m JS
199+ valueToJs' (Literal (pos, _, _, _) l) =
182200 maybe id rethrowWithPosition pos $ literalToValueJS l
183− valueToJs (Var (_, _, _, Just (IsConstructor _ [])) name) =
184− return $ JSAccessor "value" $ qualifiedToJS id name
185− valueToJs (Var (_, _, _, Just (IsConstructor _ _)) name) =
186− return $ JSAccessor "create" $ qualifiedToJS id name
187− valueToJs (Accessor _ prop val) =
201+ valueToJs' (Var (_, _, _, Just (IsConstructor _ [])) name) =
202+ return $ JSAccessor Nothing "value" $ qualifiedToJS id name
203+ valueToJs' (Var (_, _, _, Just (IsConstructor _ _)) name) =
204+ return $ JSAccessor Nothing "create" $ qualifiedToJS id name
205+ valueToJs' (Accessor _ prop val) =
188206 accessorString prop <$> valueToJs val
189− valueToJs (ObjectUpdate _ o ps) = do
207+ valueToJs' (ObjectUpdate _ o ps) = do
190208 obj <- valueToJs o
191209 sts <- mapM (sndM valueToJs) ps
192210 extendObj obj sts
193− valueToJs e@(Abs (_, _, _, Just IsTypeClassConstructor) _ _) =
211+ valueToJs' e@(Abs (_, _, _, Just IsTypeClassConstructor) _ _) =
194212 let args = unAbs e
195− in return $ JSFunction Nothing (map identToJs args) (JSBlock $ map assign args)
213+ in return $ JSFunction Nothing Nothing (map identToJs args) (JSBlock Nothing $ map assign args)
196214 where
197215 unAbs :: Expr Ann -> [Ident]
198216 unAbs (Abs _ arg val) = arg : unAbs val
199217 unAbs _ = []
200218 assign :: Ident -> JS
201− assign name = JSAssignment (accessorString (runIdent name) (JSVar "this"))
219+ assign name = JSAssignment Nothing (accessorString (runIdent name) (JSVar Nothing "this"))
202220 (var name)
203− valueToJs (Abs _ arg val) = do
221+ valueToJs' (Abs _ arg val) = do
204222 ret <- valueToJs val
205− return $ JSFunction Nothing [identToJs arg] (JSBlock [JSReturn ret])
206− valueToJs e@App{} = do
223+ return $ JSFunction Nothing Nothing [identToJs arg] (JSBlock Nothing [JSReturn Nothing ret])
224+ valueToJs' e@App{} = do
207225 let (f, args) = unApp e []
208226 args' <- mapM valueToJs args
209227 case f of
210228 Var (_, _, _, Just IsNewtype) _ -> return (head args')
211229 Var (_, _, _, Just (IsConstructor _ fields)) name | length args == length fields ->
212− return $ JSUnary JSNew $ JSApp (qualifiedToJS id name) args'
230+ return $ JSUnary Nothing JSNew $ JSApp Nothing (qualifiedToJS id name) args'
213231 Var (_, _, _, Just IsTypeClassConstructor) name ->
214− return $ JSUnary JSNew $ JSApp (qualifiedToJS id name) args'
215− _ -> flip (foldl (\fn a -> JSApp fn [a])) args' <$> valueToJs f
232+ return $ JSUnary Nothing JSNew $ JSApp Nothing (qualifiedToJS id name) args'
233+ _ -> flip (foldl (\fn a -> JSApp Nothing fn [a])) args' <$> valueToJs f
216234 where
217235 unApp :: Expr Ann -> [Expr Ann] -> (Expr Ann, [Expr Ann])
218236 unApp (App _ val arg) args = unApp val (arg : args)
219237 unApp other args = (other, args)
220− valueToJs (Var (_, _, _, Just IsForeign) qi@(Qualified (Just mn') ident)) =
238+ valueToJs' (Var (_, _, _, Just IsForeign) qi@(Qualified (Just mn') ident)) =
221239 return $ if mn' == mn
222240 then foreignIdent ident
223241 else varToJs qi
224− valueToJs (Var (_, _, _, Just IsForeign) ident) =
242+ valueToJs' (Var (_, _, _, Just IsForeign) ident) =
225243 error $ "Encountered an unqualified reference to a foreign ident " ++ showQualified showIdent ident
226− valueToJs (Var _ ident) =
227− return $ varToJs ident
228− valueToJs (Case (maybeSpan, _, _, _) values binders) = do
244+ valueToJs' (Var _ ident) = return $ varToJs ident
245+ valueToJs' (Case (maybeSpan, _, _, _) values binders) = do
229246 vals <- mapM valueToJs values
230247 bindersToJs maybeSpan binders vals
231− valueToJs (Let _ ds val) = do
248+ valueToJs' (Let _ ds val) = do
232249 ds' <- concat <$> mapM bindToJs ds
233250 ret <- valueToJs val
234− return $ JSApp (JSFunction Nothing [] (JSBlock (ds' ++ [JSReturn ret]))) []
235− valueToJs (Constructor (_, _, _, Just IsNewtype) _ (ProperName ctor) _) =
236− return $ JSVariableIntroduction ctor (Just $
237− JSObjectLiteral [("create",
238− JSFunction Nothing ["value"]
239− (JSBlock [JSReturn $ JSVar "value"]))])
240− valueToJs (Constructor _ _ (ProperName ctor) []) =
241− return $ iife ctor [ JSFunction (Just ctor) [] (JSBlock [])
242− , JSAssignment (JSAccessor "value" (JSVar ctor))
243− (JSUnary JSNew $ JSApp (JSVar ctor) []) ]
244− valueToJs (Constructor _ _ (ProperName ctor) fields) =
251+ return $ JSApp Nothing (JSFunction Nothing Nothing [] (JSBlock Nothing (ds' ++ [JSReturn Nothing ret]))) []
252+ valueToJs' (Constructor (_, _, _, Just IsNewtype) _ (ProperName ctor) _) =
253+ return $ JSVariableIntroduction Nothing ctor (Just $
254+ JSObjectLiteral Nothing [("create",
255+ JSFunction Nothing Nothing ["value"]
256+ (JSBlock Nothing [JSReturn Nothing $ JSVar Nothing "value"]))])
257+ valueToJs' (Constructor _ _ (ProperName ctor) []) =
258+ return $ iife ctor [ JSFunction Nothing (Just ctor) [] (JSBlock Nothing [])
259+ , JSAssignment Nothing (JSAccessor Nothing "value" (JSVar Nothing ctor))
260+ (JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing ctor) []) ]
261+ valueToJs' (Constructor _ _ (ProperName ctor) fields) =
245262 let constructor =
246− let body = [ JSAssignment (JSAccessor (identToJs f) (JSVar "this")) (var f) | f <- fields ]
247− in JSFunction (Just ctor) (identToJs `map` fields) (JSBlock body)
263+ let body = [ JSAssignment Nothing (JSAccessor Nothing (identToJs f) (JSVar Nothing "this")) (var f) | f <- fields ]
264+ in JSFunction Nothing (Just ctor) (identToJs `map` fields) (JSBlock Nothing body)
248265 createFn =
249− let body = JSUnary JSNew $ JSApp (JSVar ctor) (var `map` fields)
250− in foldr (\f inner -> JSFunction Nothing [identToJs f] (JSBlock [JSReturn inner])) body fields
266+ let body = JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing ctor) (var `map` fields)
267+ in foldr (\f inner -> JSFunction Nothing Nothing [identToJs f] (JSBlock Nothing [JSReturn Nothing inner])) body fields
251268 in return $ iife ctor [ constructor
252− , JSAssignment (JSAccessor "create" (JSVar ctor)) createFn
269+ , JSAssignment Nothing (JSAccessor Nothing "create" (JSVar Nothing ctor)) createFn
253270 ]
254271
255272 iife :: String -> [JS] -> JS
256− iife v exprs = JSApp (JSFunction Nothing [] (JSBlock $ exprs ++ [JSReturn $ JSVar v])) []
273+ iife v exprs = JSApp Nothing (JSFunction Nothing Nothing [] (JSBlock Nothing $ exprs ++ [JSReturn Nothing $ JSVar Nothing v])) []
257274
258275 literalToValueJS :: Literal (Expr Ann) -> m JS
259− literalToValueJS (NumericLiteral (Left i)) =
260− let minInt = -2147483648
261− maxInt = 2147483647
262− in if i < minInt || i > maxInt
263− then throwError . errorMessage $ IntOutOfRange i "JavaScript" minInt maxInt
264− else return $ JSNumericLiteral (Left i)
265− literalToValueJS (NumericLiteral (Right n)) = return $ JSNumericLiteral (Right n)
266− literalToValueJS (StringLiteral s) = return $ JSStringLiteral s
267− literalToValueJS (CharLiteral c) = return $ JSStringLiteral [c]
268− literalToValueJS (BooleanLiteral b) = return $ JSBooleanLiteral b
269− literalToValueJS (ArrayLiteral xs) = JSArrayLiteral <$> mapM valueToJs xs
270− literalToValueJS (ObjectLiteral ps) = JSObjectLiteral <$> mapM (sndM valueToJs) ps
276+ literalToValueJS (NumericLiteral (Left i)) = return $ JSNumericLiteral Nothing (Left i)
277+ literalToValueJS (NumericLiteral (Right n)) = return $ JSNumericLiteral Nothing (Right n)
278+ literalToValueJS (StringLiteral s) = return $ JSStringLiteral Nothing s
279+ literalToValueJS (CharLiteral c) = return $ JSStringLiteral Nothing [c]
280+ literalToValueJS (BooleanLiteral b) = return $ JSBooleanLiteral Nothing b
281+ literalToValueJS (ArrayLiteral xs) = JSArrayLiteral Nothing <$> mapM valueToJs xs
282+ literalToValueJS (ObjectLiteral ps) = JSObjectLiteral Nothing <$> mapM (sndM valueToJs) ps
271283
272284 -- |
273285 -- Shallow copy an object.
@@ -277,16 +289,16 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
277289 newObj <- freshName
278290 key <- freshName
279291 let
280− jsKey = JSVar key
281− jsNewObj = JSVar newObj
282− block = JSBlock (objAssign:copy:extend ++ [JSReturn jsNewObj])
283− objAssign = JSVariableIntroduction newObj (Just $ JSObjectLiteral [])
284− copy = JSForIn key obj $ JSBlock [JSIfElse cond assign Nothing]
285− cond = JSApp (JSAccessor "hasOwnProperty" obj) [jsKey]
286− assign = JSBlock [JSAssignment (JSIndexer jsKey jsNewObj) (JSIndexer jsKey obj)]
287− stToAssign (s, js) = JSAssignment (JSAccessor s jsNewObj) js
292+ jsKey = JSVar Nothing key
293+ jsNewObj = JSVar Nothing newObj
294+ block = JSBlock Nothing (objAssign:copy:extend ++ [JSReturn Nothing jsNewObj])
295+ objAssign = JSVariableIntroduction Nothing newObj (Just $ JSObjectLiteral Nothing [])
296+ copy = JSForIn Nothing key obj $ JSBlock Nothing [JSIfElse Nothing cond assign Nothing]
297+ cond = JSApp Nothing (JSAccessor Nothing "hasOwnProperty" obj) [jsKey]
298+ assign = JSBlock Nothing [JSAssignment Nothing (JSIndexer Nothing jsKey jsNewObj) (JSIndexer Nothing jsKey obj)]
299+ stToAssign (s, js) = JSAssignment Nothing (JSAccessor Nothing s jsNewObj) js
288300 extend = map stToAssign sts
289− return $ JSApp (JSFunction Nothing [] block) []
301+ return $ JSApp Nothing (JSFunction Nothing Nothing [] block) []
290302
291303 -- |
292304 -- Generate code in the simplified Javascript intermediate representation for a reference to a
@@ -301,12 +313,12 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
301313 -- variable that may have a qualified name.
302314 --
303315 qualifiedToJS :: (a -> Ident) -> Qualified a -> JS
304− qualifiedToJS f (Qualified (Just (ModuleName [ProperName mn'])) a) | mn' == C.prim = JSVar . runIdent $ f a
305− qualifiedToJS f (Qualified (Just mn') a) | mn /= mn' = accessor (f a) (JSVar (moduleNameToJs mn'))
306− qualifiedToJS f (Qualified _ a) = JSVar $ identToJs (f a)
316+ qualifiedToJS f (Qualified (Just (ModuleName [ProperName mn'])) a) | mn' == C.prim = JSVar Nothing . runIdent $ f a
317+ qualifiedToJS f (Qualified (Just mn') a) | mn /= mn' = accessor (f a) (JSVar Nothing (moduleNameToJs mn'))
318+ qualifiedToJS f (Qualified _ a) = JSVar Nothing $ identToJs (f a)
307319
308320 foreignIdent :: Ident -> JS
309− foreignIdent ident = accessorString (runIdent ident) (JSVar "$foreign")
321+ foreignIdent ident = accessorString (runIdent ident) (JSVar Nothing "$foreign")
310322
311323 -- |
312324 -- Generate code in the simplified Javascript intermediate representation for pattern match binders
@@ -315,11 +327,11 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
315327 bindersToJs :: Maybe SourceSpan -> [CaseAlternative Ann] -> [JS] -> m JS
316328 bindersToJs maybeSpan binders vals = do
317329 valNames <- replicateM (length vals) freshName
318− let assignments = zipWith JSVariableIntroduction valNames (map Just vals)
330+ let assignments = zipWith (JSVariableIntroduction Nothing) valNames (map Just vals)
319331 jss <- forM binders $ \(CaseAlternative bs result) -> do
320332 ret <- guardsToJs result
321333 go valNames ret bs
322− return $ JSApp (JSFunction Nothing [] (JSBlock (assignments ++ concat jss ++ [JSThrow $ failedPatternError valNames])))
334+ return $ JSApp Nothing (JSFunction Nothing Nothing [] (JSBlock Nothing (assignments ++ concat jss ++ [JSThrow Nothing $ failedPatternError valNames])))
323335 []
324336 where
325337 go :: [String] -> [JS] -> [Binder Ann] -> m [JS]
@@ -330,43 +342,48 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
330342 go _ _ _ = internalError "Invalid arguments to bindersToJs"
331343
332344 failedPatternError :: [String] -> JS
333− failedPatternError names = JSUnary JSNew $ JSApp (JSVar "Error") [JSBinary Add (JSStringLiteral failedPatternMessage) (JSArrayLiteral $ zipWith valueError names vals)]
345+ failedPatternError names = JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing "Error") [JSBinary Nothing Add (JSStringLiteral Nothing failedPatternMessage) (JSArrayLiteral Nothing $ zipWith valueError names vals)]
334346
335347 failedPatternMessage :: String
336348 failedPatternMessage = "Failed pattern match" ++ maybe "" (((" at " ++ runModuleName mn ++ " ") ++) . displayStartEndPos) maybeSpan ++ ": "
337349
338350 valueError :: String -> JS -> JS
339− valueError _ l@(JSNumericLiteral _) = l
340− valueError _ l@(JSStringLiteral _) = l
341− valueError _ l@(JSBooleanLiteral _) = l
342− valueError s _ = JSAccessor "name" . JSAccessor "constructor" $ JSVar s
351+ valueError _ l@(JSNumericLiteral _ _) = l
352+ valueError _ l@(JSStringLiteral _ _) = l
353+ valueError _ l@(JSBooleanLiteral _ _) = l
354+ valueError s _ = JSAccessor Nothing "name" . JSAccessor Nothing "constructor" $ JSVar Nothing s
343355
344356 guardsToJs :: Either [(Guard Ann, Expr Ann)] (Expr Ann) -> m [JS]
345357 guardsToJs (Left gs) = forM gs $ \(cond, val) -> do
346358 cond' <- valueToJs cond
347359 done <- valueToJs val
348− return $ JSIfElse cond' (JSBlock [JSReturn done]) Nothing
349− guardsToJs (Right v) = return . JSReturn <$> valueToJs v
360+ return $ JSIfElse Nothing cond' (JSBlock Nothing [JSReturn Nothing done]) Nothing
361+ guardsToJs (Right v) = return . JSReturn Nothing <$> valueToJs v
362+
363+ binderToJs :: String -> [JS] -> Binder Ann -> m [JS]
364+ binderToJs s done binder =
365+ let (ss, _, _, _) = extractBinderAnn binder in
366+ traverse (withPos ss) =<< binderToJs' s done binder
350367
351368 -- |
352369 -- Generate code in the simplified Javascript intermediate representation for a pattern match
353370 -- binder.
354371 --
355− binderToJs :: String -> [JS] -> Binder Ann -> m [JS]
356− binderToJs _ done (NullBinder{}) = return done
357− binderToJs varName done (LiteralBinder _ l) =
372+ binderToJs' :: String -> [JS] -> Binder Ann -> m [JS]
373+ binderToJs' _ done (NullBinder{}) = return done
374+ binderToJs' varName done (LiteralBinder _ l) =
358375 literalToBinderJS varName done l
359− binderToJs varName done (VarBinder _ ident) =
360− return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : done)
361− binderToJs varName done (ConstructorBinder (_, _, _, Just IsNewtype) _ _ [b]) =
376+ binderToJs' varName done (VarBinder _ ident) =
377+ return (JSVariableIntroduction Nothing (identToJs ident) (Just (JSVar Nothing varName)) : done)
378+ binderToJs' varName done (ConstructorBinder (_, _, _, Just IsNewtype) _ _ [b]) =
362379 binderToJs varName done b
363− binderToJs varName done (ConstructorBinder (_, _, _, Just (IsConstructor ctorType fields)) _ ctor bs) = do
380+ binderToJs' varName done (ConstructorBinder (_, _, _, Just (IsConstructor ctorType fields)) _ ctor bs) = do
364381 js <- go (zip fields bs) done
365382 return $ case ctorType of
366383 ProductType -> js
367384 SumType ->
368− [JSIfElse (JSInstanceOf (JSVar varName) (qualifiedToJS (Ident . runProperName) ctor))
369− (JSBlock js)
385+ [JSIfElse Nothing (JSInstanceOf Nothing (JSVar Nothing varName) (qualifiedToJS (Ident . runProperName) ctor))
386+ (JSBlock Nothing js)
370387 Nothing]
371388 where
372389 go :: [(Ident, Binder Ann)] -> [JS] -> m [JS]
@@ -375,24 +392,24 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
375392 argVar <- freshName
376393 done'' <- go remain done'
377394 js <- binderToJs argVar done'' binder
378− return (JSVariableIntroduction argVar (Just (JSAccessor (identToJs field) (JSVar varName))) : js)
379− binderToJs _ _ ConstructorBinder{} =
395+ return (JSVariableIntroduction Nothing argVar (Just (JSAccessor Nothing (identToJs field) (JSVar Nothing varName))) : js)
396+ binderToJs' _ _ ConstructorBinder{} =
380397 internalError "binderToJs: Invalid ConstructorBinder in binderToJs"
381− binderToJs varName done (NamedBinder _ ident binder) = do
398+ binderToJs' varName done (NamedBinder _ ident binder) = do
382399 js <- binderToJs varName done binder
383− return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : js)
400+ return (JSVariableIntroduction Nothing (identToJs ident) (Just (JSVar Nothing varName)) : js)
384401
385402 literalToBinderJS :: String -> [JS] -> Literal (Binder Ann) -> m [JS]
386403 literalToBinderJS varName done (NumericLiteral num) =
387− return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSNumericLiteral num)) (JSBlock done) Nothing]
404+ return [JSIfElse Nothing (JSBinary Nothing EqualTo (JSVar Nothing varName) (JSNumericLiteral Nothing num)) (JSBlock Nothing done) Nothing]
388405 literalToBinderJS varName done (CharLiteral c) =
389− return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSStringLiteral [c])) (JSBlock done) Nothing]
406+ return [JSIfElse Nothing (JSBinary Nothing EqualTo (JSVar Nothing varName) (JSStringLiteral Nothing [c])) (JSBlock Nothing done) Nothing]
390407 literalToBinderJS varName done (StringLiteral str) =
391− return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSStringLiteral str)) (JSBlock done) Nothing]
408+ return [JSIfElse Nothing (JSBinary Nothing EqualTo (JSVar Nothing varName) (JSStringLiteral Nothing str)) (JSBlock Nothing done) Nothing]
392409 literalToBinderJS varName done (BooleanLiteral True) =
393− return [JSIfElse (JSVar varName) (JSBlock done) Nothing]
410+ return [JSIfElse Nothing (JSVar Nothing varName) (JSBlock Nothing done) Nothing]
394411 literalToBinderJS varName done (BooleanLiteral False) =
395− return [JSIfElse (JSUnary Not (JSVar varName)) (JSBlock done) Nothing]
412+ return [JSIfElse Nothing (JSUnary Nothing Not (JSVar Nothing varName)) (JSBlock Nothing done) Nothing]
396413 literalToBinderJS varName done (ObjectLiteral bs) = go done bs
397414 where
398415 go :: [JS] -> [(String, Binder Ann)] -> m [JS]
@@ -401,10 +418,10 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
401418 propVar <- freshName
402419 done'' <- go done' bs'
403420 js <- binderToJs propVar done'' binder
404− return (JSVariableIntroduction propVar (Just (accessorString prop (JSVar varName))) : js)
421+ return (JSVariableIntroduction Nothing propVar (Just (accessorString prop (JSVar Nothing varName))) : js)
405422 literalToBinderJS varName done (ArrayLiteral bs) = do
406423 js <- go done 0 bs
407− return [JSIfElse (JSBinary EqualTo (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (Left (fromIntegral $ length bs)))) (JSBlock js) Nothing]
424+ return [JSIfElse Nothing (JSBinary Nothing EqualTo (JSAccessor Nothing "length" (JSVar Nothing varName)) (JSNumericLiteral Nothing (Left (fromIntegral $ length bs)))) (JSBlock Nothing js) Nothing]
408425 where
409426 go :: [JS] -> Integer -> [Binder Ann] -> m [JS]
410427 go done' _ [] = return done'
@@ -412,7 +429,24 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
412429 elVar <- freshName
413430 done'' <- go done' (index + 1) bs'
414431 js <- binderToJs elVar done'' binder
415− return (JSVariableIntroduction elVar (Just (JSIndexer (JSNumericLiteral (Left index)) (JSVar varName))) : js)
432+ return (JSVariableIntroduction Nothing elVar (Just (JSIndexer Nothing (JSNumericLiteral Nothing (Left index)) (JSVar Nothing varName))) : js)
416433
417−mainCall :: ModuleName -> String -> JS
418−mainCall mmi ns = JSApp (JSAccessor C.main (JSAccessor (moduleNameToJs mmi) (JSVar ns))) []
434+ -- Check that all integers fall within the valid int range for JavaScript.
435+ checkIntegers :: JS -> m ()
436+ checkIntegers = void . everywhereOnJSTopDownM go
437+ where
438+ go :: JS -> m JS
439+ go (JSUnary _ Negate (JSNumericLiteral ss (Left i))) =
440+ -- Move the negation inside the literal; since this is a top-down
441+ -- traversal doing this replacement will stop the next case from raising
442+ -- the error when attempting to use -2147483648, as if left unrewritten
443+ -- the value is `JSUnary Negate (JSNumericLiteral (Left 2147483648))`, and
444+ -- 2147483648 is larger than the maximum allowed int.
445+ return $ JSNumericLiteral ss (Left (-i))
446+ go js@(JSNumericLiteral _ (Left i)) =
447+ let minInt = -2147483648
448+ maxInt = 2147483647
449+ in if i < minInt || i > maxInt
450+ then throwError . errorMessage $ IntOutOfRange i "JavaScript" minInt maxInt
451+ else return js
452+ go other = return other
src/Language/PureScript/CodeGen/JS/AST.hs+173−114
@@ -1,30 +1,16 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.CodeGen.JS.AST
4−-- Copyright : (c) Phil Freeman 2013
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
111-- |
122-- Data types for the intermediate simplified-Javascript AST
133--
14−-----------------------------------------------------------------------------
15−
16−{-# LANGUAGE DeriveDataTypeable #-}
17−
184module Language.PureScript.CodeGen.JS.AST where
195
206import Prelude ()
217import Prelude.Compat
228
239import Control.Monad.Identity
24−import Data.Data
2510
2611import Language.PureScript.Comments
2712import Language.PureScript.Traversals
13+import Language.PureScript.AST (SourceSpan(..))
2814
2915-- |
3016-- Built-in unary operators
@@ -49,7 +35,8 @@ data UnaryOperator
4935 -- |
5036 -- Constructor
5137 --
52− | JSNew deriving (Show, Read, Eq, Data, Typeable)
38+ | JSNew
39+ deriving (Show, Read, Eq)
5340
5441-- |
5542-- Built-in binary operators
@@ -130,7 +117,8 @@ data BinaryOperator
130117 -- |
131118 -- Bitwise right shift with zero-fill
132119 --
133− | ZeroFillShiftRight deriving (Show, Read, Eq, Data, Typeable)
120+ | ZeroFillShiftRight
121+ deriving (Show, Read, Eq)
134122
135123-- |
136124-- Data type for simplified Javascript expressions
@@ -139,119 +127,190 @@ data JS
139127 -- |
140128 -- A numeric literal
141129 --
142− = JSNumericLiteral (Either Integer Double)
130+ = JSNumericLiteral (Maybe SourceSpan) (Either Integer Double)
143131 -- |
144132 -- A string literal
145133 --
146− | JSStringLiteral String
134+ | JSStringLiteral (Maybe SourceSpan) String
147135 -- |
148136 -- A boolean literal
149137 --
150− | JSBooleanLiteral Bool
138+ | JSBooleanLiteral (Maybe SourceSpan) Bool
151139 -- |
152140 -- A unary operator application
153141 --
154− | JSUnary UnaryOperator JS
142+ | JSUnary (Maybe SourceSpan) UnaryOperator JS
155143 -- |
156144 -- A binary operator application
157145 --
158− | JSBinary BinaryOperator JS JS
146+ | JSBinary (Maybe SourceSpan) BinaryOperator JS JS
159147 -- |
160148 -- An array literal
161149 --
162− | JSArrayLiteral [JS]
150+ | JSArrayLiteral (Maybe SourceSpan) [JS]
163151 -- |
164152 -- An array indexer expression
165153 --
166− | JSIndexer JS JS
154+ | JSIndexer (Maybe SourceSpan) JS JS
167155 -- |
168156 -- An object literal
169157 --
170− | JSObjectLiteral [(String, JS)]
158+ | JSObjectLiteral (Maybe SourceSpan) [(String, JS)]
171159 -- |
172160 -- An object property accessor expression
173161 --
174− | JSAccessor String JS
162+ | JSAccessor (Maybe SourceSpan) String JS
175163 -- |
176164 -- A function introduction (optional name, arguments, body)
177165 --
178− | JSFunction (Maybe String) [String] JS
166+ | JSFunction (Maybe SourceSpan) (Maybe String) [String] JS
179167 -- |
180168 -- Function application
181169 --
182− | JSApp JS [JS]
170+ | JSApp (Maybe SourceSpan) JS [JS]
183171 -- |
184172 -- Variable
185173 --
186− | JSVar String
174+ | JSVar (Maybe SourceSpan) String
187175 -- |
188176 -- Conditional expression
189177 --
190− | JSConditional JS JS JS
178+ | JSConditional (Maybe SourceSpan) JS JS JS
191179 -- |
192180 -- A block of expressions in braces
193181 --
194− | JSBlock [JS]
182+ | JSBlock (Maybe SourceSpan) [JS]
195183 -- |
196184 -- A variable introduction and optional initialization
197185 --
198− | JSVariableIntroduction String (Maybe JS)
186+ | JSVariableIntroduction (Maybe SourceSpan) String (Maybe JS)
199187 -- |
200188 -- A variable assignment
201189 --
202− | JSAssignment JS JS
190+ | JSAssignment (Maybe SourceSpan) JS JS
203191 -- |
204192 -- While loop
205193 --
206− | JSWhile JS JS
194+ | JSWhile (Maybe SourceSpan) JS JS
207195 -- |
208196 -- For loop
209197 --
210− | JSFor String JS JS JS
198+ | JSFor (Maybe SourceSpan) String JS JS JS
211199 -- |
212200 -- ForIn loop
213201 --
214− | JSForIn String JS JS
202+ | JSForIn (Maybe SourceSpan) String JS JS
215203 -- |
216204 -- If-then-else statement
217205 --
218− | JSIfElse JS JS (Maybe JS)
206+ | JSIfElse (Maybe SourceSpan) JS JS (Maybe JS)
219207 -- |
220208 -- Return statement
221209 --
222− | JSReturn JS
210+ | JSReturn (Maybe SourceSpan) JS
223211 -- |
224212 -- Throw statement
225213 --
226− | JSThrow JS
214+ | JSThrow (Maybe SourceSpan) JS
227215 -- |
228216 -- Type-Of operator
229217 --
230− | JSTypeOf JS
218+ | JSTypeOf (Maybe SourceSpan) JS
231219 -- |
232220 -- InstanceOf test
233221 --
234− | JSInstanceOf JS JS
222+ | JSInstanceOf (Maybe SourceSpan) JS JS
235223 -- |
236224 -- Labelled statement
237225 --
238− | JSLabel String JS
226+ | JSLabel (Maybe SourceSpan) String JS
239227 -- |
240228 -- Break statement
241229 --
242− | JSBreak String
230+ | JSBreak (Maybe SourceSpan) String
243231 -- |
244232 -- Continue statement
245233 --
246− | JSContinue String
234+ | JSContinue (Maybe SourceSpan) String
247235 -- |
248236 -- Raw Javascript (generated when parsing fails for an inline foreign import declaration)
249237 --
250− | JSRaw String
238+ | JSRaw (Maybe SourceSpan) String
251239 -- |
252240 -- Commented Javascript
253241 --
254− | JSComment [Comment] JS deriving (Show, Read, Eq, Data, Typeable)
242+ | JSComment (Maybe SourceSpan) [Comment] JS deriving (Show, Read, Eq)
243+
244+withSourceSpan :: SourceSpan -> JS -> JS
245+withSourceSpan withSpan = go
246+ where
247+ ss :: Maybe SourceSpan
248+ ss = Just withSpan
249+
250+ go :: JS -> JS
251+ go (JSNumericLiteral _ n) = JSNumericLiteral ss n
252+ go (JSStringLiteral _ s) = JSStringLiteral ss s
253+ go (JSBooleanLiteral _ b) = JSBooleanLiteral ss b
254+ go (JSUnary _ op j) = JSUnary ss op j
255+ go (JSBinary _ op j1 j2) = JSBinary ss op j1 j2
256+ go (JSArrayLiteral _ js) = JSArrayLiteral ss js
257+ go (JSIndexer _ j1 j2) = JSIndexer ss j1 j2
258+ go (JSObjectLiteral _ js) = JSObjectLiteral ss js
259+ go (JSAccessor _ prop j) = JSAccessor ss prop j
260+ go (JSFunction _ name args j) = JSFunction ss name args j
261+ go (JSApp _ j js) = JSApp ss j js
262+ go (JSVar _ s) = JSVar ss s
263+ go (JSConditional _ j1 j2 j3) = JSConditional ss j1 j2 j3
264+ go (JSBlock _ js) = JSBlock ss js
265+ go (JSVariableIntroduction _ name j) = JSVariableIntroduction ss name j
266+ go (JSAssignment _ j1 j2) = JSAssignment ss j1 j2
267+ go (JSWhile _ j1 j2) = JSWhile ss j1 j2
268+ go (JSFor _ name j1 j2 j3) = JSFor ss name j1 j2 j3
269+ go (JSForIn _ name j1 j2) = JSForIn ss name j1 j2
270+ go (JSIfElse _ j1 j2 j3) = JSIfElse ss j1 j2 j3
271+ go (JSReturn _ js) = JSReturn ss js
272+ go (JSThrow _ js) = JSThrow ss js
273+ go (JSTypeOf _ js) = JSTypeOf ss js
274+ go (JSInstanceOf _ j1 j2) = JSInstanceOf ss j1 j2
275+ go (JSLabel _ name js) = JSLabel ss name js
276+ go (JSBreak _ s) = JSBreak ss s
277+ go (JSContinue _ s) = JSContinue ss s
278+ go (JSRaw _ s) = JSRaw ss s
279+ go (JSComment _ com j) = JSComment ss com j
280+
281+getSourceSpan :: JS -> Maybe SourceSpan
282+getSourceSpan = go
283+ where
284+ go :: JS -> Maybe SourceSpan
285+ go (JSNumericLiteral ss _) = ss
286+ go (JSStringLiteral ss _) = ss
287+ go (JSBooleanLiteral ss _) = ss
288+ go (JSUnary ss _ _) = ss
289+ go (JSBinary ss _ _ _) = ss
290+ go (JSArrayLiteral ss _) = ss
291+ go (JSIndexer ss _ _) = ss
292+ go (JSObjectLiteral ss _) = ss
293+ go (JSAccessor ss _ _) = ss
294+ go (JSFunction ss _ _ _) = ss
295+ go (JSApp ss _ _) = ss
296+ go (JSVar ss _) = ss
297+ go (JSConditional ss _ _ _) = ss
298+ go (JSBlock ss _) = ss
299+ go (JSVariableIntroduction ss _ _) = ss
300+ go (JSAssignment ss _ _) = ss
301+ go (JSWhile ss _ _) = ss
302+ go (JSFor ss _ _ _ _) = ss
303+ go (JSForIn ss _ _ _) = ss
304+ go (JSIfElse ss _ _ _) = ss
305+ go (JSReturn ss _) = ss
306+ go (JSThrow ss _) = ss
307+ go (JSTypeOf ss _) = ss
308+ go (JSInstanceOf ss _ _) = ss
309+ go (JSLabel ss _ _) = ss
310+ go (JSBreak ss _) = ss
311+ go (JSContinue ss _) = ss
312+ go (JSRaw ss _) = ss
313+ go (JSComment ss _ _) = ss
255314
256315--
257316-- Traversals
@@ -261,85 +320,85 @@ everywhereOnJS :: (JS -> JS) -> JS -> JS
261320everywhereOnJS f = go
262321 where
263322 go :: JS -> JS
264− go (JSUnary op j) = f (JSUnary op (go j))
265− go (JSBinary op j1 j2) = f (JSBinary op (go j1) (go j2))
266− go (JSArrayLiteral js) = f (JSArrayLiteral (map go js))
267− go (JSIndexer j1 j2) = f (JSIndexer (go j1) (go j2))
268− go (JSObjectLiteral js) = f (JSObjectLiteral (map (fmap go) js))
269− go (JSAccessor prop j) = f (JSAccessor prop (go j))
270− go (JSFunction name args j) = f (JSFunction name args (go j))
271− go (JSApp j js) = f (JSApp (go j) (map go js))
272− go (JSConditional j1 j2 j3) = f (JSConditional (go j1) (go j2) (go j3))
273− go (JSBlock js) = f (JSBlock (map go js))
274− go (JSVariableIntroduction name j) = f (JSVariableIntroduction name (fmap go j))
275− go (JSAssignment j1 j2) = f (JSAssignment (go j1) (go j2))
276− go (JSWhile j1 j2) = f (JSWhile (go j1) (go j2))
277− go (JSFor name j1 j2 j3) = f (JSFor name (go j1) (go j2) (go j3))
278− go (JSForIn name j1 j2) = f (JSForIn name (go j1) (go j2))
279− go (JSIfElse j1 j2 j3) = f (JSIfElse (go j1) (go j2) (fmap go j3))
280− go (JSReturn js) = f (JSReturn (go js))
281− go (JSThrow js) = f (JSThrow (go js))
282− go (JSTypeOf js) = f (JSTypeOf (go js))
283− go (JSLabel name js) = f (JSLabel name (go js))
284− go (JSInstanceOf j1 j2) = f (JSInstanceOf (go j1) (go j2))
285− go (JSComment com j) = f (JSComment com (go j))
323+ go (JSUnary ss op j) = f (JSUnary ss op (go j))
324+ go (JSBinary ss op j1 j2) = f (JSBinary ss op (go j1) (go j2))
325+ go (JSArrayLiteral ss js) = f (JSArrayLiteral ss (map go js))
326+ go (JSIndexer ss j1 j2) = f (JSIndexer ss (go j1) (go j2))
327+ go (JSObjectLiteral ss js) = f (JSObjectLiteral ss (map (fmap go) js))
328+ go (JSAccessor ss prop j) = f (JSAccessor ss prop (go j))
329+ go (JSFunction ss name args j) = f (JSFunction ss name args (go j))
330+ go (JSApp ss j js) = f (JSApp ss (go j) (map go js))
331+ go (JSConditional ss j1 j2 j3) = f (JSConditional ss (go j1) (go j2) (go j3))
332+ go (JSBlock ss js) = f (JSBlock ss (map go js))
333+ go (JSVariableIntroduction ss name j) = f (JSVariableIntroduction ss name (fmap go j))
334+ go (JSAssignment ss j1 j2) = f (JSAssignment ss (go j1) (go j2))
335+ go (JSWhile ss j1 j2) = f (JSWhile ss (go j1) (go j2))
336+ go (JSFor ss name j1 j2 j3) = f (JSFor ss name (go j1) (go j2) (go j3))
337+ go (JSForIn ss name j1 j2) = f (JSForIn ss name (go j1) (go j2))
338+ go (JSIfElse ss j1 j2 j3) = f (JSIfElse ss (go j1) (go j2) (fmap go j3))
339+ go (JSReturn ss js) = f (JSReturn ss (go js))
340+ go (JSThrow ss js) = f (JSThrow ss (go js))
341+ go (JSTypeOf ss js) = f (JSTypeOf ss (go js))
342+ go (JSLabel ss name js) = f (JSLabel ss name (go js))
343+ go (JSInstanceOf ss j1 j2) = f (JSInstanceOf ss (go j1) (go j2))
344+ go (JSComment ss com j) = f (JSComment ss com (go j))
286345 go other = f other
287346
288347everywhereOnJSTopDown :: (JS -> JS) -> JS -> JS
289348everywhereOnJSTopDown f = runIdentity . everywhereOnJSTopDownM (Identity . f)
290349
291−everywhereOnJSTopDownM :: (Applicative m, Monad m) => (JS -> m JS) -> JS -> m JS
350+everywhereOnJSTopDownM :: (Monad m) => (JS -> m JS) -> JS -> m JS
292351everywhereOnJSTopDownM f = f >=> go
293352 where
294353 f' = f >=> go
295− go (JSUnary op j) = JSUnary op <$> f' j
296− go (JSBinary op j1 j2) = JSBinary op <$> f' j1 <*> f' j2
297− go (JSArrayLiteral js) = JSArrayLiteral <$> traverse f' js
298− go (JSIndexer j1 j2) = JSIndexer <$> f' j1 <*> f' j2
299− go (JSObjectLiteral js) = JSObjectLiteral <$> traverse (sndM f') js
300− go (JSAccessor prop j) = JSAccessor prop <$> f' j
301− go (JSFunction name args j) = JSFunction name args <$> f' j
302− go (JSApp j js) = JSApp <$> f' j <*> traverse f' js
303− go (JSConditional j1 j2 j3) = JSConditional <$> f' j1 <*> f' j2 <*> f' j3
304− go (JSBlock js) = JSBlock <$> traverse f' js
305− go (JSVariableIntroduction name j) = JSVariableIntroduction name <$> traverse f' j
306− go (JSAssignment j1 j2) = JSAssignment <$> f' j1 <*> f' j2
307− go (JSWhile j1 j2) = JSWhile <$> f' j1 <*> f' j2
308− go (JSFor name j1 j2 j3) = JSFor name <$> f' j1 <*> f' j2 <*> f' j3
309− go (JSForIn name j1 j2) = JSForIn name <$> f' j1 <*> f' j2
310− go (JSIfElse j1 j2 j3) = JSIfElse <$> f' j1 <*> f' j2 <*> traverse f' j3
311− go (JSReturn j) = JSReturn <$> f' j
312− go (JSThrow j) = JSThrow <$> f' j
313− go (JSTypeOf j) = JSTypeOf <$> f' j
314− go (JSLabel name j) = JSLabel name <$> f' j
315− go (JSInstanceOf j1 j2) = JSInstanceOf <$> f' j1 <*> f' j2
316− go (JSComment com j) = JSComment com <$> f' j
354+ go (JSUnary ss op j) = JSUnary ss op <$> f' j
355+ go (JSBinary ss op j1 j2) = JSBinary ss op <$> f' j1 <*> f' j2
356+ go (JSArrayLiteral ss js) = JSArrayLiteral ss <$> traverse f' js
357+ go (JSIndexer ss j1 j2) = JSIndexer ss <$> f' j1 <*> f' j2
358+ go (JSObjectLiteral ss js) = JSObjectLiteral ss <$> traverse (sndM f') js
359+ go (JSAccessor ss prop j) = JSAccessor ss prop <$> f' j
360+ go (JSFunction ss name args j) = JSFunction ss name args <$> f' j
361+ go (JSApp ss j js) = JSApp ss <$> f' j <*> traverse f' js
362+ go (JSConditional ss j1 j2 j3) = JSConditional ss <$> f' j1 <*> f' j2 <*> f' j3
363+ go (JSBlock ss js) = JSBlock ss <$> traverse f' js
364+ go (JSVariableIntroduction ss name j) = JSVariableIntroduction ss name <$> traverse f' j
365+ go (JSAssignment ss j1 j2) = JSAssignment ss <$> f' j1 <*> f' j2
366+ go (JSWhile ss j1 j2) = JSWhile ss <$> f' j1 <*> f' j2
367+ go (JSFor ss name j1 j2 j3) = JSFor ss name <$> f' j1 <*> f' j2 <*> f' j3
368+ go (JSForIn ss name j1 j2) = JSForIn ss name <$> f' j1 <*> f' j2
369+ go (JSIfElse ss j1 j2 j3) = JSIfElse ss <$> f' j1 <*> f' j2 <*> traverse f' j3
370+ go (JSReturn ss j) = JSReturn ss <$> f' j
371+ go (JSThrow ss j) = JSThrow ss <$> f' j
372+ go (JSTypeOf ss j) = JSTypeOf ss <$> f' j
373+ go (JSLabel ss name j) = JSLabel ss name <$> f' j
374+ go (JSInstanceOf ss j1 j2) = JSInstanceOf ss <$> f' j1 <*> f' j2
375+ go (JSComment ss com j) = JSComment ss com <$> f' j
317376 go other = f other
318377
319378everythingOnJS :: (r -> r -> r) -> (JS -> r) -> JS -> r
320379everythingOnJS (<>) f = go
321380 where
322− go j@(JSUnary _ j1) = f j <> go j1
323− go j@(JSBinary _ j1 j2) = f j <> go j1 <> go j2
324− go j@(JSArrayLiteral js) = foldl (<>) (f j) (map go js)
325− go j@(JSIndexer j1 j2) = f j <> go j1 <> go j2
326− go j@(JSObjectLiteral js) = foldl (<>) (f j) (map (go . snd) js)
327− go j@(JSAccessor _ j1) = f j <> go j1
328− go j@(JSFunction _ _ j1) = f j <> go j1
329− go j@(JSApp j1 js) = foldl (<>) (f j <> go j1) (map go js)
330− go j@(JSConditional j1 j2 j3) = f j <> go j1 <> go j2 <> go j3
331− go j@(JSBlock js) = foldl (<>) (f j) (map go js)
332− go j@(JSVariableIntroduction _ (Just j1)) = f j <> go j1
333− go j@(JSAssignment j1 j2) = f j <> go j1 <> go j2
334− go j@(JSWhile j1 j2) = f j <> go j1 <> go j2
335− go j@(JSFor _ j1 j2 j3) = f j <> go j1 <> go j2 <> go j3
336− go j@(JSForIn _ j1 j2) = f j <> go j1 <> go j2
337− go j@(JSIfElse j1 j2 Nothing) = f j <> go j1 <> go j2
338− go j@(JSIfElse j1 j2 (Just j3)) = f j <> go j1 <> go j2 <> go j3
339− go j@(JSReturn j1) = f j <> go j1
340− go j@(JSThrow j1) = f j <> go j1
341− go j@(JSTypeOf j1) = f j <> go j1
342− go j@(JSLabel _ j1) = f j <> go j1
343− go j@(JSInstanceOf j1 j2) = f j <> go j1 <> go j2
344− go j@(JSComment _ j1) = f j <> go j1
381+ go j@(JSUnary _ _ j1) = f j <> go j1
382+ go j@(JSBinary _ _ j1 j2) = f j <> go j1 <> go j2
383+ go j@(JSArrayLiteral _ js) = foldl (<>) (f j) (map go js)
384+ go j@(JSIndexer _ j1 j2) = f j <> go j1 <> go j2
385+ go j@(JSObjectLiteral _ js) = foldl (<>) (f j) (map (go . snd) js)
386+ go j@(JSAccessor _ _ j1) = f j <> go j1
387+ go j@(JSFunction _ _ _ j1) = f j <> go j1
388+ go j@(JSApp _ j1 js) = foldl (<>) (f j <> go j1) (map go js)
389+ go j@(JSConditional _ j1 j2 j3) = f j <> go j1 <> go j2 <> go j3
390+ go j@(JSBlock _ js) = foldl (<>) (f j) (map go js)
391+ go j@(JSVariableIntroduction _ _ (Just j1)) = f j <> go j1
392+ go j@(JSAssignment _ j1 j2) = f j <> go j1 <> go j2
393+ go j@(JSWhile _ j1 j2) = f j <> go j1 <> go j2
394+ go j@(JSFor _ _ j1 j2 j3) = f j <> go j1 <> go j2 <> go j3
395+ go j@(JSForIn _ _ j1 j2) = f j <> go j1 <> go j2
396+ go j@(JSIfElse _ j1 j2 Nothing) = f j <> go j1 <> go j2
397+ go j@(JSIfElse _ j1 j2 (Just j3)) = f j <> go j1 <> go j2 <> go j3
398+ go j@(JSReturn _ j1) = f j <> go j1
399+ go j@(JSThrow _ j1) = f j <> go j1
400+ go j@(JSTypeOf _ j1) = f j <> go j1
401+ go j@(JSLabel _ _ j1) = f j <> go j1
402+ go j@(JSInstanceOf _ j1 j2) = f j <> go j1 <> go j2
403+ go j@(JSComment _ _ j1) = f j <> go j1
345404 go other = f other
src/Language/PureScript/CodeGen/JS/Optimizer.hs+19−27
@@ -1,13 +1,5 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.CodeGen.JS.Optimizer
4−-- Copyright : (c) Phil Freeman 2013
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
1+{-# LANGUAGE FlexibleContexts #-}
2+
113-- |
124-- This module optimizes code in the simplified-Javascript intermediate representation.
135--
@@ -29,13 +21,7 @@
2921--
3022-- * Inlining primitive Javascript operators
3123--
32−-----------------------------------------------------------------------------
33−
34−{-# LANGUAGE FlexibleContexts #-}
35−
36−module Language.PureScript.CodeGen.JS.Optimizer (
37− optimize
38−) where
24+module Language.PureScript.CodeGen.JS.Optimizer (optimize) where
3925
4026import Prelude ()
4127import Prelude.Compat
@@ -57,19 +43,29 @@ import Language.PureScript.CodeGen.JS.Optimizer.Blocks
5743-- |
5844-- Apply a series of optimizer passes to simplified Javascript code
5945--
60−optimize :: (Monad m, MonadReader Options m, Applicative m, MonadSupply m) => JS -> m JS
46+optimize :: (Monad m, MonadReader Options m, MonadSupply m) => JS -> m JS
6147optimize js = do
6248 noOpt <- asks optionsNoOptimizations
6349 if noOpt then return js else optimize' js
6450
65−optimize' :: (Monad m, MonadReader Options m, Applicative m, MonadSupply m) => JS -> m JS
51+optimize' :: (Monad m, MonadReader Options m, MonadSupply m) => JS -> m JS
6652optimize' js = do
6753 opts <- ask
68− untilFixedPoint (inlineFnComposition . applyAll
54+ js' <- untilFixedPoint (inlineFnComposition . tidyUp . applyAll
55+ [ inlineCommonValues
56+ , inlineOperator (C.prelude, (C.$)) $ \f x -> JSApp Nothing f [x]
57+ , inlineOperator (C.dataFunction, C.apply) $ \f x -> JSApp Nothing f [x]
58+ , inlineOperator (C.prelude, (C.#)) $ \x f -> JSApp Nothing f [x]
59+ , inlineOperator (C.dataFunction, C.applyFlipped) $ \x f -> JSApp Nothing f [x]
60+ , inlineOperator (C.dataArrayUnsafe, C.unsafeIndex) $ flip (JSIndexer Nothing)
61+ , inlineCommonOperators
62+ ]) js
63+ untilFixedPoint (return . tidyUp) . tco opts . magicDo opts $ js'
64+ where
65+ tidyUp :: JS -> JS
66+ tidyUp = applyAll
6967 [ collapseNestedBlocks
7068 , collapseNestedIfs
71− , tco opts
72− , magicDo opts
7369 , removeCodeAfterReturnStatements
7470 , removeUnusedArg
7571 , removeUndefinedApp
@@ -77,11 +73,7 @@ optimize' js = do
7773 , etaConvert
7874 , evaluateIifes
7975 , inlineVariables
80− , inlineValues
81− , inlineOperator (C.prelude, (C.$)) $ \f x -> JSApp f [x]
82− , inlineOperator (C.prelude, (C.#)) $ \x f -> JSApp f [x]
83− , inlineOperator (C.dataArrayUnsafe, C.unsafeIndex) $ flip JSIndexer
84− , inlineCommonOperators ]) js
76+ ]
8577
8678untilFixedPoint :: (Monad m, Eq a) => (a -> m a) -> a -> m a
8779untilFixedPoint f = go
src/Language/PureScript/CodeGen/JS/Optimizer/Blocks.hs+4−4
@@ -27,16 +27,16 @@ collapseNestedBlocks :: JS -> JS
2727collapseNestedBlocks = everywhereOnJS collapse
2828 where
2929 collapse :: JS -> JS
30− collapse (JSBlock sts) = JSBlock (concatMap go sts)
30+ collapse (JSBlock ss sts) = JSBlock ss (concatMap go sts)
3131 collapse js = js
3232 go :: JS -> [JS]
33− go (JSBlock sts) = sts
33+ go (JSBlock _ sts) = sts
3434 go s = [s]
3535
3636collapseNestedIfs :: JS -> JS
3737collapseNestedIfs = everywhereOnJS collapse
3838 where
3939 collapse :: JS -> JS
40− collapse (JSIfElse cond1 (JSBlock [JSIfElse cond2 body Nothing]) Nothing) =
41− JSIfElse (JSBinary And cond1 cond2) body Nothing
40+ collapse (JSIfElse s1 cond1 (JSBlock _ [JSIfElse s2 cond2 body Nothing]) Nothing) =
41+ JSIfElse s1 (JSBinary s2 And cond1 cond2) body Nothing
4242 collapse js = js
src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs+30−27
@@ -1,18 +1,6 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.CodeGen.JS.Optimizer.Common
4−-- Copyright : (c) Phil Freeman 2013-14
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
111-- |
122-- Common functions used by the various optimizer phases
133--
14−-----------------------------------------------------------------------------
15−
164module Language.PureScript.CodeGen.JS.Optimizer.Common where
175
186import Data.Maybe (fromMaybe)
@@ -26,53 +14,68 @@ applyAll = foldl1 (.)
2614replaceIdent :: String -> JS -> JS -> JS
2715replaceIdent var1 js = everywhereOnJS replace
2816 where
29− replace (JSVar var2) | var1 == var2 = js
17+ replace (JSVar _ var2) | var1 == var2 = js
3018 replace other = other
3119
3220replaceIdents :: [(String, JS)] -> JS -> JS
3321replaceIdents vars = everywhereOnJS replace
3422 where
35− replace v@(JSVar var) = fromMaybe v $ lookup var vars
23+ replace v@(JSVar _ var) = fromMaybe v $ lookup var vars
3624 replace other = other
3725
3826isReassigned :: String -> JS -> Bool
3927isReassigned var1 = everythingOnJS (||) check
4028 where
4129 check :: JS -> Bool
42− check (JSFunction _ args _) | var1 `elem` args = True
43− check (JSVariableIntroduction arg _) | var1 == arg = True
44− check (JSAssignment (JSVar arg) _) | var1 == arg = True
45− check (JSFor arg _ _ _) | var1 == arg = True
46− check (JSForIn arg _ _) | var1 == arg = True
30+ check (JSFunction _ _ args _) | var1 `elem` args = True
31+ check (JSVariableIntroduction _ arg _) | var1 == arg = True
32+ check (JSAssignment _ (JSVar _ arg) _) | var1 == arg = True
33+ check (JSFor _ arg _ _ _) | var1 == arg = True
34+ check (JSForIn _ arg _ _) | var1 == arg = True
4735 check _ = False
4836
4937isRebound :: JS -> JS -> Bool
5038isRebound js d = any (\v -> isReassigned v d || isUpdated v d) (everythingOnJS (++) variablesOf js)
5139 where
52− variablesOf (JSVar var) = [var]
40+ variablesOf (JSVar _ var) = [var]
5341 variablesOf _ = []
5442
5543isUsed :: String -> JS -> Bool
5644isUsed var1 = everythingOnJS (||) check
5745 where
5846 check :: JS -> Bool
59− check (JSVar var2) | var1 == var2 = True
60− check (JSAssignment target _) | var1 == targetVariable target = True
47+ check (JSVar _ var2) | var1 == var2 = True
48+ check (JSAssignment _ target _) | var1 == targetVariable target = True
6149 check _ = False
6250
6351targetVariable :: JS -> String
64−targetVariable (JSVar var) = var
65−targetVariable (JSAccessor _ tgt) = targetVariable tgt
66−targetVariable (JSIndexer _ tgt) = targetVariable tgt
52+targetVariable (JSVar _ var) = var
53+targetVariable (JSAccessor _ _ tgt) = targetVariable tgt
54+targetVariable (JSIndexer _ _ tgt) = targetVariable tgt
6755targetVariable _ = internalError "Invalid argument to targetVariable"
6856
6957isUpdated :: String -> JS -> Bool
7058isUpdated var1 = everythingOnJS (||) check
7159 where
7260 check :: JS -> Bool
73− check (JSAssignment target _) | var1 == targetVariable target = True
61+ check (JSAssignment _ target _) | var1 == targetVariable target = True
7462 check _ = False
7563
7664removeFromBlock :: ([JS] -> [JS]) -> JS -> JS
77−removeFromBlock go (JSBlock sts) = JSBlock (go sts)
65+removeFromBlock go (JSBlock ss sts) = JSBlock ss (go sts)
7866removeFromBlock _ js = js
67+
68+isFn :: (String, String) -> JS -> Bool
69+isFn (moduleName, fnName) (JSAccessor _ x (JSVar _ y)) = x == fnName && y == moduleName
70+isFn (moduleName, fnName) (JSIndexer _ (JSStringLiteral _ x) (JSVar _ y)) = x == fnName && y == moduleName
71+isFn _ _ = False
72+
73+isFn' :: [(String, String)] -> JS -> Bool
74+isFn' xs js = any (`isFn` js) xs
75+
76+isDict :: (String, String) -> JS -> Bool
77+isDict (moduleName, dictName) (JSAccessor _ x (JSVar _ y)) = x == dictName && y == moduleName
78+isDict _ _ = False
79+
80+isDict' :: [(String, String)] -> JS -> Bool
81+isDict' xs js = any (`isDict` js) xs
src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs+223−171
@@ -1,28 +1,16 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.CodeGen.JS.Optimizer.Inliner
4−-- Copyright : (c) Phil Freeman 2013-14
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
111-- |
122-- This module provides basic inlining capabilities
133--
14−-----------------------------------------------------------------------------
15−
16−module Language.PureScript.CodeGen.JS.Optimizer.Inliner (
17− inlineVariables,
18− inlineValues,
19− inlineOperator,
20− inlineCommonOperators,
21− inlineFnComposition,
22− etaConvert,
23− unThunk,
24− evaluateIifes
25−) where
4+module Language.PureScript.CodeGen.JS.Optimizer.Inliner
5+ ( inlineVariables
6+ , inlineCommonValues
7+ , inlineOperator
8+ , inlineCommonOperators
9+ , inlineFnComposition
10+ , etaConvert
11+ , unThunk
12+ , evaluateIifes
13+ ) where
2614
2715import Prelude ()
2816import Prelude.Compat
@@ -41,42 +29,42 @@ import qualified Language.PureScript.Constants as C
4129-- Needs to be: { 0..toFixed(10); }
4230-- Probably needs to be fixed in pretty-printer instead.
4331shouldInline :: JS -> Bool
44−shouldInline (JSVar _) = True
45−shouldInline (JSNumericLiteral _) = True
46−shouldInline (JSStringLiteral _) = True
47−shouldInline (JSBooleanLiteral _) = True
48−shouldInline (JSAccessor _ val) = shouldInline val
49−shouldInline (JSIndexer index val) = shouldInline index && shouldInline val
32+shouldInline (JSVar _ _) = True
33+shouldInline (JSNumericLiteral _ _) = True
34+shouldInline (JSStringLiteral _ _) = True
35+shouldInline (JSBooleanLiteral _ _) = True
36+shouldInline (JSAccessor _ _ val) = shouldInline val
37+shouldInline (JSIndexer _ index val) = shouldInline index && shouldInline val
5038shouldInline _ = False
5139
5240etaConvert :: JS -> JS
5341etaConvert = everywhereOnJS convert
5442 where
5543 convert :: JS -> JS
56− convert (JSBlock [JSReturn (JSApp (JSFunction Nothing idents block@(JSBlock body)) args)])
44+ convert (JSBlock ss [JSReturn _ (JSApp _ (JSFunction _ Nothing idents block@(JSBlock _ body)) args)])
5745 | all shouldInline args &&
58− not (any (`isRebound` block) (map JSVar idents)) &&
46+ not (any (`isRebound` block) (map (JSVar Nothing) idents)) &&
5947 not (any (`isRebound` block) args)
60− = JSBlock (map (replaceIdents (zip idents args)) body)
61− convert (JSFunction Nothing [] (JSBlock [JSReturn (JSApp fn [])])) = fn
48+ = JSBlock ss (map (replaceIdents (zip idents args)) body)
49+ convert (JSFunction _ Nothing [] (JSBlock _ [JSReturn _ (JSApp _ fn [])])) = fn
6250 convert js = js
6351
6452unThunk :: JS -> JS
6553unThunk = everywhereOnJS convert
6654 where
6755 convert :: JS -> JS
68− convert (JSBlock []) = JSBlock []
69− convert (JSBlock jss) =
56+ convert (JSBlock ss []) = JSBlock ss []
57+ convert (JSBlock ss jss) =
7058 case last jss of
71− JSReturn (JSApp (JSFunction Nothing [] (JSBlock body)) []) -> JSBlock $ init jss ++ body
72− _ -> JSBlock jss
59+ JSReturn _ (JSApp _ (JSFunction _ Nothing [] (JSBlock _ body)) []) -> JSBlock ss $ init jss ++ body
60+ _ -> JSBlock ss jss
7361 convert js = js
7462
7563evaluateIifes :: JS -> JS
7664evaluateIifes = everywhereOnJS convert
7765 where
7866 convert :: JS -> JS
79− convert (JSApp (JSFunction Nothing [] (JSBlock [JSReturn ret])) []) = ret
67+ convert (JSApp _ (JSFunction _ Nothing [] (JSBlock _ [JSReturn _ ret])) []) = ret
8068 convert js = js
8169
8270inlineVariables :: JS -> JS
@@ -84,85 +72,96 @@ inlineVariables = everywhereOnJS $ removeFromBlock go
8472 where
8573 go :: [JS] -> [JS]
8674 go [] = []
87− go (JSVariableIntroduction var (Just js) : sts)
75+ go (JSVariableIntroduction _ var (Just js) : sts)
8876 | shouldInline js && not (any (isReassigned var) sts) && not (any (isRebound js) sts) && not (any (isUpdated var) sts) =
8977 go (map (replaceIdent var js) sts)
9078 go (s:sts) = s : go sts
9179
92−inlineValues :: JS -> JS
93−inlineValues = everywhereOnJS convert
80+inlineCommonValues :: JS -> JS
81+inlineCommonValues = everywhereOnJS convert
9482 where
9583 convert :: JS -> JS
96− convert (JSApp fn [dict]) | isDict semiringNumber dict && isFn fnZero fn = JSNumericLiteral (Left 0)
97− | isDict semiringNumber dict && isFn fnOne fn = JSNumericLiteral (Left 1)
98− | isDict semiringInt dict && isFn fnZero fn = JSNumericLiteral (Left 0)
99− | isDict semiringInt dict && isFn fnOne fn = JSNumericLiteral (Left 1)
100− | isDict boundedBoolean dict && isFn fnBottom fn = JSBooleanLiteral False
101− | isDict boundedBoolean dict && isFn fnTop fn = JSBooleanLiteral True
102− convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y])
103− | isDict semiringInt dict && isFn fnAdd fn = JSBinary BitwiseOr (JSBinary Add x y) (JSNumericLiteral (Left 0))
104− | isDict semiringInt dict && isFn fnMultiply fn = JSBinary BitwiseOr (JSBinary Multiply x y) (JSNumericLiteral (Left 0))
105− | isDict moduloSemiringInt dict && isFn fnDivide fn = JSBinary BitwiseOr (JSBinary Divide x y) (JSNumericLiteral (Left 0))
106− | isDict ringInt dict && isFn fnSubtract fn = JSBinary BitwiseOr (JSBinary Subtract x y) (JSNumericLiteral (Left 0))
84+ convert (JSApp ss fn [dict])
85+ | isDict' (semiringNumber ++ semiringInt) dict && isFn' fnZero fn = JSNumericLiteral ss (Left 0)
86+ | isDict' (semiringNumber ++ semiringInt) dict && isFn' fnOne fn = JSNumericLiteral ss (Left 1)
87+ | isDict' boundedBoolean dict && isFn' fnBottom fn = JSBooleanLiteral ss False
88+ | isDict' boundedBoolean dict && isFn' fnTop fn = JSBooleanLiteral ss True
89+ convert (JSApp ss (JSApp _ (JSApp _ fn [dict]) [x]) [y])
90+ | isDict' semiringInt dict && isFn' fnAdd fn = intOp ss Add x y
91+ | isDict' semiringInt dict && isFn' fnMultiply fn = intOp ss Multiply x y
92+ | isDict' moduloSemiringInt dict && isFn' fnDivide fn = intOp ss Divide x y
93+ | isDict' ringInt dict && isFn' fnSubtract fn = intOp ss Subtract x y
10794 convert other = other
108− fnZero = (C.prelude, C.zero)
109− fnOne = (C.prelude, C.one)
110− fnBottom = (C.prelude, C.bottom)
111− fnTop = (C.prelude, C.top)
112− fnAdd = (C.prelude, (C.+))
113− fnDivide = (C.prelude, (C./))
114− fnMultiply = (C.prelude, (C.*))
115− fnSubtract = (C.prelude, (C.-))
95+ fnZero = [(C.prelude, C.zero), (C.dataSemiring, C.zero)]
96+ fnOne = [(C.prelude, C.one), (C.dataSemiring, C.one)]
97+ fnBottom = [(C.prelude, C.bottom), (C.dataBounded, C.bottom)]
98+ fnTop = [(C.prelude, C.top), (C.dataBounded, C.top)]
99+ fnAdd = [(C.prelude, (C.+)), (C.prelude, (C.add)), (C.dataSemiring, (C.+)), (C.dataSemiring, (C.add))]
100+ fnDivide = [(C.prelude, (C./)), (C.prelude, (C.div)), (C.dataModuloSemiring, C.div)]
101+ fnMultiply = [(C.prelude, (C.*)), (C.prelude, (C.mul)), (C.dataSemiring, (C.*)), (C.dataSemiring, (C.mul))]
102+ fnSubtract = [(C.prelude, (C.-)), (C.prelude, C.sub), (C.dataRing, C.sub)]
103+ intOp ss op x y = JSBinary ss BitwiseOr (JSBinary ss op x y) (JSNumericLiteral ss (Left 0))
116104
117105inlineOperator :: (String, String) -> (JS -> JS -> JS) -> JS -> JS
118106inlineOperator (m, op) f = everywhereOnJS convert
119107 where
120108 convert :: JS -> JS
121− convert (JSApp (JSApp op' [x]) [y]) | isOp op' = f x y
109+ convert (JSApp _ (JSApp _ op' [x]) [y]) | isOp op' = f x y
122110 convert other = other
123− isOp (JSAccessor longForm (JSVar m')) = m == m' && longForm == identToJs (Op op)
124− isOp (JSIndexer (JSStringLiteral op') (JSVar m')) = m == m' && op == op'
111+ isOp (JSAccessor _ longForm (JSVar _ m')) = m == m' && longForm == identToJs (Op op)
112+ isOp (JSIndexer _ (JSStringLiteral _ op') (JSVar _ m')) = m == m' && op == op'
125113 isOp _ = False
126114
127115inlineCommonOperators :: JS -> JS
128116inlineCommonOperators = applyAll $
129− [ binary semiringNumber (C.+) Add
130− , binary semiringNumber (C.*) Multiply
131−
132− , binary ringNumber (C.-) Subtract
133− , unary ringNumber C.negate Negate
134− , binary ringInt (C.-) Subtract
135− , unary ringInt C.negate Negate
136−
137− , binary moduloSemiringNumber (C./) Divide
138− , binary moduloSemiringInt C.mod Modulus
139−
140− , binary eqNumber (C.==) EqualTo
141− , binary eqNumber (C./=) NotEqualTo
142− , binary eqInt (C.==) EqualTo
143− , binary eqInt (C./=) NotEqualTo
144− , binary eqString (C.==) EqualTo
145− , binary eqString (C./=) NotEqualTo
146− , binary eqBoolean (C.==) EqualTo
147− , binary eqBoolean (C./=) NotEqualTo
148−
149− , binary ordNumber (C.<) LessThan
150− , binary ordNumber (C.>) GreaterThan
151− , binary ordNumber (C.<=) LessThanOrEqualTo
152− , binary ordNumber (C.>=) GreaterThanOrEqualTo
153− , binary ordInt (C.<) LessThan
154− , binary ordInt (C.>) GreaterThan
155− , binary ordInt (C.<=) LessThanOrEqualTo
156− , binary ordInt (C.>=) GreaterThanOrEqualTo
157−
158− , binary semigroupString (C.<>) Add
159− , binary semigroupString (C.++) Add
160−
161− , binary booleanAlgebraBoolean (C.&&) And
162− , binary booleanAlgebraBoolean (C.||) Or
163− , binaryFunction booleanAlgebraBoolean C.conj And
164− , binaryFunction booleanAlgebraBoolean C.disj Or
165− , unary booleanAlgebraBoolean C.not Not
117+ [ binary semiringNumber opAdd Add
118+ , binary semiringNumber opMul Multiply
119+
120+ , binary ringNumber opSub Subtract
121+ , unary ringNumber opNegate Negate
122+ , binary ringInt opSub Subtract
123+ , unary ringInt opNegate Negate
124+
125+ , binary moduloSemiringNumber opDiv Divide
126+ , binary moduloSemiringInt opMod Modulus
127+
128+ , binary eqNumber opEq EqualTo
129+ , binary eqNumber opNotEq NotEqualTo
130+ , binary eqInt opEq EqualTo
131+ , binary eqInt opNotEq NotEqualTo
132+ , binary eqString opEq EqualTo
133+ , binary eqString opNotEq NotEqualTo
134+ , binary eqChar opEq EqualTo
135+ , binary eqChar opNotEq NotEqualTo
136+ , binary eqBoolean opEq EqualTo
137+ , binary eqBoolean opNotEq NotEqualTo
138+
139+ , binary ordBoolean opLessThan LessThan
140+ , binary ordBoolean opLessThanOrEq LessThanOrEqualTo
141+ , binary ordBoolean opGreaterThan GreaterThan
142+ , binary ordBoolean opGreaterThanOrEq GreaterThanOrEqualTo
143+ , binary ordChar opLessThan LessThan
144+ , binary ordChar opLessThanOrEq LessThanOrEqualTo
145+ , binary ordChar opGreaterThan GreaterThan
146+ , binary ordChar opGreaterThanOrEq GreaterThanOrEqualTo
147+ , binary ordInt opLessThan LessThan
148+ , binary ordInt opLessThanOrEq LessThanOrEqualTo
149+ , binary ordInt opGreaterThan GreaterThan
150+ , binary ordInt opGreaterThanOrEq GreaterThanOrEqualTo
151+ , binary ordNumber opLessThan LessThan
152+ , binary ordNumber opLessThanOrEq LessThanOrEqualTo
153+ , binary ordNumber opGreaterThan GreaterThan
154+ , binary ordNumber opGreaterThanOrEq GreaterThanOrEqualTo
155+ , binary ordString opLessThan LessThan
156+ , binary ordString opLessThanOrEq LessThanOrEqualTo
157+ , binary ordString opGreaterThan GreaterThan
158+ , binary ordString opGreaterThanOrEq GreaterThanOrEqualTo
159+
160+ , binary semigroupString opAppend Add
161+
162+ , binary booleanAlgebraBoolean opConj And
163+ , binary booleanAlgebraBoolean opDisj Or
164+ , unary booleanAlgebraBoolean opNot Not
166165
167166 , binary' C.dataIntBits (C..|.) BitwiseOr
168167 , binary' C.dataIntBits (C..&.) BitwiseAnd
@@ -174,59 +173,53 @@ inlineCommonOperators = applyAll $
174173 ] ++
175174 [ fn | i <- [0..10], fn <- [ mkFn i, runFn i ] ]
176175 where
177− binary :: (String, String) -> String -> BinaryOperator -> JS -> JS
178− binary dict opString op = everywhereOnJS convert
176+ binary :: [(String, String)] -> [(String, String)] -> BinaryOperator -> JS -> JS
177+ binary dict fns op = everywhereOnJS convert
179178 where
180179 convert :: JS -> JS
181− convert (JSApp (JSApp (JSApp fn [dict']) [x]) [y]) | isDict dict dict' && isPreludeFn opString fn = JSBinary op x y
180+ convert (JSApp ss (JSApp _ (JSApp _ fn [dict']) [x]) [y]) | isDict' dict dict' && isFn' fns fn = JSBinary ss op x y
182181 convert other = other
183182 binary' :: String -> String -> BinaryOperator -> JS -> JS
184183 binary' moduleName opString op = everywhereOnJS convert
185184 where
186185 convert :: JS -> JS
187− convert (JSApp (JSApp fn [x]) [y]) | isFn (moduleName, opString) fn = JSBinary op x y
188− convert other = other
189− binaryFunction :: (String, String) -> String -> BinaryOperator -> JS -> JS
190− binaryFunction dict fnName op = everywhereOnJS convert
191− where
192− convert :: JS -> JS
193− convert (JSApp (JSApp (JSApp fn [dict']) [x]) [y]) | isPreludeFn fnName fn && isDict dict dict' = JSBinary op x y
186+ convert (JSApp ss (JSApp _ fn [x]) [y]) | isFn (moduleName, opString) fn = JSBinary ss op x y
194187 convert other = other
195− unary :: (String, String) -> String -> UnaryOperator -> JS -> JS
196− unary dict fnName op = everywhereOnJS convert
188+ unary :: [(String, String)] -> [(String, String)] -> UnaryOperator -> JS -> JS
189+ unary dicts fns op = everywhereOnJS convert
197190 where
198191 convert :: JS -> JS
199− convert (JSApp (JSApp fn [dict']) [x]) | isPreludeFn fnName fn && isDict dict dict' = JSUnary op x
192+ convert (JSApp ss (JSApp _ fn [dict']) [x]) | isDict' dicts dict' && isFn' fns fn = JSUnary ss op x
200193 convert other = other
201194 unary' :: String -> String -> UnaryOperator -> JS -> JS
202195 unary' moduleName fnName op = everywhereOnJS convert
203196 where
204197 convert :: JS -> JS
205− convert (JSApp fn [x]) | isFn (moduleName, fnName) fn = JSUnary op x
198+ convert (JSApp ss fn [x]) | isFn (moduleName, fnName) fn = JSUnary ss op x
206199 convert other = other
207200 mkFn :: Int -> JS -> JS
208201 mkFn 0 = everywhereOnJS convert
209202 where
210203 convert :: JS -> JS
211− convert (JSApp mkFnN [JSFunction Nothing [_] (JSBlock js)]) | isNFn C.mkFn 0 mkFnN =
212− JSFunction Nothing [] (JSBlock js)
204+ convert (JSApp _ mkFnN [JSFunction s1 Nothing [_] (JSBlock s2 js)]) | isNFn C.mkFn 0 mkFnN =
205+ JSFunction s1 Nothing [] (JSBlock s2 js)
213206 convert other = other
214207 mkFn n = everywhereOnJS convert
215208 where
216209 convert :: JS -> JS
217− convert orig@(JSApp mkFnN [fn]) | isNFn C.mkFn n mkFnN =
210+ convert orig@(JSApp ss mkFnN [fn]) | isNFn C.mkFn n mkFnN =
218211 case collectArgs n [] fn of
219− Just (args, js) -> JSFunction Nothing args (JSBlock js)
212+ Just (args, js) -> JSFunction ss Nothing args (JSBlock ss js)
220213 Nothing -> orig
221214 convert other = other
222215 collectArgs :: Int -> [String] -> JS -> Maybe ([String], [JS])
223− collectArgs 1 acc (JSFunction Nothing [oneArg] (JSBlock js)) | length acc == n - 1 = Just (reverse (oneArg : acc), js)
224− collectArgs m acc (JSFunction Nothing [oneArg] (JSBlock [JSReturn ret])) = collectArgs (m - 1) (oneArg : acc) ret
216+ collectArgs 1 acc (JSFunction _ Nothing [oneArg] (JSBlock _ js)) | length acc == n - 1 = Just (reverse (oneArg : acc), js)
217+ collectArgs m acc (JSFunction _ Nothing [oneArg] (JSBlock _ [JSReturn _ ret])) = collectArgs (m - 1) (oneArg : acc) ret
225218 collectArgs _ _ _ = Nothing
226219
227220 isNFn :: String -> Int -> JS -> Bool
228− isNFn prefix n (JSVar name) = name == (prefix ++ show n)
229− isNFn prefix n (JSAccessor name (JSVar dataFunction)) | dataFunction == C.dataFunction = name == (prefix ++ show n)
221+ isNFn prefix n (JSVar _ name) = name == (prefix ++ show n)
222+ isNFn prefix n (JSAccessor _ name (JSVar _ dataFunction)) | dataFunction == C.dataFunction = name == (prefix ++ show n)
230223 isNFn _ _ _ = False
231224
232225 runFn :: Int -> JS -> JS
@@ -236,81 +229,140 @@ inlineCommonOperators = applyAll $
236229 convert js = fromMaybe js $ go n [] js
237230
238231 go :: Int -> [JS] -> JS -> Maybe JS
239− go 0 acc (JSApp runFnN [fn]) | isNFn C.runFn n runFnN && length acc == n = Just (JSApp fn acc)
240− go m acc (JSApp lhs [arg]) = go (m - 1) (arg : acc) lhs
232+ go 0 acc (JSApp ss runFnN [fn]) | isNFn C.runFn n runFnN && length acc == n = Just (JSApp ss fn acc)
233+ go m acc (JSApp _ lhs [arg]) = go (m - 1) (arg : acc) lhs
241234 go _ _ _ = Nothing
242235
243236-- (f <<< g $ x) = f (g x)
244237-- (f <<< g) = \x -> f (g x)
245−inlineFnComposition :: (Applicative m, MonadSupply m) => JS -> m JS
238+inlineFnComposition :: (MonadSupply m) => JS -> m JS
246239inlineFnComposition = everywhereOnJSTopDownM convert
247240 where
248241 convert :: (MonadSupply m) => JS -> m JS
249− convert (JSApp (JSApp (JSApp (JSApp fn [dict']) [x]) [y]) [z]) | isFnCompose dict' fn =
250− return $ JSApp x [JSApp y [z]]
251− convert (JSApp (JSApp (JSApp fn [dict']) [x]) [y]) | isFnCompose dict' fn = do
252− arg <- freshName
253− return $ JSFunction Nothing [arg] (JSBlock [JSReturn $ JSApp x [JSApp y [JSVar arg]]])
242+ convert (JSApp s1 (JSApp s2 (JSApp _ (JSApp _ fn [dict']) [x]) [y]) [z])
243+ | isFnCompose dict' fn = return $ JSApp s1 x [JSApp s2 y [z]]
244+ | isFnComposeFlipped dict' fn = return $ JSApp s2 y [JSApp s1 x [z]]
245+ convert (JSApp ss (JSApp _ (JSApp _ fn [dict']) [x]) [y])
246+ | isFnCompose dict' fn = do
247+ arg <- freshName
248+ return $ JSFunction ss Nothing [arg] (JSBlock ss [JSReturn Nothing $ JSApp Nothing x [JSApp Nothing y [JSVar Nothing arg]]])
249+ | isFnComposeFlipped dict' fn = do
250+ arg <- freshName
251+ return $ JSFunction ss Nothing [arg] (JSBlock ss [JSReturn Nothing $ JSApp Nothing y [JSApp Nothing x [JSVar Nothing arg]]])
254252 convert other = return other
255253 isFnCompose :: JS -> JS -> Bool
256− isFnCompose dict' fn = isDict semigroupoidFn dict' && (isPreludeFn (C.<<<) fn || isPreludeFn C.compose fn)
254+ isFnCompose dict' fn = isDict' semigroupoidFn dict' && isFn' fnCompose fn
255+ isFnComposeFlipped :: JS -> JS -> Bool
256+ isFnComposeFlipped dict' fn = isDict' semigroupoidFn dict' && isFn' fnComposeFlipped fn
257+ fnCompose :: [(String, String)]
258+ fnCompose = [(C.prelude, C.compose), (C.prelude, (C.<<<)), (C.controlSemigroupoid, C.compose)]
259+ fnComposeFlipped :: [(String, String)]
260+ fnComposeFlipped = [(C.prelude, (C.>>>)), (C.controlSemigroupoid, C.composeFlipped)]
261+
262+semiringNumber :: [(String, String)]
263+semiringNumber = [(C.prelude, C.semiringNumber), (C.dataSemiring, C.semiringNumber)]
264+
265+semiringInt :: [(String, String)]
266+semiringInt = [(C.prelude, C.semiringInt), (C.dataSemiring, C.semiringInt)]
267+
268+ringNumber :: [(String, String)]
269+ringNumber = [(C.prelude, C.ringNumber), (C.dataRing, C.ringNumber)]
270+
271+ringInt :: [(String, String)]
272+ringInt = [(C.prelude, C.ringInt), (C.dataRing, C.ringInt)]
273+
274+moduloSemiringNumber :: [(String, String)]
275+moduloSemiringNumber = [(C.prelude, C.moduloSemiringNumber), (C.dataModuloSemiring, C.moduloSemiringNumber)]
276+
277+moduloSemiringInt :: [(String, String)]
278+moduloSemiringInt = [(C.prelude, C.moduloSemiringInt), (C.dataModuloSemiring, C.moduloSemiringInt)]
279+
280+eqNumber :: [(String, String)]
281+eqNumber = [(C.prelude, C.eqNumber), (C.dataEq, C.eqNumber)]
282+
283+eqInt :: [(String, String)]
284+eqInt = [(C.prelude, C.eqInt), (C.dataEq, C.eqInt)]
285+
286+eqString :: [(String, String)]
287+eqString = [(C.prelude, C.eqString), (C.dataEq, C.eqString)]
288+
289+eqChar :: [(String, String)]
290+eqChar = [(C.prelude, C.eqChar), (C.dataEq, C.eqChar)]
291+
292+eqBoolean :: [(String, String)]
293+eqBoolean = [(C.prelude, C.eqBoolean), (C.dataEq, C.eqBoolean)]
294+
295+ordBoolean :: [(String, String)]
296+ordBoolean = [(C.prelude, C.ordBoolean), (C.dataOrd, C.ordBoolean)]
297+
298+ordNumber :: [(String, String)]
299+ordNumber = [(C.prelude, C.ordNumber), (C.dataOrd, C.ordNumber)]
300+
301+ordInt :: [(String, String)]
302+ordInt = [(C.prelude, C.ordInt), (C.dataOrd, C.ordInt)]
303+
304+ordString :: [(String, String)]
305+ordString = [(C.prelude, C.ordString), (C.dataOrd, C.ordString)]
306+
307+ordChar :: [(String, String)]
308+ordChar = [(C.prelude, C.ordChar), (C.dataOrd, C.ordChar)]
309+
310+semigroupString :: [(String, String)]
311+semigroupString = [(C.prelude, C.semigroupString), (C.dataSemigroup, C.semigroupString)]
257312
258−isDict :: (String, String) -> JS -> Bool
259−isDict (moduleName, dictName) (JSAccessor x (JSVar y)) = x == dictName && y == moduleName
260−isDict _ _ = False
313+boundedBoolean :: [(String, String)]
314+boundedBoolean = [(C.prelude, C.boundedBoolean), (C.dataBounded, C.boundedBoolean)]
261315
262−isFn :: (String, String) -> JS -> Bool
263−isFn (moduleName, fnName) (JSAccessor x (JSVar y)) = x == fnName && y == moduleName
264−isFn (moduleName, fnName) (JSIndexer (JSStringLiteral x) (JSVar y)) = x == fnName && y == moduleName
265−isFn _ _ = False
316+booleanAlgebraBoolean :: [(String, String)]
317+booleanAlgebraBoolean = [(C.prelude, C.booleanAlgebraBoolean), (C.dataBooleanAlgebra, C.booleanAlgebraBoolean)]
266318
267−isPreludeFn :: String -> JS -> Bool
268−isPreludeFn fnName = isFn (C.prelude, fnName)
319+semigroupoidFn :: [(String, String)]
320+semigroupoidFn = [(C.prelude, C.semigroupoidFn), (C.controlSemigroupoid, C.semigroupoidFn)]
269321
270−semiringNumber :: (String, String)
271−semiringNumber = (C.prelude, C.semiringNumber)
322+opAdd :: [(String, String)]
323+opAdd = [(C.prelude, (C.+)), (C.prelude, C.add), (C.dataSemiring, C.add)]
272324
273−semiringInt :: (String, String)
274−semiringInt = (C.prelude, C.semiringInt)
325+opMul :: [(String, String)]
326+opMul = [(C.prelude, (C.*)), (C.prelude, C.mul), (C.dataSemiring, C.mul)]
275327
276−ringNumber :: (String, String)
277−ringNumber = (C.prelude, C.ringNumber)
328+opEq :: [(String, String)]
329+opEq = [(C.prelude, (C.==)), (C.prelude, C.eq), (C.dataEq, C.eq)]
278330
279−ringInt :: (String, String)
280−ringInt = (C.prelude, C.ringInt)
331+opNotEq :: [(String, String)]
332+opNotEq = [(C.prelude, (C./=)), (C.dataEq, C.notEq)]
281333
282−moduloSemiringNumber :: (String, String)
283−moduloSemiringNumber = (C.prelude, C.moduloSemiringNumber)
334+opLessThan :: [(String, String)]
335+opLessThan = [(C.prelude, (C.<)), (C.dataOrd, C.lessThan)]
284336
285−moduloSemiringInt :: (String, String)
286−moduloSemiringInt = (C.prelude, C.moduloSemiringInt)
337+opLessThanOrEq :: [(String, String)]
338+opLessThanOrEq = [(C.prelude, (C.<=)), (C.dataOrd, C.lessThanOrEq)]
287339
288−eqNumber :: (String, String)
289−eqNumber = (C.prelude, C.eqNumber)
340+opGreaterThan :: [(String, String)]
341+opGreaterThan = [(C.prelude, (C.>)), (C.dataOrd, C.greaterThan)]
290342
291−eqInt :: (String, String)
292−eqInt = (C.prelude, C.eqInt)
343+opGreaterThanOrEq :: [(String, String)]
344+opGreaterThanOrEq = [(C.prelude, (C.>=)), (C.dataOrd, C.greaterThanOrEq)]
293345
294−eqString :: (String, String)
295−eqString = (C.prelude, C.eqNumber)
346+opAppend :: [(String, String)]
347+opAppend = [(C.prelude, (C.<>)), (C.prelude, (C.++)), (C.prelude, C.append), (C.dataSemigroup, C.append)]
296348
297−eqBoolean :: (String, String)
298−eqBoolean = (C.prelude, C.eqNumber)
349+opSub :: [(String, String)]
350+opSub = [(C.prelude, (C.-)), (C.prelude, C.sub), (C.dataRing, C.sub)]
299351
300−ordNumber :: (String, String)
301−ordNumber = (C.prelude, C.ordNumber)
352+opNegate :: [(String, String)]
353+opNegate = [(C.prelude, C.negate), (C.dataRing, C.negate)]
302354
303−ordInt :: (String, String)
304−ordInt = (C.prelude, C.ordInt)
355+opDiv :: [(String, String)]
356+opDiv = [(C.prelude, (C./)), (C.prelude, C.div), (C.dataModuloSemiring, C.div)]
305357
306−semigroupString :: (String, String)
307−semigroupString = (C.prelude, C.semigroupString)
358+opMod :: [(String, String)]
359+opMod = [(C.prelude, C.mod), (C.dataModuloSemiring, C.mod)]
308360
309−boundedBoolean :: (String, String)
310−boundedBoolean = (C.prelude, C.boundedBoolean)
361+opConj :: [(String, String)]
362+opConj = [(C.prelude, (C.&&)), (C.prelude, C.conj), (C.dataBooleanAlgebra, C.conj)]
311363
312−booleanAlgebraBoolean :: (String, String)
313−booleanAlgebraBoolean = (C.prelude, C.booleanAlgebraBoolean)
364+opDisj :: [(String, String)]
365+opDisj = [(C.prelude, (C.||)), (C.prelude, C.disj), (C.dataBooleanAlgebra, C.disj)]
314366
315−semigroupoidFn :: (String, String)
316−semigroupoidFn = (C.prelude, C.semigroupoidFn)
367+opNot :: [(String, String)]
368+opNot = [(C.prelude, C.not), (C.dataBooleanAlgebra, C.not)]
src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs+43−74
@@ -1,29 +1,14 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.CodeGen.JS.Optimizer.MagicDo
4−-- Copyright : (c) Phil Freeman 2013-14
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
111-- |
122-- This module implements the "Magic Do" optimization, which inlines calls to return
133-- and bind for the Eff monad, as well as some of its actions.
144--
15−-----------------------------------------------------------------------------
16−
17−module Language.PureScript.CodeGen.JS.Optimizer.MagicDo (
18− magicDo
19−) where
5+module Language.PureScript.CodeGen.JS.Optimizer.MagicDo (magicDo) where
206
217import Data.List (nub)
228import Data.Maybe (fromJust, isJust)
239
2410import Language.PureScript.CodeGen.JS.AST
25−import Language.PureScript.CodeGen.JS.Common
26−import Language.PureScript.Names
11+import Language.PureScript.CodeGen.JS.Optimizer.Common
2712import Language.PureScript.Options
2813import qualified Language.PureScript.Constants as C
2914
@@ -54,63 +39,47 @@ magicDo' = everywhereOnJS undo . everywhereOnJSTopDown convert
5439 fnName = "__do"
5540 -- Desugar monomorphic calls to >>= and return for the Eff monad
5641 convert :: JS -> JS
57− -- Desugar return
58− convert (JSApp (JSApp ret [val]) []) | isReturn ret = val
59− -- Desugar pure
60− convert (JSApp (JSApp pure' [val]) []) | isPure pure' = val
42+ -- Desugar pure & return
43+ convert (JSApp _ (JSApp _ pure' [val]) []) | isPure pure' = val
6144 -- Desugar >>
62− convert (JSApp (JSApp bind [m]) [JSFunction Nothing [] (JSBlock js)]) | isBind bind =
63− JSFunction (Just fnName) [] $ JSBlock (JSApp m [] : map applyReturns js )
45+ convert (JSApp _ (JSApp _ bind [m]) [JSFunction s1 Nothing [] (JSBlock s2 js)]) | isBind bind =
46+ JSFunction s1 (Just fnName) [] $ JSBlock s2 (JSApp s2 m [] : map applyReturns js )
6447 -- Desugar >>=
65− convert (JSApp (JSApp bind [m]) [JSFunction Nothing [arg] (JSBlock js)]) | isBind bind =
66− JSFunction (Just fnName) [] $ JSBlock (JSVariableIntroduction arg (Just (JSApp m [])) : map applyReturns js)
48+ convert (JSApp _ (JSApp _ bind [m]) [JSFunction s1 Nothing [arg] (JSBlock s2 js)]) | isBind bind =
49+ JSFunction s1 (Just fnName) [] $ JSBlock s2 (JSVariableIntroduction s2 arg (Just (JSApp s2 m [])) : map applyReturns js)
6750 -- Desugar untilE
68− convert (JSApp (JSApp f [arg]) []) | isEffFunc C.untilE f =
69− JSApp (JSFunction Nothing [] (JSBlock [ JSWhile (JSUnary Not (JSApp arg [])) (JSBlock []), JSReturn $ JSObjectLiteral []])) []
51+ convert (JSApp s1 (JSApp _ f [arg]) []) | isEffFunc C.untilE f =
52+ JSApp s1 (JSFunction s1 Nothing [] (JSBlock s1 [ JSWhile s1 (JSUnary s1 Not (JSApp s1 arg [])) (JSBlock s1 []), JSReturn s1 $ JSObjectLiteral s1 []])) []
7053 -- Desugar whileE
71− convert (JSApp (JSApp (JSApp f [arg1]) [arg2]) []) | isEffFunc C.whileE f =
72− JSApp (JSFunction Nothing [] (JSBlock [ JSWhile (JSApp arg1 []) (JSBlock [ JSApp arg2 [] ]), JSReturn $ JSObjectLiteral []])) []
54+ convert (JSApp _ (JSApp _ (JSApp s1 f [arg1]) [arg2]) []) | isEffFunc C.whileE f =
55+ JSApp s1 (JSFunction s1 Nothing [] (JSBlock s1 [ JSWhile s1 (JSApp s1 arg1 []) (JSBlock s1 [ JSApp s1 arg2 [] ]), JSReturn s1 $ JSObjectLiteral s1 []])) []
7356 convert other = other
7457 -- Check if an expression represents a monomorphic call to >>= for the Eff monad
75− isBind (JSApp bindPoly [effDict]) | isBindPoly bindPoly && isEffDict C.bindEffDictionary effDict = True
58+ isBind (JSApp _ fn [dict]) | isDict (C.eff, C.bindEffDictionary) dict && isBindPoly fn = True
7659 isBind _ = False
77− -- Check if an expression represents a monomorphic call to return for the Eff monad
78− isReturn (JSApp retPoly [effDict]) | isRetPoly retPoly && isEffDict C.monadEffDictionary effDict = True
79− isReturn _ = False
80− -- Check if an expression represents a monomorphic call to pure for the Eff applicative
81− isPure (JSApp purePoly [effDict]) | isPurePoly purePoly && isEffDict C.applicativeEffDictionary effDict = True
60+ -- Check if an expression represents a monomorphic call to pure or return for the Eff applicative
61+ isPure (JSApp _ fn [dict]) | isDict (C.eff, C.applicativeEffDictionary) dict && isPurePoly fn = True
8262 isPure _ = False
8363 -- Check if an expression represents the polymorphic >>= function
84− isBindPoly (JSAccessor prop (JSVar prelude)) = prelude == C.prelude && (prop `elem` map identToJs [Ident C.bind, Op (C.>>=)])
85− isBindPoly (JSIndexer (JSStringLiteral bind) (JSVar prelude)) = prelude == C.prelude && (bind `elem` [C.bind, (C.>>=)])
86− isBindPoly _ = False
87− -- Check if an expression represents the polymorphic return function
88− isRetPoly (JSAccessor returnEscaped (JSVar prelude)) = prelude == C.prelude && returnEscaped == C.returnEscaped
89− isRetPoly (JSIndexer (JSStringLiteral return') (JSVar prelude)) = prelude == C.prelude && return' == C.return
90− isRetPoly _ = False
91− -- Check if an expression represents the polymorphic pure function
92− isPurePoly (JSAccessor pure' (JSVar prelude)) = prelude == C.prelude && pure' == C.pure'
93− isPurePoly (JSIndexer (JSStringLiteral pure') (JSVar prelude)) = prelude == C.prelude && pure' == C.pure'
94− isPurePoly _ = False
95− -- Check if an expression represents a function in the Ef module
96− isEffFunc name (JSAccessor name' (JSVar eff)) = eff == C.eff && name == name'
64+ isBindPoly = isFn' [(C.prelude, C.bind), (C.prelude, (C.>>=)), (C.controlBind, C.bind)]
65+ -- Check if an expression represents the polymorphic pure or return function
66+ isPurePoly = isFn' [(C.prelude, C.pure'), (C.prelude, C.return), (C.controlApplicative, C.pure')]
67+ -- Check if an expression represents a function in the Eff module
68+ isEffFunc name (JSAccessor _ name' (JSVar _ eff)) = eff == C.eff && name == name'
9769 isEffFunc _ _ = False
98− -- Check if an expression represents the Monad Eff dictionary
99− isEffDict name (JSVar ident) | ident == name = True
100− isEffDict name (JSAccessor prop (JSVar eff)) = eff == C.eff && prop == name
101− isEffDict _ _ = False
70+
10271 -- Remove __do function applications which remain after desugaring
10372 undo :: JS -> JS
104− undo (JSReturn (JSApp (JSFunction (Just ident) [] body) [])) | ident == fnName = body
73+ undo (JSReturn _ (JSApp _ (JSFunction _ (Just ident) [] body) [])) | ident == fnName = body
10574 undo other = other
10675
10776 applyReturns :: JS -> JS
108− applyReturns (JSReturn ret) = JSReturn (JSApp ret [])
109− applyReturns (JSBlock jss) = JSBlock (map applyReturns jss)
110− applyReturns (JSWhile cond js) = JSWhile cond (applyReturns js)
111− applyReturns (JSFor v lo hi js) = JSFor v lo hi (applyReturns js)
112− applyReturns (JSForIn v xs js) = JSForIn v xs (applyReturns js)
113− applyReturns (JSIfElse cond t f) = JSIfElse cond (applyReturns t) (applyReturns `fmap` f)
77+ applyReturns (JSReturn ss ret) = JSReturn ss (JSApp ss ret [])
78+ applyReturns (JSBlock ss jss) = JSBlock ss (map applyReturns jss)
79+ applyReturns (JSWhile ss cond js) = JSWhile ss cond (applyReturns js)
80+ applyReturns (JSFor ss v lo hi js) = JSFor ss v lo hi (applyReturns js)
81+ applyReturns (JSForIn ss v xs js) = JSForIn ss v xs (applyReturns js)
82+ applyReturns (JSIfElse ss cond t f) = JSIfElse ss cond (applyReturns t) (applyReturns `fmap` f)
11483 applyReturns other = other
11584
11685-- |
@@ -122,7 +91,7 @@ inlineST = everywhereOnJS convertBlock
12291 -- Look for runST blocks and inline the STRefs there.
12392 -- If all STRefs are used in the scope of the same runST, only using { read, write, modify }STRef then
12493 -- we can be more aggressive about inlining, and actually turn STRefs into local variables.
125− convertBlock (JSApp f [arg]) | isSTFunc C.runST f =
94+ convertBlock (JSApp _ f [arg]) | isSTFunc C.runST f =
12695 let refs = nub . findSTRefsIn $ arg
12796 usages = findAllSTUsagesIn arg
12897 allUsagesAreLocalVars = all (\u -> let v = toVar u in isJust v && fromJust v `elem` refs) usages
@@ -132,34 +101,34 @@ inlineST = everywhereOnJS convertBlock
132101 -- Convert a block in a safe way, preserving object wrappers of references,
133102 -- or in a more aggressive way, turning wrappers into local variables depending on the
134103 -- agg(ressive) parameter.
135− convert agg (JSApp f [arg]) | isSTFunc C.newSTRef f =
136− JSFunction Nothing [] (JSBlock [JSReturn $ if agg then arg else JSObjectLiteral [(C.stRefValue, arg)]])
137− convert agg (JSApp (JSApp f [ref]) []) | isSTFunc C.readSTRef f =
138− if agg then ref else JSAccessor C.stRefValue ref
139− convert agg (JSApp (JSApp (JSApp f [ref]) [arg]) []) | isSTFunc C.writeSTRef f =
140− if agg then JSAssignment ref arg else JSAssignment (JSAccessor C.stRefValue ref) arg
141− convert agg (JSApp (JSApp (JSApp f [ref]) [func]) []) | isSTFunc C.modifySTRef f =
142− if agg then JSAssignment ref (JSApp func [ref]) else JSAssignment (JSAccessor C.stRefValue ref) (JSApp func [JSAccessor C.stRefValue ref])
104+ convert agg (JSApp s1 f [arg]) | isSTFunc C.newSTRef f =
105+ JSFunction s1 Nothing [] (JSBlock s1 [JSReturn s1 $ if agg then arg else JSObjectLiteral s1 [(C.stRefValue, arg)]])
106+ convert agg (JSApp _ (JSApp s1 f [ref]) []) | isSTFunc C.readSTRef f =
107+ if agg then ref else JSAccessor s1 C.stRefValue ref
108+ convert agg (JSApp _ (JSApp _ (JSApp s1 f [ref]) [arg]) []) | isSTFunc C.writeSTRef f =
109+ if agg then JSAssignment s1 ref arg else JSAssignment s1 (JSAccessor s1 C.stRefValue ref) arg
110+ convert agg (JSApp _ (JSApp _ (JSApp s1 f [ref]) [func]) []) | isSTFunc C.modifySTRef f =
111+ if agg then JSAssignment s1 ref (JSApp s1 func [ref]) else JSAssignment s1 (JSAccessor s1 C.stRefValue ref) (JSApp s1 func [JSAccessor s1 C.stRefValue ref])
143112 convert _ other = other
144113 -- Check if an expression represents a function in the ST module
145− isSTFunc name (JSAccessor name' (JSVar st)) = st == C.st && name == name'
114+ isSTFunc name (JSAccessor _ name' (JSVar _ st)) = st == C.st && name == name'
146115 isSTFunc _ _ = False
147116 -- Find all ST Refs initialized in this block
148117 findSTRefsIn = everythingOnJS (++) isSTRef
149118 where
150− isSTRef (JSVariableIntroduction ident (Just (JSApp (JSApp f [_]) []))) | isSTFunc C.newSTRef f = [ident]
119+ isSTRef (JSVariableIntroduction _ ident (Just (JSApp _ (JSApp _ f [_]) []))) | isSTFunc C.newSTRef f = [ident]
151120 isSTRef _ = []
152121 -- Find all STRefs used as arguments to readSTRef, writeSTRef, modifySTRef
153122 findAllSTUsagesIn = everythingOnJS (++) isSTUsage
154123 where
155− isSTUsage (JSApp (JSApp f [ref]) []) | isSTFunc C.readSTRef f = [ref]
156− isSTUsage (JSApp (JSApp (JSApp f [ref]) [_]) []) | isSTFunc C.writeSTRef f || isSTFunc C.modifySTRef f = [ref]
124+ isSTUsage (JSApp _ (JSApp _ f [ref]) []) | isSTFunc C.readSTRef f = [ref]
125+ isSTUsage (JSApp _ (JSApp _ (JSApp _ f [ref]) [_]) []) | isSTFunc C.writeSTRef f || isSTFunc C.modifySTRef f = [ref]
157126 isSTUsage _ = []
158127 -- Find all uses of a variable
159128 appearingIn ref = everythingOnJS (++) isVar
160129 where
161− isVar e@(JSVar v) | v == ref = [e]
130+ isVar e@(JSVar _ v) | v == ref = [e]
162131 isVar _ = []
163132 -- Convert a JS value to a String if it is a JSVar
164− toVar (JSVar v) = Just v
133+ toVar (JSVar _ v) = Just v
165134 toVar _ = Nothing
src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs+33−31
@@ -40,7 +40,7 @@ tco' = everywhereOnJS convert
4040 copyVar arg = "__copy_" ++ arg
4141
4242 convert :: JS -> JS
43− convert js@(JSVariableIntroduction name (Just fn@JSFunction {})) =
43+ convert js@(JSVariableIntroduction ss name (Just fn@JSFunction {})) =
4444 let
4545 (argss, body', replace) = collectAllFunctionArgs [] id fn
4646 in case () of
@@ -48,19 +48,19 @@ tco' = everywhereOnJS convert
4848 let
4949 allArgs = concat $ reverse argss
5050 in
51− JSVariableIntroduction name (Just (replace (toLoop name allArgs body')))
51+ JSVariableIntroduction ss name (Just (replace (toLoop name allArgs body')))
5252 | otherwise -> js
5353 convert js = js
5454
5555 collectAllFunctionArgs :: [[String]] -> (JS -> JS) -> JS -> ([[String]], JS, JS -> JS)
56− collectAllFunctionArgs allArgs f (JSFunction ident args (JSBlock (body@(JSReturn _):_))) =
57− collectAllFunctionArgs (args : allArgs) (\b -> f (JSFunction ident (map copyVar args) (JSBlock [b]))) body
58− collectAllFunctionArgs allArgs f (JSFunction ident args body@(JSBlock _)) =
59− (args : allArgs, body, f . JSFunction ident (map copyVar args))
60− collectAllFunctionArgs allArgs f (JSReturn (JSFunction ident args (JSBlock [body]))) =
61− collectAllFunctionArgs (args : allArgs) (\b -> f (JSReturn (JSFunction ident (map copyVar args) (JSBlock [b])))) body
62− collectAllFunctionArgs allArgs f (JSReturn (JSFunction ident args body@(JSBlock _))) =
63− (args : allArgs, body, f . JSReturn . JSFunction ident (map copyVar args))
56+ collectAllFunctionArgs allArgs f (JSFunction s1 ident args (JSBlock s2 (body@(JSReturn _ _):_))) =
57+ collectAllFunctionArgs (args : allArgs) (\b -> f (JSFunction s1 ident (map copyVar args) (JSBlock s2 [b]))) body
58+ collectAllFunctionArgs allArgs f (JSFunction ss ident args body@(JSBlock _ _)) =
59+ (args : allArgs, body, f . JSFunction ss ident (map copyVar args))
60+ collectAllFunctionArgs allArgs f (JSReturn s1 (JSFunction s2 ident args (JSBlock s3 [body]))) =
61+ collectAllFunctionArgs (args : allArgs) (\b -> f (JSReturn s1 (JSFunction s2 ident (map copyVar args) (JSBlock s3 [b])))) body
62+ collectAllFunctionArgs allArgs f (JSReturn s1 (JSFunction s2 ident args body@(JSBlock _ _))) =
63+ (args : allArgs, body, f . JSReturn s1 . JSFunction s2 ident (map copyVar args))
6464 collectAllFunctionArgs allArgs f body = (allArgs, body, f)
6565
6666 isTailCall :: String -> JS -> Bool
@@ -77,51 +77,53 @@ tco' = everywhereOnJS convert
7777 && numSelfCallWithFnArgs == 0
7878 where
7979 countSelfCalls :: JS -> Int
80− countSelfCalls (JSApp (JSVar ident') _) | ident == ident' = 1
80+ countSelfCalls (JSApp _ (JSVar _ ident') _) | ident == ident' = 1
8181 countSelfCalls _ = 0
82−
82+
8383 countSelfCallsInTailPosition :: JS -> Int
84− countSelfCallsInTailPosition (JSReturn ret) | isSelfCall ident ret = 1
84+ countSelfCallsInTailPosition (JSReturn _ ret) | isSelfCall ident ret = 1
8585 countSelfCallsInTailPosition _ = 0
86−
86+
8787 countSelfCallsUnderFunctions :: JS -> Int
88− countSelfCallsUnderFunctions (JSFunction _ _ js') = everythingOnJS (+) countSelfCalls js'
88+ countSelfCallsUnderFunctions (JSFunction _ _ _ js') = everythingOnJS (+) countSelfCalls js'
8989 countSelfCallsUnderFunctions _ = 0
90−
90+
9191 countSelfCallsWithFnArgs :: JS -> Int
9292 countSelfCallsWithFnArgs ret = if isSelfCallWithFnArgs ident ret [] then 1 else 0
9393
9494 toLoop :: String -> [String] -> JS -> JS
95− toLoop ident allArgs js = JSBlock $
96− map (\arg -> JSVariableIntroduction arg (Just (JSVar (copyVar arg)))) allArgs ++
97− [ JSLabel tcoLabel $ JSWhile (JSBooleanLiteral True) (JSBlock [ everywhereOnJS loopify js ]) ]
95+ toLoop ident allArgs js = JSBlock rootSS $
96+ map (\arg -> JSVariableIntroduction rootSS arg (Just (JSVar rootSS (copyVar arg)))) allArgs ++
97+ [ JSLabel rootSS tcoLabel $ JSWhile rootSS (JSBooleanLiteral rootSS True) (JSBlock rootSS [ everywhereOnJS loopify js ]) ]
9898 where
99+ rootSS = Nothing
100+
99101 loopify :: JS -> JS
100− loopify (JSReturn ret) | isSelfCall ident ret =
102+ loopify (JSReturn ss ret) | isSelfCall ident ret =
101103 let
102104 allArgumentValues = concat $ collectSelfCallArgs [] ret
103105 in
104− JSBlock $ zipWith (\val arg ->
105− JSVariableIntroduction (tcoVar arg) (Just val)) allArgumentValues allArgs
106+ JSBlock ss $ zipWith (\val arg ->
107+ JSVariableIntroduction ss (tcoVar arg) (Just val)) allArgumentValues allArgs
106108 ++ map (\arg ->
107− JSAssignment (JSVar arg) (JSVar (tcoVar arg))) allArgs
108− ++ [ JSContinue tcoLabel ]
109+ JSAssignment ss (JSVar ss arg) (JSVar ss (tcoVar arg))) allArgs
110+ ++ [ JSContinue ss tcoLabel ]
109111 loopify other = other
110112 collectSelfCallArgs :: [[JS]] -> JS -> [[JS]]
111− collectSelfCallArgs allArgumentValues (JSApp fn args') = collectSelfCallArgs (args' : allArgumentValues) fn
113+ collectSelfCallArgs allArgumentValues (JSApp _ fn args') = collectSelfCallArgs (args' : allArgumentValues) fn
112114 collectSelfCallArgs allArgumentValues _ = allArgumentValues
113115
114116 isSelfCall :: String -> JS -> Bool
115− isSelfCall ident (JSApp (JSVar ident') _) = ident == ident'
116− isSelfCall ident (JSApp fn _) = isSelfCall ident fn
117+ isSelfCall ident (JSApp _ (JSVar _ ident') _) = ident == ident'
118+ isSelfCall ident (JSApp _ fn _) = isSelfCall ident fn
117119 isSelfCall _ _ = False
118120
119121 isSelfCallWithFnArgs :: String -> JS -> [JS] -> Bool
120− isSelfCallWithFnArgs ident (JSVar ident') args | ident == ident' && any hasFunction args = True
121− isSelfCallWithFnArgs ident (JSApp fn args) acc = isSelfCallWithFnArgs ident fn (args ++ acc)
122+ isSelfCallWithFnArgs ident (JSVar _ ident') args | ident == ident' && any hasFunction args = True
123+ isSelfCallWithFnArgs ident (JSApp _ fn args) acc = isSelfCallWithFnArgs ident fn (args ++ acc)
122124 isSelfCallWithFnArgs _ _ _ = False
123−
124− hasFunction :: JS -> Bool
125+
126+ hasFunction :: JS -> Bool
125127 hasFunction = getAny . everythingOnJS mappend (Any . isFunction)
126128 where
127129 isFunction JSFunction{} = True
src/Language/PureScript/CodeGen/JS/Optimizer/Unused.hs+3−3
@@ -30,17 +30,17 @@ removeCodeAfterReturnStatements = everywhereOnJS (removeFromBlock go)
3030 go :: [JS] -> [JS]
3131 go jss | not (any isJSReturn jss) = jss
3232 | otherwise = let (body, ret : _) = break isJSReturn jss in body ++ [ret]
33− isJSReturn (JSReturn _) = True
33+ isJSReturn (JSReturn _ _) = True
3434 isJSReturn _ = False
3535
3636removeUnusedArg :: JS -> JS
3737removeUnusedArg = everywhereOnJS convert
3838 where
39− convert (JSFunction name [arg] body) | arg == C.__unused = JSFunction name [] body
39+ convert (JSFunction ss name [arg] body) | arg == C.__unused = JSFunction ss name [] body
4040 convert js = js
4141
4242removeUndefinedApp :: JS -> JS
4343removeUndefinedApp = everywhereOnJS convert
4444 where
45− convert (JSApp fn [JSVar arg]) | arg == C.undefined = JSApp fn []
45+ convert (JSApp ss fn [JSVar _ arg]) | arg == C.undefined = JSApp ss fn []
4646 convert js = js
src/Language/PureScript/Comments.hs+3−17
@@ -1,29 +1,15 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.Parser.Comments
4−-- Copyright : (c) Phil Freeman 2015
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
1+{-# LANGUAGE TemplateHaskell #-}
2+
113-- |
124-- Defines the types of source code comments
135--
14−-----------------------------------------------------------------------------
15−
16−{-# LANGUAGE DeriveDataTypeable #-}
17−{-# LANGUAGE TemplateHaskell #-}
18−
196module Language.PureScript.Comments where
207
218import Data.Aeson.TH
22−import qualified Data.Data as D
239
2410data Comment
2511 = LineComment String
2612 | BlockComment String
27− deriving (Show, Read, Eq, Ord, D.Data, D.Typeable)
13+ deriving (Show, Read, Eq, Ord)
2814
2915$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Comment)
src/Language/PureScript/Constants.hs+104−23
@@ -1,18 +1,6 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.Constants
4−-- Copyright : (c) Phil Freeman 2013
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
111-- |
122-- Various constants which refer to things in the Prelude
133--
14−-----------------------------------------------------------------------------
15−
164module Language.PureScript.Constants where
175
186-- Operators
@@ -20,59 +8,110 @@ module Language.PureScript.Constants where
208($) :: String
219($) = "$"
2210
11+apply :: String
12+apply = "apply"
13+
2314(#) :: String
2415(#) = "#"
2516
17+applyFlipped :: String
18+applyFlipped = "applyFlipped"
19+
2620(<>) :: String
2721(<>) = "<>"
2822
2923(++) :: String
3024(++) = "++"
3125
26+append :: String
27+append = "append"
28+
3229(>>=) :: String
3330(>>=) = ">>="
3431
32+bind :: String
33+bind = "bind"
34+
3535(+) :: String
3636(+) = "+"
3737
38+add :: String
39+add = "add"
40+
3841(-) :: String
3942(-) = "-"
4043
44+sub :: String
45+sub = "sub"
46+
4147(*) :: String
4248(*) = "*"
4349
50+mul :: String
51+mul = "mul"
52+
4453(/) :: String
4554(/) = "/"
4655
56+div :: String
57+div = "div"
58+
4759(%) :: String
4860(%) = "%"
4961
62+mod :: String
63+mod = "mod"
64+
5065(<) :: String
5166(<) = "<"
5267
68+lessThan :: String
69+lessThan = "lessThan"
70+
5371(>) :: String
5472(>) = ">"
5573
74+greaterThan :: String
75+greaterThan = "greaterThan"
76+
5677(<=) :: String
5778(<=) = "<="
5879
80+lessThanOrEq :: String
81+lessThanOrEq = "lessThanOrEq"
82+
5983(>=) :: String
6084(>=) = ">="
6185
86+greaterThanOrEq :: String
87+greaterThanOrEq = "greaterThanOrEq"
88+
6289(==) :: String
6390(==) = "=="
6491
92+eq :: String
93+eq = "eq"
94+
6595(/=) :: String
6696(/=) = "/="
6797
98+notEq :: String
99+notEq = "notEq"
100+
101+compare :: String
102+compare = "compare"
103+
68104(&&) :: String
69105(&&) = "&&"
70106
107+conj :: String
108+conj = "conj"
109+
71110(||) :: String
72111(||) = "||"
73112
74−bind :: String
75−bind = "bind"
113+disj :: String
114+disj = "disj"
76115
77116unsafeIndex :: String
78117unsafeIndex = "unsafeIndex"
@@ -92,6 +131,12 @@ unsafeIndex = "unsafeIndex"
92131compose :: String
93132compose = "compose"
94133
134+(>>>) :: String
135+(>>>) = ">>>"
136+
137+composeFlipped :: String
138+composeFlipped = "composeFlipped"
139+
95140-- Functions
96141
97142negate :: String
@@ -100,15 +145,6 @@ negate = "negate"
100145not :: String
101146not = "not"
102147
103−conj :: String
104−conj = "conj"
105−
106−disj :: String
107−disj = "disj"
108−
109−mod :: String
110−mod = "mod"
111−
112148shl :: String
113149shl = "shl"
114150
@@ -211,12 +247,21 @@ moduloSemiringNumber = "moduloSemiringNumber"
211247moduloSemiringInt :: String
212248moduloSemiringInt = "moduloSemiringInt"
213249
250+ordBoolean :: String
251+ordBoolean = "ordBoolean"
252+
214253ordNumber :: String
215254ordNumber = "ordNumber"
216255
217256ordInt :: String
218257ordInt = "ordInt"
219258
259+ordString :: String
260+ordString = "ordString"
261+
262+ordChar :: String
263+ordChar = "ordChar"
264+
220265eqNumber :: String
221266eqNumber = "eqNumber"
222267
@@ -226,6 +271,9 @@ eqInt = "eqInt"
226271eqString :: String
227272eqString = "eqString"
228273
274+eqChar :: String
275+eqChar = "eqChar"
276+
229277eqBoolean :: String
230278eqBoolean = "eqBoolean"
231279
@@ -285,6 +333,39 @@ eff = "Control_Monad_Eff"
285333st :: String
286334st = "Control_Monad_ST"
287335
336+controlApplicative :: String
337+controlApplicative = "Control_Applicative"
338+
339+controlSemigroupoid :: String
340+controlSemigroupoid = "Control_Semigroupoid"
341+
342+controlBind :: String
343+controlBind = "Control_Bind"
344+
345+dataBounded :: String
346+dataBounded = "Data_Bounded"
347+
348+dataSemigroup :: String
349+dataSemigroup = "Data_Semigroup"
350+
351+dataModuloSemiring :: String
352+dataModuloSemiring = "Data_ModuloSemiring"
353+
354+dataBooleanAlgebra :: String
355+dataBooleanAlgebra = "Data_BooleanAlgebra"
356+
357+dataEq :: String
358+dataEq = "Data_Eq"
359+
360+dataOrd :: String
361+dataOrd = "Data_Ord"
362+
363+dataSemiring :: String
364+dataSemiring = "Data_Semiring"
365+
366+dataRing :: String
367+dataRing = "Data_Ring"
368+
288369dataFunction :: String
289370dataFunction = "Data_Function"
290371
src/Language/PureScript/CoreFn.hs+3−14
@@ -1,17 +1,6 @@
1−-----------------------------------------------------------------------------
1+-- |
2+-- The core functional representation
23--
3−-- Module : Language.PureScript.CoreFn
4−-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- | The core functional representation
12−--
13−-----------------------------------------------------------------------------
14−
154module Language.PureScript.CoreFn (
165 module C
176) where
@@ -20,7 +9,7 @@ import Language.PureScript.CoreFn.Ann as C
209import Language.PureScript.CoreFn.Binders as C
2110import Language.PureScript.CoreFn.Desugar as C
2211import Language.PureScript.CoreFn.Expr as C
23−import Language.PureScript.CoreFn.Literals as C
12+import Language.PureScript.AST.Literals as C
2413import Language.PureScript.CoreFn.Meta as C
2514import Language.PureScript.CoreFn.Module as C
2615import Language.PureScript.CoreFn.Traversals as C
src/Language/PureScript/CoreFn/Binders.hs+15−21
@@ -1,25 +1,11 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.CoreFn.Binders
4−-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- | The core functional representation for binders
12−--
13−-----------------------------------------------------------------------------
14−
15−{-# LANGUAGE DeriveDataTypeable #-}
161{-# LANGUAGE DeriveFunctor #-}
172
3+-- |
4+-- The core functional representation for binders
5+--
186module Language.PureScript.CoreFn.Binders where
197
20−import qualified Data.Data as D
21−
22−import Language.PureScript.CoreFn.Literals
8+import Language.PureScript.AST.Literals
239import Language.PureScript.Names
2410
2511-- |
@@ -39,10 +25,18 @@ data Binder a
3925 --
4026 | VarBinder a Ident
4127 -- |
42− -- A binder which matches a data constructor (type name, constructor name, binders)
28+ -- A binder which matches a data constructor
4329 --
44− | ConstructorBinder a (Qualified ProperName) (Qualified ProperName) [Binder a]
30+ | ConstructorBinder a (Qualified (ProperName 'TypeName)) (Qualified (ProperName 'ConstructorName)) [Binder a]
4531 -- |
4632 -- A binder which binds its input to an identifier
4733 --
48− | NamedBinder a Ident (Binder a) deriving (Show, Read, D.Data, D.Typeable, Functor)
34+ | NamedBinder a Ident (Binder a) deriving (Show, Read, Functor)
35+
36+
37+extractBinderAnn :: Binder a -> a
38+extractBinderAnn (NullBinder a) = a
39+extractBinderAnn (LiteralBinder a _) = a
40+extractBinderAnn (VarBinder a _) = a
41+extractBinderAnn (ConstructorBinder a _ _ _) = a
42+extractBinderAnn (NamedBinder a _ _) = a
src/Language/PureScript/CoreFn/Desugar.hs+67−50
@@ -1,5 +1,9 @@
11module Language.PureScript.CoreFn.Desugar (moduleToCoreFn) where
22
3+import Prelude ()
4+import Prelude.Compat
5+
6+
37import Data.Function (on)
48import Data.List (sort, sortBy, nub)
59import Data.Maybe (mapMaybe)
@@ -13,7 +17,7 @@ import Language.PureScript.AST.Traversals
1317import Language.PureScript.CoreFn.Ann
1418import Language.PureScript.CoreFn.Binders
1519import Language.PureScript.CoreFn.Expr
16−import Language.PureScript.CoreFn.Literals
20+import Language.PureScript.AST.Literals
1721import Language.PureScript.CoreFn.Meta
1822import Language.PureScript.CoreFn.Module
1923import Language.PureScript.Environment
@@ -30,37 +34,52 @@ moduleToCoreFn :: Environment -> A.Module -> Module Ann
3034moduleToCoreFn _ (A.Module _ _ _ _ Nothing) =
3135 internalError "Module exports were not elaborated before moduleToCoreFn"
3236moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =
33− let imports = nub $ mapMaybe importToCoreFn decls ++ findQualModules decls
37+ let imports = mapMaybe importToCoreFn decls ++ findQualModules decls
38+ imports' = nub $ filter (keepImp imports) imports-- TODO could be more efficient
3439 exps' = nub $ concatMap exportToCoreFn exps
3540 externs = nub $ mapMaybe externToCoreFn decls
3641 decls' = concatMap (declToCoreFn Nothing []) decls
37− in Module coms mn imports exps' externs decls'
42+ in Module coms mn imports' exps' externs decls'
3843
3944 where
4045
46+ -- Remove duplicate imports favoring the one containing sourcespan info
47+ keepImp :: [(Ann, ModuleName)] -> (Ann, ModuleName) -> Bool
48+ keepImp imps (a, i) = hasSS a || not (any hasDup imps)
49+ where
50+ hasDup (a', i') = i == i' && hasSS a'
51+
52+ hasSS :: Ann -> Bool
53+ hasSS (Just _, _, _, _) = True
54+ hasSS _ = False
55+
56+ ssA :: Maybe SourceSpan -> Ann
57+ ssA ss = (ss, [], Nothing, Nothing)
58+
4159 -- |
4260 -- Desugars member declarations from AST to CoreFn representation.
4361 --
4462 declToCoreFn :: Maybe SourceSpan -> [Comment] -> A.Declaration -> [Bind Ann]
4563 declToCoreFn ss com (A.DataDeclaration Newtype _ _ [(ctor, _)]) =
46− [NonRec (properToIdent ctor) $
64+ [NonRec (ssA ss) (properToIdent ctor) $
4765 Abs (ss, com, Nothing, Just IsNewtype) (Ident "x") (Var nullAnn $ Qualified Nothing (Ident "x"))]
4866 declToCoreFn _ _ d@(A.DataDeclaration Newtype _ _ _) =
4967 error $ "Found newtype with multiple constructors: " ++ show d
5068 declToCoreFn ss com (A.DataDeclaration Data tyName _ ctors) =
5169 flip map ctors $ \(ctor, _) ->
5270 let (_, _, _, fields) = lookupConstructor env (Qualified (Just mn) ctor)
53− in NonRec (properToIdent ctor) $ Constructor (ss, com, Nothing, Nothing) tyName ctor fields
71+ in NonRec (ssA ss) (properToIdent ctor) $ Constructor (ss, com, Nothing, Nothing) tyName ctor fields
5472 declToCoreFn ss _ (A.DataBindingGroupDeclaration ds) = concatMap (declToCoreFn ss []) ds
5573 declToCoreFn ss com (A.ValueDeclaration name _ _ (Right e)) =
56− [NonRec name (exprToCoreFn ss com Nothing e)]
74+ [NonRec (ssA ss) name (exprToCoreFn ss com Nothing e)]
5775 declToCoreFn ss com (A.FixityDeclaration _ name (Just alias)) =
58− let qname = Qualified (Just mn) alias
59− in [NonRec (Op name) (Var (ss, com, Nothing, getValueMeta qname) (Qualified Nothing alias))]
76+ let meta = either getValueMeta (Just . getConstructorMeta) alias
77+ alias' = either id (fmap properToIdent) alias
78+ in [NonRec (ssA ss) (Op name) (Var (ss, com, Nothing, meta) alias')]
6079 declToCoreFn ss _ (A.BindingGroupDeclaration ds) =
61− [Rec $ map (\(name, _, e) -> (name, exprToCoreFn ss [] Nothing e)) ds]
80+ [Rec $ map (\(name, _, e) -> ((ssA ss, name), exprToCoreFn ss [] Nothing e)) ds]
6281 declToCoreFn ss com (A.TypeClassDeclaration name _ supers members) =
63− [NonRec (properToIdent name) $ mkTypeClassConstructor ss com supers members]
82+ [NonRec (ssA ss) (properToIdent name) $ mkTypeClassConstructor ss com supers members]
6483 declToCoreFn _ com (A.PositionedDeclaration ss com1 d) =
6584 declToCoreFn (Just ss) (com ++ com1) d
6685 declToCoreFn _ _ _ = []
@@ -69,18 +88,8 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =
6988 -- Desugars expressions from AST to CoreFn representation.
7089 --
7190 exprToCoreFn :: Maybe SourceSpan -> [Comment] -> Maybe Type -> A.Expr -> Expr Ann
72− exprToCoreFn ss com ty (A.NumericLiteral v) =
73− Literal (ss, com, ty, Nothing) (NumericLiteral v)
74− exprToCoreFn ss com ty (A.StringLiteral v) =
75− Literal (ss, com, ty, Nothing) (StringLiteral v)
76− exprToCoreFn ss com ty (A.CharLiteral v) =
77− Literal (ss, com, ty, Nothing) (CharLiteral v)
78− exprToCoreFn ss com ty (A.BooleanLiteral v) =
79− Literal (ss, com, ty, Nothing) (BooleanLiteral v)
80− exprToCoreFn ss com ty (A.ArrayLiteral vs) =
81− Literal (ss, com, ty, Nothing) (ArrayLiteral $ map (exprToCoreFn ss [] Nothing) vs)
82− exprToCoreFn ss com ty (A.ObjectLiteral vs) =
83− Literal (ss, com, ty, Nothing) (ObjectLiteral $ map (second (exprToCoreFn ss [] Nothing)) vs)
91+ exprToCoreFn ss com ty (A.Literal lit) =
92+ Literal (ss, com, ty, Nothing) (fmap (exprToCoreFn ss com Nothing) lit)
8493 exprToCoreFn ss com ty (A.Accessor name v) =
8594 Accessor (ss, com, ty, Nothing) name (exprToCoreFn ss [] Nothing v)
8695 exprToCoreFn ss com ty (A.ObjectUpdate obj vs) =
@@ -107,7 +116,7 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =
107116 exprToCoreFn ss com (Just ty) v
108117 exprToCoreFn ss com ty (A.Let ds v) =
109118 Let (ss, com, ty, Nothing) (concatMap (declToCoreFn ss []) ds) (exprToCoreFn ss [] Nothing v)
110− exprToCoreFn ss com _ (A.TypeClassDictionaryConstructorApp name (A.TypedValue _ (A.ObjectLiteral vs) _)) =
119+ exprToCoreFn ss com _ (A.TypeClassDictionaryConstructorApp name (A.TypedValue _ (A.Literal (A.ObjectLiteral vs)) _)) =
111120 let args = map (exprToCoreFn ss [] Nothing . snd) $ sortBy (compare `on` fst) vs
112121 ctor = Var (ss, [], Nothing, Just IsTypeClassConstructor) (fmap properToIdent name)
113122 in foldl (App (ss, com, Nothing, Nothing)) ctor args
@@ -133,31 +142,27 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =
133142 -- Desugars case binders from AST to CoreFn representation.
134143 --
135144 binderToCoreFn :: Maybe SourceSpan -> [Comment] -> A.Binder -> Binder Ann
145+ binderToCoreFn ss com (A.LiteralBinder lit) =
146+ LiteralBinder (ss, com, Nothing, Nothing) (fmap (binderToCoreFn ss com) lit)
136147 binderToCoreFn ss com (A.NullBinder) =
137148 NullBinder (ss, com, Nothing, Nothing)
138− binderToCoreFn ss com (A.BooleanBinder b) =
139− LiteralBinder (ss, com, Nothing, Nothing) (BooleanLiteral b)
140− binderToCoreFn ss com (A.StringBinder s) =
141− LiteralBinder (ss, com, Nothing, Nothing) (StringLiteral s)
142− binderToCoreFn ss com (A.CharBinder c) =
143− LiteralBinder (ss, com, Nothing, Nothing) (CharLiteral c)
144− binderToCoreFn ss com (A.NumberBinder n) =
145− LiteralBinder (ss, com, Nothing, Nothing) (NumericLiteral n)
146149 binderToCoreFn ss com (A.VarBinder name) =
147150 VarBinder (ss, com, Nothing, Nothing) name
148151 binderToCoreFn ss com (A.ConstructorBinder dctor@(Qualified mn' _) bs) =
149152 let (_, tctor, _, _) = lookupConstructor env dctor
150153 in ConstructorBinder (ss, com, Nothing, Just $ getConstructorMeta dctor) (Qualified mn' tctor) dctor (map (binderToCoreFn ss []) bs)
151− binderToCoreFn ss com (A.ObjectBinder bs) =
152− LiteralBinder (ss, com, Nothing, Nothing) (ObjectLiteral $ map (second (binderToCoreFn ss [])) bs)
153− binderToCoreFn ss com (A.ArrayBinder bs) =
154− LiteralBinder (ss, com, Nothing, Nothing) (ArrayLiteral $ map (binderToCoreFn ss []) bs)
155154 binderToCoreFn ss com (A.NamedBinder name b) =
156155 NamedBinder (ss, com, Nothing, Nothing) name (binderToCoreFn ss [] b)
157156 binderToCoreFn _ com (A.PositionedBinder ss com1 b) =
158157 binderToCoreFn (Just ss) (com ++ com1) b
159158 binderToCoreFn ss com (A.TypedBinder _ b) =
160159 binderToCoreFn ss com b
160+ binderToCoreFn _ _ A.OpBinder{} =
161+ internalError "OpBinder should have been desugared before binderToCoreFn"
162+ binderToCoreFn _ _ A.BinaryNoParensBinder{} =
163+ internalError "BinaryNoParensBinder should have been desugared before binderToCoreFn"
164+ binderToCoreFn _ _ A.ParensInBinder{} =
165+ internalError "ParensInBinder should have been desugared before binderToCoreFn"
161166
162167 -- |
163168 -- Gets metadata for values.
@@ -171,7 +176,7 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =
171176 -- |
172177 -- Gets metadata for data constructors.
173178 --
174− getConstructorMeta :: Qualified ProperName -> Meta
179+ getConstructorMeta :: Qualified (ProperName 'ConstructorName) -> Meta
175180 getConstructorMeta ctor =
176181 case lookupConstructor env ctor of
177182 (Newtype, _, _, _) -> IsNewtype
@@ -179,9 +184,15 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =
179184 let constructorType = if numConstructors (ctor, dc) == 1 then ProductType else SumType
180185 in IsConstructor constructorType fields
181186 where
182− numConstructors :: (Qualified ProperName, (DataDeclType, ProperName, Type, [Ident])) -> Int
187+
188+ numConstructors
189+ :: (Qualified (ProperName 'ConstructorName), (DataDeclType, ProperName 'TypeName, Type, [Ident]))
190+ -> Int
183191 numConstructors ty = length $ filter (((==) `on` typeConstructor) ty) $ M.toList $ dataConstructors env
184− typeConstructor :: (Qualified ProperName, (DataDeclType, ProperName, Type, [Ident])) -> (ModuleName, ProperName)
192+
193+ typeConstructor
194+ :: (Qualified (ProperName 'ConstructorName), (DataDeclType, ProperName 'TypeName, Type, [Ident]))
195+ -> (ModuleName, ProperName 'TypeName)
185196 typeConstructor (Qualified (Just mn') _, (_, tyCtor, _, _)) = (mn', tyCtor)
186197 typeConstructor _ = internalError "Invalid argument to typeConstructor"
187198
@@ -190,30 +201,36 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =
190201-- ensure instances are imported from any module that is referenced by the
191202-- current module, not just from those that are imported explicitly (#667).
192203--
193−findQualModules :: [A.Declaration] -> [ModuleName]
204+findQualModules :: [A.Declaration] -> [(Ann, ModuleName)]
194205findQualModules decls =
195206 let (f, _, _, _, _) = everythingOnValues (++) fqDecls fqValues fqBinders (const []) (const [])
196207 in f `concatMap` decls
197208 where
198− fqDecls :: A.Declaration -> [ModuleName]
199− fqDecls (A.TypeInstanceDeclaration _ _ (Qualified (Just mn) _) _ _) = [mn]
209+ fqDecls :: A.Declaration -> [(Ann, ModuleName)]
210+ fqDecls (A.TypeInstanceDeclaration _ _ q _ _) = getQual q
211+ fqDecls (A.FixityDeclaration _ _ (Just eq)) = either getQual getQual eq
200212 fqDecls _ = []
201213
202− fqValues :: A.Expr -> [ModuleName]
203− fqValues (A.Var (Qualified (Just mn) _)) = [mn]
204− fqValues (A.Constructor (Qualified (Just mn) _)) = [mn]
214+ fqValues :: A.Expr -> [(Ann, ModuleName)]
215+ fqValues (A.Var q) = getQual q
216+ fqValues (A.Constructor q) = getQual q
205217 fqValues _ = []
206218
207− fqBinders :: A.Binder -> [ModuleName]
208− fqBinders (A.ConstructorBinder (Qualified (Just mn) _) _) = [mn]
219+ fqBinders :: A.Binder -> [(Ann, ModuleName)]
220+ fqBinders (A.ConstructorBinder q _) = getQual q
209221 fqBinders _ = []
210222
223+ getQual :: Qualified a -> [(Ann, ModuleName)]
224+ getQual (Qualified (Just mn) _) = [(nullAnn, mn)]
225+ getQual _ = []
226+
211227-- |
212228-- Desugars import declarations from AST to CoreFn representation.
213229--
214−importToCoreFn :: A.Declaration -> Maybe ModuleName
215−importToCoreFn (A.ImportDeclaration name _ _ _) = Just name
216−importToCoreFn (A.PositionedDeclaration _ _ d) = importToCoreFn d
230+importToCoreFn :: A.Declaration -> Maybe (Ann, ModuleName)
231+importToCoreFn (A.ImportDeclaration name _ _ _) = Just (nullAnn, name)
232+importToCoreFn (A.PositionedDeclaration ss _ d) =
233+ ((,) (Just ss, [], Nothing, Nothing) . snd) <$> importToCoreFn d
217234importToCoreFn _ = Nothing
218235
219236-- |
@@ -255,5 +272,5 @@ mkTypeClassConstructor ss com supers members =
255272-- |
256273-- Converts a ProperName to an Ident.
257274--
258−properToIdent :: ProperName -> Ident
275+properToIdent :: ProperName a -> Ident
259276properToIdent = Ident . runProperName
src/Language/PureScript/CoreFn/Expr.hs+10−23
@@ -1,28 +1,14 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.CoreFn.Expr
4−-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- | The core functional representation
12−--
13−-----------------------------------------------------------------------------
14−
15−{-# LANGUAGE DeriveDataTypeable #-}
161{-# LANGUAGE DeriveFunctor #-}
172
3+-- |
4+-- The core functional representation
5+--
186module Language.PureScript.CoreFn.Expr where
197
208import Control.Arrow ((***))
219
22−import qualified Data.Data as D
23−
2410import Language.PureScript.CoreFn.Binders
25−import Language.PureScript.CoreFn.Literals
11+import Language.PureScript.AST.Literals
2612import Language.PureScript.Names
2713
2814-- |
@@ -36,7 +22,7 @@ data Expr a
3622 -- |
3723 -- A data constructor (type name, constructor name, field names)
3824 --
39− | Constructor a ProperName ProperName [Ident]
25+ | Constructor a (ProperName 'TypeName) (ProperName 'ConstructorName) [Ident]
4026 -- |
4127 -- A record property accessor
4228 --
@@ -64,7 +50,8 @@ data Expr a
6450 -- |
6551 -- A let binding
6652 --
67− | Let a [Bind a] (Expr a) deriving (Show, Read, D.Data, D.Typeable, Functor)
53+ | Let a [Bind a] (Expr a)
54+ deriving (Show, Read, Functor)
6855
6956-- |
7057-- A let or module binding.
@@ -73,11 +60,11 @@ data Bind a
7360 -- |
7461 -- Non-recursive binding for a single value
7562 --
76− = NonRec Ident (Expr a)
63+ = NonRec a Ident (Expr a)
7764 -- |
7865 -- Mutually recursive binding group for several values
7966 --
80− | Rec [(Ident, Expr a)] deriving (Show, Read, D.Data, D.Typeable, Functor)
67+ | Rec [((a, Ident), Expr a)] deriving (Show, Read, Functor)
8168
8269-- |
8370-- A guard is just a boolean-valued expression that appears alongside a set of binders
@@ -96,7 +83,7 @@ data CaseAlternative a = CaseAlternative
9683 -- The result expression or a collect of guarded expressions
9784 --
9885 , caseAlternativeResult :: Either [(Guard a, Expr a)] (Expr a)
99− } deriving (Show, Read, D.Data, D.Typeable)
86+ } deriving (Show, Read)
10087
10188instance Functor CaseAlternative where
10289
src/Language/PureScript/CoreFn/Literals.hsdeleted−50
@@ -1,50 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.CoreFn.Literals
4−-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- | The core functional representation for literal values.
12−--
13−-----------------------------------------------------------------------------
14−
15−{-# LANGUAGE DeriveDataTypeable #-}
16−{-# LANGUAGE DeriveFunctor #-}
17−
18−module Language.PureScript.CoreFn.Literals where
19−
20−import qualified Data.Data as D
21−
22−-- |
23−-- Data type for literal values. Parameterised so it can be used for Exprs and
24−-- Binders.
25−--
26−data Literal a
27− -- |
28− -- A numeric literal
29− --
30− = NumericLiteral (Either Integer Double)
31− -- |
32− -- A string literal
33− --
34− | StringLiteral String
35− -- |
36− -- A character literal
37− --
38− | CharLiteral Char
39− -- |
40− -- A boolean literal
41− --
42− | BooleanLiteral Bool
43− -- |
44− -- An array literal
45− --
46− | ArrayLiteral [a]
47− -- |
48− -- An object literal
49− --
50− | ObjectLiteral [(String, a)] deriving (Show, Read, D.Data, D.Typeable, Functor)
src/Language/PureScript/CoreFn/Meta.hs+4−19
@@ -1,23 +1,8 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.CoreFn.Meta
4−-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- | Metadata annotations for core functional representation
1+-- |
2+-- Metadata annotations for core functional representation
123--
13−-----------------------------------------------------------------------------
14−
15−{-# LANGUAGE DeriveDataTypeable #-}
16−
174module Language.PureScript.CoreFn.Meta where
185
19−import qualified Data.Data as D
20−
216import Language.PureScript.Names
227
238-- |
@@ -39,7 +24,7 @@ data Meta
3924 -- |
4025 -- The contained reference is for a foreign member
4126 --
42− | IsForeign deriving (Show, Read, D.Data, D.Typeable)
27+ | IsForeign deriving (Show, Read, Eq)
4328
4429-- |
4530-- Data constructor metadata
@@ -52,4 +37,4 @@ data ConstructorType
5237 -- |
5338 -- The constructor is for a type with multiple construcors
5439 --
55− | SumType deriving (Show, Read, D.Data, D.Typeable)
40+ | SumType deriving (Show, Read, Eq)
src/Language/PureScript/CoreFn/Module.hs+1−1
@@ -22,7 +22,7 @@ import Language.PureScript.Types
2222data Module a = Module
2323 { moduleComments :: [Comment]
2424 , moduleName :: ModuleName
25− , moduleImports :: [ModuleName]
25+ , moduleImports :: [(a, ModuleName)]
2626 , moduleExports :: [Ident]
2727 , moduleForeign :: [ForeignDecl]
2828 , moduleDecls :: [Bind a]
src/Language/PureScript/CoreFn/Traversals.hs+6−16
@@ -1,24 +1,13 @@
1−-----------------------------------------------------------------------------
1+-- |
2+-- CoreFn traversal helpers
23--
3−-- Module : Language.PureScript.CoreFn.Traversals
4−-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- | CoreFn traversal helpers
12−--
13−-----------------------------------------------------------------------------
14−
154module Language.PureScript.CoreFn.Traversals where
165
176import Control.Arrow (second, (***), (+++))
187
198import Language.PureScript.CoreFn.Binders
209import Language.PureScript.CoreFn.Expr
21−import Language.PureScript.CoreFn.Literals
10+import Language.PureScript.AST.Literals
2211
2312everywhereOnValues :: (Bind a -> Bind a) ->
2413 (Expr a -> Expr a) ->
@@ -26,7 +15,7 @@ everywhereOnValues :: (Bind a -> Bind a) ->
2615 (Bind a -> Bind a, Expr a -> Expr a, Binder a -> Binder a)
2716everywhereOnValues f g h = (f', g', h')
2817 where
29− f' (NonRec name e) = f (NonRec name (g' e))
18+ f' (NonRec a name e) = f (NonRec a name (g' e))
3019 f' (Rec es) = f (Rec (map (second g') es))
3120
3221 g' (Literal ann e) = g (Literal ann (handleLiteral g' e))
@@ -40,6 +29,7 @@ everywhereOnValues f g h = (f', g', h')
4029
4130 h' (LiteralBinder a b) = h (LiteralBinder a (handleLiteral h' b))
4231 h' (NamedBinder a name b) = h (NamedBinder a name (h' b))
32+ h' (ConstructorBinder a q1 q2 bs) = h (ConstructorBinder a q1 q2 (map h' bs))
4333 h' b = h b
4434
4535 handleCaseAlternative ca =
@@ -60,7 +50,7 @@ everythingOnValues :: (r -> r -> r) ->
6050 (Bind a -> r, Expr a -> r, Binder a -> r, CaseAlternative a -> r)
6151everythingOnValues (<>) f g h i = (f', g', h', i')
6252 where
63− f' b@(NonRec _ e) = f b <> g' e
53+ f' b@(NonRec _ _ e) = f b <> g' e
6454 f' b@(Rec es) = foldl (<>) (f b) (map (g' . snd) es)
6555
6656 g' v@(Literal _ l) = foldl (<>) (g v) (map g' (extractLiteral l))
src/Language/PureScript/Docs.hs+1−1
@@ -11,4 +11,4 @@ import Language.PureScript.Docs.RenderedCode.Types as Docs
1111import Language.PureScript.Docs.RenderedCode.Render as Docs
1212import Language.PureScript.Docs.Convert as Docs
1313import Language.PureScript.Docs.Render as Docs
14−import Language.PureScript.Docs.ParseAndDesugar as Docs
14+import Language.PureScript.Docs.ParseAndBookmark as Docs
src/Language/PureScript/Docs/AsMarkdown.hs+31−16
@@ -1,10 +1,19 @@
11{-# LANGUAGE RecordWildCards #-}
2+{-# LANGUAGE FlexibleContexts #-}
23
3−module Language.PureScript.Docs.AsMarkdown (
4− renderModulesAsMarkdown
5−) where
4+module Language.PureScript.Docs.AsMarkdown
5+ ( renderModulesAsMarkdown
6+ , Docs
7+ , runDocs
8+ , modulesAsMarkdown
9+ ) where
610
7−import Control.Monad.Writer hiding (First)
11+import Prelude ()
12+import Prelude.Compat
13+
14+import Control.Monad (unless, zipWithM_)
15+import Control.Monad.Writer (Writer, tell, execWriter)
16+import Control.Monad.Error.Class (MonadError)
817import Data.Foldable (for_)
918import Data.List (partition)
1019
@@ -19,33 +28,41 @@ import qualified Language.PureScript.Docs.Render as Render
1928-- Take a list of modules and render them all in order, returning a single
2029-- Markdown-formatted String.
2130--
22−renderModulesAsMarkdown :: [P.Module] -> String
31+renderModulesAsMarkdown ::
32+ (MonadError P.MultipleErrors m) =>
33+ [P.Module] ->
34+ m String
2335renderModulesAsMarkdown =
24− runDocs . modulesAsMarkdown . map Convert.convertModule
36+ fmap (runDocs . modulesAsMarkdown) . Convert.convertModules
2537
2638modulesAsMarkdown :: [Module] -> Docs
2739modulesAsMarkdown = mapM_ moduleAsMarkdown
2840
2941moduleAsMarkdown :: Module -> Docs
3042moduleAsMarkdown Module{..} = do
31− headerLevel 2 $ "Module " ++ modName
43+ headerLevel 2 $ "Module " ++ P.runModuleName modName
3244 spacer
3345 for_ modComments tell'
34− mapM_ declAsMarkdown modDeclarations
46+ mapM_ (declAsMarkdown modName) modDeclarations
3547 spacer
48+ for_ modReExports $ \(mn, decls) -> do
49+ headerLevel 3 $ "Re-exported from " ++ P.runModuleName mn ++ ":"
50+ spacer
51+ mapM_ (declAsMarkdown mn) decls
3652
37−declAsMarkdown :: Declaration -> Docs
38−declAsMarkdown decl@Declaration{..} = do
53+declAsMarkdown :: P.ModuleName -> Declaration -> Docs
54+declAsMarkdown mn decl@Declaration{..} = do
55+ let options = defaultRenderTypeOptions { currentModule = Just mn }
3956 headerLevel 4 (ticks declTitle)
4057 spacer
4158
4259 let (instances, children) = partition (isChildInstance . cdeclInfo) declChildren
4360 fencedBlock $ do
44− tell' (codeToString $ Render.renderDeclaration decl)
61+ tell' (codeToString $ Render.renderDeclarationWithOptions options decl)
4562 zipWithM_ (\f c -> tell' (childToString f c)) (First : repeat NotFirst) children
4663 spacer
4764
48− for_ declFixity (\(fixity, alias) -> fixityAsMarkdown fixity alias >> spacer)
65+ for_ declFixity (\fixity -> fixityAsMarkdown fixity >> spacer)
4966
5067 for_ declComments tell'
5168
@@ -68,11 +85,9 @@ codeToString = outputWith elemAsMarkdown
6885 elemAsMarkdown (Keyword x) = x
6986 elemAsMarkdown Space = " "
7087
71−fixityAsMarkdown :: P.Fixity -> Maybe String -> Docs
72−fixityAsMarkdown (P.Fixity associativity precedence) alias =
73− -- TODO: link alias name to member
88+fixityAsMarkdown :: P.Fixity -> Docs
89+fixityAsMarkdown (P.Fixity associativity precedence) =
7490 tell' $ concat [ "_"
75− , maybe "" (\i -> "alias for " ++ i ++ " - ") alias
7691 , associativityStr
7792 , " / precedence "
7893 , show precedence
src/Language/PureScript/Docs/Convert.hs+160−193
@@ -2,228 +2,195 @@
22{-# LANGUAGE OverloadedStrings #-}
33{-# LANGUAGE RecordWildCards #-}
44{-# LANGUAGE ViewPatterns #-}
5+{-# LANGUAGE FlexibleContexts #-}
56
67-- | Functions for converting PureScript ASTs into values of the data types
78-- from Language.PureScript.Docs.
89
910module Language.PureScript.Docs.Convert
10− ( convertModule
11+ ( convertModules
12+ , convertModulesInPackage
1113 , collectBookmarks
1214 ) where
1315
1416import Prelude ()
1517import Prelude.Compat
1618
17−import Control.Monad
19+import Control.Arrow ((&&&), second)
1820import Control.Category ((>>>))
19−import Data.Either
20−import Data.Maybe (mapMaybe, isNothing)
21−import Data.List (nub, isPrefixOf, isSuffixOf)
21+import Control.Monad
22+import Control.Monad.State (runStateT)
23+import Control.Monad.Writer.Strict (runWriterT)
24+import Control.Monad.Error.Class (MonadError)
25+import qualified Data.Map as Map
2226
27+import Text.Parsec (eof)
2328import qualified Language.PureScript as P
29+import qualified Language.PureScript.Constants as C
2430
2531import Language.PureScript.Docs.Types
32+import Language.PureScript.Docs.Convert.Single (convertSingleModule, collectBookmarks)
33+import Language.PureScript.Docs.Convert.ReExports (updateReExports)
2634
2735-- |
28−-- Convert a single Module.
36+-- Like convertModules, except that it takes a list of modules, together with
37+-- their dependency status, and discards dependency modules in the resulting
38+-- documentation.
2939--
30−convertModule :: P.Module -> Module
31−convertModule m@(P.Module _ coms moduleName _ _) =
32− Module (P.runModuleName moduleName) comments (declarations m)
40+convertModulesInPackage ::
41+ (MonadError P.MultipleErrors m) =>
42+ [InPackage P.Module] ->
43+ m [Module]
44+convertModulesInPackage modules =
45+ go modules
3346 where
34− comments = convertComments coms
35− declarations =
36− P.exportedDeclarations
37− >>> mapMaybe (\d -> getDeclarationTitle d >>= convertDeclaration d)
38− >>> augmentDeclarations
39− >>> map addDefaultFixity
40−
41−-- | The data type for an intermediate stage which we go through during
42−-- converting.
43−--
44−-- In the first pass, we take all top level declarations in the module, and
45−-- collect other information which will later be used to augment the top level
46−-- declarations. These two situation correspond to the Right and Left
47−-- constructors, respectively.
47+ localNames =
48+ map P.getModuleName (takeLocals modules)
49+ go =
50+ map ignorePackage
51+ >>> convertModules
52+ >>> fmap (filter ((`elem` localNames) . modName))
53+
54+-- |
55+-- Convert a group of modules to the intermediate format, designed for
56+-- producing documentation from. It is also necessary to pass an Env containing
57+-- imports/exports information about the list of modules, which is needed for
58+-- documenting re-exports.
4859--
49−-- In the second pass, we go over all of the Left values and augment the
50−-- relevant declarations, leaving only the augmented Right values.
60+-- Note that the whole module dependency graph must be included in the list; if
61+-- some modules import things from other modules, then those modules must also
62+-- be included.
5163--
52−-- Note that in the Left case, we provide a [String] as well as augment
53−-- information. The [String] value should be a list of titles of declarations
54−-- that the augmentation should apply to. For example, for a type instance
55−-- declaration, that would be any types or type classes mentioned in the
56−-- instance. For a fixity declaration, it would be just the relevant operator's
57−-- name.
58−type IntermediateDeclaration
59− = Either ([String], DeclarationAugment) Declaration
60−
61−-- | Some data which will be used to augment a Declaration in the
62−-- output.
64+-- For value declarations, if explicit type signatures are omitted, or a
65+-- wildcard type is used, then we typecheck the modules and use the inferred
66+-- types.
6367--
64−-- The AugmentChild constructor allows us to move all children under their
65−-- respective parents. It is only necessary for type instance declarations,
66−-- since they appear at the top level in the AST, and since they might need to
67−-- appear as children in two places (for example, if a data type defined in a
68−-- module is an instance of a type class also defined in that module).
68+convertModules ::
69+ (MonadError P.MultipleErrors m) =>
70+ [P.Module] ->
71+ m [Module]
72+convertModules =
73+ P.sortModules
74+ >>> fmap (fst >>> map importPrim)
75+ >=> convertSorted
76+
77+importPrim :: P.Module -> P.Module
78+importPrim = P.addDefaultImport (P.ModuleName [P.ProperName C.prim])
79+
80+-- |
81+-- Convert a sorted list of modules.
6982--
70−-- The AugmentFixity constructor allows us to augment operator definitions
71−-- with their associativity and precedence.
72−data DeclarationAugment
73− = AugmentChild ChildDeclaration
74− | AugmentFixity P.Fixity (Maybe P.Ident)
75−
76−-- | Augment top-level declarations; the second pass. See the comments under
77−-- the type synonym IntermediateDeclaration for more information.
78−augmentDeclarations :: [IntermediateDeclaration] -> [Declaration]
79−augmentDeclarations (partitionEithers -> (augments, toplevels)) =
80− foldl go toplevels augments
81− where
82− go ds (parentTitles, a) =
83− map (\d ->
84− if declTitle d `elem` parentTitles
85− then augmentWith a d
86− else d) ds
87−
88− augmentWith a d =
89− case a of
90− AugmentChild child ->
91− d { declChildren = declChildren d ++ [child] }
92− AugmentFixity fixity alias ->
93− d { declFixity = Just (fixity, P.runIdent <$> alias) }
94−
95−-- | Add the default operator fixity for operators which do not have associated
96−-- fixity declarations.
83+convertSorted ::
84+ (MonadError P.MultipleErrors m) =>
85+ [P.Module] ->
86+ m [Module]
87+convertSorted modules = do
88+ (env, convertedModules) <- second (map convertSingleModule) <$> partiallyDesugar modules
89+
90+ modulesWithTypes <- typeCheckIfNecessary modules convertedModules
91+ let moduleMap = Map.fromList (map (modName &&& id) modulesWithTypes)
92+
93+ let traversalOrder = map P.getModuleName modules
94+ pure (Map.elems (updateReExports env traversalOrder moduleMap))
95+
96+-- |
97+-- If any exported value declarations have either wildcard type signatures, or
98+-- none at all, then typecheck in order to fill them in with the inferred
99+-- types.
97100--
98−-- TODO: This may no longer be necessary after issue 806 is resolved, hopefully
99−-- in 0.9.
100−addDefaultFixity :: Declaration -> Declaration
101−addDefaultFixity decl@Declaration{..}
102− | isOp declTitle && isNothing declFixity =
103− decl { declFixity = Just (defaultFixity, Nothing) }
104− | otherwise =
105− decl
106− where
107− isOp :: String -> Bool
108− isOp str = "(" `isPrefixOf` str && ")" `isSuffixOf` str
109− defaultFixity = P.Fixity P.Infixl (-1)
110−
111−getDeclarationTitle :: P.Declaration -> Maybe String
112−getDeclarationTitle (P.TypeDeclaration name _) = Just (P.showIdent name)
113−getDeclarationTitle (P.ExternDeclaration name _) = Just (P.showIdent name)
114−getDeclarationTitle (P.DataDeclaration _ name _ _) = Just (P.runProperName name)
115−getDeclarationTitle (P.ExternDataDeclaration name _) = Just (P.runProperName name)
116−getDeclarationTitle (P.TypeSynonymDeclaration name _ _) = Just (P.runProperName name)
117−getDeclarationTitle (P.TypeClassDeclaration name _ _ _) = Just (P.runProperName name)
118−getDeclarationTitle (P.TypeInstanceDeclaration name _ _ _ _) = Just (P.showIdent name)
119−getDeclarationTitle (P.FixityDeclaration _ name _) = Just ("(" ++ name ++ ")")
120−getDeclarationTitle (P.PositionedDeclaration _ _ d) = getDeclarationTitle d
121−getDeclarationTitle _ = Nothing
122−
123−-- | Create a basic Declaration value.
124−mkDeclaration :: String -> DeclarationInfo -> Declaration
125−mkDeclaration title info =
126− Declaration { declTitle = title
127− , declComments = Nothing
128− , declSourceSpan = Nothing
129− , declChildren = []
130− , declFixity = Nothing
131− , declInfo = info
132− }
133−
134−basicDeclaration :: String -> DeclarationInfo -> Maybe IntermediateDeclaration
135−basicDeclaration title info = Just $ Right $ mkDeclaration title info
136−
137−convertDeclaration :: P.Declaration -> String -> Maybe IntermediateDeclaration
138−convertDeclaration (P.TypeDeclaration _ ty) title =
139− basicDeclaration title (ValueDeclaration ty)
140−convertDeclaration (P.ExternDeclaration _ ty) title =
141− basicDeclaration title (ValueDeclaration ty)
142−convertDeclaration (P.DataDeclaration dtype _ args ctors) title =
143− Just (Right (mkDeclaration title info) { declChildren = children })
144− where
145− info = DataDeclaration dtype args
146− children = map convertCtor ctors
147− convertCtor (ctor', tys) =
148− ChildDeclaration (P.runProperName ctor') Nothing Nothing (ChildDataConstructor tys)
149−convertDeclaration (P.ExternDataDeclaration _ kind') title =
150− basicDeclaration title (ExternDataDeclaration kind')
151−convertDeclaration (P.TypeSynonymDeclaration _ args ty) title =
152− basicDeclaration title (TypeSynonymDeclaration args ty)
153−convertDeclaration (P.TypeClassDeclaration _ args implies ds) title =
154− Just (Right (mkDeclaration title info) { declChildren = children })
155− where
156− info = TypeClassDeclaration args implies
157− children = map convertClassMember ds
158− convertClassMember (P.PositionedDeclaration _ _ d) =
159− convertClassMember d
160− convertClassMember (P.TypeDeclaration ident' ty) =
161− ChildDeclaration (P.showIdent ident') Nothing Nothing (ChildTypeClassMember ty)
162− convertClassMember _ =
163− P.internalError "convertDeclaration: Invalid argument to convertClassMember."
164−convertDeclaration (P.TypeInstanceDeclaration _ constraints className tys _) title =
165− Just (Left (classNameString : typeNameStrings, AugmentChild childDecl))
166− where
167− classNameString = unQual className
168− typeNameStrings = nub (concatMap (P.everythingOnTypes (++) extractProperNames) tys)
169− unQual x = let (P.Qualified _ y) = x in P.runProperName y
170−
171− extractProperNames (P.TypeConstructor n) = [unQual n]
172− extractProperNames _ = []
173−
174− childDecl = ChildDeclaration title Nothing Nothing (ChildInstance constraints classApp)
175− classApp = foldl P.TypeApp (P.TypeConstructor className) tys
176−convertDeclaration (P.FixityDeclaration fixity _ alias) title =
177− Just (Left ([title], AugmentFixity fixity alias))
178−convertDeclaration (P.PositionedDeclaration srcSpan com d') title =
179− fmap (addComments . addSourceSpan) (convertDeclaration d' title)
180− where
181− addComments (Right d) =
182− Right (d { declComments = convertComments com })
183− addComments (Left augment) =
184− Left (withAugmentChild (\d -> d { cdeclComments = convertComments com })
185− augment)
186−
187− addSourceSpan (Right d) =
188− Right (d { declSourceSpan = Just srcSpan })
189− addSourceSpan (Left augment) =
190− Left (withAugmentChild (\d -> d { cdeclSourceSpan = Just srcSpan })
191− augment)
192−
193− withAugmentChild f (t, a) =
194− case a of
195− AugmentChild d -> (t, AugmentChild (f d))
196− _ -> (t, a)
197−convertDeclaration _ _ = Nothing
198−
199−convertComments :: [P.Comment] -> Maybe String
200−convertComments cs = do
201− let raw = concatMap toLines cs
202− guard (all hasPipe raw && not (null raw))
203− return (go raw)
101+typeCheckIfNecessary ::
102+ (MonadError P.MultipleErrors m) =>
103+ [P.Module] ->
104+ [Module] ->
105+ m [Module]
106+typeCheckIfNecessary modules convertedModules =
107+ if any hasWildcards convertedModules
108+ then go
109+ else pure convertedModules
110+
204111 where
205− go = unlines . map stripPipes
112+ hasWildcards =
113+ any ((==) (ValueDeclaration P.TypeWildcard) . declInfo) . modDeclarations
206114
207− toLines (P.LineComment s) = [s]
208− toLines (P.BlockComment s) = lines s
115+ go = do
116+ checkEnv <- snd <$> typeCheck modules
117+ pure (map (insertValueTypes checkEnv) convertedModules)
118+
119+-- |
120+-- Typechecks all the modules together. Also returns the final 'P.Environment',
121+-- which is useful for adding in inferred types where explicit declarations
122+-- were not provided.
123+--
124+typeCheck ::
125+ (MonadError P.MultipleErrors m) =>
126+ [P.Module] ->
127+ m ([P.Module], P.Environment)
128+typeCheck =
129+ (P.desugar [] >=> check)
130+ >>> fmap (second P.checkEnv)
131+ >>> P.evalSupplyT 0
132+ >>> ignoreWarnings
209133
210− hasPipe s = case dropWhile (== ' ') s of { ('|':_) -> True; _ -> False }
134+ where
135+ check ms =
136+ runStateT
137+ (traverse P.typeCheckModule ms)
138+ (P.emptyCheckState P.initEnvironment)
211139
212− stripPipes = dropPipe . dropWhile (== ' ')
140+ ignoreWarnings =
141+ fmap fst . runWriterT
213142
214− dropPipe ('|':' ':s) = s
215− dropPipe ('|':s) = s
216− dropPipe s = s
143+-- |
144+-- Updates all the types of the ValueDeclarations inside the module based on
145+-- their types inside the given Environment.
146+--
147+insertValueTypes ::
148+ P.Environment -> Module -> Module
149+insertValueTypes env m =
150+ m { modDeclarations = map go (modDeclarations m) }
151+ where
152+ go (d@Declaration { declInfo = ValueDeclaration P.TypeWildcard }) =
153+ let
154+ ident = parseIdent (declTitle d)
155+ ty = lookupName ident
156+ in
157+ d { declInfo = ValueDeclaration ty }
158+ go other =
159+ other
160+
161+ parseIdent =
162+ either (err . ("failed to parse Ident: " ++)) id . runParser P.parseIdent
163+
164+ lookupName name =
165+ let key = (modName m, name)
166+ in case Map.lookup key (P.names env) of
167+ Just (ty, _, _) ->
168+ ty
169+ Nothing ->
170+ err ("name not found: " ++ show key)
171+
172+ err msg =
173+ P.internalError ("Docs.Convert.insertValueTypes: " ++ msg)
174+
175+runParser :: P.TokenParser a -> String -> Either String a
176+runParser p s = either (Left . show) Right $ do
177+ ts <- P.lex "" s
178+ P.runTokenParser "" (p <* eof) ts
217179
218−-- | Go through a PureScript module and extract a list of Bookmarks; references
219−-- to data types or values, to be used as a kind of index. These are used for
220−-- generating links in the HTML documentation, for example.
221−collectBookmarks :: InPackage P.Module -> [Bookmark]
222−collectBookmarks (Local m) = map Local (collectBookmarks' m)
223−collectBookmarks (FromDep pkg m) = map (FromDep pkg) (collectBookmarks' m)
180+-- |
181+-- Partially desugar modules so that they are suitable for extracting
182+-- documentation information from.
183+--
184+partiallyDesugar ::
185+ (MonadError P.MultipleErrors m) =>
186+ [P.Module]
187+ -> m (P.Env, [P.Module])
188+partiallyDesugar = P.evalSupplyT 0 . desugar'
189+ where
190+ desugar' =
191+ traverse P.desugarDoModule
192+ >=> P.desugarCasesModule
193+ >=> P.desugarTypeDeclarationsModule
194+ >=> ignoreWarnings . P.desugarImportsWithEnv []
224195
225−collectBookmarks' :: P.Module -> [(P.ModuleName, String)]
226−collectBookmarks' m =
227− map (P.getModuleName m, )
228− (mapMaybe getDeclarationTitle
229− (P.exportedDeclarations m))
196+ ignoreWarnings = fmap fst . runWriterT
src/Language/PureScript/Docs/Convert/ReExports.hsnew file+477
@@ -0,0 +1,477 @@
1+{-# LANGUAGE ViewPatterns #-}
2+{-# LANGUAGE TupleSections #-}
3+{-# LANGUAGE RecordWildCards #-}
4+{-# LANGUAGE FlexibleContexts #-}
5+
6+module Language.PureScript.Docs.Convert.ReExports
7+ ( updateReExports
8+ ) where
9+
10+import Prelude ()
11+import Prelude.Compat
12+
13+import Control.Monad
14+import Control.Monad.Trans.State.Strict (execState)
15+import Control.Monad.State.Class (MonadState, gets, modify)
16+import Control.Monad.Trans.Reader (runReaderT)
17+import Control.Monad.Reader.Class (MonadReader, ask)
18+import Control.Arrow ((&&&), first, second)
19+import Data.Either
20+import Data.Maybe (mapMaybe)
21+import Data.Map (Map)
22+import qualified Data.Map as Map
23+import Data.Monoid ((<>))
24+
25+import qualified Language.PureScript as P
26+
27+import Language.PureScript.Docs.Types
28+
29+-- |
30+-- Given:
31+--
32+-- * The Imports/Exports Env
33+-- * An order to traverse the modules (which must be topological)
34+-- * A map of modules, indexed by their names, which are assumed to not
35+-- have their re-exports listed yet
36+--
37+-- This function adds all the missing re-exports.
38+--
39+updateReExports ::
40+ P.Env ->
41+ [P.ModuleName] ->
42+ Map P.ModuleName Module ->
43+ Map P.ModuleName Module
44+updateReExports env order modules =
45+ execState action modules
46+ where
47+ action =
48+ void (traverse go order)
49+
50+ go mn = do
51+ mdl <- lookup' mn
52+ reExports <- getReExports env mn
53+ let mdl' = mdl { modReExports = reExports }
54+ modify (Map.insert mn mdl')
55+
56+ lookup' mn = do
57+ v <- gets (Map.lookup mn)
58+ case v of
59+ Just v' ->
60+ pure v'
61+ Nothing ->
62+ internalError ("Module missing: " ++ P.runModuleName mn)
63+
64+-- |
65+-- Collect all of the re-exported declarations for a single module.
66+--
67+-- We require that modules have already been sorted (P.sortModules) in order to
68+-- ensure that by the time we convert a particular module, all its dependencies
69+-- have already been converted.
70+--
71+getReExports ::
72+ (MonadState (Map P.ModuleName Module) m) =>
73+ P.Env ->
74+ P.ModuleName ->
75+ m [(P.ModuleName, [Declaration])]
76+getReExports env mn =
77+ case Map.lookup mn env of
78+ Nothing ->
79+ internalError ("Module missing: " ++ P.runModuleName mn)
80+ Just (_, imports, exports) -> do
81+ allExports <- runReaderT (collectDeclarations imports exports) mn
82+ pure (filter notLocal allExports)
83+
84+ where
85+ notLocal = (/= mn) . fst
86+
87+-- |
88+-- Assemble a list of declarations re-exported from a particular module, based
89+-- on the Imports and Exports value for that module, and by extracting the
90+-- declarations from the current state.
91+--
92+-- This function works by searching through the lists of exported declarations
93+-- in the Exports, and looking them up in the associated Imports value to find
94+-- the module they were imported from.
95+--
96+-- Additionally:
97+--
98+-- * Attempts to move re-exported type class members under their parent
99+-- type classes, if possible, or otherwise, "promote" them from
100+-- ChildDeclarations to proper Declarations.
101+-- * Filters data declarations to ensure that only re-exported data
102+-- constructors are listed.
103+-- * Filters type class declarations to ensure that only re-exported type
104+-- class members are listed.
105+--
106+collectDeclarations ::
107+ (MonadState (Map P.ModuleName Module) m, MonadReader P.ModuleName m) =>
108+ P.Imports ->
109+ P.Exports ->
110+ m [(P.ModuleName, [Declaration])]
111+collectDeclarations imports exports = do
112+ valsAndMembers <- collect lookupValueDeclaration impVals expVals
113+ typeClasses <- collect lookupTypeClassDeclaration impTCs expTCs
114+ types <- collect lookupTypeDeclaration impTypes expTypes
115+
116+ (vals, classes) <- handleTypeClassMembers valsAndMembers typeClasses
117+
118+ let filteredTypes = filterDataConstructors expCtors types
119+ let filteredClasses = filterTypeClassMembers (map fst expVals) classes
120+
121+ pure (Map.toList (Map.unionsWith (<>) [filteredTypes, filteredClasses, vals]))
122+
123+ where
124+ collect lookup' imps exps = do
125+ imps' <- traverse (findImport imps) exps
126+ Map.fromListWith (<>) <$> traverse (uncurry lookup') imps'
127+
128+ expVals = P.exportedValues exports
129+ impVals = concat (Map.elems (P.importedValues imports))
130+
131+ expTypes = map (first fst) (P.exportedTypes exports)
132+ impTypes = concat (Map.elems (P.importedTypes imports))
133+
134+ expCtors = concatMap (snd . fst) (P.exportedTypes exports)
135+
136+ expTCs = P.exportedTypeClasses exports
137+ impTCs = concat (Map.elems (P.importedTypeClasses imports))
138+
139+-- |
140+-- Given a list of imported declarations (of a particular kind, ie. type, data,
141+-- class, value, etc), and the name of an exported declaration of the same
142+-- kind, together with the module it was originally defined in, return a tuple
143+-- of:
144+--
145+-- * the module that exported declaration was imported from (note that
146+-- this can be different from the module it was originally defined in, if
147+-- it is a re-export),
148+-- * that same declaration's name.
149+--
150+-- This function uses a type variable for names because we want to be able to
151+-- instantiate @name@ as both 'P.Ident' and 'P.ProperName'.
152+--
153+findImport ::
154+ (Show name, Eq name, MonadReader P.ModuleName m) =>
155+ [P.ImportRecord name] ->
156+ (name, P.ModuleName) ->
157+ m (P.ModuleName, name)
158+findImport imps (name, orig) =
159+ let
160+ matches (P.ImportRecord qual mn _) = P.disqualify qual == name && mn == orig
161+ matching = filter matches imps
162+ getQualified (P.Qualified mname _) = mname
163+ in
164+ case mapMaybe (getQualified . P.importName) matching of
165+ -- A value can occur more than once if it is imported twice (eg, if it is
166+ -- exported by A, re-exported from A by B, and C imports it from both A
167+ -- and B). In this case, we just take its first appearance.
168+ (importedFrom:_) ->
169+ pure (importedFrom, name)
170+ [] ->
171+ internalErrorInModule ("findImport: not found: " ++ show (name, orig))
172+
173+lookupValueDeclaration ::
174+ (MonadState (Map P.ModuleName Module) m,
175+ MonadReader P.ModuleName m) =>
176+ P.ModuleName ->
177+ P.Ident ->
178+ m (P.ModuleName, [Either (String, P.Constraint, ChildDeclaration) Declaration])
179+lookupValueDeclaration importedFrom ident = do
180+ decls <- lookupModuleDeclarations "lookupValueDeclaration" importedFrom
181+ let
182+ rs =
183+ filter (\d -> declTitle d == P.showIdent ident
184+ && (isValue d || isAlias d)) decls
185+ errOther other =
186+ internalErrorInModule
187+ ("lookupValueDeclaration: unexpected result:\n" ++
188+ "other: " ++ show other ++ "\n" ++
189+ "ident: " ++ show ident ++ "\n" ++
190+ "decls: " ++ show decls)
191+
192+ case rs of
193+ [r] ->
194+ pure (importedFrom, [Right r])
195+ [] ->
196+ -- It's a type class member.
197+ -- Note that we need to filter based on the child declaration info using
198+ -- `isTypeClassMember` anyway, because child declarations of type classes
199+ -- are not necessarily members; they could also be instances.
200+ let
201+ allTypeClassChildDecls =
202+ decls
203+ |> mapMaybe (\d -> (d,) <$> typeClassConstraintFor d)
204+ |> concatMap (\(d, constr) ->
205+ map (declTitle d, constr,)
206+ (declChildren d))
207+
208+ matchesIdent cdecl =
209+ cdeclTitle cdecl == P.showIdent ident
210+
211+ matchesAndIsTypeClassMember =
212+ uncurry (&&) . (matchesIdent &&& isTypeClassMember)
213+
214+ in
215+ case filter (matchesAndIsTypeClassMember . thd) allTypeClassChildDecls of
216+ [r'] ->
217+ pure (importedFrom, [Left r'])
218+ other ->
219+ errOther other
220+ other -> do
221+ errOther other
222+
223+ where
224+ thd :: (a, b, c) -> c
225+ thd (_, _, x) = x
226+
227+-- |
228+-- Extract a particular type declaration. For data declarations, constructors
229+-- are only included in the output if they are listed in the arguments.
230+--
231+lookupTypeDeclaration ::
232+ (MonadState (Map P.ModuleName Module) m,
233+ MonadReader P.ModuleName m) =>
234+ P.ModuleName ->
235+ P.ProperName 'P.TypeName ->
236+ m (P.ModuleName, [Declaration])
237+lookupTypeDeclaration importedFrom ty = do
238+ decls <- lookupModuleDeclarations "lookupTypeDeclaration" importedFrom
239+ let
240+ ds = filter (\d -> declTitle d == P.runProperName ty && isType d) decls
241+ case ds of
242+ [d] ->
243+ pure (importedFrom, [d])
244+ other ->
245+ internalErrorInModule
246+ ("lookupTypeDeclaration: unexpected result: " ++ show other)
247+
248+lookupTypeClassDeclaration ::
249+ (MonadState (Map P.ModuleName Module) m,
250+ MonadReader P.ModuleName m) =>
251+ P.ModuleName ->
252+ P.ProperName 'P.ClassName ->
253+ m (P.ModuleName, [Declaration])
254+lookupTypeClassDeclaration importedFrom tyClass = do
255+ decls <- lookupModuleDeclarations "lookupTypeClassDeclaration" importedFrom
256+ let
257+ ds = filter (\d -> declTitle d == P.runProperName tyClass
258+ && isTypeClass d)
259+ decls
260+ case ds of
261+ [d] ->
262+ pure (importedFrom, [d])
263+ other ->
264+ internalErrorInModule
265+ ("lookupTypeClassDeclaration: unexpected result: "
266+ ++ (unlines . map show) other)
267+
268+-- |
269+-- Get the full list of declarations for a particular module out of the
270+-- state, or raise an internal error if it is not there.
271+--
272+lookupModuleDeclarations ::
273+ (MonadState (Map P.ModuleName Module) m,
274+ MonadReader P.ModuleName m) =>
275+ String ->
276+ P.ModuleName ->
277+ m [Declaration]
278+lookupModuleDeclarations definedIn moduleName = do
279+ mmdl <- gets (Map.lookup moduleName)
280+ case mmdl of
281+ Nothing ->
282+ internalErrorInModule
283+ (definedIn ++ ": module missing: "
284+ ++ P.runModuleName moduleName)
285+ Just mdl ->
286+ pure (allDeclarations mdl)
287+
288+handleTypeClassMembers ::
289+ (MonadReader P.ModuleName m) =>
290+ Map P.ModuleName [Either (String, P.Constraint, ChildDeclaration) Declaration] ->
291+ Map P.ModuleName [Declaration] ->
292+ m (Map P.ModuleName [Declaration], Map P.ModuleName [Declaration])
293+handleTypeClassMembers valsAndMembers typeClasses =
294+ let
295+ moduleEnvs =
296+ Map.unionWith (<>)
297+ (fmap valsAndMembersToEnv valsAndMembers)
298+ (fmap typeClassesToEnv typeClasses)
299+ in
300+ moduleEnvs
301+ |> traverse handleEnv
302+ |> fmap splitMap
303+
304+valsAndMembersToEnv ::
305+ [Either (String, P.Constraint, ChildDeclaration) Declaration] -> TypeClassEnv
306+valsAndMembersToEnv xs =
307+ let (envUnhandledMembers, envValues) = partitionEithers xs
308+ envTypeClasses = []
309+ in TypeClassEnv{..}
310+
311+typeClassesToEnv :: [Declaration] -> TypeClassEnv
312+typeClassesToEnv classes =
313+ TypeClassEnv
314+ { envUnhandledMembers = []
315+ , envValues = []
316+ , envTypeClasses = classes
317+ }
318+
319+-- |
320+-- An intermediate data type, used for either moving type class members under
321+-- their parent type classes, or promoting them to normal Declaration values
322+-- if their parent type class has not been re-exported.
323+--
324+data TypeClassEnv = TypeClassEnv
325+ { -- |
326+ -- Type class members which have not yet been dealt with. The String is the
327+ -- name of the type class they belong to, and the constraint is used to
328+ -- make sure that they have the correct type if they get promoted.
329+ --
330+ envUnhandledMembers :: [(String, P.Constraint, ChildDeclaration)]
331+ -- |
332+ -- A list of normal value declarations. Type class members will be added to
333+ -- this list if their parent type class is not available.
334+ --
335+ , envValues :: [Declaration]
336+ -- |
337+ -- A list of type class declarations. Type class members will be added to
338+ -- their parents in this list, if they exist.
339+ --
340+ , envTypeClasses :: [Declaration]
341+ }
342+ deriving (Show)
343+
344+instance Monoid TypeClassEnv where
345+ mempty =
346+ TypeClassEnv mempty mempty mempty
347+ mappend (TypeClassEnv a1 b1 c1)
348+ (TypeClassEnv a2 b2 c2) =
349+ TypeClassEnv (a1 <> a2) (b1 <> b2) (c1 <> c2)
350+
351+-- |
352+-- Take a TypeClassEnv and handle all of the type class members in it, either
353+-- adding them to their parent classes, or promoting them to normal Declaration
354+-- values.
355+--
356+-- Returns a tuple of (values, type classes).
357+--
358+handleEnv ::
359+ (MonadReader P.ModuleName m) =>
360+ TypeClassEnv ->
361+ m ([Declaration], [Declaration])
362+handleEnv TypeClassEnv{..} =
363+ envUnhandledMembers
364+ |> foldM go (envValues, mkMap envTypeClasses)
365+ |> fmap (second Map.elems)
366+
367+ where
368+ mkMap =
369+ Map.fromList . map (declTitle &&& id)
370+
371+ go (values, tcs) (title, constraint, childDecl) =
372+ case Map.lookup title tcs of
373+ Just _ ->
374+ -- Leave the state unchanged; if the type class is there, the child
375+ -- will be too.
376+ pure (values, tcs)
377+ Nothing -> do
378+ c <- promoteChild constraint childDecl
379+ pure (c : values, tcs)
380+
381+ promoteChild constraint ChildDeclaration{..} =
382+ case cdeclInfo of
383+ ChildTypeClassMember typ ->
384+ pure $ Declaration
385+ { declTitle = cdeclTitle
386+ , declComments = cdeclComments
387+ , declSourceSpan = cdeclSourceSpan
388+ , declChildren = []
389+ , declFixity = Nothing
390+ , declInfo = ValueDeclaration (addConstraint constraint typ)
391+ }
392+ _ ->
393+ internalErrorInModule
394+ ("handleEnv: Bad child declaration passed to promoteChild: "
395+ ++ cdeclTitle)
396+
397+ addConstraint constraint =
398+ P.quantify . P.moveQuantifiersToFront . P.ConstrainedType [constraint]
399+
400+splitMap :: (Ord k) => Map k (v1, v2) -> (Map k v1, Map k v2)
401+splitMap = foldl go (Map.empty, Map.empty) . Map.toList
402+ where
403+ go (m1, m2) (k, (v1, v2)) =
404+ (Map.insert k v1 m1, Map.insert k v2 m2)
405+
406+-- |
407+-- Given a list of exported constructor names, remove any data constructor
408+-- names in the provided Map of declarations which are not in the list.
409+--
410+filterDataConstructors ::
411+ [P.ProperName 'P.ConstructorName] ->
412+ Map P.ModuleName [Declaration] ->
413+ Map P.ModuleName [Declaration]
414+filterDataConstructors =
415+ filterExportedChildren isDataConstructor P.runProperName
416+
417+-- |
418+-- Given a list of exported type class member names, remove any data
419+-- type class member names in the provided Map of declarations which are not in
420+-- the list.
421+--
422+filterTypeClassMembers ::
423+ [P.Ident] ->
424+ Map P.ModuleName [Declaration] ->
425+ Map P.ModuleName [Declaration]
426+filterTypeClassMembers =
427+ filterExportedChildren isTypeClassMember P.showIdent
428+
429+filterExportedChildren ::
430+ (Functor f) =>
431+ (ChildDeclaration -> Bool) ->
432+ (name -> String) ->
433+ [name] ->
434+ f [Declaration] ->
435+ f [Declaration]
436+filterExportedChildren isTargetedKind runName expNames =
437+ fmap filterDecls
438+ where
439+ filterDecls =
440+ map (filterChildren (\c -> not (isTargetedKind c) ||
441+ cdeclTitle c `elem` expNames'))
442+
443+ expNames' = map runName expNames
444+
445+allDeclarations :: Module -> [Declaration]
446+allDeclarations Module{..} =
447+ modDeclarations ++ concatMap snd modReExports
448+
449+(|>) :: a -> (a -> b) -> b
450+x |> f = f x
451+
452+internalError :: String -> a
453+internalError = P.internalError . ("Docs.Convert.ReExports: " ++)
454+
455+internalErrorInModule ::
456+ (MonadReader P.ModuleName m) =>
457+ String ->
458+ m a
459+internalErrorInModule msg = do
460+ mn <- ask
461+ internalError
462+ ("while collecting re-exports for module: " ++ P.runModuleName mn ++
463+ ", " ++ msg)
464+
465+-- |
466+-- If the provided Declaration is a TypeClassDeclaration, construct an
467+-- appropriate Constraint for use with the types of its members.
468+--
469+typeClassConstraintFor :: Declaration -> Maybe P.Constraint
470+typeClassConstraintFor Declaration{..} =
471+ case declInfo of
472+ TypeClassDeclaration tyArgs _ ->
473+ Just (P.Qualified Nothing (P.ProperName declTitle), mkConstraint tyArgs)
474+ _ ->
475+ Nothing
476+ where
477+ mkConstraint = map (P.TypeVar . fst)
src/Language/PureScript/Docs/Convert/Single.hsnew file+236
@@ -0,0 +1,236 @@
1+{-# LANGUAGE TupleSections #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE RecordWildCards #-}
4+{-# LANGUAGE ViewPatterns #-}
5+{-# LANGUAGE FlexibleContexts #-}
6+
7+module Language.PureScript.Docs.Convert.Single
8+ ( convertSingleModule
9+ , collectBookmarks
10+ ) where
11+
12+import Prelude ()
13+import Prelude.Compat
14+import Data.Maybe (catMaybes)
15+
16+import Control.Monad
17+import Control.Category ((>>>))
18+import Data.Maybe (mapMaybe, isNothing)
19+import Data.Either
20+import Data.List (nub, isPrefixOf, isSuffixOf)
21+
22+import qualified Language.PureScript as P
23+
24+import Language.PureScript.Docs.Types
25+
26+-- |
27+-- Convert a single Module, but ignore re-exports; any re-exported types or
28+-- values will not appear in the result.
29+--
30+convertSingleModule :: P.Module -> Module
31+convertSingleModule m@(P.Module _ coms moduleName _ _) =
32+ Module moduleName comments (declarations m) []
33+ where
34+ comments = convertComments coms
35+ declarations =
36+ P.exportedDeclarations
37+ >>> mapMaybe (\d -> getDeclarationTitle d >>= convertDeclaration d)
38+ >>> augmentDeclarations
39+ >>> map addDefaultFixity
40+
41+-- | The data type for an intermediate stage which we go through during
42+-- converting.
43+--
44+-- In the first pass, we take all top level declarations in the module, and
45+-- collect other information which will later be used to augment the top level
46+-- declarations. These two situation correspond to the Right and Left
47+-- constructors, respectively.
48+--
49+-- In the second pass, we go over all of the Left values and augment the
50+-- relevant declarations, leaving only the augmented Right values.
51+--
52+-- Note that in the Left case, we provide a [String] as well as augment
53+-- information. The [String] value should be a list of titles of declarations
54+-- that the augmentation should apply to. For example, for a type instance
55+-- declaration, that would be any types or type classes mentioned in the
56+-- instance. For a fixity declaration, it would be just the relevant operator's
57+-- name.
58+type IntermediateDeclaration
59+ = Either ([String], DeclarationAugment) Declaration
60+
61+-- | Some data which will be used to augment a Declaration in the
62+-- output.
63+--
64+-- The AugmentChild constructor allows us to move all children under their
65+-- respective parents. It is only necessary for type instance declarations,
66+-- since they appear at the top level in the AST, and since they might need to
67+-- appear as children in two places (for example, if a data type defined in a
68+-- module is an instance of a type class also defined in that module).
69+--
70+-- The AugmentFixity constructor allows us to augment operator definitions
71+-- with their associativity and precedence.
72+data DeclarationAugment
73+ = AugmentChild ChildDeclaration
74+ | AugmentFixity P.Fixity
75+
76+-- | Augment top-level declarations; the second pass. See the comments under
77+-- the type synonym IntermediateDeclaration for more information.
78+augmentDeclarations :: [IntermediateDeclaration] -> [Declaration]
79+augmentDeclarations (partitionEithers -> (augments, toplevels)) =
80+ foldl go toplevels augments
81+ where
82+ go ds (parentTitles, a) =
83+ map (\d ->
84+ if declTitle d `elem` parentTitles
85+ then augmentWith a d
86+ else d) ds
87+
88+ augmentWith a d =
89+ case a of
90+ AugmentChild child ->
91+ d { declChildren = declChildren d ++ [child] }
92+ AugmentFixity fixity ->
93+ d { declFixity = Just fixity }
94+
95+-- | Add the default operator fixity for operators which do not have associated
96+-- fixity declarations.
97+--
98+-- TODO: This may no longer be necessary after issue 806 is resolved, hopefully
99+-- in 0.9.
100+addDefaultFixity :: Declaration -> Declaration
101+addDefaultFixity decl@Declaration{..}
102+ | isOp declTitle && isNothing declFixity =
103+ decl { declFixity = Just defaultFixity }
104+ | otherwise =
105+ decl
106+ where
107+ isOp :: String -> Bool
108+ isOp str = "(" `isPrefixOf` str && ")" `isSuffixOf` str
109+ defaultFixity = P.Fixity P.Infixl (-1)
110+
111+getDeclarationTitle :: P.Declaration -> Maybe String
112+getDeclarationTitle (P.ValueDeclaration name _ _ _) = Just (P.showIdent name)
113+getDeclarationTitle (P.ExternDeclaration name _) = Just (P.showIdent name)
114+getDeclarationTitle (P.DataDeclaration _ name _ _) = Just (P.runProperName name)
115+getDeclarationTitle (P.ExternDataDeclaration name _) = Just (P.runProperName name)
116+getDeclarationTitle (P.TypeSynonymDeclaration name _ _) = Just (P.runProperName name)
117+getDeclarationTitle (P.TypeClassDeclaration name _ _ _) = Just (P.runProperName name)
118+getDeclarationTitle (P.TypeInstanceDeclaration name _ _ _ _) = Just (P.showIdent name)
119+getDeclarationTitle (P.FixityDeclaration _ name _) = Just ("(" ++ name ++ ")")
120+getDeclarationTitle (P.PositionedDeclaration _ _ d) = getDeclarationTitle d
121+getDeclarationTitle _ = Nothing
122+
123+-- | Create a basic Declaration value.
124+mkDeclaration :: String -> DeclarationInfo -> Declaration
125+mkDeclaration title info =
126+ Declaration { declTitle = title
127+ , declComments = Nothing
128+ , declSourceSpan = Nothing
129+ , declChildren = []
130+ , declFixity = Nothing
131+ , declInfo = info
132+ }
133+
134+basicDeclaration :: String -> DeclarationInfo -> Maybe IntermediateDeclaration
135+basicDeclaration title info = Just $ Right $ mkDeclaration title info
136+
137+convertDeclaration :: P.Declaration -> String -> Maybe IntermediateDeclaration
138+convertDeclaration (P.ValueDeclaration _ _ _ (Right (P.TypedValue _ _ ty))) title =
139+ basicDeclaration title (ValueDeclaration ty)
140+convertDeclaration (P.ValueDeclaration _ _ _ _) title =
141+ -- If no explicit type declaration was provided, insert a wildcard, so that
142+ -- the actual type will be added during type checking.
143+ basicDeclaration title (ValueDeclaration P.TypeWildcard)
144+convertDeclaration (P.ExternDeclaration _ ty) title =
145+ basicDeclaration title (ValueDeclaration ty)
146+convertDeclaration (P.DataDeclaration dtype _ args ctors) title =
147+ Just (Right (mkDeclaration title info) { declChildren = children })
148+ where
149+ info = DataDeclaration dtype args
150+ children = map convertCtor ctors
151+ convertCtor (ctor', tys) =
152+ ChildDeclaration (P.runProperName ctor') Nothing Nothing (ChildDataConstructor tys)
153+convertDeclaration (P.ExternDataDeclaration _ kind') title =
154+ basicDeclaration title (ExternDataDeclaration kind')
155+convertDeclaration (P.TypeSynonymDeclaration _ args ty) title =
156+ basicDeclaration title (TypeSynonymDeclaration args ty)
157+convertDeclaration (P.TypeClassDeclaration _ args implies ds) title =
158+ Just (Right (mkDeclaration title info) { declChildren = children })
159+ where
160+ info = TypeClassDeclaration args implies
161+ children = map convertClassMember ds
162+ convertClassMember (P.PositionedDeclaration _ _ d) =
163+ convertClassMember d
164+ convertClassMember (P.TypeDeclaration ident' ty) =
165+ ChildDeclaration (P.showIdent ident') Nothing Nothing (ChildTypeClassMember ty)
166+ convertClassMember _ =
167+ P.internalError "convertDeclaration: Invalid argument to convertClassMember."
168+convertDeclaration (P.TypeInstanceDeclaration _ constraints className tys _) title =
169+ Just (Left (classNameString : typeNameStrings, AugmentChild childDecl))
170+ where
171+ classNameString = unQual className
172+ typeNameStrings = nub (concatMap (P.everythingOnTypes (++) extractProperNames) tys)
173+ unQual x = let (P.Qualified _ y) = x in P.runProperName y
174+
175+ extractProperNames (P.TypeConstructor n) = [unQual n]
176+ extractProperNames _ = []
177+
178+ childDecl = ChildDeclaration title Nothing Nothing (ChildInstance constraints classApp)
179+ classApp = foldl P.TypeApp (P.TypeConstructor (fmap P.coerceProperName className)) tys
180+convertDeclaration (P.FixityDeclaration fixity _ Nothing) title =
181+ Just (Left ([title], AugmentFixity fixity))
182+convertDeclaration (P.FixityDeclaration fixity _ (Just alias)) title =
183+ Just $ Right $ (mkDeclaration title (AliasDeclaration alias fixity)) { declFixity = Just fixity }
184+convertDeclaration (P.PositionedDeclaration srcSpan com d') title =
185+ fmap (addComments . addSourceSpan) (convertDeclaration d' title)
186+ where
187+ addComments (Right d) =
188+ Right (d { declComments = convertComments com })
189+ addComments (Left augment) =
190+ Left (withAugmentChild (\d -> d { cdeclComments = convertComments com })
191+ augment)
192+
193+ addSourceSpan (Right d) =
194+ Right (d { declSourceSpan = Just srcSpan })
195+ addSourceSpan (Left augment) =
196+ Left (withAugmentChild (\d -> d { cdeclSourceSpan = Just srcSpan })
197+ augment)
198+
199+ withAugmentChild f (t, a) =
200+ case a of
201+ AugmentChild d -> (t, AugmentChild (f d))
202+ _ -> (t, a)
203+convertDeclaration _ _ = Nothing
204+
205+convertComments :: [P.Comment] -> Maybe String
206+convertComments cs = do
207+ let raw = concatMap toLines cs
208+ let docs = catMaybes (map stripPipe raw)
209+ guard (not (null docs))
210+ pure (unlines docs)
211+
212+ where
213+ toLines (P.LineComment s) = [s]
214+ toLines (P.BlockComment s) = lines s
215+
216+ stripPipe s' =
217+ case dropWhile (== ' ') s' of
218+ ('|':' ':s) ->
219+ Just s
220+ ('|':s) ->
221+ Just s
222+ _ ->
223+ Nothing
224+
225+-- | Go through a PureScript module and extract a list of Bookmarks; references
226+-- to data types or values, to be used as a kind of index. These are used for
227+-- generating links in the HTML documentation, for example.
228+collectBookmarks :: InPackage P.Module -> [Bookmark]
229+collectBookmarks (Local m) = map Local (collectBookmarks' m)
230+collectBookmarks (FromDep pkg m) = map (FromDep pkg) (collectBookmarks' m)
231+
232+collectBookmarks' :: P.Module -> [(P.ModuleName, String)]
233+collectBookmarks' m =
234+ map (P.getModuleName m, )
235+ (mapMaybe getDeclarationTitle
236+ (P.exportedDeclarations m))
src/Language/PureScript/Docs/ParseAndBookmark.hsnew file+100
@@ -0,0 +1,100 @@
1+{-# LANGUAGE TupleSections #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+
4+module Language.PureScript.Docs.ParseAndBookmark
5+ ( parseAndBookmark
6+ ) where
7+
8+import Prelude ()
9+import Prelude.Compat
10+
11+import qualified Data.Map as M
12+import Control.Arrow (first)
13+
14+import Control.Monad.Error.Class (MonadError(..))
15+import Control.Monad.IO.Class (MonadIO(..))
16+
17+import Web.Bower.PackageMeta (PackageName)
18+
19+import qualified Language.PureScript as P
20+import Language.PureScript.Docs.Types
21+import Language.PureScript.Docs.Convert (collectBookmarks)
22+
23+-- |
24+-- Given:
25+--
26+-- * A list of local source files
27+-- * A list of source files from external dependencies, together with their
28+-- package names
29+--
30+-- This function does the following:
31+--
32+-- * Parse all of the input and dependency source files
33+-- * Associate each dependency module with its package name, thereby
34+-- distinguishing these from local modules
35+-- * Collect a list of bookmarks from the whole set of source files
36+-- * Return the parsed modules and the bookmarks
37+parseAndBookmark ::
38+ (MonadError P.MultipleErrors m, MonadIO m) =>
39+ [FilePath]
40+ -> [(PackageName, FilePath)]
41+ -> m ([InPackage P.Module], [Bookmark])
42+parseAndBookmark inputFiles depsFiles = do
43+ inputFiles' <- traverse (parseAs Local) inputFiles
44+ depsFiles' <- traverse (\(pkgName, f) -> parseAs (FromDep pkgName) f) depsFiles
45+
46+ addBookmarks <$> parseFiles (inputFiles' ++ depsFiles')
47+
48+parseFiles ::
49+ (MonadError P.MultipleErrors m, MonadIO m) =>
50+ [(FileInfo, FilePath)]
51+ -> m [(FileInfo, P.Module)]
52+parseFiles =
53+ throwLeft . P.parseModulesFromFiles fileInfoToString
54+
55+addBookmarks ::
56+ [(FileInfo, P.Module)]
57+ -> ([InPackage P.Module], [Bookmark])
58+addBookmarks msInfo =
59+ let
60+ msDeps = getDepsModuleNames (map (\(fp, m) -> (,m) <$> fp) msInfo)
61+ msPackages = map (addPackage msDeps . snd) msInfo
62+ bookmarks = concatMap collectBookmarks msPackages
63+ in
64+ (msPackages, bookmarks)
65+
66+throwLeft :: (MonadError l m) => Either l r -> m r
67+throwLeft = either throwError return
68+
69+-- | Specifies whether a PureScript source file is considered as:
70+--
71+-- 1) with the `Local` constructor, a target source file, i.e., we want to see
72+-- its modules in the output
73+-- 2) with the `FromDep` constructor, a dependencies source file, i.e. we do
74+-- not want its modules in the output; it is there to enable desugaring, and
75+-- to ensure that links between modules are constructed correctly.
76+type FileInfo = InPackage FilePath
77+
78+fileInfoToString :: FileInfo -> FilePath
79+fileInfoToString (Local fn) = fn
80+fileInfoToString (FromDep _ fn) = fn
81+
82+parseFile :: FilePath -> IO (FilePath, String)
83+parseFile input' = (,) input' <$> readFile input'
84+
85+parseAs :: (MonadIO m) => (FilePath -> a) -> FilePath -> m (a, String)
86+parseAs g = fmap (first g) . liftIO . parseFile
87+
88+getDepsModuleNames :: [InPackage (FilePath, P.Module)] -> M.Map P.ModuleName PackageName
89+getDepsModuleNames = foldl go M.empty
90+ where
91+ go deps p = deps # case p of
92+ Local _ -> id
93+ FromDep pkgName (_, m) -> M.insert (P.getModuleName m) pkgName
94+ (#) = flip ($)
95+
96+addPackage :: M.Map P.ModuleName PackageName -> P.Module -> InPackage P.Module
97+addPackage depsModules m =
98+ case M.lookup (P.getModuleName m) depsModules of
99+ Just pkgName -> FromDep pkgName m
100+ Nothing -> Local m
src/Language/PureScript/Docs/ParseAndDesugar.hsdeleted−136
@@ -1,136 +0,0 @@
1−{-# LANGUAGE TupleSections #-}
2−
3−module Language.PureScript.Docs.ParseAndDesugar
4− ( parseAndDesugar
5− , ParseDesugarError(..)
6− ) where
7−
8−import Prelude ()
9−import Prelude.Compat
10−
11−import qualified Data.Map as M
12−import Control.Arrow (first)
13−import Control.Monad
14−
15−import Control.Monad.Trans.Except
16−import Control.Monad.Writer.Strict (runWriterT)
17−import Control.Monad.Error.Class (MonadError(..))
18−import Control.Monad.IO.Class (MonadIO(..))
19−
20−import Web.Bower.PackageMeta (PackageName)
21−
22−import qualified Language.PureScript as P
23−import qualified Language.PureScript.Constants as C
24−import Language.PureScript.Docs.Types
25−import Language.PureScript.Docs.Convert (collectBookmarks)
26−
27−data ParseDesugarError
28− = ParseError P.MultipleErrors
29− | SortModulesError P.MultipleErrors
30− | DesugarError P.MultipleErrors
31− deriving (Show)
32−
33−-- |
34−-- Given:
35−--
36−-- * A list of local source files
37−-- * A list of source files from external dependencies, together with their
38−-- package names
39−-- * A callback, taking a list of bookmarks, and a list of desugared modules
40−--
41−-- This function does the following:
42−--
43−-- * Parse all of the input and dependency source files
44−-- * Partially desugar all of the resulting modules
45−-- * Collect a list of bookmarks from the whole set of source files
46−-- * Collect a list of desugared modules from just the input source files (not
47−-- dependencies)
48−-- * Call the callback with the bookmarks and desugared module list.
49−parseAndDesugar ::
50− [FilePath]
51− -> [(PackageName, FilePath)]
52− -> ([Bookmark] -> [P.Module] -> IO a)
53− -> IO (Either ParseDesugarError a)
54−parseAndDesugar inputFiles depsFiles callback = do
55− inputFiles' <- traverse (parseAs Local) inputFiles
56− depsFiles' <- traverse (\(pkgName, f) -> parseAs (FromDep pkgName) f) depsFiles
57−
58− runExceptT $ do
59− ms <- parseFiles (inputFiles' ++ depsFiles')
60− ms' <- sortModules (map snd ms)
61− (bs, ms'') <- desugarWithBookmarks ms ms'
62− liftIO $ callback bs ms''
63−
64−parseFiles ::
65− [(FileInfo, FilePath)]
66− -> ExceptT ParseDesugarError IO [(FileInfo, P.Module)]
67−parseFiles =
68− throwLeft ParseError . P.parseModulesFromFiles fileInfoToString
69−
70−sortModules ::
71− [P.Module]
72− -> ExceptT ParseDesugarError IO [P.Module]
73−sortModules =
74− fmap fst . throwLeft SortModulesError . sortModules' . map importPrim
75− where
76− sortModules' :: [P.Module] -> Either P.MultipleErrors ([P.Module], P.ModuleGraph)
77− sortModules' = P.sortModules
78−
79−desugarWithBookmarks ::
80− [(FileInfo, P.Module)]
81− -> [P.Module]
82− -> ExceptT ParseDesugarError IO ([Bookmark], [P.Module])
83−desugarWithBookmarks msInfo msSorted = do
84− msDesugared <- throwLeft DesugarError (desugar msSorted)
85−
86− let msDeps = getDepsModuleNames (map (\(fp, m) -> (,m) <$> fp) msInfo)
87− msPackages = map (addPackage msDeps) msDesugared
88− bookmarks = concatMap collectBookmarks msPackages
89−
90− return (bookmarks, takeLocals msPackages)
91−
92−throwLeft :: (MonadError e m) => (l -> e) -> Either l r -> m r
93−throwLeft f = either (throwError . f) return
94−
95−-- | Specifies whether a PureScript source file is considered as:
96−--
97−-- 1) with the `Local` constructor, a target source file, i.e., we want to see
98−-- its modules in the output
99−-- 2) with the `FromDep` constructor, a dependencies source file, i.e. we do
100−-- not want its modules in the output; it is there to enable desugaring, and
101−-- to ensure that links between modules are constructed correctly.
102−type FileInfo = InPackage FilePath
103−
104−fileInfoToString :: FileInfo -> FilePath
105−fileInfoToString (Local fn) = fn
106−fileInfoToString (FromDep _ fn) = fn
107−
108−importPrim :: P.Module -> P.Module
109−importPrim = P.addDefaultImport (P.ModuleName [P.ProperName C.prim])
110−
111−desugar :: [P.Module] -> Either P.MultipleErrors [P.Module]
112−desugar = P.evalSupplyT 0 . desugar'
113− where
114− desugar' :: [P.Module] -> P.SupplyT (Either P.MultipleErrors) [P.Module]
115− desugar' = traverse P.desugarDoModule >=> P.desugarCasesModule >=> ignoreWarnings . P.desugarImports []
116− ignoreWarnings m = liftM fst (runWriterT m)
117−
118−parseFile :: FilePath -> IO (FilePath, String)
119−parseFile input' = (,) input' <$> readFile input'
120−
121−parseAs :: (FilePath -> a) -> FilePath -> IO (a, String)
122−parseAs g = fmap (first g) . parseFile
123−
124−getDepsModuleNames :: [InPackage (FilePath, P.Module)] -> M.Map P.ModuleName PackageName
125−getDepsModuleNames = foldl go M.empty
126− where
127− go deps p = deps # case p of
128− Local _ -> id
129− FromDep pkgName (_, m) -> M.insert (P.getModuleName m) pkgName
130− (#) = flip ($)
131−
132−addPackage :: M.Map P.ModuleName PackageName -> P.Module -> InPackage P.Module
133−addPackage depsModules m =
134− case M.lookup (P.getModuleName m) depsModules of
135− Just pkgName -> FromDep pkgName m
136− Nothing -> Local m
src/Language/PureScript/Docs/Render.hs+19−7
@@ -49,7 +49,7 @@ renderDeclarationWithOptions opts Declaration{..} =
4949 [ keywordClass ]
5050 ++ maybeToList superclasses
5151 ++ [renderType' (typeApp declTitle args)]
52− ++ [keywordWhere | any (isTypeClassMember . cdeclInfo) declChildren]
52+ ++ [keywordWhere | any isTypeClassMember declChildren]
5353
5454 where
5555 superclasses
@@ -58,11 +58,23 @@ renderDeclarationWithOptions opts Declaration{..} =
5858 syntax "("
5959 <> mintersperse (syntax "," <> sp) (map renderConstraint implies)
6060 <> syntax ")" <> sp <> syntax "<="
61+ AliasDeclaration for (P.Fixity associativity precedence) ->
62+ [ keywordFixity associativity
63+ , syntax $ show precedence
64+ , ident $
65+ either
66+ (P.showQualified P.runIdent . dequalifyCurrentModule)
67+ (P.showQualified P.runProperName . dequalifyCurrentModule)
68+ for
69+ , keyword "as"
70+ , ident . tail . init $ declTitle
71+ ]
6172
62− isTypeClassMember (ChildTypeClassMember _) = True
63− isTypeClassMember _ = False
6473 where
6574 renderType' = renderTypeWithOptions opts
75+ dequalifyCurrentModule (P.Qualified mn a)
76+ | mn == currentModule opts = P.Qualified Nothing a
77+ | otherwise = P.Qualified mn a
6678
6779renderChildDeclaration :: ChildDeclaration -> RenderedCode
6880renderChildDeclaration = renderChildDeclarationWithOptions defaultRenderTypeOptions
@@ -86,12 +98,12 @@ renderChildDeclarationWithOptions opts ChildDeclaration{..} =
8698 where
8799 renderType' = renderTypeWithOptions opts
88100
89−renderConstraint :: (P.Qualified P.ProperName, [P.Type]) -> RenderedCode
101+renderConstraint :: P.Constraint -> RenderedCode
90102renderConstraint = renderConstraintWithOptions defaultRenderTypeOptions
91103
92−renderConstraintWithOptions :: RenderTypeOptions -> (P.Qualified P.ProperName, [P.Type]) -> RenderedCode
104+renderConstraintWithOptions :: RenderTypeOptions -> P.Constraint -> RenderedCode
93105renderConstraintWithOptions opts (pn, tys) =
94− renderTypeWithOptions opts $ foldl P.TypeApp (P.TypeConstructor pn) tys
106+ renderTypeWithOptions opts $ foldl P.TypeApp (P.TypeConstructor (fmap P.coerceProperName pn)) tys
95107
96108renderConstraints :: [P.Constraint] -> Maybe RenderedCode
97109renderConstraints = renderConstraintsWithOptions defaultRenderTypeOptions
@@ -108,7 +120,7 @@ renderConstraintsWithOptions opts constraints
108120 mintersperse (syntax "," <> sp)
109121 (map (renderConstraintWithOptions opts) constraints)
110122
111−notQualified :: String -> P.Qualified P.ProperName
123+notQualified :: String -> P.Qualified (P.ProperName a)
112124notQualified = P.Qualified Nothing . P.ProperName
113125
114126typeApp :: String -> [(String, Maybe P.Kind)] -> P.Type
src/Language/PureScript/Docs/RenderedCode/Render.hs+10−4
@@ -9,7 +9,7 @@ module Language.PureScript.Docs.RenderedCode.Render (
99 defaultRenderTypeOptions,
1010 renderTypeWithOptions
1111) where
12−
12+
1313import Prelude ()
1414import Prelude.Compat
1515
@@ -52,9 +52,10 @@ typeLiterals = mkPattern match
5252 ]
5353 where
5454 constraints = mintersperse (syntax "," <> sp) (map renderDep deps)
55+ renderDep :: Constraint -> RenderedCode
5556 renderDep (pn, tys) =
56− let instApp = foldl TypeApp (TypeConstructor pn) tys
57− in renderType instApp
57+ let instApp = foldl TypeApp (TypeConstructor (fmap coerceProperName pn)) tys
58+ in renderType instApp
5859 match REmpty =
5960 Just (syntax "()")
6061 match row@RCons{} =
@@ -172,10 +173,15 @@ renderType = renderTypeWithOptions defaultRenderTypeOptions
172173
173174data RenderTypeOptions = RenderTypeOptions
174175 { prettyPrintObjects :: Bool
176+ , currentModule :: Maybe ModuleName
175177 }
176178
177179defaultRenderTypeOptions :: RenderTypeOptions
178−defaultRenderTypeOptions = RenderTypeOptions { prettyPrintObjects = True }
180+defaultRenderTypeOptions =
181+ RenderTypeOptions
182+ { prettyPrintObjects = True
183+ , currentModule = Nothing
184+ }
179185
180186renderTypeWithOptions :: RenderTypeOptions -> Type -> RenderedCode
181187renderTypeWithOptions opts =
src/Language/PureScript/Docs/RenderedCode/Types.hs+6
@@ -28,6 +28,7 @@ module Language.PureScript.Docs.RenderedCode.Types
2828 , keywordClass
2929 , keywordInstance
3030 , keywordWhere
31+ , keywordFixity
3132 ) where
3233
3334import Prelude ()
@@ -189,3 +190,8 @@ keywordInstance = keyword "instance"
189190
190191keywordWhere :: RenderedCode
191192keywordWhere = keyword "where"
193+
194+keywordFixity :: P.Associativity -> RenderedCode
195+keywordFixity P.Infixl = keyword "infixl"
196+keywordFixity P.Infixr = keyword "infixr"
197+keywordFixity P.Infix = keyword "infix"
src/Language/PureScript/Docs/Types.hs+92−17
@@ -73,9 +73,11 @@ packageName :: Package a -> PackageName
7373packageName = bowerName . pkgMeta
7474
7575data Module = Module
76− { modName :: String
76+ { modName :: P.ModuleName
7777 , modComments :: Maybe String
7878 , modDeclarations :: [Declaration]
79+ -- Re-exported values from other modules
80+ , modReExports :: [(P.ModuleName, [Declaration])]
7981 }
8082 deriving (Show, Eq, Ord)
8183
@@ -84,7 +86,7 @@ data Declaration = Declaration
8486 , declComments :: Maybe String
8587 , declSourceSpan :: Maybe P.SourceSpan
8688 , declChildren :: [ChildDeclaration]
87− , declFixity :: Maybe (P.Fixity, Maybe String)
89+ , declFixity :: Maybe P.Fixity -- TODO: remove in 0.9
8890 , declInfo :: DeclarationInfo
8991 }
9092 deriving (Show, Eq, Ord)
@@ -126,6 +128,12 @@ data DeclarationInfo
126128 -- members are represented as child declarations.
127129 --
128130 | TypeClassDeclaration [(String, Maybe P.Kind)] [P.Constraint]
131+
132+ -- |
133+ -- An operator alias declaration, with the member the alias is for and the
134+ -- operator's fixity.
135+ --
136+ | AliasDeclaration (Either (P.Qualified P.Ident) (P.Qualified (P.ProperName 'P.ConstructorName))) P.Fixity
129137 deriving (Show, Eq, Ord)
130138
131139declInfoToString :: DeclarationInfo -> String
@@ -134,6 +142,38 @@ declInfoToString (DataDeclaration _ _) = "data"
134142declInfoToString (ExternDataDeclaration _) = "externData"
135143declInfoToString (TypeSynonymDeclaration _ _) = "typeSynonym"
136144declInfoToString (TypeClassDeclaration _ _) = "typeClass"
145+declInfoToString (AliasDeclaration _ _) = "alias"
146+
147+isTypeClass :: Declaration -> Bool
148+isTypeClass Declaration{..} =
149+ case declInfo of
150+ TypeClassDeclaration{} -> True
151+ _ -> False
152+
153+isValue :: Declaration -> Bool
154+isValue Declaration{..} =
155+ case declInfo of
156+ ValueDeclaration{} -> True
157+ _ -> False
158+
159+isType :: Declaration -> Bool
160+isType Declaration{..} =
161+ case declInfo of
162+ TypeSynonymDeclaration{} -> True
163+ DataDeclaration{} -> True
164+ ExternDataDeclaration{} -> True
165+ _ -> False
166+
167+isAlias :: Declaration -> Bool
168+isAlias Declaration{..} =
169+ case declInfo of
170+ AliasDeclaration{} -> True
171+ _ -> False
172+
173+-- | Discard any children which do not satisfy the given predicate.
174+filterChildren :: (ChildDeclaration -> Bool) -> Declaration -> Declaration
175+filterChildren p decl =
176+ decl { declChildren = filter p (declChildren decl) }
137177
138178data ChildDeclaration = ChildDeclaration
139179 { cdeclTitle :: String
@@ -167,6 +207,18 @@ childDeclInfoToString (ChildInstance _ _) = "instance"
167207childDeclInfoToString (ChildDataConstructor _) = "dataConstructor"
168208childDeclInfoToString (ChildTypeClassMember _) = "typeClassMember"
169209
210+isTypeClassMember :: ChildDeclaration -> Bool
211+isTypeClassMember ChildDeclaration{..} =
212+ case cdeclInfo of
213+ ChildTypeClassMember{} -> True
214+ _ -> False
215+
216+isDataConstructor :: ChildDeclaration -> Bool
217+isDataConstructor ChildDeclaration{..} =
218+ case cdeclInfo of
219+ ChildDataConstructor{} -> True
220+ _ -> False
221+
170222newtype GithubUser
171223 = GithubUser { runGithubUser :: String }
172224 deriving (Show, Eq, Ord)
@@ -294,9 +346,10 @@ parseVersion' str =
294346
295347asModule :: Parse PackageError Module
296348asModule =
297− Module <$> key "name" asString
349+ Module <$> key "name" (P.moduleNameFromString <$> asString)
298350 <*> key "comments" (perhaps asString)
299351 <*> key "declarations" (eachInArray asDeclaration)
352+ <*> key "reExports" (eachInArray asReExport)
300353
301354asDeclaration :: Parse PackageError Declaration
302355asDeclaration =
@@ -307,12 +360,23 @@ asDeclaration =
307360 <*> key "fixity" (perhaps asFixity)
308361 <*> key "info" asDeclarationInfo
309362
310−asFixity :: Parse PackageError (P.Fixity, Maybe String)
311−asFixity = do
312− fixity <- P.Fixity <$> key "associativity" asAssociativity
313− <*> key "precedence" asIntegral
314− alias <- keyMay "alias" asString
315− return (fixity, alias)
363+asReExport :: Parse PackageError (P.ModuleName, [Declaration])
364+asReExport =
365+ (,) <$> key "moduleName" fromAesonParser
366+ <*> key "declarations" (eachInArray asDeclaration)
367+
368+asInPackage :: Parse BowerError a -> Parse BowerError (InPackage a)
369+asInPackage inner =
370+ build <$> key "package" (perhaps (withString parsePackageName))
371+ <*> key "item" inner
372+ where
373+ build Nothing = Local
374+ build (Just pn) = FromDep pn
375+
376+asFixity :: Parse PackageError P.Fixity
377+asFixity =
378+ P.Fixity <$> key "associativity" asAssociativity
379+ <*> key "precedence" asIntegral
316380
317381parseAssociativity :: String -> Maybe P.Associativity
318382parseAssociativity str = case str of
@@ -341,9 +405,15 @@ asDeclarationInfo = do
341405 "typeClass" ->
342406 TypeClassDeclaration <$> key "arguments" asTypeArguments
343407 <*> key "superclasses" (eachInArray asConstraint)
408+ "alias" ->
409+ AliasDeclaration <$> key "for" asAliasFor
410+ <*> key "fixity" asFixity
344411 other ->
345412 throwCustomError (InvalidDeclarationType other)
346413
414+asAliasFor :: Parse e (Either (P.Qualified P.Ident) (P.Qualified (P.ProperName 'P.ConstructorName)))
415+asAliasFor = fromAesonParser
416+
347417asTypeArguments :: Parse PackageError [(String, Maybe P.Kind)]
348418asTypeArguments = eachInArray asTypeArgument
349419 where
@@ -391,20 +461,19 @@ asConstraint :: Parse PackageError P.Constraint
391461asConstraint = (,) <$> nth 0 asQualifiedProperName
392462 <*> nth 1 (eachInArray asType)
393463
394−asQualifiedProperName :: Parse e (P.Qualified P.ProperName)
464+asQualifiedProperName :: Parse e (P.Qualified (P.ProperName a))
395465asQualifiedProperName = fromAesonParser
396466
467+asQualifiedIdent :: Parse e (P.Qualified P.Ident)
468+asQualifiedIdent = fromAesonParser
469+
397470asBookmarks :: Parse BowerError [Bookmark]
398471asBookmarks = eachInArray asBookmark
399472
400473asBookmark :: Parse BowerError Bookmark
401474asBookmark =
402− build <$> key "package" (perhaps (withString parsePackageName))
403− <*> key "item" ((,) <$> nth 0 (P.moduleNameFromString <$> asString)
404− <*> nth 1 asString)
405− where
406− build Nothing = Local
407− build (Just pn) = FromDep pn
475+ asInPackage ((,) <$> nth 0 (P.moduleNameFromString <$> asString)
476+ <*> nth 1 asString)
408477
409478asResolvedDependencies :: Parse PackageError [(PackageName, Version)]
410479asResolvedDependencies =
@@ -446,10 +515,15 @@ instance A.ToJSON NotYetKnown where
446515
447516instance A.ToJSON Module where
448517 toJSON Module{..} =
449− A.object [ "name" .= modName
518+ A.object [ "name" .= P.runModuleName modName
450519 , "comments" .= modComments
451520 , "declarations" .= modDeclarations
521+ , "reExports" .= map toObj modReExports
452522 ]
523+ where
524+ toObj (mn, decls) = A.object [ "moduleName" .= mn
525+ , "declarations" .= decls
526+ ]
453527
454528instance A.ToJSON Declaration where
455529 toJSON Declaration{..} =
@@ -478,6 +552,7 @@ instance A.ToJSON DeclarationInfo where
478552 ExternDataDeclaration kind -> ["kind" .= kind]
479553 TypeSynonymDeclaration args ty -> ["arguments" .= args, "type" .= ty]
480554 TypeClassDeclaration args super -> ["arguments" .= args, "superclasses" .= super]
555+ AliasDeclaration for fixity -> ["for" .= for, "fixity" .= fixity]
481556
482557instance A.ToJSON ChildDeclarationInfo where
483558 toJSON info = A.object $ "declType" .= childDeclInfoToString info : props
src/Language/PureScript/Environment.hs+16−30
@@ -1,24 +1,8 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.Environment
4−-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−--
13−-----------------------------------------------------------------------------
14−
15−{-# LANGUAGE DeriveDataTypeable #-}
161{-# LANGUAGE OverloadedStrings #-}
172{-# LANGUAGE TemplateHaskell #-}
183
194module Language.PureScript.Environment where
205
21−import Data.Data
226import Data.Maybe (fromMaybe)
237import Data.Aeson.TH
248import qualified Data.Map as M
@@ -43,23 +27,23 @@ data Environment = Environment {
4327 -- |
4428 -- Type names currently in scope
4529 --
46− , types :: M.Map (Qualified ProperName) (Kind, TypeKind)
30+ , types :: M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind)
4731 -- |
4832 -- Data constructors currently in scope, along with their associated type
4933 -- constructor name, argument types and return type.
50− , dataConstructors :: M.Map (Qualified ProperName) (DataDeclType, ProperName, Type, [Ident])
34+ , dataConstructors :: M.Map (Qualified (ProperName 'ConstructorName)) (DataDeclType, ProperName 'TypeName, Type, [Ident])
5135 -- |
5236 -- Type synonyms currently in scope
5337 --
54− , typeSynonyms :: M.Map (Qualified ProperName) ([(String, Maybe Kind)], Type)
38+ , typeSynonyms :: M.Map (Qualified (ProperName 'TypeName)) ([(String, Maybe Kind)], Type)
5539 -- |
5640 -- Available type class dictionaries
5741 --
58− , typeClassDictionaries :: M.Map (Maybe ModuleName) (M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope))
42+ , typeClassDictionaries :: M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope))
5943 -- |
6044 -- Type classes
6145 --
62− , typeClasses :: M.Map (Qualified ProperName) ([(String, Maybe Kind)], [(Ident, Type)], [Constraint])
46+ , typeClasses :: M.Map (Qualified (ProperName 'ClassName)) ([(String, Maybe Kind)], [(Ident, Type)], [Constraint])
6347 } deriving (Show, Read)
6448
6549-- |
@@ -98,7 +82,8 @@ data NameKind
9882 -- |
9983 -- A name for member introduced by foreign import
10084 --
101− | External deriving (Show, Read, Eq, Data, Typeable)
85+ | External
86+ deriving (Show, Read, Eq)
10287
10388-- |
10489-- The kinds of a type
@@ -107,7 +92,7 @@ data TypeKind
10792 -- |
10893 -- Data type
10994 --
110− = DataType [(String, Maybe Kind)] [(ProperName, [Type])]
95+ = DataType [(String, Maybe Kind)] [(ProperName 'ConstructorName, [Type])]
11196 -- |
11297 -- Type synonym
11398 --
@@ -124,7 +109,7 @@ data TypeKind
124109 -- A scoped type variable
125110 --
126111 | ScopedTypeVar
127− deriving (Show, Read, Eq, Data, Typeable)
112+ deriving (Show, Read, Eq)
128113
129114-- |
130115-- The type ('data' or 'newtype') of a data type declaration
@@ -137,7 +122,8 @@ data DataDeclType
137122 -- |
138123 -- A newtype constructor
139124 --
140− | Newtype deriving (Show, Read, Eq, Ord, Data, Typeable)
125+ | Newtype
126+ deriving (Show, Read, Eq, Ord)
141127
142128showDataDeclType :: DataDeclType -> String
143129showDataDeclType Data = "data"
@@ -156,7 +142,7 @@ instance A.FromJSON DataDeclType where
156142-- |
157143-- Construct a ProperName in the Prim module
158144--
159−primName :: String -> Qualified ProperName
145+primName :: String -> Qualified (ProperName a)
160146primName = Qualified (Just $ ModuleName [ProperName C.prim]) . ProperName
161147
162148-- |
@@ -240,7 +226,7 @@ function t1 = TypeApp (TypeApp tyFunction t1)
240226-- associated kinds. There is also a pseudo `Partial` type that corresponds to
241227-- the class with the same name.
242228--
243−primTypes :: M.Map (Qualified ProperName) (Kind, TypeKind)
229+primTypes :: M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind)
244230primTypes =
245231 M.fromList
246232 [ (primName "Function", (FunKind Star (FunKind Star Star), ExternData))
@@ -258,7 +244,7 @@ primTypes =
258244-- The primitive class map. This just contains to `Partial` class, used as a
259245-- kind of magic constraint for partial functions.
260246--
261−primClasses :: M.Map (Qualified ProperName) ([(String, Maybe Kind)], [(Ident, Type)], [Constraint])
247+primClasses :: M.Map (Qualified (ProperName 'ClassName)) ([(String, Maybe Kind)], [(Ident, Type)], [Constraint])
262248primClasses =
263249 M.fromList
264250 [ (primName "Partial", ([], [], [])) ]
@@ -266,14 +252,14 @@ primClasses =
266252-- |
267253-- Finds information about data constructors from the current environment.
268254--
269−lookupConstructor :: Environment -> Qualified ProperName -> (DataDeclType, ProperName, Type, [Ident])
255+lookupConstructor :: Environment -> Qualified (ProperName 'ConstructorName) -> (DataDeclType, ProperName 'TypeName, Type, [Ident])
270256lookupConstructor env ctor =
271257 fromMaybe (internalError "Data constructor not found") $ ctor `M.lookup` dataConstructors env
272258
273259-- |
274260-- Checks whether a data constructor is for a newtype.
275261--
276−isNewtypeConstructor :: Environment -> Qualified ProperName -> Bool
262+isNewtypeConstructor :: Environment -> Qualified (ProperName 'ConstructorName) -> Bool
277263isNewtypeConstructor e ctor = case lookupConstructor e ctor of
278264 (Newtype, _, _, _) -> True
279265 (Data, _, _, _) -> False
src/Language/PureScript/Errors.hs+264−128
@@ -1,6 +1,5 @@
11{-# LANGUAGE GeneralizedNewtypeDeriving #-}
22{-# LANGUAGE FlexibleContexts #-}
3−{-# LANGUAGE RecordWildCards #-}
43{-# LANGUAGE MultiParamTypeClasses #-}
54
65module Language.PureScript.Errors where
@@ -9,6 +8,7 @@ import Prelude ()
98import Prelude.Compat
109
1110import Data.Ord (comparing)
11+import Data.Char (isSpace)
1212import Data.Either (lefts, rights)
1313import Data.List (intercalate, transpose, nub, nubBy, sortBy)
1414import Data.Foldable (fold)
@@ -24,6 +24,7 @@ import Control.Arrow ((&&&))
2424import Language.PureScript.Crash
2525import Language.PureScript.AST
2626import Language.PureScript.Pretty
27+import Language.PureScript.Pretty.Common (before)
2728import Language.PureScript.Types
2829import Language.PureScript.Names
2930import Language.PureScript.Kinds
@@ -53,65 +54,67 @@ data SimpleErrorMessage
5354 | RedefinedIdent Ident
5455 | OverlappingNamesInLet
5556 | UnknownModule ModuleName
56− | UnknownType (Qualified ProperName)
57− | UnknownTypeClass (Qualified ProperName)
57+ | UnknownType (Qualified (ProperName 'TypeName))
58+ | UnknownTypeClass (Qualified (ProperName 'ClassName))
5859 | UnknownValue (Qualified Ident)
59− | UnknownDataConstructor (Qualified ProperName) (Maybe (Qualified ProperName))
60− | UnknownTypeConstructor (Qualified ProperName)
61− | UnknownImportType ModuleName ProperName
62− | UnknownExportType ProperName
63− | UnknownImportTypeClass ModuleName ProperName
64− | UnknownExportTypeClass ProperName
60+ | UnknownDataConstructor (Qualified (ProperName 'ConstructorName)) (Maybe (Qualified (ProperName 'ConstructorName)))
61+ | UnknownTypeConstructor (Qualified (ProperName 'TypeName))
62+ | UnknownImportType ModuleName (ProperName 'TypeName)
63+ | UnknownExportType (ProperName 'TypeName)
64+ | UnknownImportTypeClass ModuleName (ProperName 'ClassName)
65+ | UnknownExportTypeClass (ProperName 'ClassName)
6566 | UnknownImportValue ModuleName Ident
6667 | UnknownExportValue Ident
6768 | UnknownExportModule ModuleName
68− | UnknownImportDataConstructor ModuleName ProperName ProperName
69− | UnknownExportDataConstructor ProperName ProperName
69+ | UnknownImportDataConstructor ModuleName (ProperName 'TypeName) (ProperName 'ConstructorName)
70+ | UnknownExportDataConstructor (ProperName 'TypeName) (ProperName 'ConstructorName)
7071 | ScopeConflict String [ModuleName]
71− | ConflictingTypeDecls ProperName
72− | ConflictingCtorDecls ProperName
73− | TypeConflictsWithClass ProperName
74− | CtorConflictsWithClass ProperName
75− | ClassConflictsWithType ProperName
76− | ClassConflictsWithCtor ProperName
72+ | ScopeShadowing String (Maybe ModuleName) [ModuleName]
73+ | ConflictingTypeDecls (ProperName 'TypeName)
74+ | ConflictingCtorDecls (ProperName 'ConstructorName)
75+ | TypeConflictsWithClass (ProperName 'TypeName)
76+ | CtorConflictsWithClass (ProperName 'ConstructorName)
77+ | ClassConflictsWithType (ProperName 'ClassName)
78+ | ClassConflictsWithCtor (ProperName 'ClassName)
7779 | DuplicateModuleName ModuleName
78− | DuplicateClassExport ProperName
80+ | DuplicateClassExport (ProperName 'ClassName)
7981 | DuplicateValueExport Ident
8082 | DuplicateTypeArgument String
8183 | InvalidDoBind
8284 | InvalidDoLet
8385 | CycleInDeclaration Ident
84− | CycleInTypeSynonym (Maybe ProperName)
86+ | CycleInTypeSynonym (Maybe (ProperName 'TypeName))
8587 | CycleInModules [ModuleName]
8688 | NameIsUndefined Ident
87− | UndefinedTypeVariable ProperName
88− | PartiallyAppliedSynonym (Qualified ProperName)
89+ | UndefinedTypeVariable (ProperName 'TypeName)
90+ | PartiallyAppliedSynonym (Qualified (ProperName 'TypeName))
8991 | EscapedSkolem (Maybe Expr)
9092 | TypesDoNotUnify Type Type
9193 | KindsDoNotUnify Kind Kind
9294 | ConstrainedTypeUnified Type Type
93− | OverlappingInstances (Qualified ProperName) [Type] [Qualified Ident]
94− | NoInstanceFound (Qualified ProperName) [Type]
95− | PossiblyInfiniteInstance (Qualified ProperName) [Type]
96− | CannotDerive (Qualified ProperName) [Type]
97− | CannotFindDerivingType ProperName
95+ | OverlappingInstances (Qualified (ProperName 'ClassName)) [Type] [Qualified Ident]
96+ | NoInstanceFound (Qualified (ProperName 'ClassName)) [Type]
97+ | PossiblyInfiniteInstance (Qualified (ProperName 'ClassName)) [Type]
98+ | CannotDerive (Qualified (ProperName 'ClassName)) [Type]
99+ | CannotFindDerivingType (ProperName 'TypeName)
98100 | DuplicateLabel String (Maybe Expr)
99101 | DuplicateValueDeclaration Ident
100102 | ArgListLengthsDiffer Ident
101103 | OverlappingArgNames (Maybe Ident)
102104 | MissingClassMember Ident
103− | ExtraneousClassMember Ident (Qualified ProperName)
105+ | ExtraneousClassMember Ident (Qualified (ProperName 'ClassName))
104106 | ExpectedType Type Kind
105− | IncorrectConstructorArity (Qualified ProperName)
107+ | IncorrectConstructorArity (Qualified (ProperName 'ConstructorName))
106108 | ExprDoesNotHaveType Expr Type
107109 | PropertyIsMissing String
108110 | AdditionalProperty String
109111 | CannotApplyFunction Type Expr
110112 | TypeSynonymInstance
111− | OrphanInstance Ident (Qualified ProperName) [Type]
112− | InvalidNewtype ProperName
113+ | OrphanInstance Ident (Qualified (ProperName 'ClassName)) [Type]
114+ | InvalidNewtype (ProperName 'TypeName)
113115 | InvalidInstanceHead Type
114116 | TransitiveExportError DeclarationRef [DeclarationRef]
117+ | TransitiveDctorExportError DeclarationRef (ProperName 'ConstructorName)
115118 | ShadowedName Ident
116119 | ShadowedTypeVar String
117120 | UnusedTypeVar String
@@ -120,17 +123,18 @@ data SimpleErrorMessage
120123 | NotExhaustivePattern [[Binder]] Bool
121124 | OverlappingPattern [[Binder]] Bool
122125 | IncompleteExhaustivityCheck
123− | ClassOperator ProperName Ident
124− | MisleadingEmptyTypeImport ModuleName ProperName
126+ | ClassOperator (ProperName 'ClassName) Ident
127+ | MisleadingEmptyTypeImport ModuleName (ProperName 'TypeName)
125128 | ImportHidingModule ModuleName
126129 | UnusedImport ModuleName
127− | UnusedExplicitImport ModuleName [String]
128− | UnusedDctorImport ProperName
129− | UnusedDctorExplicitImport ProperName [ProperName]
130+ | UnusedExplicitImport ModuleName [String] (Maybe ModuleName) [DeclarationRef]
131+ | UnusedDctorImport (ProperName 'TypeName)
132+ | UnusedDctorExplicitImport (ProperName 'TypeName) [ProperName 'ConstructorName]
130133 | DeprecatedOperatorDecl String
134+ | DeprecatedOperatorSection Expr (Either Expr Expr)
131135 | DeprecatedQualifiedSyntax ModuleName ModuleName
132− | DeprecatedClassImport ModuleName ProperName
133− | DeprecatedClassExport ProperName
136+ | DeprecatedClassImport ModuleName (ProperName 'ClassName)
137+ | DeprecatedClassExport (ProperName 'ClassName)
134138 | RedundantUnqualifiedImport ModuleName ImportDeclarationType
135139 | DuplicateSelectiveImport ModuleName
136140 | DuplicateImport ModuleName ImportDeclarationType (Maybe ModuleName)
@@ -138,8 +142,12 @@ data SimpleErrorMessage
138142 | DuplicateExportRef String
139143 | IntOutOfRange Integer String Integer Integer
140144 | RedundantEmptyHidingImport ModuleName
145+ | ImplicitQualifiedImport ModuleName ModuleName [DeclarationRef]
141146 | ImplicitImport ModuleName [DeclarationRef]
147+ | HidingImport ModuleName [DeclarationRef]
142148 | CaseBinderLengthDiffers Int [Binder]
149+ | IncorrectAnonymousArgument
150+ | InvalidOperatorInBinder Ident Ident
143151 deriving (Show)
144152
145153-- | Error message hints, providing more detailed information about failure.
@@ -147,7 +155,7 @@ data ErrorMessageHint
147155 = ErrorUnifyingTypes Type Type
148156 | ErrorInExpression Expr
149157 | ErrorInModule ModuleName
150− | ErrorInInstance (Qualified ProperName) [Type]
158+ | ErrorInInstance (Qualified (ProperName 'ClassName)) [Type]
151159 | ErrorInSubsumption Type Type
152160 | ErrorCheckingAccessor Expr String
153161 | ErrorCheckingType Expr Type
@@ -155,11 +163,11 @@ data ErrorMessageHint
155163 | ErrorCheckingGuard
156164 | ErrorInferringType Expr
157165 | ErrorInApplication Expr Type Expr
158− | ErrorInDataConstructor ProperName
159− | ErrorInTypeConstructor ProperName
166+ | ErrorInDataConstructor (ProperName 'ConstructorName)
167+ | ErrorInTypeConstructor (ProperName 'TypeName)
160168 | ErrorInBindingGroup [Ident]
161169 | ErrorInDataBindingGroup
162− | ErrorInTypeSynonym ProperName
170+ | ErrorInTypeSynonym (ProperName 'TypeName)
163171 | ErrorInValueDeclaration Ident
164172 | ErrorInTypeDeclaration Ident
165173 | ErrorInForeignImport Ident
@@ -177,6 +185,8 @@ data HintCategory
177185
178186data ErrorMessage = ErrorMessage [ErrorMessageHint] SimpleErrorMessage deriving (Show)
179187
188+newtype ErrorSuggestion = ErrorSuggestion String
189+
180190-- | Get the source span for an error
181191errorSpan :: ErrorMessage -> Maybe SourceSpan
182192errorSpan = findHint matchSpan
@@ -239,6 +249,7 @@ errorCode em = case unwrapErrorMessage em of
239249 UnknownImportDataConstructor{} -> "UnknownImportDataConstructor"
240250 UnknownExportDataConstructor{} -> "UnknownExportDataConstructor"
241251 ScopeConflict{} -> "ScopeConflict"
252+ ScopeShadowing{} -> "ScopeShadowing"
242253 ConflictingTypeDecls{} -> "ConflictingTypeDecls"
243254 ConflictingCtorDecls{} -> "ConflictingCtorDecls"
244255 TypeConflictsWithClass{} -> "TypeConflictsWithClass"
@@ -283,6 +294,7 @@ errorCode em = case unwrapErrorMessage em of
283294 InvalidNewtype{} -> "InvalidNewtype"
284295 InvalidInstanceHead{} -> "InvalidInstanceHead"
285296 TransitiveExportError{} -> "TransitiveExportError"
297+ TransitiveDctorExportError{} -> "TransitiveDctorExportError"
286298 ShadowedName{} -> "ShadowedName"
287299 ShadowedTypeVar{} -> "ShadowedTypeVar"
288300 UnusedTypeVar{} -> "UnusedTypeVar"
@@ -299,6 +311,7 @@ errorCode em = case unwrapErrorMessage em of
299311 UnusedDctorImport{} -> "UnusedDctorImport"
300312 UnusedDctorExplicitImport{} -> "UnusedDctorExplicitImport"
301313 DeprecatedOperatorDecl{} -> "DeprecatedOperatorDecl"
314+ DeprecatedOperatorSection{} -> "DeprecatedOperatorSection"
302315 DeprecatedQualifiedSyntax{} -> "DeprecatedQualifiedSyntax"
303316 DeprecatedClassImport{} -> "DeprecatedClassImport"
304317 DeprecatedClassExport{} -> "DeprecatedClassExport"
@@ -309,8 +322,12 @@ errorCode em = case unwrapErrorMessage em of
309322 DuplicateExportRef{} -> "DuplicateExportRef"
310323 IntOutOfRange{} -> "IntOutOfRange"
311324 RedundantEmptyHidingImport{} -> "RedundantEmptyHidingImport"
325+ ImplicitQualifiedImport{} -> "ImplicitQualifiedImport"
312326 ImplicitImport{} -> "ImplicitImport"
327+ HidingImport{} -> "HidingImport"
313328 CaseBinderLengthDiffers{} -> "CaseBinderLengthDiffers"
329+ IncorrectAnonymousArgument -> "IncorrectAnonymousArgument"
330+ InvalidOperatorInBinder{} -> "InvalidOperatorInBinder"
314331
315332-- |
316333-- A stack trace for an error
@@ -412,14 +429,48 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse
412429 gHint (ErrorInInstance cl ts) = ErrorInInstance cl <$> traverse f ts
413430 gHint other = pure other
414431
415−prettyPrintSingleError' :: Bool -> Level -> ErrorMessage ->Box.Box
416−prettyPrintSingleError' full level = flip evalState defaultUnknownMap . prettyPrintSingleError full level
432+wikiUri :: ErrorMessage -> String
433+wikiUri e = "https://github.com/purescript/purescript/wiki/Error-Code-" ++ errorCode e
434+
435+-- TODO Other possible suggestions:
436+-- WildcardInferredType - source span not small enough
437+-- DuplicateSelectiveImport - would require 2 ranges to remove and 1 insert
438+-- DeprecatedClassExport, DeprecatedClassImport, DeprecatedOperatorSection, would want to replace smaller span?
439+errorSuggestion :: SimpleErrorMessage -> Maybe ErrorSuggestion
440+errorSuggestion err = case err of
441+ UnusedImport{} -> emptySuggestion
442+ RedundantEmptyHidingImport{} -> emptySuggestion
443+ DuplicateImport{} -> emptySuggestion
444+ RedundantUnqualifiedImport{} -> emptySuggestion
445+ DeprecatedQualifiedSyntax name qualName -> suggest $
446+ "import " ++ runModuleName name ++ " as " ++ runModuleName qualName
447+ UnusedExplicitImport mn _ qual refs -> suggest $ importSuggestion mn refs qual
448+ ImplicitImport mn refs -> suggest $ importSuggestion mn refs Nothing
449+ ImplicitQualifiedImport mn asModule refs -> suggest $ importSuggestion mn refs (Just asModule)
450+ _ -> Nothing
451+
452+ where
453+ emptySuggestion = Just $ ErrorSuggestion ""
454+ suggest = Just . ErrorSuggestion
455+
456+ importSuggestion :: ModuleName -> [ DeclarationRef ] -> Maybe ModuleName -> String
457+ importSuggestion mn refs qual =
458+ "import " ++ runModuleName mn ++ " (" ++ intercalate ", " (map prettyPrintRef refs) ++ ")" ++ qstr qual
459+
460+ qstr :: Maybe ModuleName -> String
461+ qstr (Just mn) = " as " ++ runModuleName mn
462+ qstr Nothing = ""
463+
464+showSuggestion :: SimpleErrorMessage -> String
465+showSuggestion suggestion = case errorSuggestion suggestion of
466+ Just (ErrorSuggestion x) -> x
467+ _ -> ""
417468
418469-- |
419470-- Pretty print a single error, simplifying if necessary
420471--
421−prettyPrintSingleError :: Bool -> Level -> ErrorMessage -> State TypeMap Box.Box
422−prettyPrintSingleError full level e = do
472+prettyPrintSingleError :: Bool -> Level -> Bool -> ErrorMessage -> Box.Box
473+prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap $ do
423474 em <- onTypesInErrorMessageM replaceUnknowns (if full then e else simplifyErrorMessage e)
424475 um <- get
425476 return (prettyPrintErrorMessage um em)
@@ -428,20 +479,19 @@ prettyPrintSingleError full level e = do
428479 -- Pretty print an ErrorMessage
429480 prettyPrintErrorMessage :: TypeMap -> ErrorMessage -> Box.Box
430481 prettyPrintErrorMessage typeMap (ErrorMessage hints simple) =
431− paras
482+ paras $
432483 [ foldr renderHint (indent (renderSimpleErrorMessage simple)) hints
433− , Box.moveDown 1 typeInformation
434− , Box.moveDown 1 $ paras [ line $ "See " ++ wikiUri ++ " for more information, "
435− , line $ "or to contribute content related to this " ++ levelText ++ "."
436− ]
484+ ] ++
485+ maybe [] (return . Box.moveDown 1) typeInformation ++
486+ [ Box.moveDown 1 $ paras [ line $ "See " ++ wikiUri e ++ " for more information, "
487+ , line $ "or to contribute content related to this " ++ levelText ++ "."
488+ ]
489+ | showWiki
437490 ]
438491 where
439− wikiUri :: String
440− wikiUri = "https://github.com/purescript/purescript/wiki/Error-Code-" ++ errorCode e
441−
442− typeInformation :: Box.Box
443− typeInformation | not (null types) = Box.hsep 1 Box.left [ line "where", paras types]
444− | otherwise = Box.emptyBox 0 0
492+ typeInformation :: Maybe Box.Box
493+ typeInformation | not (null types) = Just $ Box.hsep 1 Box.left [ line "where", paras types ]
494+ | otherwise = Nothing
445495 where
446496 types :: [Box.Box]
447497 types = map skolemInfo (M.elems (umSkolemMap typeMap)) ++
@@ -556,6 +606,13 @@ prettyPrintSingleError full level e = do
556606 paras [ line $ "Conflicting definitions are in scope for " ++ nm ++ " from the following modules:"
557607 , indent $ paras $ map (line . runModuleName) ms
558608 ]
609+ renderSimpleErrorMessage (ScopeShadowing nm exmn ms) =
610+ paras [ line $ "Shadowed definitions are in scope for " ++ nm ++ " from the following open imports:"
611+ , indent $ paras $ map (line . ("import " ++) . runModuleName) ms
612+ , line $ "These will be ignored and the " ++ case exmn of
613+ Just exmn' -> "declaration from " ++ runModuleName exmn' ++ " will be used."
614+ Nothing -> "local declaration will be used."
615+ ]
559616 renderSimpleErrorMessage (ConflictingTypeDecls nm) =
560617 line $ "Conflicting type declarations for " ++ runProperName nm
561618 renderSimpleErrorMessage (ConflictingCtorDecls nm) =
@@ -745,6 +802,10 @@ prettyPrintSingleError full level e = do
745802 paras [ line $ "An export for " ++ prettyPrintExport x ++ " requires the following to also be exported: "
746803 , indent $ paras $ map (line . prettyPrintExport) ys
747804 ]
805+ renderSimpleErrorMessage (TransitiveDctorExportError x ctor) =
806+ paras [ line $ "An export for " ++ prettyPrintExport x ++ " requires the following data constructor to also be exported: "
807+ , indent $ line $ runProperName ctor
808+ ]
748809 renderSimpleErrorMessage (ShadowedName nm) =
749810 line $ "Name '" ++ showIdent nm ++ "' was shadowed."
750811 renderSimpleErrorMessage (ShadowedTypeVar tv) =
@@ -759,7 +820,7 @@ prettyPrintSingleError full level e = do
759820 renderSimpleErrorMessage (MisleadingEmptyTypeImport mn name) =
760821 line $ "Importing type " ++ runProperName name ++ "(..) from " ++ runModuleName mn ++ " is misleading as it has no exported data constructors."
761822 renderSimpleErrorMessage (ImportHidingModule name) =
762− paras [ line $ "'hiding' imports cannot be used to hide modules."
823+ paras [ line "'hiding' imports cannot be used to hide modules."
763824 , line $ "An attempt was made to hide the import of " ++ runModuleName name
764825 ]
765826 renderSimpleErrorMessage (WildcardInferredType ty) =
@@ -773,14 +834,14 @@ prettyPrintSingleError full level e = do
773834 , indent $ typeAsBox ty
774835 ]
775836 renderSimpleErrorMessage (NotExhaustivePattern bs b) =
776− paras $ [ line "A case expression could not be determined to cover all inputs."
777− , line "The following additional cases are required to cover all inputs:\n"
778− , indent $ paras $
779− [ Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs)) ]
780− ++ [ line "..." | not b ]
781− , line "Or alternatively, add a Partial constraint to the type of the enclosing value."
782− , line "Non-exhaustive patterns for values without a `Partial` constraint will be disallowed in PureScript 0.9."
783− ]
837+ paras [ line "A case expression could not be determined to cover all inputs."
838+ , line "The following additional cases are required to cover all inputs:\n"
839+ , indent $ paras $
840+ [ Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs)) ]
841+ ++ [ line "..." | not b ]
842+ , line "Or alternatively, add a Partial constraint to the type of the enclosing value."
843+ , line "Non-exhaustive patterns for values without a `Partial` constraint will be disallowed in PureScript 0.9."
844+ ]
784845 renderSimpleErrorMessage (OverlappingPattern bs b) =
785846 paras $ [ line "A case expression contains unreachable cases:\n"
786847 , Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs))
@@ -793,9 +854,11 @@ prettyPrintSingleError full level e = do
793854 renderSimpleErrorMessage (UnusedImport name) =
794855 line $ "The import of module " ++ runModuleName name ++ " is redundant"
795856
796− renderSimpleErrorMessage (UnusedExplicitImport name names) =
797− paras [ line $ "The import of module " ++ runModuleName name ++ " contains the following unused references:"
798− , indent $ paras $ map line names ]
857+ renderSimpleErrorMessage msg@(UnusedExplicitImport mn names _ _) =
858+ paras [ line $ "The import of module " ++ runModuleName mn ++ " contains the following unused references:"
859+ , indent $ paras $ map line names
860+ , line "It could be replaced with:"
861+ , indent $ line $ showSuggestion msg ]
799862
800863 renderSimpleErrorMessage (UnusedDctorImport name) =
801864 line $ "The import of type " ++ runProperName name ++ " includes data constructors but only the type is used"
@@ -808,15 +871,39 @@ prettyPrintSingleError full level e = do
808871 paras [ line $ "The operator (" ++ name ++ ") was declared as a value rather than an alias for a named function."
809872 , line "Operator aliases are declared by using a fixity declaration, for example:"
810873 , indent $ line $ "infixl 9 someFunction as " ++ name
811− , line $ "Support for value-declared operators will be removed in PureScript 0.9."
874+ , line "Support for value-declared operators will be removed in PureScript 0.9."
812875 ]
813876
877+ renderSimpleErrorMessage (DeprecatedOperatorSection op val) =
878+ paras [ line "An operator section uses legacy syntax. Operator sections are now written using anonymous function syntax:"
879+ , indent $ foldr1 before $
880+ case val of
881+ Left l ->
882+ [ line "("
883+ , prettyPrintValue valueDepth l
884+ , line " "
885+ , renderOperator op
886+ , line " _)"
887+ ]
888+ Right r ->
889+ [ line "(_ "
890+ , renderOperator op
891+ , line " "
892+ , prettyPrintValue valueDepth r
893+ , line ")"
894+ ]
895+ , line "Support for legacy operator sections will be removed in PureScript 0.9."
896+ ]
897+ where
898+ renderOperator (PositionedValue _ _ ex) = renderOperator ex
899+ renderOperator (Var (Qualified _ (Op ident))) = line ident
900+ renderOperator other = Box.hcat Box.top [ line "`", prettyPrintValue valueDepth other, line "`" ]
814901 renderSimpleErrorMessage (DeprecatedQualifiedSyntax name qualName) =
815− paras [ line $ "Import uses the deprecated 'qualified' syntax:"
902+ paras [ line "Import uses the deprecated 'qualified' syntax:"
816903 , indent $ line $ "import qualified " ++ runModuleName name ++ " as " ++ runModuleName qualName
817904 , line "Should instead use the form:"
818905 , indent $ line $ "import " ++ runModuleName name ++ " as " ++ runModuleName qualName
819− , line $ "The deprecated syntax will be removed in PureScript 0.9."
906+ , line "The deprecated syntax will be removed in PureScript 0.9."
820907 ]
821908
822909 renderSimpleErrorMessage (DeprecatedClassImport mn name) =
@@ -824,15 +911,15 @@ prettyPrintSingleError full level e = do
824911 , indent $ line $ runProperName name
825912 , line "Should instead use the form:"
826913 , indent $ line $ "class " ++ runProperName name
827− , line $ "The deprecated syntax will be removed in PureScript 0.9."
914+ , line "The deprecated syntax will be removed in PureScript 0.9."
828915 ]
829916
830917 renderSimpleErrorMessage (DeprecatedClassExport name) =
831− paras [ line $ "Class export uses deprecated syntax that omits the 'class' keyword:"
918+ paras [ line "Class export uses deprecated syntax that omits the 'class' keyword:"
832919 , indent $ line $ runProperName name
833920 , line "Should instead use the form:"
834921 , indent $ line $ "class " ++ runProperName name
835− , line $ "The deprecated syntax will be removed in PureScript 0.9."
922+ , line "The deprecated syntax will be removed in PureScript 0.9."
836923 ]
837924
838925 renderSimpleErrorMessage (RedundantUnqualifiedImport name imp) =
@@ -857,15 +944,35 @@ prettyPrintSingleError full level e = do
857944 renderSimpleErrorMessage (RedundantEmptyHidingImport mn) =
858945 line $ "The import for module " ++ runModuleName mn ++ " is redundant as all members have been explicitly hidden."
859946
860− renderSimpleErrorMessage (ImplicitImport mn refs) =
947+ renderSimpleErrorMessage msg@(ImplicitQualifiedImport importedModule asModule _) =
948+ paras [ line $ "Module " ++ runModuleName importedModule ++ " was imported as " ++ runModuleName asModule ++ " with unspecified imports."
949+ , line $ "As there are multiple modules being imported as " ++ runModuleName asModule ++ ", consider using the explicit form:"
950+ , indent $ line $ showSuggestion msg
951+ ]
952+
953+ renderSimpleErrorMessage msg@(ImplicitImport mn _) =
861954 paras [ line $ "Module " ++ runModuleName mn ++ " has unspecified imports, consider using the explicit form: "
955+ , indent $ line $ showSuggestion msg
956+ ]
957+
958+ renderSimpleErrorMessage (HidingImport mn refs) =
959+ paras [ line $ "Module " ++ runModuleName mn ++ " has unspecified imports, consider using the inclusive form: "
862960 , indent $ line $ "import " ++ runModuleName mn ++ " (" ++ intercalate ", " (map prettyPrintRef refs) ++ ")"
863961 ]
864962
865963 renderSimpleErrorMessage (CaseBinderLengthDiffers l bs) =
866− paras $ [ line $ "Binder list length differs in case alternative:"
867− , indent $ line $ intercalate ", " $ fmap prettyPrintBinderAtom bs
868− , line $ "Expecting " ++ show l ++ " binder" ++ (if l == 1 then "" else "s") ++ "." ]
964+ paras [ line "Binder list length differs in case alternative:"
965+ , indent $ line $ intercalate ", " $ fmap prettyPrintBinderAtom bs
966+ , line $ "Expecting " ++ show l ++ " binder" ++ (if l == 1 then "" else "s") ++ "."
967+ ]
968+
969+ renderSimpleErrorMessage IncorrectAnonymousArgument =
970+ line "An anonymous function argument appears in an invalid context."
971+
972+ renderSimpleErrorMessage (InvalidOperatorInBinder op fn) =
973+ paras $ [ line $ "Operator " ++ showIdent op ++ " cannot be used in a pattern as it is an alias for function " ++ showIdent fn ++ "."
974+ , line "Only aliases for data constructors may be used in patterns."
975+ ]
869976
870977 renderHint :: ErrorMessageHint -> Box.Box -> Box.Box
871978 renderHint (ErrorUnifyingTypes t1 t2) detail =
@@ -995,38 +1102,13 @@ prettyPrintSingleError full level e = do
9951102 paras :: [Box.Box] -> Box.Box
9961103 paras = Box.vcat Box.left
9971104
998− -- Pretty print and export declaration
999− prettyPrintExport :: DeclarationRef -> String
1000− prettyPrintExport (TypeRef pn _) = runProperName pn
1001− prettyPrintExport ref = prettyPrintRef ref
1002−
1003− prettyPrintRef :: DeclarationRef -> String
1004− prettyPrintRef (TypeRef pn Nothing) = runProperName pn ++ "(..)"
1005− prettyPrintRef (TypeRef pn (Just [])) = runProperName pn
1006− prettyPrintRef (TypeRef pn (Just dctors)) = runProperName pn ++ "(" ++ intercalate ", " (map runProperName dctors) ++ ")"
1007− prettyPrintRef (ValueRef ident) = showIdent ident
1008− prettyPrintRef (TypeClassRef pn) = "class " ++ runProperName pn
1009− prettyPrintRef (ProperRef pn) = runProperName pn
1010− prettyPrintRef (TypeInstanceRef ident) = showIdent ident
1011− prettyPrintRef (ModuleRef name) = "module " ++ runModuleName name
1012− prettyPrintRef (PositionedDeclarationRef _ _ ref) = prettyPrintExport ref
1013−
1014− prettyPrintImport :: ModuleName -> ImportDeclarationType -> Maybe ModuleName -> String
1015− prettyPrintImport mn idt qual =
1016− let i = case idt of
1017− Implicit True -> runModuleName mn ++ " (..)"
1018− Implicit False -> runModuleName mn
1019− Explicit refs -> runModuleName mn ++ " (" ++ intercalate ", " (map prettyPrintRef refs) ++ ")"
1020− Hiding refs -> runModuleName mn ++ " hiding (" ++ intercalate "," (map prettyPrintRef refs) ++ ")"
1021− in i ++ maybe "" (\q -> " as " ++ runModuleName q) qual
1022−
10231105 -- | Simplify an error message
10241106 simplifyErrorMessage :: ErrorMessage -> ErrorMessage
10251107 simplifyErrorMessage (ErrorMessage hints simple) = ErrorMessage (simplifyHints hints) simple
10261108 where
10271109 -- Take the last instance of each "hint category"
10281110 simplifyHints :: [ErrorMessageHint] -> [ErrorMessageHint]
1029− simplifyHints = reverse . nubBy categoriesEqual . reverse
1111+ simplifyHints = reverse . nubBy categoriesEqual . stripRedudantHints simple . reverse
10301112
10311113 -- Don't remove hints in the "other" category
10321114 categoriesEqual :: ErrorMessageHint -> ErrorMessageHint -> Bool
@@ -1036,6 +1118,30 @@ prettyPrintSingleError full level e = do
10361118 (_, OtherHint) -> False
10371119 (c1, c2) -> c1 == c2
10381120
1121+ -- | See https://github.com/purescript/purescript/issues/1802
1122+ stripRedudantHints :: SimpleErrorMessage -> [ErrorMessageHint] -> [ErrorMessageHint]
1123+ stripRedudantHints CannotApplyFunction{} = stripFirst isApplicationHint
1124+ where
1125+ isApplicationHint ErrorInApplication{} = True
1126+ isApplicationHint _ = False
1127+ stripRedudantHints ExprDoesNotHaveType{} = stripFirst isCheckHint
1128+ where
1129+ isCheckHint ErrorCheckingType{} = True
1130+ isCheckHint _ = False
1131+ stripRedudantHints TypesDoNotUnify{} = stripFirst isUnifyHint
1132+ where
1133+ isUnifyHint ErrorUnifyingTypes{} = True
1134+ isUnifyHint _ = False
1135+ stripRedudantHints _ = id
1136+
1137+ stripFirst :: (ErrorMessageHint -> Bool) -> [ErrorMessageHint] -> [ErrorMessageHint]
1138+ stripFirst p (PositionedError pos : hs) = PositionedError pos : stripFirst p hs
1139+ stripFirst p (ErrorInModule mn : hs) = ErrorInModule mn : stripFirst p hs
1140+ stripFirst p (hint : hs)
1141+ | p hint = hs
1142+ | otherwise = hint : hs
1143+ stripFirst _ [] = []
1144+
10391145 hintCategory :: ErrorMessageHint -> HintCategory
10401146 hintCategory ErrorCheckingType{} = ExprHint
10411147 hintCategory ErrorInferringType{} = ExprHint
@@ -1047,36 +1153,60 @@ prettyPrintSingleError full level e = do
10471153 hintCategory PositionedError{} = PositionHint
10481154 hintCategory _ = OtherHint
10491155
1156+-- Pretty print and export declaration
1157+prettyPrintExport :: DeclarationRef -> String
1158+prettyPrintExport (TypeRef pn _) = runProperName pn
1159+prettyPrintExport ref = prettyPrintRef ref
1160+
1161+prettyPrintImport :: ModuleName -> ImportDeclarationType -> Maybe ModuleName -> String
1162+prettyPrintImport mn idt qual =
1163+ let i = case idt of
1164+ Implicit -> runModuleName mn
1165+ Explicit refs -> runModuleName mn ++ " (" ++ intercalate ", " (map prettyPrintRef refs) ++ ")"
1166+ Hiding refs -> runModuleName mn ++ " hiding (" ++ intercalate "," (map prettyPrintRef refs) ++ ")"
1167+ in i ++ maybe "" (\q -> " as " ++ runModuleName q) qual
1168+
1169+prettyPrintRef :: DeclarationRef -> String
1170+prettyPrintRef (TypeRef pn Nothing) = runProperName pn ++ "(..)"
1171+prettyPrintRef (TypeRef pn (Just [])) = runProperName pn
1172+prettyPrintRef (TypeRef pn (Just dctors)) = runProperName pn ++ "(" ++ intercalate ", " (map runProperName dctors) ++ ")"
1173+prettyPrintRef (ValueRef ident) = showIdent ident
1174+prettyPrintRef (TypeClassRef pn) = "class " ++ runProperName pn
1175+prettyPrintRef (ProperRef name) = name
1176+prettyPrintRef (TypeInstanceRef ident) = showIdent ident
1177+prettyPrintRef (ModuleRef name) = "module " ++ runModuleName name
1178+prettyPrintRef (PositionedDeclarationRef _ _ ref) = prettyPrintExport ref
1179+
10501180-- |
10511181-- Pretty print multiple errors
10521182--
10531183prettyPrintMultipleErrors :: Bool -> MultipleErrors -> String
1054−prettyPrintMultipleErrors full = renderBox . prettyPrintMultipleErrorsBox full
1184+prettyPrintMultipleErrors full = unlines . map renderBox . prettyPrintMultipleErrorsBox full
10551185
10561186-- |
10571187-- Pretty print multiple warnings
10581188--
1059−prettyPrintMultipleWarnings :: Bool -> MultipleErrors -> String
1060−prettyPrintMultipleWarnings full = renderBox . prettyPrintMultipleWarningsBox full
1189+prettyPrintMultipleWarnings :: Bool -> MultipleErrors -> String
1190+prettyPrintMultipleWarnings full = unlines . map renderBox . prettyPrintMultipleWarningsBox full
10611191
10621192-- | Pretty print warnings as a Box
1063−prettyPrintMultipleWarningsBox :: Bool -> MultipleErrors -> Box.Box
1064−prettyPrintMultipleWarningsBox full = flip evalState defaultUnknownMap . prettyPrintMultipleErrorsWith Warning "Warning found:" "Warning" full
1193+prettyPrintMultipleWarningsBox :: Bool -> MultipleErrors -> [Box.Box]
1194+prettyPrintMultipleWarningsBox full = prettyPrintMultipleErrorsWith Warning "Warning found:" "Warning" full
10651195
10661196-- | Pretty print errors as a Box
1067−prettyPrintMultipleErrorsBox :: Bool -> MultipleErrors -> Box.Box
1068−prettyPrintMultipleErrorsBox full = flip evalState defaultUnknownMap . prettyPrintMultipleErrorsWith Error "Error found:" "Error" full
1069−
1070−prettyPrintMultipleErrorsWith :: Level -> String -> String -> Bool -> MultipleErrors -> State TypeMap Box.Box
1071−prettyPrintMultipleErrorsWith level intro _ full (MultipleErrors [e]) = do
1072− result <- prettyPrintSingleError full level e
1073− return $
1074− Box.vcat Box.left [ Box.text intro
1075− , result
1076− ]
1077−prettyPrintMultipleErrorsWith level _ intro full (MultipleErrors es) = do
1078− result <- forM es $ prettyPrintSingleError full level
1079− return $ Box.vsep 1 Box.left $ concat $ zipWith withIntro [1 :: Int ..] result
1197+prettyPrintMultipleErrorsBox :: Bool -> MultipleErrors -> [Box.Box]
1198+prettyPrintMultipleErrorsBox full = prettyPrintMultipleErrorsWith Error "Error found:" "Error" full
1199+
1200+prettyPrintMultipleErrorsWith :: Level -> String -> String -> Bool -> MultipleErrors -> [Box.Box]
1201+prettyPrintMultipleErrorsWith level intro _ full (MultipleErrors [e]) =
1202+ let result = prettyPrintSingleError full level True e
1203+ in [ Box.vcat Box.left [ Box.text intro
1204+ , result
1205+ ]
1206+ ]
1207+prettyPrintMultipleErrorsWith level _ intro full (MultipleErrors es) =
1208+ let result = map (prettyPrintSingleError full level True) es
1209+ in concat $ zipWith withIntro [1 :: Int ..] result
10801210 where
10811211 withIntro i err = [ Box.text (intro ++ " " ++ show i ++ " of " ++ show (length es) ++ ":")
10821212 , Box.moveRight 2 err
@@ -1138,9 +1268,15 @@ line :: String -> Box.Box
11381268line = Box.text
11391269
11401270renderBox :: Box.Box -> String
1141−renderBox = unlines . map trimEnd . lines . Box.render
1271+renderBox = unlines
1272+ . map (dropWhileEnd isSpace)
1273+ . dropWhile whiteSpace
1274+ . dropWhileEnd whiteSpace
1275+ . lines
1276+ . Box.render
11421277 where
1143− trimEnd = reverse . dropWhile (== ' ') . reverse
1278+ dropWhileEnd p = reverse . dropWhile p . reverse
1279+ whiteSpace = all isSpace
11441280
11451281-- |
11461282-- Rethrow an error with a more detailed error message in the case of failure
@@ -1148,7 +1284,7 @@ renderBox = unlines . map trimEnd . lines . Box.render
11481284rethrow :: (MonadError e m) => (e -> e) -> m a -> m a
11491285rethrow f = flip catchError $ \e -> throwError (f e)
11501286
1151−reifyErrors :: (Functor m, MonadError e m) => m a -> m (Either e a)
1287+reifyErrors :: (MonadError e m) => m a -> m (Either e a)
11521288reifyErrors ma = catchError (fmap Right ma) (return . Left)
11531289
11541290reflectErrors :: (MonadError e m) => m (Either e a) -> m a
@@ -1175,13 +1311,13 @@ withPosition pos (ErrorMessage hints se) = ErrorMessage (PositionedError pos : h
11751311-- |
11761312-- Collect errors in in parallel
11771313--
1178−parU :: (MonadError MultipleErrors m, Functor m) => [a] -> (a -> m b) -> m [b]
1314+parU :: (MonadError MultipleErrors m) => [a] -> (a -> m b) -> m [b]
11791315parU xs f = forM xs (withError . f) >>= collectErrors
11801316 where
1181− withError :: (MonadError MultipleErrors m, Functor m) => m a -> m (Either MultipleErrors a)
1317+ withError :: (MonadError MultipleErrors m) => m a -> m (Either MultipleErrors a)
11821318 withError u = catchError (Right <$> u) (return . Left)
11831319
1184− collectErrors :: (MonadError MultipleErrors m, Functor m) => [Either MultipleErrors a] -> m [a]
1320+ collectErrors :: (MonadError MultipleErrors m) => [Either MultipleErrors a] -> m [a]
11851321 collectErrors es = case lefts es of
11861322 [] -> return $ rights es
11871323 errs -> throwError $ fold errs
src/Language/PureScript/Externs.hs+14−13
@@ -73,28 +73,28 @@ data ExternsFixity = ExternsFixity
7373 -- | The operator symbol
7474 , efOperator :: String
7575 -- | The value the operator is an alias for
76− , efAlias :: Maybe Ident
76+ , efAlias :: Maybe (Either (Qualified Ident) (Qualified (ProperName 'ConstructorName)))
7777 } deriving (Show, Read)
7878
7979-- | A type or value declaration appearing in an externs file
8080data ExternsDeclaration =
8181 -- | A type declaration
8282 EDType
83− { edTypeName :: ProperName
83+ { edTypeName :: ProperName 'TypeName
8484 , edTypeKind :: Kind
8585 , edTypeDeclarationKind :: TypeKind
8686 }
8787 -- | A type synonym
8888 | EDTypeSynonym
89− { edTypeSynonymName :: ProperName
89+ { edTypeSynonymName :: ProperName 'TypeName
9090 , edTypeSynonymArguments :: [(String, Maybe Kind)]
9191 , edTypeSynonymType :: Type
9292 }
9393 -- | A data construtor
9494 | EDDataConstructor
95− { edDataCtorName :: ProperName
95+ { edDataCtorName :: ProperName 'ConstructorName
9696 , edDataCtorOrigin :: DataDeclType
97− , edDataCtorTypeCtor :: ProperName
97+ , edDataCtorTypeCtor :: ProperName 'TypeName
9898 , edDataCtorType :: Type
9999 , edDataCtorFields :: [Ident]
100100 }
@@ -105,14 +105,14 @@ data ExternsDeclaration =
105105 }
106106 -- | A type class declaration
107107 | EDClass
108− { edClassName :: ProperName
108+ { edClassName :: ProperName 'ClassName
109109 , edClassTypeArguments :: [(String, Maybe Kind)]
110110 , edClassMembers :: [(Ident, Type)]
111111 , edClassConstraints :: [Constraint]
112112 }
113113 -- | An instance declaration
114114 | EDInstance
115− { edInstanceClassName :: Qualified ProperName
115+ { edInstanceClassName :: Qualified (ProperName 'ClassName)
116116 , edInstanceName :: Ident
117117 , edInstanceTypes :: [Type]
118118 , edInstanceConstraints :: Maybe [Constraint]
@@ -153,7 +153,8 @@ moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..}
153153 efDeclarations = concatMap toExternsDeclaration efExports
154154
155155 fixityDecl :: Declaration -> Maybe ExternsFixity
156− fixityDecl (FixityDeclaration (Fixity assoc prec) op alias) = fmap (const (ExternsFixity assoc prec op alias)) (find exportsOp exps)
156+ fixityDecl (FixityDeclaration (Fixity assoc prec) op alias) =
157+ fmap (const (ExternsFixity assoc prec op alias)) (find exportsOp exps)
157158 where
158159 exportsOp :: DeclarationRef -> Bool
159160 exportsOp (PositionedDeclarationRef _ _ r) = exportsOp r
@@ -178,7 +179,7 @@ moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..}
178179 Just (kind, tk@(DataType _ tys)) ->
179180 EDType pn kind tk : [ EDDataConstructor dctor dty pn ty args
180181 | dctor <- fromMaybe (map fst tys) dctors
181− , (dty, _, ty, args) <- maybeToList (M.lookup (Qualified (Just mn) dctor) (dataConstructors env))
182+ , (dty, _, ty, args) <- maybeToList (Qualified (Just mn) dctor `M.lookup` dataConstructors env)
182183 ]
183184 _ -> internalError "toExternsDeclaration: Invalid input"
184185 toExternsDeclaration (ValueRef ident)
@@ -186,10 +187,10 @@ moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..}
186187 = [ EDValue ident ty ]
187188 toExternsDeclaration (TypeClassRef className)
188189 | Just (args, members, implies) <- Qualified (Just mn) className `M.lookup` typeClasses env
189− , Just (kind, TypeSynonym) <- M.lookup (Qualified (Just mn) className) (types env)
190− , Just (_, synTy) <- Qualified (Just mn) className `M.lookup` typeSynonyms env
191− = [ EDType className kind TypeSynonym
192− , EDTypeSynonym className args synTy
190+ , Just (kind, TypeSynonym) <- Qualified (Just mn) (coerceProperName className) `M.lookup` types env
191+ , Just (_, synTy) <- Qualified (Just mn) (coerceProperName className) `M.lookup` typeSynonyms env
192+ = [ EDType (coerceProperName className) kind TypeSynonym
193+ , EDTypeSynonym (coerceProperName className) args synTy
193194 , EDClass className args members implies
194195 ]
195196 toExternsDeclaration (TypeInstanceRef ident)
src/Language/PureScript/Ide.hsnew file+199
@@ -0,0 +1,199 @@
1+{-# LANGUAGE ConstraintKinds #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE MultiParamTypeClasses #-}
4+{-# LANGUAGE OverloadedStrings #-}
5+{-# LANGUAGE PackageImports #-}
6+{-# LANGUAGE TemplateHaskell #-}
7+{-# LANGUAGE TupleSections #-}
8+
9+module Language.PureScript.Ide where
10+
11+import Prelude ()
12+import Prelude.Compat
13+
14+import Control.Monad.Error.Class
15+import Control.Monad.IO.Class
16+import "monad-logger" Control.Monad.Logger
17+import Control.Monad.Reader.Class
18+import Data.Foldable
19+import qualified Data.Map.Lazy as M
20+import Data.Maybe (catMaybes, mapMaybe)
21+import Data.Monoid
22+import Data.Text (Text)
23+import qualified Data.Text as T
24+import qualified Language.PureScript.Ide.CaseSplit as CS
25+import Language.PureScript.Ide.Command
26+import Language.PureScript.Ide.Completion
27+import Language.PureScript.Ide.Error
28+import Language.PureScript.Ide.Externs
29+import Language.PureScript.Ide.Filter
30+import Language.PureScript.Ide.Matcher
31+import Language.PureScript.Ide.Pursuit
32+import Language.PureScript.Ide.Reexports
33+import Language.PureScript.Ide.SourceFile
34+import Language.PureScript.Ide.State
35+import Language.PureScript.Ide.Types
36+import System.Directory
37+import System.FilePath
38+import System.Exit
39+
40+
41+handleCommand :: (PscIde m, MonadLogger m, MonadError PscIdeError m) =>
42+ Command -> m Success
43+handleCommand (Load modules deps) =
44+ loadModulesAndDeps modules deps
45+handleCommand (Type search filters) =
46+ findType search filters
47+handleCommand (Complete filters matcher) =
48+ findCompletions filters matcher
49+handleCommand (Pursuit query Package) =
50+ findPursuitPackages query
51+handleCommand (Pursuit query Identifier) =
52+ findPursuitCompletions query
53+handleCommand (List LoadedModules) =
54+ printModules
55+handleCommand (List AvailableModules) =
56+ listAvailableModules
57+handleCommand (List (Imports fp)) =
58+ importsForFile fp
59+handleCommand (CaseSplit l b e wca t) =
60+ caseSplit l b e wca t
61+handleCommand (AddClause l wca) =
62+ pure $ addClause l wca
63+handleCommand Cwd =
64+ TextResult . T.pack <$> liftIO getCurrentDirectory
65+handleCommand Quit = liftIO exitSuccess
66+
67+findCompletions :: (PscIde m, MonadLogger m) =>
68+ [Filter] -> Matcher -> m Success
69+findCompletions filters matcher =
70+ CompletionResult . getCompletions filters matcher <$> getAllModulesWithReexports
71+
72+findType :: (PscIde m, MonadLogger m) =>
73+ DeclIdent -> [Filter] -> m Success
74+findType search filters =
75+ CompletionResult . getExactMatches search filters <$> getAllModulesWithReexports
76+
77+findPursuitCompletions :: (MonadIO m, MonadLogger m) =>
78+ PursuitQuery -> m Success
79+findPursuitCompletions (PursuitQuery q) =
80+ PursuitResult <$> liftIO (searchPursuitForDeclarations q)
81+
82+findPursuitPackages :: (MonadIO m, MonadLogger m) =>
83+ PursuitQuery -> m Success
84+findPursuitPackages (PursuitQuery q) =
85+ PursuitResult <$> liftIO (findPackagesForModuleIdent q)
86+
87+loadExtern ::(PscIde m, MonadLogger m, MonadError PscIdeError m) =>
88+ FilePath -> m ()
89+loadExtern fp = do
90+ m <- readExternFile fp
91+ insertModule m
92+
93+printModules :: (PscIde m) => m Success
94+printModules = printModules' <$> getPscIdeState
95+
96+printModules' :: M.Map ModuleIdent [ExternDecl] -> Success
97+printModules' = ModuleList . M.keys
98+
99+listAvailableModules :: PscIde m => m Success
100+listAvailableModules = do
101+ outputPath <- confOutputPath . envConfiguration <$> ask
102+ liftIO $ do
103+ cwd <- getCurrentDirectory
104+ dirs <- getDirectoryContents (cwd </> outputPath)
105+ return (ModuleList (listAvailableModules' dirs))
106+
107+listAvailableModules' :: [FilePath] -> [Text]
108+listAvailableModules' dirs =
109+ let cleanedModules = filter (`notElem` [".", ".."]) dirs
110+ in map T.pack cleanedModules
111+
112+caseSplit :: (PscIde m, MonadLogger m, MonadError PscIdeError m) =>
113+ Text -> Int -> Int -> CS.WildcardAnnotations -> Text -> m Success
114+caseSplit l b e csa t = do
115+ patterns <- CS.makePattern l b e csa <$> CS.caseSplit t
116+ pure (MultilineTextResult patterns)
117+
118+addClause :: Text -> CS.WildcardAnnotations -> Success
119+addClause t wca = MultilineTextResult (CS.addClause t wca)
120+
121+importsForFile :: (MonadIO m, MonadLogger m, MonadError PscIdeError m) =>
122+ FilePath -> m Success
123+importsForFile fp = do
124+ imports <- getImportsForFile fp
125+ pure (ImportList imports)
126+
127+-- | The first argument is a set of modules to load. The second argument
128+-- denotes modules for which to load dependencies
129+loadModulesAndDeps :: (PscIde m, MonadLogger m, MonadError PscIdeError m) =>
130+ [ModuleIdent] -> [ModuleIdent] -> m Success
131+loadModulesAndDeps mods deps = do
132+ r1 <- mapM loadModule (mods ++ deps)
133+ r2 <- mapM loadModuleDependencies deps
134+ let moduleResults = T.concat r1
135+ let dependencyResults = T.concat r2
136+ pure (TextResult (moduleResults <> ", " <> dependencyResults))
137+
138+loadModuleDependencies ::(PscIde m, MonadLogger m, MonadError PscIdeError m) =>
139+ ModuleIdent -> m Text
140+loadModuleDependencies moduleName = do
141+ m <- getModule moduleName
142+ case getDependenciesForModule <$> m of
143+ Just deps -> do
144+ mapM_ loadModule deps
145+ -- We need to load the modules, that get reexported from the dependencies
146+ depModules <- catMaybes <$> mapM getModule deps
147+ -- What to do with errors here? This basically means a reexported dependency
148+ -- doesn't exist in the output/ folder
149+ traverse_ loadReexports depModules
150+ pure ("Dependencies for " <> moduleName <> " loaded.")
151+ Nothing -> throwError (ModuleNotFound moduleName)
152+
153+loadReexports :: (PscIde m, MonadLogger m, MonadError PscIdeError m) =>
154+ Module -> m [ModuleIdent]
155+loadReexports m = case getReexports m of
156+ [] -> pure []
157+ exportDeps -> do
158+ -- I'm fine with this crashing on a failed pattern match.
159+ -- If this ever fails I'll need to look at GADTs
160+ let reexports = map (\(Export mn) -> mn) exportDeps
161+ $(logDebug) ("Loading reexports for module: " <> fst m <>
162+ " reexports: " <> T.intercalate ", " reexports)
163+ traverse_ loadModule reexports
164+ exportDepsModules <- catMaybes <$> traverse getModule reexports
165+ exportDepDeps <- traverse loadReexports exportDepsModules
166+ return $ concat exportDepDeps
167+
168+getDependenciesForModule :: Module -> [ModuleIdent]
169+getDependenciesForModule (_, decls) = mapMaybe getDependencyName decls
170+ where getDependencyName (Dependency dependencyName _ _) = Just dependencyName
171+ getDependencyName _ = Nothing
172+
173+loadModule :: (PscIde m, MonadLogger m, MonadError PscIdeError m) =>
174+ ModuleIdent -> m Text
175+loadModule "Prim" = pure "Prim won't be loaded"
176+loadModule mn = do
177+ path <- filePathFromModule mn
178+ loadExtern path
179+ $(logDebug) ("Loaded extern file at: " <> T.pack path)
180+ pure ("Loaded extern file at: " <> T.pack path)
181+
182+filePathFromModule :: (PscIde m, MonadError PscIdeError m) =>
183+ ModuleIdent -> m FilePath
184+filePathFromModule moduleName = do
185+ outputPath <- confOutputPath . envConfiguration <$> ask
186+ cwd <- liftIO getCurrentDirectory
187+ let path = cwd </> outputPath </> T.unpack moduleName </> "externs.json"
188+ ex <- liftIO $ doesFileExist path
189+ if ex
190+ then pure path
191+ else throwError (ModuleFileNotFound moduleName)
192+
193+-- | Taken from Data.Either.Utils
194+maybeToEither :: MonadError e m =>
195+ e -- ^ (Left e) will be returned if the Maybe value is Nothing
196+ -> Maybe a -- ^ (Right a) will be returned if this is (Just a)
197+ -> m a
198+maybeToEither errorval Nothing = throwError errorval
199+maybeToEither _ (Just normalval) = return normalval
src/Language/PureScript/Ide/CaseSplit.hsnew file+148
@@ -0,0 +1,148 @@
1+{-# LANGUAGE ConstraintKinds #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE LambdaCase #-}
5+{-# LANGUAGE MultiParamTypeClasses #-}
6+{-# LANGUAGE OverloadedStrings #-}
7+{-# LANGUAGE PackageImports #-}
8+{-# LANGUAGE RecordWildCards #-}
9+
10+module Language.PureScript.Ide.CaseSplit
11+ ( WildcardAnnotations()
12+ , explicitAnnotations
13+ , noAnnotations
14+ , makePattern
15+ , addClause
16+ , caseSplit
17+ ) where
18+
19+import Prelude ()
20+import Prelude.Compat hiding (lex)
21+
22+import Control.Monad.Error.Class
23+import "monad-logger" Control.Monad.Logger
24+import Data.List (find)
25+import Data.Monoid
26+import Data.Text (Text)
27+import qualified Data.Text as T
28+import Language.PureScript.AST
29+import Language.PureScript.Environment
30+import Language.PureScript.Externs
31+import Language.PureScript.Ide.Error
32+import Language.PureScript.Ide.Externs (unwrapPositioned)
33+import Language.PureScript.Ide.State
34+import Language.PureScript.Ide.Types hiding (Type)
35+import Language.PureScript.Names
36+import Language.PureScript.Parser.Common (runTokenParser)
37+import Language.PureScript.Parser.Declarations
38+import Language.PureScript.Parser.Lexer (lex)
39+import Language.PureScript.Parser.Types
40+import Language.PureScript.Pretty
41+import Language.PureScript.Types
42+import Text.Parsec as P
43+
44+type Constructor = (ProperName 'ConstructorName, [Type])
45+
46+newtype WildcardAnnotations = WildcardAnnotations Bool
47+
48+explicitAnnotations :: WildcardAnnotations
49+explicitAnnotations = WildcardAnnotations True
50+
51+noAnnotations :: WildcardAnnotations
52+noAnnotations = WildcardAnnotations False
53+
54+caseSplit :: (PscIde m, MonadLogger m, MonadError PscIdeError m) =>
55+ Text -> m [Constructor]
56+caseSplit q = do
57+ (tc, args) <- splitTypeConstructor (parseType' (T.unpack q))
58+ (EDType _ _ (DataType typeVars ctors)) <- findTypeDeclaration tc
59+ let applyTypeVars = everywhereOnTypes (replaceAllTypeVars (zip (map fst typeVars) args))
60+ let appliedCtors = map (\(n, ts) -> (n, map applyTypeVars ts)) ctors
61+ pure appliedCtors
62+
63+findTypeDeclaration :: (PscIde m, MonadLogger m, MonadError PscIdeError m) =>
64+ ProperName 'TypeName -> m ExternsDeclaration
65+findTypeDeclaration q = do
66+ efs <- getExternFiles
67+ let m = getFirst $ foldMap (findTypeDeclaration' q) efs
68+ case m of
69+ Just mn -> pure mn
70+ Nothing -> throwError (GeneralError "Not Found")
71+
72+findTypeDeclaration' ::
73+ ProperName 'TypeName
74+ -> ExternsFile
75+ -> First ExternsDeclaration
76+findTypeDeclaration' t ExternsFile{..} =
77+ First $ find (\case
78+ EDType tn _ _ -> tn == t
79+ _ -> False) efDeclarations
80+
81+splitTypeConstructor :: (MonadError PscIdeError m) =>
82+ Type -> m (ProperName 'TypeName, [Type])
83+splitTypeConstructor = go []
84+ where
85+ go acc (TypeApp ty arg) = go (arg : acc) ty
86+ go acc (TypeConstructor tc) = pure (disqualify tc, acc)
87+ go _ _ = throwError (GeneralError "Failed to read TypeConstructor")
88+
89+prettyCtor :: WildcardAnnotations -> Constructor -> Text
90+prettyCtor _ (ctorName, []) = T.pack (runProperName ctorName)
91+prettyCtor wsa (ctorName, ctorArgs) =
92+ "("<> T.pack (runProperName ctorName) <> " "
93+ <> T.unwords (map (prettyPrintWildcard wsa) ctorArgs) <>")"
94+
95+prettyPrintWildcard :: WildcardAnnotations -> Type -> Text
96+prettyPrintWildcard (WildcardAnnotations True) = prettyWildcard
97+prettyPrintWildcard (WildcardAnnotations False) = const "_"
98+
99+prettyWildcard :: Type -> Text
100+prettyWildcard t = "( _ :: " <> T.strip (T.pack (prettyPrintTypeAtom t)) <> ")"
101+
102+-- | Constructs Patterns to insert into a sourcefile
103+makePattern :: Text -- ^ Current line
104+ -> Int -- ^ Begin of the split
105+ -> Int -- ^ End of the split
106+ -> WildcardAnnotations -- ^ Whether to explicitly type the splits
107+ -> [Constructor] -- ^ Constructors to split
108+ -> [Text]
109+makePattern t x y wsa = makePattern' (T.take x t) (T.drop y t)
110+ where
111+ makePattern' lhs rhs = map (\ctor -> lhs <> prettyCtor wsa ctor <> rhs)
112+
113+addClause :: Text -> WildcardAnnotations -> [Text]
114+addClause s wca =
115+ let (fName, fType) = parseTypeDeclaration' (T.unpack s)
116+ (args, _) = splitFunctionType fType
117+ template = T.pack (runIdent fName) <> " " <>
118+ T.unwords (map (prettyPrintWildcard wca) args) <>
119+ " = ?" <> (T.strip . T.pack . runIdent $ fName)
120+ in [s, template]
121+
122+parseType' :: String -> Type
123+parseType' s = let (Right t) = do
124+ ts <- lex "" s
125+ runTokenParser "" (parseType <* P.eof) ts
126+ in t
127+
128+parseTypeDeclaration' :: String -> (Ident, Type)
129+parseTypeDeclaration' s =
130+ let x = do
131+ ts <- lex "" s
132+ runTokenParser "" (parseDeclaration <* P.eof) ts
133+ in
134+ case unwrapPositioned <$> x of
135+ Right (TypeDeclaration i t) -> (i, t)
136+ y -> error (show y)
137+
138+splitFunctionType :: Type -> ([Type], Type)
139+splitFunctionType t = (arguments, returns)
140+ where
141+ returns = last splitted
142+ arguments = init splitted
143+ splitted = splitType' t
144+ splitType' (ForAll _ t' _) = splitType' t'
145+ splitType' (ConstrainedType _ t') = splitType' t'
146+ splitType' (TypeApp (TypeApp t' lhs) rhs)
147+ | t' == tyFunction = lhs : splitType' rhs
148+ splitType' t' = [t']
src/Language/PureScript/Ide/CodecJSON.hsnew file+13
@@ -0,0 +1,13 @@
1+module Language.PureScript.Ide.CodecJSON where
2+
3+import Data.Aeson
4+import Data.Text (Text())
5+import Data.Text.Lazy (toStrict, fromStrict)
6+import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8)
7+
8+encodeT :: (ToJSON a) => a -> Text
9+encodeT = toStrict . decodeUtf8 . encode
10+
11+decodeT :: (FromJSON a) => Text -> Maybe a
12+decodeT = decode . encodeUtf8 . fromStrict
13+
src/Language/PureScript/Ide/Command.hsnew file+101
@@ -0,0 +1,101 @@
1+{-# LANGUAGE MultiParamTypeClasses #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE ScopedTypeVariables #-}
4+
5+module Language.PureScript.Ide.Command where
6+
7+import Prelude ()
8+import Prelude.Compat
9+
10+import Control.Monad
11+import Data.Aeson
12+import Data.Maybe
13+import Data.Text (Text)
14+import Language.PureScript.Ide.CaseSplit
15+import Language.PureScript.Ide.Filter
16+import Language.PureScript.Ide.Matcher
17+import Language.PureScript.Ide.Types
18+
19+data Command
20+ = Load { loadModules :: [ModuleIdent]
21+ , loadDependencies :: [ModuleIdent]}
22+ | Type { typeSearch :: DeclIdent
23+ , typeFilters :: [Filter]}
24+ | Complete { completeFilters :: [Filter]
25+ , completeMatcher :: Matcher}
26+ | Pursuit { pursuitQuery :: PursuitQuery
27+ , pursuitSearchType :: PursuitSearchType}
28+ | List {listType :: ListType}
29+ | CaseSplit {
30+ caseSplitLine :: Text
31+ , caseSplitBegin :: Int
32+ , caseSplitEnd :: Int
33+ , caseSplitAnnotations :: WildcardAnnotations
34+ , caseSplitType :: Type}
35+ | AddClause {
36+ addClauseLine :: Text
37+ , addClauseAnnotations :: WildcardAnnotations}
38+ | Cwd
39+ | Quit
40+
41+data ListType = LoadedModules | Imports FilePath | AvailableModules
42+
43+instance FromJSON ListType where
44+ parseJSON = withObject "ListType" $ \o -> do
45+ (listType' :: String) <- o .: "type"
46+ case listType' of
47+ "import" -> do
48+ fp <- o .: "file"
49+ return (Imports fp)
50+ "loadedModules" -> return LoadedModules
51+ "availableModules" -> return AvailableModules
52+ _ -> mzero
53+
54+instance FromJSON Command where
55+ parseJSON = withObject "command" $ \o -> do
56+ (command :: String) <- o .: "command"
57+ case command of
58+ "list" -> do
59+ listType' <- o .:? "params"
60+ return $ List (fromMaybe LoadedModules listType')
61+ "cwd" -> return Cwd
62+ "quit" -> return Quit
63+ "load" -> do
64+ params <- o .: "params"
65+ mods <- params .:? "modules"
66+ deps <- params .:? "dependencies"
67+ return $ Load (fromMaybe [] mods) (fromMaybe [] deps)
68+ "type" -> do
69+ params <- o .: "params"
70+ search <- params .: "search"
71+ filters <- params .: "filters"
72+ return $ Type search filters
73+ "complete" -> do
74+ params <- o .: "params"
75+ filters <- params .:? "filters"
76+ matcher <- params .:? "matcher"
77+ return $ Complete (fromMaybe [] filters) (fromMaybe mempty matcher)
78+ "pursuit" -> do
79+ params <- o .: "params"
80+ query <- params .: "query"
81+ queryType <- params .: "type"
82+ return $ Pursuit query queryType
83+ "caseSplit" -> do
84+ params <- o .: "params"
85+ line <- params .: "line"
86+ begin <- params .: "begin"
87+ end <- params .: "end"
88+ annotations <- params .: "annotations"
89+ type' <- params .: "type"
90+ return $ CaseSplit line begin end (if annotations
91+ then explicitAnnotations
92+ else noAnnotations) type'
93+ "addClause" -> do
94+ params <- o .: "params"
95+ line <- params .: "line"
96+ annotations <- params .: "annotations"
97+ return $ AddClause line (if annotations
98+ then explicitAnnotations
99+ else noAnnotations)
100+ _ -> mzero
101+
src/Language/PureScript/Ide/Completion.hsnew file+35
@@ -0,0 +1,35 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module Language.PureScript.Ide.Completion
3+ (getCompletions, getExactMatches)
4+ where
5+
6+import Prelude ()
7+import Prelude.Compat
8+
9+import Data.Maybe (mapMaybe)
10+import Language.PureScript.Ide.Filter
11+import Language.PureScript.Ide.Matcher
12+import Language.PureScript.Ide.Types
13+
14+-- | Applies the CompletionFilters and the Matcher to the given Modules
15+-- and sorts the found Completions according to the Matching Score
16+getCompletions :: [Filter] -> Matcher -> [Module] -> [Completion]
17+getCompletions filters matcher modules =
18+ runMatcher matcher $ completionsFromModules (applyFilters filters modules)
19+
20+getExactMatches :: DeclIdent -> [Filter] -> [Module] -> [Completion]
21+getExactMatches search filters modules =
22+ completionsFromModules $
23+ applyFilters (equalityFilter search : filters) modules
24+
25+completionsFromModules :: [Module] -> [Completion]
26+completionsFromModules = foldMap completionFromModule
27+ where
28+ completionFromModule :: Module -> [Completion]
29+ completionFromModule (moduleIdent, decls) = mapMaybe (completionFromDecl moduleIdent) decls
30+
31+completionFromDecl :: ModuleIdent -> ExternDecl -> Maybe Completion
32+completionFromDecl mi (FunctionDecl name type') = Just (Completion (mi, name, type'))
33+completionFromDecl mi (DataDecl name kind) = Just (Completion (mi, name, kind))
34+completionFromDecl _ (ModuleDecl name _) = Just (Completion ("module", name, "module"))
35+completionFromDecl _ _ = Nothing
src/Language/PureScript/Ide/Error.hsnew file+42
@@ -0,0 +1,42 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module Language.PureScript.Ide.Error
3+ (ErrorMsg, PscIdeError(..), textError, first)
4+ where
5+
6+import Data.Aeson
7+import Data.Monoid
8+import Data.Text (Text, pack)
9+import Language.PureScript.Ide.Types (ModuleIdent)
10+import qualified Text.Parsec.Error as P
11+
12+type ErrorMsg = String
13+
14+data PscIdeError
15+ = GeneralError ErrorMsg
16+ | NotFound Text
17+ | ModuleNotFound ModuleIdent
18+ | ModuleFileNotFound ModuleIdent
19+ | ParseError P.ParseError ErrorMsg
20+ deriving (Show, Eq)
21+
22+instance ToJSON PscIdeError where
23+ toJSON err = object
24+ [ "resultType" .= ("error" :: Text)
25+ , "result" .= textError err
26+ ]
27+
28+textError :: PscIdeError -> Text
29+textError (GeneralError msg) = pack msg
30+textError (NotFound ident) = "Symbol '" <> ident <> "' not found."
31+textError (ModuleNotFound ident) = "Module '" <> ident <> "' not found."
32+textError (ModuleFileNotFound ident) = "Extern file for module " <> ident <>" could not be found"
33+textError (ParseError parseError msg) = pack $ msg <> ": " <> show (escape parseError)
34+ where
35+ -- escape newlines and other special chars so we can send the error over the socket as a single line
36+ escape :: P.ParseError -> String
37+ escape = show
38+
39+-- | Specialized version of `first` from `Data.Bifunctors`
40+first :: (a -> b) -> Either a r -> Either b r
41+first f (Left x) = Left (f x)
42+first _ (Right r2) = Right r2
src/Language/PureScript/Ide/Externs.hsnew file+102
@@ -0,0 +1,102 @@
1+{-# LANGUAGE FlexibleContexts #-}
2+{-# LANGUAGE MultiParamTypeClasses #-}
3+{-# LANGUAGE OverloadedStrings #-}
4+{-# LANGUAGE RecordWildCards #-}
5+{-# LANGUAGE ScopedTypeVariables #-}
6+
7+module Language.PureScript.Ide.Externs
8+ (
9+ ExternDecl(..),
10+ ModuleIdent,
11+ DeclIdent,
12+ Type,
13+ Fixity(..),
14+ readExternFile,
15+ convertExterns,
16+ unwrapPositioned,
17+ unwrapPositionedRef
18+ ) where
19+
20+import Prelude ()
21+import Prelude.Compat
22+
23+import Control.Monad.Error.Class
24+import Control.Monad.IO.Class
25+import Data.Maybe (mapMaybe)
26+import Data.Text (Text)
27+import qualified Data.Text as T
28+import qualified Data.Text.IO as T
29+import qualified Language.PureScript.AST.Declarations as D
30+import qualified Language.PureScript.Externs as PE
31+import Language.PureScript.Ide.CodecJSON
32+import Language.PureScript.Ide.Error (PscIdeError (..))
33+import Language.PureScript.Ide.Types
34+import qualified Language.PureScript.Names as N
35+import qualified Language.PureScript.Pretty as PP
36+
37+readExternFile :: (MonadIO m, MonadError PscIdeError m) =>
38+ FilePath -> m PE.ExternsFile
39+readExternFile fp = do
40+ parseResult <- liftIO (decodeT <$> T.readFile fp)
41+ case parseResult of
42+ Nothing -> throwError . GeneralError $ "Parsing the extern at: " ++ fp ++ " failed"
43+ Just externs -> pure externs
44+
45+moduleNameToText :: N.ModuleName -> Text
46+moduleNameToText = T.pack . N.runModuleName
47+
48+properNameToText :: N.ProperName a -> Text
49+properNameToText = T.pack . N.runProperName
50+
51+identToText :: N.Ident -> Text
52+identToText = T.pack . N.runIdent
53+
54+convertExterns :: PE.ExternsFile -> Module
55+convertExterns ef = (moduleName, exportDecls ++ importDecls ++ otherDecls)
56+ where
57+ moduleName = moduleNameToText (PE.efModuleName ef)
58+ importDecls = convertImport <$> PE.efImports ef
59+ exportDecls = mapMaybe (convertExport . unwrapPositionedRef) (PE.efExports ef)
60+ -- Ignoring operator fixities for now since we're not using them
61+ -- operatorDecls = convertOperator <$> PE.efFixities ef
62+ otherDecls = mapMaybe convertDecl (PE.efDeclarations ef)
63+
64+convertImport :: PE.ExternsImport -> ExternDecl
65+convertImport ei = Dependency
66+ (moduleNameToText (PE.eiModule ei))
67+ []
68+ (moduleNameToText <$> PE.eiImportedAs ei)
69+
70+convertExport :: D.DeclarationRef -> Maybe ExternDecl
71+convertExport (D.ModuleRef mn) = Just (Export (moduleNameToText mn))
72+convertExport _ = Nothing
73+
74+convertDecl :: PE.ExternsDeclaration -> Maybe ExternDecl
75+convertDecl PE.EDType{..} = Just $
76+ DataDecl
77+ (properNameToText edTypeName)
78+ (packAndStrip (PP.prettyPrintKind edTypeKind))
79+convertDecl PE.EDTypeSynonym{..} = Just $
80+ DataDecl
81+ (properNameToText edTypeSynonymName)
82+ (packAndStrip (PP.prettyPrintType edTypeSynonymType))
83+convertDecl PE.EDDataConstructor{..} = Just $
84+ DataDecl
85+ (properNameToText edDataCtorName)
86+ (packAndStrip (PP.prettyPrintType edDataCtorType))
87+convertDecl PE.EDValue{..} = Just $
88+ FunctionDecl
89+ (identToText edValueName)
90+ (packAndStrip (PP.prettyPrintType edValueType))
91+convertDecl _ = Nothing
92+
93+packAndStrip :: String -> Text
94+packAndStrip = T.unwords . fmap T.strip . T.lines . T.pack
95+
96+unwrapPositioned :: D.Declaration -> D.Declaration
97+unwrapPositioned (D.PositionedDeclaration _ _ x) = x
98+unwrapPositioned x = x
99+
100+unwrapPositionedRef :: D.DeclarationRef -> D.DeclarationRef
101+unwrapPositionedRef (D.PositionedDeclarationRef _ _ x) = x
102+unwrapPositionedRef x = x
src/Language/PureScript/Ide/Filter.hsnew file+110
@@ -0,0 +1,110 @@
1+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE ScopedTypeVariables #-}
4+module Language.PureScript.Ide.Filter
5+ (Filter, moduleFilter, prefixFilter, equalityFilter, dependencyFilter,
6+ runFilter, applyFilters)
7+ where
8+
9+import Prelude ()
10+import Prelude.Compat
11+
12+import Control.Monad
13+import Data.Aeson
14+import Data.Foldable
15+import Data.Maybe (listToMaybe, mapMaybe)
16+import Data.Monoid
17+import Data.Text (Text, isPrefixOf)
18+import Language.PureScript.Ide.Types
19+
20+newtype Filter = Filter (Endo [Module]) deriving(Monoid)
21+
22+mkFilter :: ([Module] -> [Module]) -> Filter
23+mkFilter = Filter . Endo
24+
25+-- | Only keeps the given Modules
26+moduleFilter :: [ModuleIdent] -> Filter
27+moduleFilter =
28+ mkFilter . moduleFilter'
29+
30+moduleFilter' :: [ModuleIdent] -> [Module] -> [Module]
31+moduleFilter' moduleIdents = filter (flip elem moduleIdents . fst)
32+
33+-- | Only keeps the given Modules and all of their dependencies
34+dependencyFilter :: [ModuleIdent] -> Filter
35+dependencyFilter = mkFilter . dependencyFilter'
36+
37+dependencyFilter' :: [ModuleIdent] -> [Module] -> [Module]
38+dependencyFilter' moduleIdents mods =
39+ moduleFilter' (concatMap (getDepForModule mods) moduleIdents) mods
40+ where
41+ getDepForModule :: [Module] -> ModuleIdent -> [ModuleIdent]
42+ getDepForModule ms moduleIdent =
43+ moduleIdent : maybe [] extractDeps (findModule moduleIdent ms)
44+
45+ findModule :: ModuleIdent -> [Module] -> Maybe Module
46+ findModule i ms = listToMaybe $ filter go ms
47+ where go (mn, _) = i == mn
48+
49+ extractDeps :: Module -> [ModuleIdent]
50+ extractDeps = mapMaybe extractDep . snd
51+ where extractDep (Dependency n _ _) = Just n
52+ extractDep _ = Nothing
53+
54+-- | Only keeps Identifiers that start with the given prefix
55+prefixFilter :: Text -> Filter
56+prefixFilter "" = mkFilter id
57+prefixFilter t = mkFilter $ identFilter prefix t
58+ where
59+ prefix :: ExternDecl -> Text -> Bool
60+ prefix (FunctionDecl name _) search = search `isPrefixOf` name
61+ prefix (DataDecl name _) search = search `isPrefixOf` name
62+ prefix (ModuleDecl name _) search = search `isPrefixOf` name
63+ prefix _ _ = False
64+
65+
66+-- | Only keeps Identifiers that are equal to the search string
67+equalityFilter :: Text -> Filter
68+equalityFilter = mkFilter . identFilter equality
69+ where
70+ equality :: ExternDecl -> Text -> Bool
71+ equality (FunctionDecl name _) prefix = prefix == name
72+ equality (DataDecl name _) prefix = prefix == name
73+ equality _ _ = False
74+
75+
76+identFilter :: (ExternDecl -> Text -> Bool ) -> Text -> [Module] -> [Module]
77+identFilter predicate search =
78+ filter (not . null . snd) . fmap filterModuleDecls
79+ where
80+ filterModuleDecls :: Module -> Module
81+ filterModuleDecls (moduleIdent,decls) =
82+ (moduleIdent, filter (`predicate` search) decls)
83+
84+runFilter :: Filter -> [Module] -> [Module]
85+runFilter (Filter f)= appEndo f
86+
87+applyFilters :: [Filter] -> [Module] -> [Module]
88+applyFilters = runFilter . fold
89+
90+instance FromJSON Filter where
91+ parseJSON = withObject "filter" $ \o -> do
92+ (filter' :: String) <- o .: "filter"
93+ case filter' of
94+ "exact" -> do
95+ params <- o .: "params"
96+ search <- params .: "search"
97+ return $ equalityFilter search
98+ "prefix" -> do
99+ params <- o.: "params"
100+ search <- params .: "search"
101+ return $ prefixFilter search
102+ "modules" -> do
103+ params <- o .: "params"
104+ modules <- params .: "modules"
105+ return $ moduleFilter modules
106+ "dependencies" -> do
107+ params <- o .: "params"
108+ deps <- params .: "modules"
109+ return $ dependencyFilter deps
110+ _ -> mzero
src/Language/PureScript/Ide/Matcher.hsnew file+100
@@ -0,0 +1,100 @@
1+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE ScopedTypeVariables #-}
4+module Language.PureScript.Ide.Matcher (Matcher, flexMatcher, runMatcher) where
5+
6+import Prelude ()
7+import Prelude.Compat
8+
9+import Control.Monad
10+import Data.Aeson
11+import Data.Function (on)
12+import Data.List (sortBy)
13+import Data.Maybe (mapMaybe)
14+import Data.Monoid
15+import Data.Text (Text)
16+import qualified Data.Text as T
17+import qualified Data.Text.Encoding as TE
18+import Language.PureScript.Ide.Types
19+import Text.EditDistance
20+import Text.Regex.TDFA ((=~))
21+
22+
23+type ScoredCompletion = (Completion, Double)
24+
25+newtype Matcher = Matcher (Endo [Completion]) deriving(Monoid)
26+
27+instance FromJSON Matcher where
28+ parseJSON = withObject "matcher" $ \o -> do
29+ (matcher :: Maybe String) <- o .:? "matcher"
30+ case matcher of
31+ Just "flex" -> do
32+ params <- o .: "params"
33+ search <- params .: "search"
34+ pure $ flexMatcher search
35+ Just "distance" -> do
36+ params <- o .: "params"
37+ search <- params .: "search"
38+ maxDist <- params .: "maximumDistance"
39+ pure $ distanceMatcher search maxDist
40+ Just _ -> mzero
41+ Nothing -> return mempty
42+
43+-- | Matches any occurence of the search string with intersections
44+-- |
45+-- | The scoring measures how far the matches span the string where
46+-- | closer is better.
47+-- | Examples:
48+-- | flMa matches flexMatcher. Score: 14.28
49+-- | sons matches sortCompletions. Score: 6.25
50+flexMatcher :: Text -> Matcher
51+flexMatcher pattern = mkMatcher (flexMatch pattern)
52+
53+distanceMatcher :: Text -> Int -> Matcher
54+distanceMatcher q maxDist = mkMatcher (distanceMatcher' q maxDist)
55+
56+distanceMatcher' :: Text -> Int -> [Completion] -> [ScoredCompletion]
57+distanceMatcher' q maxDist = mapMaybe go
58+ where
59+ go c@(Completion (_, y, _)) = let d = dist (T.unpack y)
60+ in if d <= maxDist
61+ then Just (c, 1 / fromIntegral d)
62+ else Nothing
63+ dist = levenshteinDistance defaultEditCosts (T.unpack q)
64+
65+mkMatcher :: ([Completion] -> [ScoredCompletion]) -> Matcher
66+mkMatcher matcher = Matcher . Endo $ fmap fst . sortCompletions . matcher
67+
68+runMatcher :: Matcher -> [Completion] -> [Completion]
69+runMatcher (Matcher m)= appEndo m
70+
71+sortCompletions :: [ScoredCompletion] -> [ScoredCompletion]
72+sortCompletions = sortBy (flip compare `on` snd)
73+
74+flexMatch :: Text -> [Completion] -> [ScoredCompletion]
75+flexMatch pattern = mapMaybe (flexRate pattern)
76+
77+flexRate :: Text -> Completion -> Maybe ScoredCompletion
78+flexRate pattern c@(Completion (_,ident,_)) = do
79+ score <- flexScore pattern ident
80+ return (c, score)
81+
82+-- FlexMatching ala Sublime.
83+-- Borrowed from: http://cdewaka.com/2013/06/fuzzy-pattern-matching-in-haskell/
84+--
85+-- By string =~ pattern we'll get the start of the match and the length of
86+-- the matchas a (start, length) tuple if there's a match.
87+-- If match fails then it would be (-1,0)
88+flexScore :: Text -> DeclIdent -> Maybe Double
89+flexScore "" _ = Nothing
90+flexScore pat str =
91+ case TE.encodeUtf8 str =~ TE.encodeUtf8 pat' :: (Int, Int) of
92+ (-1,0) -> Nothing
93+ (start,len) -> Just $ calcScore start (start + len)
94+ where
95+ Just (first,pattern) = T.uncons pat
96+ -- This just interleaves the search string with .*
97+ -- abcd -> a.*b.*c.*d
98+ pat' = first `T.cons` T.concatMap (T.snoc ".*") pattern
99+ calcScore start end =
100+ 100.0 / fromIntegral ((1 + start) * (end - start + 1))
src/Language/PureScript/Ide/Pursuit.hsnew file+65
@@ -0,0 +1,65 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE ScopedTypeVariables #-}
3+
4+module Language.PureScript.Ide.Pursuit where
5+
6+import Prelude ()
7+import Prelude.Compat
8+
9+import qualified Control.Exception as E
10+import Data.Aeson
11+import Data.ByteString (ByteString)
12+import Data.ByteString.Lazy (fromStrict)
13+import Data.Foldable (toList)
14+import Data.Maybe (mapMaybe)
15+import Data.Monoid ((<>))
16+import Data.String
17+import Data.Text (Text)
18+import qualified Data.Text as T
19+import Language.PureScript.Ide.Types
20+import Network.HTTP.Types.Header (hAccept)
21+import Pipes.HTTP
22+import qualified Pipes.Prelude as P
23+
24+-- We need to remove trailing dots because Pursuit will return a 400 otherwise
25+-- TODO: remove this when the issue is fixed at Pursuit
26+queryPursuit :: Text -> IO ByteString
27+queryPursuit q = do
28+ let qClean = T.dropWhileEnd (== '.') q
29+ req' <- parseUrl "http://pursuit.purescript.org/search"
30+ let req = req'
31+ { queryString=("q=" <> (fromString . T.unpack) qClean)
32+ , requestHeaders=[(hAccept, "application/json")]
33+ }
34+ m <- newManager tlsManagerSettings
35+ withHTTP req m $ \resp ->
36+ P.fold (<>) "" id $ responseBody resp
37+
38+
39+handler :: HttpException -> IO [a]
40+handler StatusCodeException{} = pure []
41+handler _ = pure []
42+
43+searchPursuitForDeclarations :: Text -> IO [PursuitResponse]
44+searchPursuitForDeclarations query =
45+ (do r <- queryPursuit query
46+ let results' = decode (fromStrict r) :: Maybe Array
47+ case results' of
48+ Nothing -> pure []
49+ Just results -> pure (mapMaybe isDeclarationResponse (map fromJSON (toList results)))) `E.catch`
50+ handler
51+ where
52+ isDeclarationResponse (Success a@DeclarationResponse{}) = Just a
53+ isDeclarationResponse _ = Nothing
54+
55+findPackagesForModuleIdent :: Text -> IO [PursuitResponse]
56+findPackagesForModuleIdent query =
57+ (do r <- queryPursuit query
58+ let results' = decode (fromStrict r) :: Maybe Array
59+ case results' of
60+ Nothing -> pure []
61+ Just results -> pure (mapMaybe isModuleResponse (map fromJSON (toList results)))) `E.catch`
62+ handler
63+ where
64+ isModuleResponse (Success a@ModuleResponse{}) = Just a
65+ isModuleResponse _ = Nothing
src/Language/PureScript/Ide/Reexports.hsnew file+75
@@ -0,0 +1,75 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE PatternGuards #-}
3+{-# LANGUAGE TupleSections #-}
4+module Language.PureScript.Ide.Reexports where
5+
6+
7+import Prelude ()
8+import Prelude.Compat
9+
10+import Data.List (union)
11+import Data.Map (Map)
12+import qualified Data.Map as Map
13+import Data.Maybe
14+import Language.PureScript.Ide.Types
15+
16+getReexports :: Module -> [ExternDecl]
17+getReexports (mn, decls)= concatMap getExport decls
18+ where getExport d
19+ | (Export mn') <- d
20+ , mn /= mn' = replaceExportWithAliases decls mn'
21+ | otherwise = []
22+
23+dependencyToExport :: ExternDecl -> ExternDecl
24+dependencyToExport (Dependency m _ _) = Export m
25+dependencyToExport decl = decl
26+
27+replaceExportWithAliases :: [ExternDecl] -> ModuleIdent -> [ExternDecl]
28+replaceExportWithAliases decls ident =
29+ case filter isMatch decls of
30+ [] -> [Export ident]
31+ aliases -> map dependencyToExport aliases
32+ where isMatch d
33+ | Dependency _ _ (Just alias) <- d
34+ , alias == ident = True
35+ | otherwise = False
36+
37+replaceReexport :: ExternDecl -> Module -> Module -> Module
38+replaceReexport e@(Export _) (m, decls) (_, newDecls) =
39+ (m, filter (/= e) decls `union` newDecls)
40+replaceReexport _ _ _ = error "Should only get Exports here."
41+
42+emptyModule :: Module
43+emptyModule = ("Empty", [])
44+
45+isExport :: ExternDecl -> Bool
46+isExport (Export _) = True
47+isExport _ = False
48+
49+removeExportDecls :: Module -> Module
50+removeExportDecls = fmap (filter (not . isExport))
51+
52+replaceReexports :: Module -> Map ModuleIdent [ExternDecl] -> Module
53+replaceReexports m db = result
54+ where
55+ reexports = getReexports m
56+ result = foldl go (removeExportDecls m) reexports
57+
58+ go :: Module -> ExternDecl -> Module
59+ go m' re@(Export name) = replaceReexport re m' (getModule name)
60+ go _ _ = error "partiality! woohoo"
61+
62+ getModule :: ModuleIdent -> Module
63+ getModule name = clean res
64+ where
65+ res = fromMaybe emptyModule $ (name , ) <$> Map.lookup name db
66+ -- we have to do this because keeping self exports in will result in
67+ -- infinite loops
68+ clean (mn, decls) = (mn,) (filter (/= Export mn) decls)
69+
70+resolveReexports :: Map ModuleIdent [ExternDecl] -> Module -> Module
71+resolveReexports modules m =
72+ let replaced = replaceReexports m modules
73+ in if null (getReexports replaced)
74+ then replaced
75+ else resolveReexports modules replaced
src/Language/PureScript/Ide/SourceFile.hsnew file+106
@@ -0,0 +1,106 @@
1+{-# LANGUAGE FlexibleContexts #-}
2+{-# LANGUAGE MultiParamTypeClasses #-}
3+{-# LANGUAGE OverloadedStrings #-}
4+module Language.PureScript.Ide.SourceFile where
5+
6+import Prelude
7+
8+import Control.Monad.Error.Class
9+import Control.Monad.IO.Class
10+import Control.Monad.Trans.Except
11+import Data.Maybe (mapMaybe)
12+import Data.Monoid
13+import qualified Data.Text as T
14+import qualified Language.PureScript.AST.Declarations as D
15+import qualified Language.PureScript.AST.SourcePos as SP
16+import Language.PureScript.Ide.Error
17+import Language.PureScript.Ide.Externs (unwrapPositioned,
18+ unwrapPositionedRef)
19+import Language.PureScript.Ide.Types
20+import qualified Language.PureScript.Names as N
21+import qualified Language.PureScript.Parser as P
22+import System.Directory
23+
24+parseModuleFromFile :: (MonadIO m, MonadError PscIdeError m) =>
25+ FilePath -> m D.Module
26+parseModuleFromFile fp = do
27+ exists <- liftIO (doesFileExist fp)
28+ if exists
29+ then do
30+ content <- liftIO (readFile fp)
31+ let m = do tokens <- P.lex fp content
32+ P.runTokenParser "" P.parseModule tokens
33+ either (throwError . (`ParseError` "File could not be parsed.")) pure m
34+ else throwError (NotFound "File does not exist.")
35+
36+-- data Module = Module SourceSpan [Comment] ModuleName [Declaration] (Maybe [DeclarationRef])
37+
38+getDeclarations :: D.Module -> [D.Declaration]
39+getDeclarations (D.Module _ _ _ declarations _) = declarations
40+
41+getImports :: D.Module -> [D.Declaration]
42+getImports (D.Module _ _ _ declarations _) =
43+ mapMaybe isImport declarations
44+ where
45+ isImport (D.PositionedDeclaration _ _ (i@D.ImportDeclaration{})) = Just i
46+ isImport _ = Nothing
47+
48+getImportsForFile :: (MonadIO m, MonadError PscIdeError m) =>
49+ FilePath -> m [ModuleImport]
50+getImportsForFile fp = do
51+ module' <- parseModuleFromFile fp
52+ let imports = getImports module'
53+ pure (mkModuleImport . unwrapPositionedImport <$> imports)
54+ where
55+ mkModuleImport (D.ImportDeclaration mn importType' qualifier _) =
56+ ModuleImport
57+ (T.pack (N.runModuleName mn))
58+ importType'
59+ (T.pack . N.runModuleName <$> qualifier)
60+ mkModuleImport _ = error "Shouldn't have gotten anything but Imports here"
61+ unwrapPositionedImport (D.ImportDeclaration mn importType' qualifier b) =
62+ D.ImportDeclaration mn (unwrapImportType importType') qualifier b
63+ unwrapPositionedImport x = x
64+ unwrapImportType (D.Explicit decls) = D.Explicit (map unwrapPositionedRef decls)
65+ unwrapImportType (D.Hiding decls) = D.Hiding (map unwrapPositionedRef decls)
66+ unwrapImportType D.Implicit = D.Implicit
67+
68+getPositionedImports :: D.Module -> [D.Declaration]
69+getPositionedImports (D.Module _ _ _ declarations _) =
70+ mapMaybe isImport declarations
71+ where
72+ isImport i@(D.PositionedDeclaration _ _ (D.ImportDeclaration{})) = Just i
73+ isImport _ = Nothing
74+
75+getDeclPosition :: D.Module -> String -> Maybe SP.SourceSpan
76+getDeclPosition m ident = getFirst (foldMap (match ident) decls)
77+ where
78+ decls = getDeclarations m
79+ match q (D.PositionedDeclaration ss _ decl) = First (if go q decl
80+ then Just ss
81+ else Nothing)
82+ match _ _ = First Nothing
83+
84+ go q (D.DataDeclaration _ name _ constructors) =
85+ properEqual name q || any (\(x,_) -> properEqual x q) constructors
86+ go q (D.DataBindingGroupDeclaration decls') = any (go q) decls'
87+ go q (D.TypeSynonymDeclaration name _ _) = properEqual name q
88+ go q (D.TypeDeclaration ident' _) = identEqual ident' q
89+ go q (D.ValueDeclaration ident' _ _ _) = identEqual ident' q
90+ go q (D.ExternDeclaration ident' _) = identEqual ident' q
91+ go q (D.ExternDataDeclaration name _) = properEqual name q
92+ go q (D.TypeClassDeclaration name _ _ members) =
93+ properEqual name q || any (go q . unwrapPositioned) members
94+ go q (D.TypeInstanceDeclaration ident' _ _ _ _) =
95+ identEqual ident' q
96+ go _ _ = False
97+
98+ properEqual x q = N.runProperName x == q
99+ identEqual x q = N.runIdent x == q
100+
101+goToDefinition :: String -> FilePath -> IO (Maybe SP.SourceSpan)
102+goToDefinition q fp = do
103+ m <- runExceptT (parseModuleFromFile fp)
104+ case m of
105+ Right module' -> pure (getDeclPosition module' q)
106+ Left _ -> pure Nothing
src/Language/PureScript/Ide/State.hsnew file+80
@@ -0,0 +1,80 @@
1+{-# LANGUAGE ConstraintKinds #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE MultiParamTypeClasses #-}
4+{-# LANGUAGE OverloadedStrings #-}
5+{-# LANGUAGE PackageImports #-}
6+{-# LANGUAGE TemplateHaskell #-}
7+{-# LANGUAGE TupleSections #-}
8+
9+module Language.PureScript.Ide.State where
10+
11+import Prelude ()
12+import Prelude.Compat
13+
14+import Control.Concurrent.STM
15+import Control.Monad.IO.Class
16+import "monad-logger" Control.Monad.Logger
17+import Control.Monad.Reader.Class
18+import qualified Data.Map.Lazy as M
19+import Data.Maybe (catMaybes)
20+import Data.Monoid
21+import qualified Data.Text as T
22+import Language.PureScript.Externs
23+import Language.PureScript.Ide.Externs
24+import Language.PureScript.Ide.Reexports
25+import Language.PureScript.Ide.Types
26+import Language.PureScript.Names
27+
28+getPscIdeState :: (PscIde m) =>
29+ m (M.Map ModuleIdent [ExternDecl])
30+getPscIdeState = do
31+ stateVar <- envStateVar <$> ask
32+ liftIO $ pscStateModules <$> readTVarIO stateVar
33+
34+getExternFiles :: (PscIde m) =>
35+ m (M.Map ModuleName ExternsFile)
36+getExternFiles = do
37+ stateVar <- envStateVar <$> ask
38+ liftIO (externsFiles <$> readTVarIO stateVar)
39+
40+getAllDecls :: (PscIde m) => m [ExternDecl]
41+getAllDecls = concat <$> getPscIdeState
42+
43+getAllModules :: (PscIde m) => m [Module]
44+getAllModules = M.toList <$> getPscIdeState
45+
46+getAllModulesWithReexports :: (PscIde m, MonadLogger m) =>
47+ m [Module]
48+getAllModulesWithReexports = do
49+ mis <- M.keys <$> getPscIdeState
50+ ms <- traverse getModuleWithReexports mis
51+ pure (catMaybes ms)
52+
53+getModule :: (PscIde m, MonadLogger m) =>
54+ ModuleIdent -> m (Maybe Module)
55+getModule m = do
56+ modules <- getPscIdeState
57+ pure ((m,) <$> M.lookup m modules)
58+
59+getModuleWithReexports :: (PscIde m, MonadLogger m) =>
60+ ModuleIdent -> m (Maybe Module)
61+getModuleWithReexports mi = do
62+ m <- getModule mi
63+ modules <- getPscIdeState
64+ pure $ resolveReexports modules <$> m
65+
66+insertModule ::(PscIde m, MonadLogger m) =>
67+ ExternsFile -> m ()
68+insertModule externsFile = do
69+ env <- ask
70+ let moduleName = efModuleName externsFile
71+ $(logDebug) $ "Inserting Module: " <> (T.pack (runModuleName moduleName))
72+ liftIO . atomically $ insertModule' (envStateVar env) externsFile
73+
74+insertModule' :: TVar PscIdeState -> ExternsFile -> STM ()
75+insertModule' st ef = do
76+ modifyTVar st $ \x ->
77+ x { externsFiles = M.insert (efModuleName ef) ef (externsFiles x)
78+ , pscStateModules = let (mn, decls) = convertExterns ef
79+ in M.insert mn decls (pscStateModules x)
80+ }
src/Language/PureScript/Ide/Types.hsnew file+238
@@ -0,0 +1,238 @@
1+{-# LANGUAGE ConstraintKinds #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4+{-# LANGUAGE OverloadedStrings #-}
5+{-# LANGUAGE RecordWildCards #-}
6+{-# LANGUAGE ScopedTypeVariables #-}
7+
8+module Language.PureScript.Ide.Types where
9+
10+import Prelude ()
11+import Prelude.Compat
12+
13+import Control.Concurrent.STM
14+import Control.Monad
15+import Control.Monad.Reader.Class
16+import Control.Monad.Trans
17+import Data.Aeson
18+import Data.Map.Lazy as M
19+import Data.Maybe (maybeToList)
20+import Data.Text (Text (), pack, unpack)
21+import qualified Language.PureScript.AST.Declarations as D
22+import Language.PureScript.Externs
23+import Language.PureScript.Names
24+import qualified Language.PureScript.Names as N
25+
26+import Text.Parsec
27+import Text.Parsec.Text
28+
29+type ModuleIdent = Text
30+type DeclIdent = Text
31+type Type = Text
32+
33+data Fixity = Infix | Infixl | Infixr deriving(Show, Eq, Ord)
34+
35+data ExternDecl
36+ -- | A function/value declaration
37+ = FunctionDecl
38+ DeclIdent -- The functions name
39+ Type -- The functions type
40+ | FixityDeclaration Fixity Int DeclIdent
41+ -- | A Dependency onto another Module
42+ | Dependency
43+ ModuleIdent -- name of the dependency
44+ [Text] -- explicit imports
45+ (Maybe Text) -- An eventual qualifier
46+
47+ -- | A module declaration
48+ | ModuleDecl
49+ ModuleIdent -- The modules name
50+ [DeclIdent] -- The exported identifiers
51+ -- | A data/newtype declaration
52+ | DataDecl DeclIdent -- The type name
53+ Text -- The "type"
54+ -- | An exported module
55+ | Export ModuleIdent -- The exported Modules name
56+ deriving (Show,Eq,Ord)
57+
58+instance ToJSON ExternDecl where
59+ toJSON (FunctionDecl n t) = object ["name" .= n, "type" .= t]
60+ toJSON (ModuleDecl n t) = object ["name" .= n, "type" .= t]
61+ toJSON (DataDecl n t) = object ["name" .= n, "type" .= t]
62+ toJSON (Dependency n names _) = object ["module" .= n, "names" .= names]
63+ toJSON (FixityDeclaration f p n) = object ["name" .= n
64+ , "fixity" .= show f
65+ , "precedence" .= p]
66+ toJSON (Export _) = object []
67+
68+type Module = (ModuleIdent, [ExternDecl])
69+
70+data Configuration =
71+ Configuration
72+ { confOutputPath :: FilePath
73+ , confDebug :: Bool
74+ }
75+
76+data PscIdeEnvironment =
77+ PscIdeEnvironment
78+ { envStateVar :: TVar PscIdeState
79+ , envConfiguration :: Configuration
80+ }
81+
82+type PscIde m = (MonadIO m, MonadReader PscIdeEnvironment m)
83+
84+data PscIdeState =
85+ PscIdeState
86+ { pscStateModules :: M.Map Text [ExternDecl]
87+ , externsFiles :: M.Map ModuleName ExternsFile
88+ } deriving Show
89+
90+emptyPscIdeState :: PscIdeState
91+emptyPscIdeState = PscIdeState M.empty M.empty
92+
93+newtype Completion =
94+ Completion (ModuleIdent, DeclIdent, Type)
95+ deriving (Show,Eq)
96+
97+data ModuleImport =
98+ ModuleImport
99+ { importModuleName :: ModuleIdent
100+ , importType :: D.ImportDeclarationType
101+ , importQualifier :: Maybe Text
102+ } deriving(Show)
103+
104+instance Eq ModuleImport where
105+ mi1 == mi2 =
106+ importModuleName mi1 == importModuleName mi2
107+ && importQualifier mi1 == importQualifier mi2
108+
109+instance ToJSON ModuleImport where
110+ toJSON (ModuleImport mn D.Implicit qualifier) =
111+ object $ [ "module" .= mn
112+ , "importType" .= ("implicit" :: Text)
113+ ] ++ fmap (\x -> "qualifier" .= x) (maybeToList qualifier)
114+ toJSON (ModuleImport mn (D.Explicit refs) _) =
115+ object [ "module" .= mn
116+ , "importType" .= ("explicit" :: Text)
117+ , "identifiers" .= (identifierFromDeclarationRef <$> refs)
118+ ]
119+ toJSON (ModuleImport mn (D.Hiding refs) _) =
120+ object [ "module" .= mn
121+ , "importType" .= ("hiding" :: Text)
122+ , "identifiers" .= (identifierFromDeclarationRef <$> refs)
123+ ]
124+
125+identifierFromDeclarationRef :: D.DeclarationRef -> String
126+identifierFromDeclarationRef (D.TypeRef name _) = N.runProperName name
127+identifierFromDeclarationRef (D.ValueRef ident) = N.runIdent ident
128+identifierFromDeclarationRef (D.TypeClassRef name) = N.runProperName name
129+identifierFromDeclarationRef _ = ""
130+
131+instance FromJSON Completion where
132+ parseJSON (Object o) = do
133+ m <- o .: "module"
134+ d <- o .: "identifier"
135+ t <- o .: "type"
136+ pure (Completion (m, d, t))
137+ parseJSON _ = mzero
138+
139+instance ToJSON Completion where
140+ toJSON (Completion (m,d,t)) =
141+ object ["module" .= m, "identifier" .= d, "type" .= t]
142+
143+data Success =
144+ CompletionResult [Completion]
145+ | TextResult Text
146+ | MultilineTextResult [Text]
147+ | PursuitResult [PursuitResponse]
148+ | ImportList [ModuleImport]
149+ | ModuleList [ModuleIdent]
150+ deriving(Show, Eq)
151+
152+encodeSuccess :: (ToJSON a) => a -> Value
153+encodeSuccess res =
154+ object ["resultType" .= ("success" :: Text), "result" .= res]
155+
156+instance ToJSON Success where
157+ toJSON (CompletionResult cs) = encodeSuccess cs
158+ toJSON (TextResult t) = encodeSuccess t
159+ toJSON (MultilineTextResult ts) = encodeSuccess ts
160+ toJSON (PursuitResult resp) = encodeSuccess resp
161+ toJSON (ImportList decls) = encodeSuccess decls
162+ toJSON (ModuleList modules) = encodeSuccess modules
163+
164+newtype PursuitQuery = PursuitQuery Text
165+ deriving (Show, Eq)
166+
167+data PursuitSearchType = Package | Identifier
168+ deriving (Show, Eq)
169+
170+instance FromJSON PursuitSearchType where
171+ parseJSON (String t) = case t of
172+ "package" -> pure Package
173+ "completion" -> pure Identifier
174+ _ -> mzero
175+ parseJSON _ = mzero
176+
177+instance FromJSON PursuitQuery where
178+ parseJSON o = PursuitQuery <$> (parseJSON o)
179+
180+data PursuitResponse =
181+ -- | A Pursuit Response for a module. Consists of the modules name and the
182+ -- package it belongs to
183+ ModuleResponse ModuleIdent Text
184+ -- | A Pursuit Response for a declaration. Consist of the declarations type,
185+ -- module, name and package
186+ | DeclarationResponse Type ModuleIdent DeclIdent Text
187+ deriving (Show,Eq)
188+
189+instance FromJSON PursuitResponse where
190+ parseJSON (Object o) = do
191+ package <- o .: "package"
192+ info <- o .: "info"
193+ (type' :: String) <- info .: "type"
194+ case type' of
195+ "module" -> do
196+ name <- info .: "module"
197+ pure (ModuleResponse name package)
198+ "declaration" -> do
199+ moduleName <- info .: "module"
200+ Right (ident, declType) <- typeParse <$> o .: "text"
201+ pure (DeclarationResponse declType moduleName ident package)
202+ _ -> mzero
203+ parseJSON _ = mzero
204+
205+
206+typeParse :: Text -> Either Text (Text, Text)
207+typeParse t = case parse parseType "" t of
208+ Right (x,y) -> Right (pack x, pack y)
209+ Left err -> Left (pack (show err))
210+ where
211+ parseType :: Parser (String, String)
212+ parseType = do
213+ name <- identifier
214+ _ <- string "::"
215+ spaces
216+ type' <- many1 anyChar
217+ pure (unpack name, type')
218+
219+identifier :: Parser Text
220+identifier = do
221+ spaces
222+ ident <-
223+ -- necessary for being able to parse the following ((++), concat)
224+ between (char '(') (char ')') (many1 (noneOf ", )")) <|>
225+ many1 (noneOf ", )")
226+ spaces
227+ pure (pack ident)
228+
229+instance ToJSON PursuitResponse where
230+ toJSON (ModuleResponse name package) =
231+ object ["module" .= name, "package" .= package]
232+ toJSON (DeclarationResponse module' ident type' package) =
233+ object
234+ [ "module" .= module'
235+ , "ident" .= ident
236+ , "type" .= type'
237+ , "package" .= package
238+ ]
src/Language/PureScript/Ide/Watcher.hsnew file+40
@@ -0,0 +1,40 @@
1+{-# LANGUAGE RecordWildCards #-}
2+module Language.PureScript.Ide.Watcher where
3+
4+import Prelude ()
5+import Prelude.Compat
6+
7+import Control.Concurrent (threadDelay)
8+import Control.Concurrent.STM
9+import Control.Monad
10+import Control.Monad.Trans.Except
11+import qualified Data.Map as M
12+import Data.Maybe (isJust)
13+import Language.PureScript.Externs
14+import Language.PureScript.Ide.Externs
15+import Language.PureScript.Ide.State
16+import Language.PureScript.Ide.Types
17+import System.FilePath
18+import System.FSNotify
19+
20+
21+reloadFile :: TVar PscIdeState -> FilePath -> IO ()
22+reloadFile stateVar fp = do
23+ (Right ef@ExternsFile{..}) <- runExceptT $ readExternFile fp
24+ reloaded <- atomically $ do
25+ st <- readTVar stateVar
26+ if isLoaded efModuleName st
27+ then
28+ insertModule' stateVar ef *> pure True
29+ else
30+ pure False
31+ when reloaded $ putStrLn $ "Reloaded File at: " ++ fp
32+ where
33+ isLoaded name st = isJust (M.lookup name (externsFiles st))
34+
35+watcher :: TVar PscIdeState -> FilePath -> IO ()
36+watcher stateVar fp = withManager $ \mgr -> do
37+ _ <- watchTree mgr fp
38+ (\ev -> takeFileName (eventPath ev) == "externs.json")
39+ (reloadFile stateVar . eventPath)
40+ forever (threadDelay 10000)
src/Language/PureScript/Kinds.hs+3−18
@@ -1,18 +1,3 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.Kinds
4−-- Copyright : (c) Phil Freeman 2013
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−--
13−-----------------------------------------------------------------------------
14−
15−{-# LANGUAGE DeriveDataTypeable #-}
161{-# LANGUAGE TemplateHaskell #-}
172
183module Language.PureScript.Kinds where
@@ -20,7 +5,6 @@ module Language.PureScript.Kinds where
205import Prelude ()
216import Prelude.Compat
227
23−import Data.Data
248import qualified Data.Aeson.TH as A
259
2610-- |
@@ -46,7 +30,8 @@ data Kind
4630 -- |
4731 -- Function kinds
4832 --
49− | FunKind Kind Kind deriving (Show, Read, Eq, Ord, Data, Typeable)
33+ | FunKind Kind Kind
34+ deriving (Show, Read, Eq, Ord)
5035
5136$(A.deriveJSON A.defaultOptions ''Kind)
5237
@@ -57,7 +42,7 @@ everywhereOnKinds f = go
5742 go (FunKind k1 k2) = f (FunKind (go k1) (go k2))
5843 go other = f other
5944
60−everywhereOnKindsM :: (Functor m, Applicative m, Monad m) => (Kind -> m Kind) -> Kind -> m Kind
45+everywhereOnKindsM :: Monad m => (Kind -> m Kind) -> Kind -> m Kind
6146everywhereOnKindsM f = go
6247 where
6348 go (Row k1) = (Row <$> go k1) >>= f
src/Language/PureScript/Linter.hs+2−1
@@ -29,7 +29,7 @@ import Language.PureScript.Linter.Imports as L
2929-- | Lint the PureScript AST.
3030-- |
3131-- | Right now, this pass only performs a shadowing check.
32−lint :: forall m. (Applicative m, MonadWriter MultipleErrors m) => Module -> m ()
32+lint :: forall m. (MonadWriter MultipleErrors m) => Module -> m ()
3333lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDeclaration ds
3434 where
3535 moduleNames :: S.Set Ident
@@ -71,6 +71,7 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl
7171 go d | Just i <- getDeclIdent d
7272 , i `S.member` s = errorMessage (ShadowedName i)
7373 | otherwise = mempty
74+ stepE _ (OperatorSection op val) = errorMessage $ DeprecatedOperatorSection op val
7475 stepE _ _ = mempty
7576
7677 stepB :: S.Set Ident -> Binder -> MultipleErrors
src/Language/PureScript/Linter/Exhaustive.hs+55−62
@@ -1,24 +1,12 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.Exhaustive
4−-- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
5−-- License : MIT (http://opensource.org/licenses/MIT)
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−-- | Module for exhaustivity checking over pattern matching definitions
13−-- | The algorithm analyses the clauses of a definition one by one from top
14−-- | to bottom, where in each step it has the cases already missing (uncovered),
15−-- | and it generates the new set of missing cases.
16−--
17−-----------------------------------------------------------------------------
18−
191{-# LANGUAGE FlexibleContexts #-}
202{-# LANGUAGE ScopedTypeVariables #-}
213
4+-- |
5+-- Module for exhaustivity checking over pattern matching definitions
6+-- The algorithm analyses the clauses of a definition one by one from top
7+-- to bottom, where in each step it has the cases already missing (uncovered),
8+-- and it generates the new set of missing cases.
9+--
2210module Language.PureScript.Linter.Exhaustive (checkExhaustiveModule) where
2311
2412import Prelude ()
@@ -36,6 +24,7 @@ import Control.Monad.Writer.Class
3624
3725import Language.PureScript.Crash
3826import Language.PureScript.AST.Binders
27+import Language.PureScript.AST.Literals
3928import Language.PureScript.AST.Declarations
4029import Language.PureScript.Environment
4130import Language.PureScript.Names as P
@@ -43,18 +32,22 @@ import Language.PureScript.Kinds
4332import Language.PureScript.Types as P
4433import Language.PureScript.Errors
4534
46−-- | There are two modes of failure for the redudancy check:
35+-- | There are two modes of failure for the redundancy check:
4736--
4837-- 1. Exhaustivity was incomplete due to too many cases, so we couldn't determine redundancy.
4938-- 2. We didn't attempt to determine redundancy for a binder, e.g. an integer binder.
5039--
5140-- We want to warn the user in the first case.
52−data RedudancyError = Incomplete | Unknown
41+data RedundancyError = Incomplete | Unknown
5342
5443-- |
5544-- Qualifies a propername from a given qualified propername and a default module name
5645--
57−qualifyName :: a -> ModuleName -> Qualified a -> Qualified a
46+qualifyName
47+ :: (ProperName a)
48+ -> ModuleName
49+ -> Qualified (ProperName b)
50+ -> Qualified (ProperName a)
5851qualifyName n defmn qn = Qualified (Just mn) n
5952 where
6053 (mn, _) = qualify defmn qn
@@ -65,31 +58,28 @@ qualifyName n defmn qn = Qualified (Just mn) n
6558-- where: - ProperName is the name of the constructor (for example, "Nothing" in Maybe)
6659-- - [Type] is the list of arguments, if it has (for example, "Just" has [TypeVar "a"])
6760--
68−getConstructors :: Environment -> ModuleName -> Qualified ProperName -> [(ProperName, [Type])]
61+getConstructors :: Environment -> ModuleName -> Qualified (ProperName 'ConstructorName) -> [(ProperName 'ConstructorName, [Type])]
6962getConstructors env defmn n = extractConstructors lnte
7063 where
71− qpn :: Qualified ProperName
72− qpn = getConsDataName n
7364
74− getConsDataName :: Qualified ProperName -> Qualified ProperName
75− getConsDataName con = qualifyName nm defmn con
76− where
77− nm = case getConsInfo con of
78− Nothing -> error $ "Constructor " ++ showQualified runProperName con ++ " not in the scope of the current environment in getConsDataName."
79− Just (_, pm, _, _) -> pm
80−
81− getConsInfo :: Qualified ProperName -> Maybe (DataDeclType, ProperName, Type, [Ident])
82− getConsInfo con = M.lookup con dce
83− where
84− dce :: M.Map (Qualified ProperName) (DataDeclType, ProperName, Type, [Ident])
85− dce = dataConstructors env
65+ extractConstructors :: Maybe (Kind, TypeKind) -> [(ProperName 'ConstructorName, [Type])]
66+ extractConstructors (Just (_, DataType _ pt)) = pt
67+ extractConstructors _ = internalError "Data name not in the scope of the current environment in extractConstructors"
8668
8769 lnte :: Maybe (Kind, TypeKind)
8870 lnte = M.lookup qpn (types env)
8971
90− extractConstructors :: Maybe (Kind, TypeKind) -> [(ProperName, [Type])]
91− extractConstructors (Just (_, DataType _ pt)) = pt
92− extractConstructors _ = internalError "Data name not in the scope of the current environment in extractConstructors"
72+ qpn :: Qualified (ProperName 'TypeName)
73+ qpn = getConsDataName n
74+
75+ getConsDataName :: Qualified (ProperName 'ConstructorName) -> Qualified (ProperName 'TypeName)
76+ getConsDataName con =
77+ case getConsInfo con of
78+ Nothing -> internalError $ "Constructor " ++ showQualified runProperName con ++ " not in the scope of the current environment in getConsDataName."
79+ Just (_, pm, _, _) -> qualifyName pm defmn con
80+
81+ getConsInfo :: Qualified (ProperName 'ConstructorName) -> Maybe (DataDeclType, ProperName 'TypeName, Type, [Ident])
82+ getConsInfo con = M.lookup con (dataConstructors env)
9383
9484-- |
9585-- Replicates a wildcard binder
@@ -117,7 +107,7 @@ genericMerge f bsl@((s, b):bs) bsr@((s', b'):bs')
117107-- Find the uncovered set between two binders:
118108-- the first binder is the case we are trying to cover, the second one is the matching binder
119109--
120−missingCasesSingle :: Environment -> ModuleName -> Binder -> Binder -> ([Binder], Either RedudancyError Bool)
110+missingCasesSingle :: Environment -> ModuleName -> Binder -> Binder -> ([Binder], Either RedundancyError Bool)
121111missingCasesSingle _ _ _ NullBinder = ([], return True)
122112missingCasesSingle _ _ _ (VarBinder _) = ([], return True)
123113missingCasesSingle env mn (VarBinder _) b = missingCasesSingle env mn NullBinder b
@@ -130,12 +120,12 @@ missingCasesSingle env mn NullBinder cb@(ConstructorBinder con _) =
130120missingCasesSingle env mn cb@(ConstructorBinder con bs) (ConstructorBinder con' bs')
131121 | con == con' = let (bs'', pr) = missingCasesMultiple env mn bs bs' in (map (ConstructorBinder con) bs'', pr)
132122 | otherwise = ([cb], return False)
133−missingCasesSingle env mn NullBinder (ObjectBinder bs) =
134− (map (ObjectBinder . zip (map fst bs)) allMisses, pr)
123+missingCasesSingle env mn NullBinder (LiteralBinder (ObjectLiteral bs)) =
124+ (map (LiteralBinder . ObjectLiteral . zip (map fst bs)) allMisses, pr)
135125 where
136126 (allMisses, pr) = missingCasesMultiple env mn (initialize $ length bs) (map snd bs)
137−missingCasesSingle env mn (ObjectBinder bs) (ObjectBinder bs') =
138− (map (ObjectBinder . zip sortedNames) allMisses, pr)
127+missingCasesSingle env mn (LiteralBinder (ObjectLiteral bs)) (LiteralBinder (ObjectLiteral bs')) =
128+ (map (LiteralBinder . ObjectLiteral . zip sortedNames) allMisses, pr)
139129 where
140130 (allMisses, pr) = uncurry (missingCasesMultiple env mn) (unzip binders)
141131
@@ -152,10 +142,10 @@ missingCasesSingle env mn (ObjectBinder bs) (ObjectBinder bs') =
152142 compBS e s b b' = (s, compB e b b')
153143
154144 (sortedNames, binders) = unzip $ genericMerge (compBS NullBinder) sbs sbs'
155−missingCasesSingle _ _ NullBinder (BooleanBinder b) = ([BooleanBinder $ not b], return True)
156−missingCasesSingle _ _ (BooleanBinder bl) (BooleanBinder br)
145+missingCasesSingle _ _ NullBinder (LiteralBinder (BooleanLiteral b)) = ([LiteralBinder . BooleanLiteral $ not b], return True)
146+missingCasesSingle _ _ (LiteralBinder (BooleanLiteral bl)) (LiteralBinder (BooleanLiteral br))
157147 | bl == br = ([], return True)
158− | otherwise = ([BooleanBinder bl], return False)
148+ | otherwise = ([LiteralBinder $ BooleanLiteral bl], return False)
159149missingCasesSingle env mn b (PositionedBinder _ _ cb) = missingCasesSingle env mn b cb
160150missingCasesSingle env mn b (TypedBinder _ cb) = missingCasesSingle env mn b cb
161151missingCasesSingle _ _ b _ = ([b], Left Unknown)
@@ -186,7 +176,7 @@ missingCasesSingle _ _ b _ = ([b], Left Unknown)
186176-- redundant or not, but uncovered at least. If we use `y` instead, we'll need to have a redundancy checker
187177-- (which ought to be available soon), or increase the complexity of the algorithm.
188178--
189−missingCasesMultiple :: Environment -> ModuleName -> [Binder] -> [Binder] -> ([[Binder]], Either RedudancyError Bool)
179+missingCasesMultiple :: Environment -> ModuleName -> [Binder] -> [Binder] -> ([[Binder]], Either RedundancyError Bool)
190180missingCasesMultiple env mn = go
191181 where
192182 go [] [] = ([], pure True)
@@ -212,18 +202,21 @@ isExhaustiveGuard :: Either [(Guard, Expr)] Expr -> Bool
212202isExhaustiveGuard (Left gs) = not . null $ filter (\(g, _) -> isOtherwise g) gs
213203 where
214204 isOtherwise :: Expr -> Bool
215− isOtherwise (TypedValue _ (BooleanLiteral True) _) = True
216− isOtherwise (TypedValue _ (Var (Qualified (Just (ModuleName [ProperName "Prelude"])) (Ident "otherwise"))) _) = True
205+ isOtherwise (Literal (BooleanLiteral True)) = True
206+ isOtherwise (Var (Qualified (Just (ModuleName [ProperName "Prelude"])) (Ident "otherwise"))) = True
207+ isOtherwise (Var (Qualified (Just (ModuleName [ProperName "Data", ProperName "Boolean"])) (Ident "otherwise"))) = True
208+ isOtherwise (TypedValue _ e _) = isOtherwise e
209+ isOtherwise (PositionedValue _ _ e) = isOtherwise e
217210 isOtherwise _ = False
218211isExhaustiveGuard (Right _) = True
219212
220213-- |
221214-- Returns the uncovered set of case alternatives
222215--
223−missingCases :: Environment -> ModuleName -> [Binder] -> CaseAlternative -> ([[Binder]], Either RedudancyError Bool)
216+missingCases :: Environment -> ModuleName -> [Binder] -> CaseAlternative -> ([[Binder]], Either RedundancyError Bool)
224217missingCases env mn uncovered ca = missingCasesMultiple env mn uncovered (caseAlternativeBinders ca)
225218
226−missingAlternative :: Environment -> ModuleName -> CaseAlternative -> [Binder] -> ([[Binder]], Either RedudancyError Bool)
219+missingAlternative :: Environment -> ModuleName -> CaseAlternative -> [Binder] -> ([[Binder]], Either RedundancyError Bool)
227220missingAlternative env mn ca uncovered
228221 | isExhaustiveGuard (caseAlternativeResult ca) = mcases
229222 | otherwise = ([uncovered], snd mcases)
@@ -239,13 +232,13 @@ missingAlternative env mn ca uncovered
239232checkExhaustive :: forall m. (MonadWriter MultipleErrors m) => Bool -> Environment -> ModuleName -> Int -> [CaseAlternative] -> m ()
240233checkExhaustive hasConstraint env mn numArgs cas = makeResult . first nub $ foldl' step ([initialize numArgs], (pure True, [])) cas
241234 where
242− step :: ([[Binder]], (Either RedudancyError Bool, [[Binder]])) -> CaseAlternative -> ([[Binder]], (Either RedudancyError Bool, [[Binder]]))
235+ step :: ([[Binder]], (Either RedundancyError Bool, [[Binder]])) -> CaseAlternative -> ([[Binder]], (Either RedundancyError Bool, [[Binder]]))
243236 step (uncovered, (nec, redundant)) ca =
244237 let (missed, pr) = unzip (map (missingAlternative env mn ca) uncovered)
245238 (missed', approx) = splitAt 10000 (nub (concat missed))
246− cond = liftA2 (&&) (or <$> sequenceA pr) nec
239+ cond = or <$> sequenceA pr
247240 in (missed', ( if null approx
248− then cond
241+ then liftA2 (&&) cond nec
249242 else Left Incomplete
250243 , if either (const True) id cond
251244 then redundant
@@ -253,7 +246,7 @@ checkExhaustive hasConstraint env mn numArgs cas = makeResult . first nub $ fold
253246 )
254247 )
255248
256− makeResult :: ([[Binder]], (Either RedudancyError Bool, [[Binder]])) -> m ()
249+ makeResult :: ([[Binder]], (Either RedundancyError Bool, [[Binder]])) -> m ()
257250 makeResult (bss, (rr, bss')) =
258251 do unless (hasConstraint || null bss) tellNonExhaustive
259252 unless (null bss') tellRedundant
@@ -268,7 +261,7 @@ checkExhaustive hasConstraint env mn numArgs cas = makeResult . first nub $ fold
268261-- |
269262-- Exhaustivity checking over a list of declarations
270263--
271−checkExhaustiveDecls :: forall m. (Applicative m, MonadWriter MultipleErrors m) => Environment -> ModuleName -> [Declaration] -> m ()
264+checkExhaustiveDecls :: forall m. MonadWriter MultipleErrors m => Environment -> ModuleName -> [Declaration] -> m ()
272265checkExhaustiveDecls env mn = mapM_ onDecl
273266 where
274267 onDecl :: Declaration -> m ()
@@ -282,8 +275,8 @@ checkExhaustiveDecls env mn = mapM_ onDecl
282275
283276 onExpr :: Bool -> Expr -> m ()
284277 onExpr isP (UnaryMinus e) = onExpr isP e
285− onExpr isP (ArrayLiteral es) = mapM_ (onExpr isP) es
286− onExpr isP (ObjectLiteral es) = mapM_ (onExpr isP . snd) es
278+ onExpr isP (Literal (ArrayLiteral es)) = mapM_ (onExpr isP) es
279+ onExpr isP (Literal (ObjectLiteral es)) = mapM_ (onExpr isP . snd) es
287280 onExpr isP (TypeClassDictionaryConstructorApp _ e) = onExpr isP e
288281 onExpr isP (Accessor _ e) = onExpr isP e
289282 onExpr isP (ObjectUpdate o es) = onExpr isP o >> mapM_ (onExpr isP . snd) es
@@ -303,19 +296,19 @@ checkExhaustiveDecls env mn = mapM_ onDecl
303296 hasPartialConstraint :: Type -> Bool
304297 hasPartialConstraint (ConstrainedType cs _) = any (go . fst) cs
305298 where
306− go :: Qualified ProperName -> Bool
299+ go :: Qualified (ProperName 'ClassName) -> Bool
307300 go qname
308301 | qname == partialClass = True
309302 | otherwise =
310303 case qname `M.lookup` typeClasses env of
311304 Just ([], _, cs') -> any (go . fst) cs'
312305 _ -> False
313− partialClass :: Qualified ProperName
306+ partialClass :: Qualified (ProperName 'ClassName)
314307 partialClass = primName "Partial"
315308 hasPartialConstraint _ = False
316309
317310-- |
318311-- Exhaustivity checking over a single module
319312--
320−checkExhaustiveModule :: forall m. (Applicative m, MonadWriter MultipleErrors m) => Environment -> Module -> m ()
313+checkExhaustiveModule :: forall m. MonadWriter MultipleErrors m => Environment -> Module -> m ()
321314checkExhaustiveModule env (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ checkExhaustiveDecls env mn ds
src/Language/PureScript/Linter/Imports.hs+251−93
@@ -1,18 +1,24 @@
11{-# LANGUAGE ScopedTypeVariables #-}
22{-# LANGUAGE FlexibleContexts #-}
33
4−module Language.PureScript.Linter.Imports (findUnusedImports, Name(..), UsedImports()) where
4+module Language.PureScript.Linter.Imports
5+ ( lintImports
6+ , Name(..)
7+ , UsedImports()
8+ ) where
59
610import Prelude ()
711import Prelude.Compat
812
9−import qualified Data.Map as M
10−import Data.Maybe (mapMaybe)
11−import Data.List ((\\), find, intersect, nub)
13+import Control.Monad (unless, when)
1214import Control.Monad.Error.Class (MonadError(..))
1315import Control.Monad.Writer.Class
14−import Control.Monad (unless,when)
16+
1517import Data.Foldable (forM_)
18+import Data.List ((\\), find, intersect, nub)
19+import Data.Maybe (mapMaybe)
20+import Data.Monoid (Sum(..))
21+import qualified Data.Map as M
1622
1723import Language.PureScript.AST.Declarations
1824import Language.PureScript.AST.SourcePos
@@ -28,130 +34,280 @@ import qualified Language.PureScript.Constants as C
2834-- | Imported name used in some type or expression.
2935data Name
3036 = IdentName (Qualified Ident)
31− | TypeName (Qualified ProperName)
32− | DctorName (Qualified ProperName)
33− | ClassName (Qualified ProperName)
34− deriving (Eq)
37+ | TyName (Qualified (ProperName 'TypeName))
38+ | DctorName (Qualified (ProperName 'ConstructorName))
39+ | TyClassName (Qualified (ProperName 'ClassName))
40+ deriving (Eq, Show)
3541
36−getIdentName :: Name -> Maybe Ident
37−getIdentName (IdentName (Qualified _ name)) = Just name
38−getIdentName _ = Nothing
42+getIdentName :: Maybe ModuleName -> Name -> Maybe Ident
43+getIdentName q (IdentName (Qualified q' name)) | q == q' = Just name
44+getIdentName _ _ = Nothing
3945
40−getTypeName :: Name -> Maybe ProperName
41−getTypeName (TypeName (Qualified _ name)) = Just name
42−getTypeName _ = Nothing
46+getTypeName :: Maybe ModuleName -> Name -> Maybe (ProperName 'TypeName)
47+getTypeName q (TyName (Qualified q' name)) | q == q' = Just name
48+getTypeName _ _ = Nothing
4349
44−getClassName :: Name -> Maybe ProperName
45−getClassName (ClassName (Qualified _ name)) = Just name
46−getClassName _ = Nothing
50+getClassName :: Maybe ModuleName -> Name -> Maybe (ProperName 'ClassName)
51+getClassName q (TyClassName (Qualified q' name)) | q == q' = Just name
52+getClassName _ _ = Nothing
4753
4854-- | Map of module name to list of imported names from that module which have been used.
4955type UsedImports = M.Map ModuleName [Name]
5056
5157-- |
52−-- Find and warn on any unused import statements (qualified or unqualified)
53−-- or references in an explicit import list.
58+-- Find and warn on:
5459--
55−findUnusedImports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Module -> Env -> UsedImports -> m ()
56−findUnusedImports (Module _ _ _ mdecls mexports) env usedImps = do
57− imps <- findImports mdecls
58− forM_ (M.toAscList imps) $ \(mni, decls) -> unless (mni `elem` alwaysUsedModules) $
59− forM_ decls $ \(ss, declType, qualifierName) ->
60− censor (onErrorMessages $ addModuleLocError ss) $ unless (qnameUsed qualifierName) $
61− let names = nub $ sugarNames mni ++ M.findWithDefault [] mni usedImps
62− usedNames = mapMaybe (matchName (typeForDCtor mni) qualifierName) names
63− usedDctors = mapMaybe (matchDctor qualifierName) names
64− in case declType of
65− Implicit _ | null usedNames -> tell $ errorMessage $ UnusedImport mni
66− Implicit False ->
67− let classRefs = TypeClassRef <$> mapMaybe getClassName names
68− valueRefs = ValueRef <$> mapMaybe getIdentName names
69− types = mapMaybe getTypeName names
70− typesWithDctors = reconstructTypeRefs mni usedDctors
71− typesWithoutDctors = filter (`M.notMember` typesWithDctors) types
72− typesRefs
73− = map (flip TypeRef (Just [])) typesWithoutDctors
74− ++ map (\(ty, ds) -> TypeRef ty (Just ds)) (M.toList typesWithDctors)
75− in tell $ errorMessage $ ImplicitImport mni (classRefs ++ typesRefs ++ valueRefs)
76− Explicit declrefs -> do
77− let idents = nub (mapMaybe runDeclRef declrefs)
78− let diff = idents \\ usedNames
79− case (length diff, length idents) of
80− (0, _) -> return ()
81− (n, m) | n == m -> tell $ errorMessage $ UnusedImport mni
82− _ -> tell $ errorMessage $ UnusedExplicitImport mni diff
83−
84− -- If we've not already warned a type is unused, check its data constructors
85− forM_ (mapMaybe getTypeRef declrefs) $ \(tn, c) -> do
86− let allCtors = dctorsForType mni tn
87− when (runProperName tn `elem` usedNames) $ case (c, null $ usedDctors `intersect` allCtors) of
88− (Nothing, True) -> tell $ errorMessage $ UnusedDctorImport tn
89− (Just (_:_), True) -> tell $ errorMessage $ UnusedDctorImport tn
90− (Just ctors, _) ->
91− let ddiff = ctors \\ usedDctors
92− in unless (null ddiff) $ tell $ errorMessage $ UnusedDctorExplicitImport tn ddiff
93− _ -> return ()
94−
95− return ()
96−
97− _ -> return ()
60+-- * Unused import statements (qualified or unqualified)
61+--
62+-- * Unused references in an explicit import list
63+--
64+-- * Implicit imports of modules
65+--
66+-- * Implicit imports into a virtual module (unless the virtual module only has
67+-- members from one module imported)
68+--
69+-- * Imports using `hiding` (this is another form of implicit importing)
70+--
71+lintImports
72+ :: forall m
73+ . (MonadError MultipleErrors m, MonadWriter MultipleErrors m)
74+ => Module
75+ -> Env
76+ -> UsedImports
77+ -> m ()
78+lintImports (Module _ _ mn mdecls mexports) env usedImps = do
79+
80+ let scope = maybe nullImports (\(_, imps, _) -> imps) (M.lookup mn env)
81+ usedImps' = foldr (elaborateUsed scope) usedImps exportedModules
82+ numOpenImports = getSum $ foldMap (Sum . countOpenImports) mdecls
83+ allowImplicit = numOpenImports == 1
84+
85+ imps <- M.toAscList <$> findImports mdecls
86+
87+ forM_ imps $ \(mni, decls) ->
88+ unless (isPrim mni) $ do
89+ forM_ decls $ \(ss, declType, qualifierName) ->
90+ censor (onErrorMessages $ addModuleLocError ss) $ do
91+ let names = nub $ M.findWithDefault [] mni usedImps'
92+ lintImportDecl env mni qualifierName names declType allowImplicit
93+
94+ forM_ (M.toAscList (byQual imps)) $ \(mnq, entries) -> do
95+ let mnis = nub $ map (\(_, _, mni) -> mni) entries
96+ unless (length mnis == 1) $ do
97+ let implicits = filter (\(_, declType, _) -> not $ isExplicit declType) entries
98+ forM_ implicits $ \(ss, _, mni) ->
99+ censor (onErrorMessages $ addModuleLocError ss) $ do
100+ let names = nub $ M.findWithDefault [] mni usedImps'
101+ usedRefs = findUsedRefs env mni (Just mnq) names
102+ unless (null usedRefs) $
103+ tell $ errorMessage $ ImplicitQualifiedImport mni mnq usedRefs
104+
105+ return ()
106+
98107 where
99− sugarNames :: ModuleName -> [ Name ]
100− sugarNames (ModuleName [ProperName n]) | n == C.prelude = [ IdentName $ Qualified Nothing (Ident C.bind) ]
101− sugarNames _ = []
102108
103− reconstructTypeRefs :: ModuleName -> [ProperName] -> M.Map ProperName [ProperName]
104− reconstructTypeRefs mni = foldr accumDctors M.empty
105− where
106− accumDctors dctor = M.alter (Just . maybe [dctor] (dctor :)) (findTypeForDctor mni dctor)
109+ countOpenImports :: Declaration -> Int
110+ countOpenImports (ImportDeclaration mn' Implicit Nothing _) | not (isPrim mn') = 1
111+ countOpenImports (ImportDeclaration mn' (Hiding _) Nothing _) | not (isPrim mn') = 1
112+ countOpenImports (PositionedDeclaration _ _ d) = countOpenImports d
113+ countOpenImports _ = 0
107114
108− findTypeForDctor :: ModuleName -> ProperName -> ProperName
109− findTypeForDctor mn dctor =
110− case mn `M.lookup` env of
111− Just (_, _, exps) ->
112− case find (elem dctor . snd . fst) (exportedTypes exps) of
113− Just ((ty, _), _) -> ty
114− Nothing -> internalError $ "missing type for data constructor " ++ runProperName dctor ++ " in findTypeForDctor"
115− Nothing -> internalError $ "missing module " ++ runModuleName mn ++ " in findTypeForDctor"
115+ -- Checks whether a module is the Prim module - used to suppress any checks
116+ -- made, as Prim is always implicitly imported.
117+ isPrim :: ModuleName -> Bool
118+ isPrim = (== ModuleName [ProperName C.prim])
116119
117− -- rely on exports being elaborated by this point
118− alwaysUsedModules :: [ ModuleName ]
119− alwaysUsedModules = ModuleName [ProperName C.prim] : maybe [] (mapMaybe extractModule) mexports
120+ -- Creates a map of virtual modules mapped to all the declarations that
121+ -- import to that module, with the corresponding source span, import type,
122+ -- and module being imported
123+ byQual
124+ :: [(ModuleName, [(Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)])]
125+ -> M.Map ModuleName [(Maybe SourceSpan, ImportDeclarationType, ModuleName)]
126+ byQual = foldr goImp M.empty
127+ where
128+ goImp (mni, xs) acc = foldr (goDecl mni) acc xs
129+ goDecl mni (ss, declType, Just qmn) acc =
130+ let entry = (ss, declType, mni)
131+ in M.alter (Just . maybe [entry] (entry :)) qmn acc
132+ goDecl _ _ acc = acc
133+
134+ -- The list of modules that are being re-exported by the current module. Any
135+ -- module that appears in this list is always considered to be used.
136+ exportedModules :: [ModuleName]
137+ exportedModules = nub $ maybe [] (mapMaybe extractModule) mexports
120138 where
121139 extractModule (PositionedDeclarationRef _ _ r) = extractModule r
122− extractModule (ModuleRef mn) = Just mn
140+ extractModule (ModuleRef mne) = Just mne
123141 extractModule _ = Nothing
124142
125− qnameUsed :: Maybe ModuleName -> Bool
126− qnameUsed (Just qn) = qn `elem` alwaysUsedModules
127− qnameUsed Nothing = False
143+ -- Elaborates the UsedImports to include values from modules that are being
144+ -- re-exported. This ensures explicit export hints are printed for modules
145+ -- that are implicitly exported and then re-exported.
146+ elaborateUsed :: Imports -> ModuleName -> UsedImports -> UsedImports
147+ elaborateUsed scope mne used =
148+ let classes = extractByQual mne (importedTypeClasses scope) TyClassName
149+ types = extractByQual mne (importedTypes scope) TyName
150+ dctors = extractByQual mne (importedDataConstructors scope) DctorName
151+ values = extractByQual mne (importedValues scope) IdentName
152+ in foldr go used (classes ++ types ++ dctors ++ values)
153+ where
154+ go :: (ModuleName, Name) -> UsedImports -> UsedImports
155+ go (q, name) acc = M.alter (Just . maybe [name] (name :)) q acc
156+
157+ extractByQual
158+ :: (Eq a)
159+ => ModuleName
160+ -> M.Map (Qualified a) [ImportRecord a]
161+ -> (Qualified a -> Name)
162+ -> [(ModuleName, Name)]
163+ extractByQual k m toName = mapMaybe go (M.toList m)
164+ where
165+ go (q@(Qualified mnq _), is) | isUnqualified q || isQualifiedWith k q =
166+ case importName (head is) of
167+ Qualified (Just mn') name -> Just (mn', toName $ Qualified mnq name)
168+ _ -> internalError "unqualified name in extractByQual"
169+ go _ = Nothing
170+
171+lintImportDecl
172+ :: forall m
173+ . (MonadError MultipleErrors m, MonadWriter MultipleErrors m)
174+ => Env
175+ -> ModuleName
176+ -> Maybe ModuleName
177+ -> [Name]
178+ -> ImportDeclarationType
179+ -> Bool
180+ -> m ()
181+lintImportDecl env mni qualifierName names declType allowImplicit =
182+ case declType of
183+ Implicit -> case qualifierName of
184+ Nothing -> unless allowImplicit (checkImplicit ImplicitImport)
185+ Just q ->
186+ let usedModuleNames = mapMaybe extractQualName names
187+ in unless (q `elem` usedModuleNames) unused
188+ Hiding _ -> checkImplicit HidingImport
189+ Explicit [] -> unused
190+ Explicit declrefs -> checkExplicit declrefs
191+
192+ where
193+
194+ checkImplicit
195+ :: (ModuleName -> [DeclarationRef] -> SimpleErrorMessage)
196+ -> m ()
197+ checkImplicit warning =
198+ if null allRefs
199+ then unused
200+ else tell $ errorMessage $ warning mni allRefs
201+
202+ checkExplicit
203+ :: [DeclarationRef]
204+ -> m ()
205+ checkExplicit declrefs = do
206+ let idents = nub (mapMaybe runDeclRef declrefs)
207+ dctors = mapMaybe (matchDctor qualifierName) names
208+ usedNames = mapMaybe (matchName (typeForDCtor mni) qualifierName) names
209+ diff = idents \\ usedNames
210+ case (length diff, length idents) of
211+ (0, _) -> return ()
212+ (n, m) | n == m -> unused
213+ _ -> tell $ errorMessage $ UnusedExplicitImport mni diff qualifierName allRefs
214+
215+ -- If we've not already warned a type is unused, check its data constructors
216+ forM_ (mapMaybe getTypeRef declrefs) $ \(tn, c) -> do
217+ let allCtors = dctorsForType mni tn
218+ when (runProperName tn `elem` usedNames) $ case (c, dctors `intersect` allCtors) of
219+ (_, []) | c /= Just [] ->
220+ tell $ errorMessage $ UnusedDctorImport tn
221+ (Just ctors, dctors') ->
222+ let ddiff = ctors \\ dctors'
223+ in unless (null ddiff) $ tell $ errorMessage $ UnusedDctorExplicitImport tn ddiff
224+ _ -> return ()
225+ return ()
128226
129− dtys :: ModuleName -> [((ProperName, [ProperName]), ModuleName)]
227+ unused :: m ()
228+ unused = tell $ errorMessage $ UnusedImport mni
229+
230+ allRefs :: [DeclarationRef]
231+ allRefs = findUsedRefs env mni qualifierName names
232+
233+ dtys
234+ :: ModuleName
235+ -> [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]
130236 dtys mn = maybe [] exportedTypes $ envModuleExports <$> mn `M.lookup` env
131237
132− dctorsForType :: ModuleName -> ProperName -> [ProperName]
238+ dctorsForType
239+ :: ModuleName
240+ -> ProperName 'TypeName
241+ -> [ProperName 'ConstructorName]
133242 dctorsForType mn tn =
134243 maybe [] getDctors (find matches $ dtys mn)
135244 where
136245 matches ((ty, _),_) = ty == tn
137246 getDctors ((_,ctors),_) = ctors
138247
139− typeForDCtor :: ModuleName -> ProperName -> Maybe ProperName
248+ typeForDCtor
249+ :: ModuleName
250+ -> ProperName 'ConstructorName
251+ -> Maybe (ProperName 'TypeName)
140252 typeForDCtor mn pn =
141253 getTy <$> find matches (dtys mn)
142254 where
143255 matches ((_, ctors), _) = pn `elem` ctors
144256 getTy ((ty, _), _) = ty
145257
258+findUsedRefs :: Env -> ModuleName -> Maybe ModuleName -> [Name] -> [DeclarationRef]
259+findUsedRefs env mni qualifierName names =
260+ let
261+ classRefs = TypeClassRef <$> mapMaybe (getClassName qualifierName) names
262+ valueRefs = ValueRef <$> mapMaybe (getIdentName qualifierName) names
263+ types = mapMaybe (getTypeName qualifierName) names
264+ dctors = mapMaybe (matchDctor qualifierName) names
265+ typesWithDctors = reconstructTypeRefs dctors
266+ typesWithoutDctors = filter (`M.notMember` typesWithDctors) types
267+ typesRefs
268+ = map (flip TypeRef (Just [])) typesWithoutDctors
269+ ++ map (\(ty, ds) -> TypeRef ty (Just ds)) (M.toList typesWithDctors)
270+ in classRefs ++ typesRefs ++ valueRefs
146271
147−matchName :: (ProperName -> Maybe ProperName) -> Maybe ModuleName -> Name -> Maybe String
272+ where
273+
274+ reconstructTypeRefs
275+ :: [ProperName 'ConstructorName]
276+ -> M.Map (ProperName 'TypeName) [ProperName 'ConstructorName]
277+ reconstructTypeRefs = foldr accumDctors M.empty
278+ where
279+ accumDctors dctor = M.alter (Just . maybe [dctor] (dctor :)) (findTypeForDctor mni dctor)
280+
281+ findTypeForDctor
282+ :: ModuleName
283+ -> ProperName 'ConstructorName
284+ -> ProperName 'TypeName
285+ findTypeForDctor mn dctor =
286+ case mn `M.lookup` env of
287+ Just (_, _, exps) ->
288+ case find (elem dctor . snd . fst) (exportedTypes exps) of
289+ Just ((ty, _), _) -> ty
290+ Nothing -> internalError $ "missing type for data constructor " ++ runProperName dctor ++ " in findTypeForDctor"
291+ Nothing -> internalError $ "missing module " ++ runModuleName mn ++ " in findTypeForDctor"
292+
293+matchName
294+ :: (ProperName 'ConstructorName -> Maybe (ProperName 'TypeName))
295+ -> Maybe ModuleName
296+ -> Name
297+ -> Maybe String
148298matchName _ qual (IdentName (Qualified q x)) | q == qual = Just $ showIdent x
149−matchName _ qual (TypeName (Qualified q x)) | q == qual = Just $ runProperName x
150−matchName _ qual (ClassName (Qualified q x)) | q == qual = Just $ runProperName x
299+matchName _ qual (TyName (Qualified q x)) | q == qual = Just $ runProperName x
300+matchName _ qual (TyClassName (Qualified q x)) | q == qual = Just $ runProperName x
151301matchName lookupDc qual (DctorName (Qualified q x)) | q == qual = runProperName <$> lookupDc x
152302matchName _ _ _ = Nothing
153303
154−matchDctor :: Maybe ModuleName -> Name -> Maybe ProperName
304+extractQualName :: Name -> Maybe ModuleName
305+extractQualName (IdentName (Qualified q _)) = q
306+extractQualName (TyName (Qualified q _)) = q
307+extractQualName (TyClassName (Qualified q _)) = q
308+extractQualName (DctorName (Qualified q _)) = q
309+
310+matchDctor :: Maybe ModuleName -> Name -> Maybe (ProperName 'ConstructorName)
155311matchDctor qual (DctorName (Qualified q x)) | q == qual = Just x
156312matchDctor _ _ = Nothing
157313
@@ -162,7 +318,9 @@ runDeclRef (TypeRef pn _) = Just $ runProperName pn
162318runDeclRef (TypeClassRef pn) = Just $ runProperName pn
163319runDeclRef _ = Nothing
164320
165−getTypeRef :: DeclarationRef -> Maybe (ProperName, Maybe [ProperName])
321+getTypeRef
322+ :: DeclarationRef
323+ -> Maybe (ProperName 'TypeName, Maybe [ProperName 'ConstructorName])
166324getTypeRef (PositionedDeclarationRef _ _ ref) = getTypeRef ref
167325getTypeRef (TypeRef pn x) = Just (pn, x)
168326getTypeRef _ = Nothing
src/Language/PureScript/Make.hs+42−8
@@ -1,4 +1,3 @@
1−{-# LANGUAGE DataKinds #-}
21{-# LANGUAGE FlexibleContexts #-}
32{-# LANGUAGE GeneralizedNewtypeDeriving #-}
43{-# LANGUAGE TupleSections #-}
@@ -32,7 +31,7 @@ import Control.Monad.Writer.Class (MonadWriter(..))
3231import Control.Monad.Trans.Class (MonadTrans(..))
3332import Control.Monad.Trans.Except
3433import Control.Monad.IO.Class
35−import Control.Monad.Reader (MonadReader(..), ReaderT(..))
34+import Control.Monad.Reader (MonadReader(..), ReaderT(..), asks)
3635import Control.Monad.Logger
3736import Control.Monad.Supply
3837import Control.Monad.Base (MonadBase(..))
@@ -53,9 +52,12 @@ import qualified Data.ByteString.UTF8 as BU8
5352import qualified Data.Set as S
5453import qualified Data.Map as M
5554
55+import SourceMap.Types
56+import SourceMap
57+
5658import System.Directory
57− (doesFileExist, getModificationTime, createDirectoryIfMissing)
58−import System.FilePath ((</>), takeDirectory)
59+ (doesFileExist, getModificationTime, createDirectoryIfMissing, getCurrentDirectory)
60+import System.FilePath ((</>), takeDirectory, makeRelative, splitPath, normalise)
5961import System.IO.Error (tryIOError)
6062import System.IO.UTF8 (readUTF8File, writeUTF8File)
6163
@@ -69,6 +71,7 @@ import Language.PureScript.ModuleDependencies
6971import Language.PureScript.Names
7072import Language.PureScript.Options
7173import Language.PureScript.Pretty
74+import Language.PureScript.Pretty.Common(SMap(..))
7275import Language.PureScript.Renamer
7376import Language.PureScript.Sugar
7477import Language.PureScript.TypeChecker
@@ -142,7 +145,7 @@ data RebuildPolicy
142145-- If timestamps have not changed, the externs file can be used to provide the module's types without
143146-- having to typecheck the module again.
144147--
145−make :: forall m. (Functor m, Applicative m, Monad m, MonadBaseControl IO m, MonadReader Options m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
148+make :: forall m. (Monad m, MonadBaseControl IO m, MonadReader Options m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
146149 => MakeActions m
147150 -> [Module]
148151 -> m Environment
@@ -325,20 +328,51 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
325328 | not $ requiresForeign m -> do
326329 tell $ errorMessage $ UnnecessaryFFIModule mn path
327330 return Nothing
328− | otherwise -> return $ Just $ J.JSApp (J.JSVar "require") [J.JSStringLiteral "./foreign"]
331+ | otherwise -> return $ Just $ J.JSApp Nothing (J.JSVar Nothing "require") [J.JSStringLiteral Nothing "./foreign"]
329332 Nothing | requiresForeign m -> throwError . errorMessage $ MissingFFIModule mn
330333 | otherwise -> return Nothing
331− pjs <- prettyPrintJS <$> J.moduleToJs m foreignInclude
334+ rawJs <- J.moduleToJs m foreignInclude
335+ dir <- lift $ makeIO (const (ErrorMessage [] $ CannotGetFileInfo ".")) getCurrentDirectory
336+ sourceMaps <- lift $ asks optionsSourceMaps
337+ let (pjs, mappings) = if sourceMaps then prettyPrintJSWithSourceMaps rawJs else (prettyPrintJS rawJs, [])
332338 let filePath = runModuleName mn
333339 jsFile = outputDir </> filePath </> "index.js"
340+ mapFile = outputDir </> filePath </> "index.js.map"
334341 externsFile = outputDir </> filePath </> "externs.json"
335342 foreignFile = outputDir </> filePath </> "foreign.js"
336343 prefix = ["Generated by psc version " ++ showVersion Paths.version | usePrefix]
337344 js = unlines $ map ("// " ++) prefix ++ [pjs]
345+ mapRef = if sourceMaps then "//# sourceMappingURL=index.js.map\n" else ""
338346 lift $ do
339− writeTextFile jsFile (fromString js)
347+ writeTextFile jsFile (fromString $ js ++ mapRef)
340348 for_ (mn `M.lookup` foreigns) (readTextFile >=> writeTextFile foreignFile)
341349 writeTextFile externsFile exts
350+ lift $ when sourceMaps $ genSourceMap dir mapFile (length prefix) mappings
351+
352+ genSourceMap :: String -> String -> Int -> [SMap] -> Make ()
353+ genSourceMap dir mapFile extraLines mappings = do
354+ let pathToDir = iterate (".." </>) ".." !! length (splitPath $ normalise outputDir)
355+ sourceFile = case mappings of
356+ ((SMap file _ _):_) -> Just $ pathToDir </> makeRelative dir file
357+ _ -> Nothing
358+ let rawMapping = SourceMapping { smFile = "index.js", smSourceRoot = Nothing, smMappings =
359+ map (\(SMap _ orig gen) -> Mapping {
360+ mapOriginal = Just $ convertPos $ add 0 (-1) orig
361+ , mapSourceFile = sourceFile
362+ , mapGenerated = convertPos $ add (extraLines+1) 0 gen
363+ , mapName = Nothing
364+ }) $
365+ mappings
366+ }
367+ let mapping = generate rawMapping
368+ writeTextFile mapFile $ BU8.toString . B.toStrict . encode $ mapping
369+ where
370+ add :: Int -> Int -> SourcePos -> SourcePos
371+ add n m (SourcePos n' m') = SourcePos (n+n') (m+m')
372+
373+ convertPos :: SourcePos -> Pos
374+ convertPos SourcePos { sourcePosLine = l, sourcePosColumn = c } =
375+ Pos { posLine = fromIntegral l, posColumn = fromIntegral c }
342376
343377 requiresForeign :: CF.Module a -> Bool
344378 requiresForeign = not . null . CF.moduleForeign
src/Language/PureScript/ModuleDependencies.hs+8−4
@@ -23,7 +23,7 @@ import Control.Monad.Error.Class (MonadError(..))
2323
2424import Data.Graph
2525import Data.List (nub)
26−import Data.Maybe (fromMaybe, mapMaybe)
26+import Data.Maybe (fromMaybe)
2727
2828import Language.PureScript.Crash
2929import Language.PureScript.AST
@@ -54,21 +54,25 @@ sortModules ms = do
5454-- Calculate a list of used modules based on explicit imports and qualified names
5555--
5656usedModules :: Declaration -> [ModuleName]
57−usedModules = let (f, _, _, _, _) = everythingOnValues (++) forDecls forValues (const []) (const []) (const []) in nub . f
57+usedModules d =
58+ let (f, _, _, _, _) = everythingOnValues (++) forDecls forValues (const []) (const []) (const [])
59+ (g, _, _, _, _) = accumTypes (everythingOnTypes (++) forTypes)
60+ in nub (f d ++ g d)
5861 where
5962 forDecls :: Declaration -> [ModuleName]
6063 forDecls (ImportDeclaration mn _ _ _) = [mn]
64+ forDecls (FixityDeclaration _ _ (Just (Left (Qualified (Just mn) _)))) = [mn]
65+ forDecls (FixityDeclaration _ _ (Just (Right (Qualified (Just mn) _)))) = [mn]
66+ forDecls (TypeInstanceDeclaration _ _ (Qualified (Just mn) _) _ _) = [mn]
6167 forDecls _ = []
6268
6369 forValues :: Expr -> [ModuleName]
6470 forValues (Var (Qualified (Just mn) _)) = [mn]
6571 forValues (Constructor (Qualified (Just mn) _)) = [mn]
66− forValues (TypedValue _ _ ty) = forTypes ty
6772 forValues _ = []
6873
6974 forTypes :: Type -> [ModuleName]
7075 forTypes (TypeConstructor (Qualified (Just mn) _)) = [mn]
71− forTypes (ConstrainedType cs _) = mapMaybe (\(Qualified mn _, _) -> mn) cs
7276 forTypes _ = []
7377
7478-- |
src/Language/PureScript/Names.hs+46−26
@@ -1,7 +1,7 @@
1−{-# LANGUAGE DeriveDataTypeable #-}
21{-# LANGUAGE DeriveFunctor #-}
32{-# LANGUAGE TemplateHaskell #-}
4−{-# LANGUAGE GADTs #-}
3+{-# LANGUAGE EmptyDataDecls #-}
4+{-# LANGUAGE KindSignatures #-}
55
66-- |
77-- Data types for names
@@ -12,11 +12,8 @@ import Control.Monad (liftM)
1212import Control.Monad.Supply.Class
1313
1414import Data.List
15−import Data.Data
16−import Data.List.Split (splitOn)
15+import Data.Aeson
1716import Data.Aeson.TH
18−import qualified Data.Aeson as A
19−import qualified Data.Text as T
2017
2118-- |
2219-- Names for value identifiers
@@ -33,7 +30,8 @@ data Ident
3330 -- |
3431 -- A generated name for an identifier
3532 --
36− | GenIdent (Maybe String) Integer deriving (Show, Read, Eq, Ord, Data, Typeable)
33+ | GenIdent (Maybe String) Integer
34+ deriving (Show, Read, Eq, Ord)
3735
3836runIdent :: Ident -> String
3937runIdent (Ident i) = i
@@ -54,12 +52,33 @@ freshIdent' = liftM (GenIdent Nothing) fresh
5452-- |
5553-- Proper names, i.e. capitalized names for e.g. module names, type//data constructors.
5654--
57−newtype ProperName = ProperName { runProperName :: String } deriving (Show, Read, Eq, Ord, Data, Typeable)
55+newtype ProperName (a :: ProperNameType) = ProperName { runProperName :: String }
56+ deriving (Show, Read, Eq, Ord)
57+
58+instance ToJSON (ProperName a) where
59+ toJSON = toJSON . runProperName
60+
61+instance FromJSON (ProperName a) where
62+ parseJSON = fmap ProperName . parseJSON
63+
64+-- |
65+-- The closed set of proper name types.
66+--
67+data ProperNameType = TypeName | ConstructorName | ClassName | Namespace
68+
69+-- |
70+-- Coerces a ProperName from one ProperNameType to another. This should be used
71+-- with care, and is primarily used to convert ClassNames into TypeNames after
72+-- classes have been desugared.
73+--
74+coerceProperName :: ProperName a -> ProperName b
75+coerceProperName = ProperName . runProperName
5876
5977-- |
6078-- Module names
6179--
62−newtype ModuleName = ModuleName [ProperName] deriving (Show, Read, Eq, Ord, Data, Typeable)
80+newtype ModuleName = ModuleName [ProperName 'Namespace]
81+ deriving (Show, Read, Eq, Ord)
6382
6483runModuleName :: ModuleName -> String
6584runModuleName (ModuleName pns) = intercalate "." (runProperName `map` pns)
@@ -75,25 +94,13 @@ moduleNameFromString = ModuleName . splitProperNames
7594-- |
7695-- A qualified name, i.e. a name with an optional module name
7796--
78−data Qualified a = Qualified (Maybe ModuleName) a deriving (Show, Read, Eq, Ord, Data, Typeable, Functor)
97+data Qualified a = Qualified (Maybe ModuleName) a
98+ deriving (Show, Read, Eq, Ord, Functor)
7999
80100showQualified :: (a -> String) -> Qualified a -> String
81101showQualified f (Qualified Nothing a) = f a
82102showQualified f (Qualified (Just name) a) = runModuleName name ++ "." ++ f a
83103
84−instance (a ~ ProperName) => A.ToJSON (Qualified a) where
85− toJSON = A.toJSON . showQualified runProperName
86−
87−instance (a ~ ProperName) => A.FromJSON (Qualified a) where
88− parseJSON =
89− A.withText "Qualified ProperName" $ \str ->
90− return $ case reverse (splitOn "." (T.unpack str)) of
91− [name] -> Qualified Nothing (ProperName name)
92− (name:rest) -> Qualified (Just (reconstructModuleName rest)) (ProperName name)
93− _ -> Qualified Nothing (ProperName "")
94− where
95− reconstructModuleName = moduleNameFromString . intercalate "." . reverse
96−
97104-- |
98105-- Provide a default module name, if a name is unqualified
99106--
@@ -114,10 +121,23 @@ disqualify (Qualified _ a) = a
114121-- |
115122-- Checks whether a qualified value is actually qualified with a module reference
116123--
124+isQualified :: Qualified a -> Bool
125+isQualified (Qualified Nothing _) = False
126+isQualified _ = True
127+
128+-- |
129+-- Checks whether a qualified value is not actually qualified with a module reference
130+--
117131isUnqualified :: Qualified a -> Bool
118−isUnqualified (Qualified Nothing _) = True
119−isUnqualified _ = False
132+isUnqualified = not . isQualified
133+
134+-- |
135+-- Checks whether a qualified value is qualified with a particular module
136+--
137+isQualifiedWith :: ModuleName -> Qualified a -> Bool
138+isQualifiedWith mn (Qualified (Just mn') _) = mn == mn'
139+isQualifiedWith _ _ = False
120140
141+$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Qualified)
121142$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Ident)
122−$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ProperName)
123143$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ModuleName)
src/Language/PureScript/Options.hs+4−1
@@ -41,9 +41,12 @@ data Options = Options {
4141 -- |
4242 -- The path to prepend to require statements
4343 , optionsRequirePath :: Maybe FilePath
44+ -- |
45+ -- Generate soure maps
46+ , optionsSourceMaps :: Bool
4447 } deriving Show
4548
4649-- |
4750-- Default make options
4851defaultOptions :: Options
49−defaultOptions = Options False False Nothing False False False Nothing
52+defaultOptions = Options False False Nothing False False False Nothing False
src/Language/PureScript/Parser/Common.hs+3−15
@@ -1,20 +1,8 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.Parser.Common
4−-- Copyright : (c) Phil Freeman 2013
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
1+{-# LANGUAGE FlexibleContexts #-}
2+
113-- |
124-- Constants, and utility functions to be used when parsing
135--
14−-----------------------------------------------------------------------------
15−
16−{-# LANGUAGE FlexibleContexts #-}
17−
186module Language.PureScript.Parser.Common where
197
208import Control.Applicative
@@ -27,7 +15,7 @@ import Language.PureScript.Names
2715
2816import qualified Text.Parsec as P
2917
30−properName :: TokenParser ProperName
18+properName :: TokenParser (ProperName a)
3119properName = ProperName <$> uname
3220
3321-- |
src/Language/PureScript/Parser/Declarations.hs+63−63
@@ -122,9 +122,12 @@ parseFixityDeclaration :: TokenParser Declaration
122122parseFixityDeclaration = do
123123 fixity <- parseFixity
124124 indented
125− alias <- P.optionMaybe $ (Ident <$> identifier) <* reserved "as"
125+ alias <- P.optionMaybe $ aliased <* reserved "as"
126126 name <- symbol
127127 return $ FixityDeclaration fixity name alias
128+ where
129+ aliased = (Left <$> parseQualified (Ident <$> identifier))
130+ <|> (Right <$> parseQualified (ProperName <$> uname))
128131
129132parseImportDeclaration :: TokenParser Declaration
130133parseImportDeclaration = do
@@ -151,10 +154,8 @@ parseImportDeclaration' = do
151154 qName <- qualifiedName
152155 return (moduleName', declType, Just qName, True)
153156 qualifyingList expectedType = do
154− declType <- P.optionMaybe
155− $ P.try (expectedType <$> (indented *> parens (commaSep parseDeclarationRef)))
156− <|> (const (Implicit True) <$> (indented *> parens (symbol' "..")))
157− return $ fromMaybe (Implicit False) declType
157+ declType <- P.optionMaybe (expectedType <$> (indented *> parens (commaSep parseDeclarationRef)))
158+ return $ fromMaybe Implicit declType
158159
159160parseDeclarationRef :: TokenParser DeclarationRef
160161parseDeclarationRef =
@@ -167,7 +168,7 @@ parseDeclarationRef =
167168 parseProperRef = do
168169 name <- properName
169170 dctors <- P.optionMaybe $ parens (symbol' ".." *> pure Nothing <|> Just <$> commaSep properName)
170− return $ maybe (ProperRef name) (TypeRef name) dctors
171+ return $ maybe (ProperRef (runProperName name)) (TypeRef name) dctors
171172
172173parseTypeClassDeclaration :: TokenParser Declaration
173174parseTypeClassDeclaration = do
@@ -259,7 +260,7 @@ parseModule = do
259260 return $ Module ss comments name decls exports
260261
261262-- | Parse a collection of modules in parallel
262−parseModulesFromFiles :: forall m k. (MonadError MultipleErrors m, Functor m) =>
263+parseModulesFromFiles :: forall m k. (MonadError MultipleErrors m) =>
263264 (k -> FilePath) -> [(k, String)] -> m [(k, Module)]
264265parseModulesFromFiles toFilePath input = do
265266 modules <- flip parU id $ map wrapError $ inParallel $ flip map input $ \(k, content) -> do
@@ -298,34 +299,33 @@ parseModules = mark (P.many (same *> parseModule)) <* P.eof
298299booleanLiteral :: TokenParser Bool
299300booleanLiteral = (reserved "true" >> return True) P.<|> (reserved "false" >> return False)
300301
301−parseNumericLiteral :: TokenParser Expr
302+parseNumericLiteral :: TokenParser (Literal a)
302303parseNumericLiteral = NumericLiteral <$> number
303304
304−parseCharLiteral :: TokenParser Expr
305+parseCharLiteral :: TokenParser (Literal a)
305306parseCharLiteral = CharLiteral <$> charLiteral
306307
307−parseStringLiteral :: TokenParser Expr
308+parseStringLiteral :: TokenParser (Literal a)
308309parseStringLiteral = StringLiteral <$> stringLiteral
309310
310−parseBooleanLiteral :: TokenParser Expr
311+parseBooleanLiteral :: TokenParser (Literal a)
311312parseBooleanLiteral = BooleanLiteral <$> booleanLiteral
312313
313−parseArrayLiteral :: TokenParser Expr
314−parseArrayLiteral = ArrayLiteral <$> squares (commaSep parseValue)
314+parseArrayLiteral :: TokenParser a -> TokenParser (Literal a)
315+parseArrayLiteral p = ArrayLiteral <$> squares (commaSep p)
315316
316−parseObjectLiteral :: TokenParser Expr
317−parseObjectLiteral = ObjectConstructor <$> braces (commaSep parseIdentifierAndValue)
317+parseObjectLiteral :: TokenParser (String, a) -> TokenParser (Literal a)
318+parseObjectLiteral p = ObjectLiteral <$> braces (commaSep p)
318319
319−parseIdentifierAndValue :: TokenParser (String, Maybe Expr)
320+parseIdentifierAndValue :: TokenParser (String, Expr)
320321parseIdentifierAndValue =
321322 do
322323 name <- C.indented *> lname
323− b <- P.option (Just $ Var $ Qualified Nothing (Ident name)) rest
324+ b <- P.option (Var $ Qualified Nothing (Ident name)) rest
324325 return (name, b)
325326 <|> (,) <$> (C.indented *> stringLiteral) <*> rest
326327 where
327− rest = C.indented *> colon *> C.indented *> val
328− val = (underscore *> pure Nothing) <|> (Just <$> parseValue)
328+ rest = C.indented *> colon *> C.indented *> parseValue
329329
330330parseAbs :: TokenParser Expr
331331parseAbs = do
@@ -375,13 +375,13 @@ parseLet = do
375375
376376parseValueAtom :: TokenParser Expr
377377parseValueAtom = P.choice
378− [ parseNumericLiteral
379− , parseCharLiteral
380− , parseStringLiteral
381− , parseBooleanLiteral
382− , parseArrayLiteral
383− , P.try parseObjectLiteral
384− , P.try parseObjectGetter
378+ [ parseAnonymousArgument
379+ , Literal <$> parseNumericLiteral
380+ , Literal <$> parseCharLiteral
381+ , Literal <$> parseStringLiteral
382+ , Literal <$> parseBooleanLiteral
383+ , Literal <$> parseArrayLiteral parseValue
384+ , Literal <$> P.try (parseObjectLiteral parseIdentifierAndValue)
385385 , parseAbs
386386 , P.try parseConstructor
387387 , P.try parseVar
@@ -391,8 +391,6 @@ parseValueAtom = P.choice
391391 , parseLet
392392 , P.try $ Parens <$> parens parseValue
393393 , parseOperatorSection
394− -- TODO: combine this with parseObjectGetter
395− , parseObjectUpdaterWildcard
396394 ]
397395
398396-- |
@@ -408,11 +406,11 @@ parseOperatorSection = parens $ left <|> right
408406 right = OperatorSection <$> parseInfixExpr <* indented <*> (Right <$> indexersAndAccessors)
409407 left = flip OperatorSection <$> (Left <$> indexersAndAccessors) <* indented <*> parseInfixExpr
410408
411−parsePropertyUpdate :: TokenParser (String, Maybe Expr)
409+parsePropertyUpdate :: TokenParser (String, Expr)
412410parsePropertyUpdate = do
413411 name <- lname <|> stringLiteral
414412 _ <- C.indented *> equals
415− value <- C.indented *> (underscore *> pure Nothing) <|> (Just <$> parseValue)
413+ value <- C.indented *> parseValue
416414 return (name, value)
417415
418416parseAccessor :: Expr -> TokenParser Expr
@@ -438,15 +436,12 @@ parseDoNotationElement = P.choice
438436 , DoNotationValue <$> parseValue
439437 ]
440438
441−parseObjectGetter :: TokenParser Expr
442−parseObjectGetter = ObjectGetter <$> (underscore *> C.indented *> dot *> C.indented *> (lname <|> stringLiteral))
443−
444439-- | Expressions including indexers and record updates
445440indexersAndAccessors :: TokenParser Expr
446441indexersAndAccessors = C.buildPostfixParser postfixTable parseValueAtom
447442 where
448443 postfixTable = [ parseAccessor
449− , P.try . parseUpdaterBody . Just
444+ , P.try . parseUpdaterBody
450445 ]
451446
452447-- |
@@ -468,23 +463,14 @@ parseValue = withSourceSpan PositionedValue
468463 ]
469464 ]
470465
471−parseUpdaterBody :: Maybe Expr -> TokenParser Expr
472−parseUpdaterBody v = ObjectUpdater v <$> (C.indented *> braces (commaSep1 (C.indented *> parsePropertyUpdate)))
473−
474−parseObjectUpdaterWildcard :: TokenParser Expr
475−parseObjectUpdaterWildcard = underscore *> C.indented *> parseUpdaterBody Nothing
466+parseUpdaterBody :: Expr -> TokenParser Expr
467+parseUpdaterBody v = ObjectUpdate v <$> (C.indented *> braces (commaSep1 (C.indented *> parsePropertyUpdate)))
476468
477−parseStringBinder :: TokenParser Binder
478−parseStringBinder = StringBinder <$> stringLiteral
469+parseAnonymousArgument :: TokenParser Expr
470+parseAnonymousArgument = underscore *> pure AnonymousArgument
479471
480−parseCharBinder :: TokenParser Binder
481−parseCharBinder = CharBinder <$> charLiteral
482−
483−parseBooleanBinder :: TokenParser Binder
484−parseBooleanBinder = BooleanBinder <$> booleanLiteral
485−
486−parseNumberBinder :: TokenParser Binder
487−parseNumberBinder = NumberBinder <$> (sign <*> number)
472+parseNumberLiteral :: TokenParser Binder
473+parseNumberLiteral = LiteralBinder . NumericLiteral <$> (sign <*> number)
488474 where
489475 sign :: TokenParser (Either Integer Double -> Either Integer Double)
490476 sign = (symbol' "-" >> return (negate +++ negate))
@@ -497,11 +483,11 @@ parseNullaryConstructorBinder = ConstructorBinder <$> C.parseQualified C.properN
497483parseConstructorBinder :: TokenParser Binder
498484parseConstructorBinder = ConstructorBinder <$> C.parseQualified C.properName <*> many (C.indented *> parseBinderNoParens)
499485
500−parseObjectBinder :: TokenParser Binder
501−parseObjectBinder = ObjectBinder <$> braces (commaSep (C.indented *> parseIdentifierAndBinder))
486+parseObjectBinder:: TokenParser Binder
487+parseObjectBinder= LiteralBinder <$> parseObjectLiteral (C.indented *> parseIdentifierAndBinder)
502488
503489parseArrayBinder :: TokenParser Binder
504−parseArrayBinder = squares $ ArrayBinder <$> commaSep (C.indented *> parseBinder)
490+parseArrayBinder = LiteralBinder <$> parseArrayLiteral (C.indented *> parseBinder)
505491
506492parseVarOrNamedBinder :: TokenParser Binder
507493parseVarOrNamedBinder = do
@@ -527,40 +513,54 @@ parseIdentifierAndBinder =
527513-- Parse a binder
528514--
529515parseBinder :: TokenParser Binder
530−parseBinder = withSourceSpan PositionedBinder (buildPostfixParser postfixTable parseBinderAtom)
516+parseBinder =
517+ withSourceSpan
518+ PositionedBinder
519+ ( P.buildExpressionParser operators
520+ . buildPostfixParser postfixTable
521+ $ parseBinderAtom
522+ )
531523 where
524+ operators =
525+ [ [ P.Infix (P.try (C.indented *> parseOpBinder P.<?> "binder operator") >>= \op ->
526+ return (BinaryNoParensBinder op)) P.AssocRight
527+ ]
528+ ]
532529 -- TODO: parsePolyType when adding support for polymorphic types
533530 postfixTable = [ \b -> flip TypedBinder b <$> (indented *> doubleColon *> parseType)
534531 ]
535532 parseBinderAtom :: TokenParser Binder
536533 parseBinderAtom = P.choice
537534 [ parseNullBinder
538− , parseCharBinder
539− , parseStringBinder
540− , parseBooleanBinder
541− , parseNumberBinder
535+ , LiteralBinder <$> parseCharLiteral
536+ , LiteralBinder <$> parseStringLiteral
537+ , LiteralBinder <$> parseBooleanLiteral
538+ , parseNumberLiteral
542539 , parseVarOrNamedBinder
543540 , parseConstructorBinder
544541 , parseObjectBinder
545542 , parseArrayBinder
546− , parens parseBinder
543+ , ParensInBinder <$> parens parseBinder
547544 ] P.<?> "binder"
548545
546+ parseOpBinder :: TokenParser Binder
547+ parseOpBinder = OpBinder <$> parseQualified (Op <$> symbol)
548+
549549-- |
550550-- Parse a binder as it would appear in a top level declaration
551551--
552552parseBinderNoParens :: TokenParser Binder
553553parseBinderNoParens = P.choice
554554 [ parseNullBinder
555− , parseCharBinder
556− , parseStringBinder
557− , parseBooleanBinder
558− , parseNumberBinder
555+ , LiteralBinder <$> parseCharLiteral
556+ , LiteralBinder <$> parseStringLiteral
557+ , LiteralBinder <$> parseBooleanLiteral
558+ , parseNumberLiteral
559559 , parseVarOrNamedBinder
560560 , parseNullaryConstructorBinder
561561 , parseObjectBinder
562562 , parseArrayBinder
563− , parens parseBinder
563+ , ParensInBinder <$> parens parseBinder
564564 ] P.<?> "binder"
565565
566566-- |
src/Language/PureScript/Parser/JS.hs+1−1
@@ -36,7 +36,7 @@ import qualified Text.Parsec as PS
3636
3737type ForeignJS = String
3838
39−parseForeignModulesFromFiles :: (Functor m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
39+parseForeignModulesFromFiles :: (MonadError MultipleErrors m, MonadWriter MultipleErrors m)
4040 => [(FilePath, ForeignJS)]
4141 -> m (M.Map ModuleName FilePath)
4242parseForeignModulesFromFiles files = do
src/Language/PureScript/Parser/Lexer.hs+6
@@ -185,10 +185,15 @@ parsePositionedToken = P.try $ do
185185parseToken :: P.Parsec String u Token
186186parseToken = P.choice
187187 [ P.try $ P.string "<-" *> P.notFollowedBy symbolChar *> pure LArrow
188+ , P.try $ P.string "←" *> P.notFollowedBy symbolChar *> pure LArrow
188189 , P.try $ P.string "<=" *> P.notFollowedBy symbolChar *> pure LFatArrow
190+ , P.try $ P.string "⇐" *> P.notFollowedBy symbolChar *> pure LFatArrow
189191 , P.try $ P.string "->" *> P.notFollowedBy symbolChar *> pure RArrow
192+ , P.try $ P.string "→" *> P.notFollowedBy symbolChar *> pure RArrow
190193 , P.try $ P.string "=>" *> P.notFollowedBy symbolChar *> pure RFatArrow
194+ , P.try $ P.string "⇒" *> P.notFollowedBy symbolChar *> pure RFatArrow
191195 , P.try $ P.string "::" *> P.notFollowedBy symbolChar *> pure DoubleColon
196+ , P.try $ P.string "∷" *> P.notFollowedBy symbolChar *> pure DoubleColon
192197 , P.try $ P.char '(' *> pure LParen
193198 , P.try $ P.char ')' *> pure RParen
194199 , P.try $ P.char '{' *> pure LBrace
@@ -411,6 +416,7 @@ reserved :: String -> TokenParser ()
411416reserved s = token go P.<?> show s
412417 where
413418 go (LName s') | s == s' = Just ()
419+ go (Symbol s') | s == s' = Just ()
414420 go _ = Nothing
415421
416422uname :: TokenParser String
src/Language/PureScript/Parser/Types.hs+1−1
@@ -36,7 +36,7 @@ parseTypeConstructor :: TokenParser Type
3636parseTypeConstructor = TypeConstructor <$> parseQualified properName
3737
3838parseForAll :: TokenParser Type
39−parseForAll = mkForAll <$> (reserved "forall" *> P.many1 (indented *> identifier) <* indented <* dot)
39+parseForAll = mkForAll <$> ((reserved "forall" <|> reserved "∀") *> P.many1 (indented *> identifier) <* indented <* dot)
4040 <*> parseType
4141
4242-- |
src/Language/PureScript/Pretty.hs−3
@@ -27,6 +27,3 @@ import Language.PureScript.Pretty.Kinds as P
2727import Language.PureScript.Pretty.Values as P
2828import Language.PureScript.Pretty.Types as P
2929import Language.PureScript.Pretty.JS as P
30−
31−
32−
src/Language/PureScript/Pretty/Common.hs+96−9
@@ -13,12 +13,18 @@
1313--
1414-----------------------------------------------------------------------------
1515
16+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
17+
1618module Language.PureScript.Pretty.Common where
1719
18−import Control.Monad.State
19−import Data.List (intercalate)
20+import Prelude ()
21+import Prelude.Compat
22+
23+import Control.Monad.State (StateT, modify, get)
24+import Data.List (elemIndices, intersperse)
2025
2126import Language.PureScript.Parser.Lexer (reservedPsNames, isSymbolChar)
27+import Language.PureScript.AST (SourcePos(..), SourceSpan(..))
2228
2329import Text.PrettyPrint.Boxes
2430
@@ -26,9 +32,90 @@ import Text.PrettyPrint.Boxes
2632-- Wrap a string in parentheses
2733--
2834parens :: String -> String
29−parens s = ('(':s) ++ ")"
35+parens s = '(':s ++ ")"
36+
37+parensPos :: (Emit gen) => gen -> gen
38+parensPos s = emit "(" `mappend` s `mappend` emit ")"
39+
40+-- |
41+-- Generalize intercalate slightly for monoids
42+--
43+intercalate :: Monoid m => m -> [m] -> m
44+intercalate x xs = mconcat (intersperse x xs)
45+
46+class (Monoid gen) => Emit gen where
47+ emit :: String -> gen
48+ addMapping :: SourceSpan -> gen
49+
50+data SMap = SMap String SourcePos SourcePos
51+
52+-- |
53+-- String with length and source-map entries
54+--
55+newtype StrPos = StrPos (SourcePos, String, [SMap])
56+
57+-- |
58+-- Make a monoid where append consists of concatenating the string part, adding the lengths
59+-- appropriately and advancing source mappings on the right hand side to account for
60+-- the length of the left.
61+--
62+instance Monoid StrPos where
63+ mempty = StrPos (SourcePos 0 0, "", [])
64+
65+ StrPos (a,b,c) `mappend` StrPos (a',b',c') = StrPos (a `addPos` a', b ++ b', c ++ (bumpPos a <$> c'))
66+
67+ mconcat ms =
68+ let s' = concatMap (\(StrPos(_, s, _)) -> s) ms
69+ (p, maps) = foldl plus (SourcePos 0 0, []) ms
70+ in
71+ StrPos (p, s', concat $ reverse maps)
72+ where
73+ plus :: (SourcePos, [[SMap]]) -> StrPos -> (SourcePos, [[SMap]])
74+ plus (a, c) (StrPos (a', _, c')) = (a `addPos` a', (bumpPos a <$> c') : c)
75+
76+instance Emit StrPos where
77+ -- |
78+ -- Augment a string with its length (rows/column)
79+ --
80+ emit str =
81+ let newlines = elemIndices '\n' str
82+ index = if null newlines then 0 else last newlines + 1
83+ in
84+ StrPos (SourcePos { sourcePosLine = length newlines, sourcePosColumn = length str - index }, str, [])
85+
86+ -- |
87+ -- Add a new mapping entry for given source position with initially zero generated position
88+ --
89+ addMapping (SourceSpan { spanName = file, spanStart = startPos }) = StrPos (zeroPos, mempty, [mapping])
90+ where
91+ mapping = SMap file startPos zeroPos
92+ zeroPos = SourcePos 0 0
93+
94+newtype PlainString = PlainString String deriving Monoid
95+
96+runPlainString :: PlainString -> String
97+runPlainString (PlainString s) = s
98+
99+instance Emit PlainString where
100+ emit = PlainString
101+ addMapping _ = mempty
102+
103+addMapping' :: (Emit gen) => Maybe SourceSpan -> gen
104+addMapping' (Just ss) = addMapping ss
105+addMapping' Nothing = mempty
106+
107+bumpPos :: SourcePos -> SMap -> SMap
108+bumpPos p (SMap f s g) = SMap f s $ p `addPos` g
109+
110+addPos :: SourcePos -> SourcePos -> SourcePos
111+addPos (SourcePos n m) (SourcePos 0 m') = SourcePos n (m+m')
112+addPos (SourcePos n _) (SourcePos n' m') = SourcePos (n+n') m'
113+
114+
115+data PrinterState = PrinterState { indent :: Int }
30116
31−newtype PrinterState = PrinterState { indent :: Int } deriving (Show, Read, Eq, Ord)
117+emptyPrinterState :: PrinterState
118+emptyPrinterState = PrinterState { indent = 0 }
32119
33120-- |
34121-- Number of characters per identation level
@@ -39,7 +126,7 @@ blockIndent = 4
39126-- |
40127-- Pretty print with a new indentation level
41128--
42−withIndent :: StateT PrinterState Maybe String -> StateT PrinterState Maybe String
129+withIndent :: (Emit gen) => StateT PrinterState Maybe gen -> StateT PrinterState Maybe gen
43130withIndent action = do
44131 modify $ \st -> st { indent = indent st + blockIndent }
45132 result <- action
@@ -49,19 +136,19 @@ withIndent action = do
49136-- |
50137-- Get the current indentation level
51138--
52−currentIndent :: StateT PrinterState Maybe String
139+currentIndent :: (Emit gen) => StateT PrinterState Maybe gen
53140currentIndent = do
54141 current <- get
55− return $ replicate (indent current) ' '
142+ return $ emit $ replicate (indent current) ' '
56143
57144-- |
58145-- Print many lines
59146--
60−prettyPrintMany :: (a -> StateT PrinterState Maybe String) -> [a] -> StateT PrinterState Maybe String
147+prettyPrintMany :: (Emit gen) => (a -> StateT PrinterState Maybe gen) -> [a] -> StateT PrinterState Maybe gen
61148prettyPrintMany f xs = do
62149 ss <- mapM f xs
63150 indentString <- currentIndent
64− return $ intercalate "\n" $ map (indentString ++) ss
151+ return $ intercalate (emit "\n") $ map (\s -> mappend indentString s) ss
65152
66153-- |
67154-- Prints an object key, escaping reserved names.
src/Language/PureScript/Pretty/JS.hs+118−105
@@ -14,13 +14,12 @@
1414-----------------------------------------------------------------------------
1515
1616module Language.PureScript.Pretty.JS (
17− prettyPrintJS
17+ prettyPrintJS, prettyPrintJSWithSourceMaps
1818) where
1919
2020import Prelude ()
2121import Prelude.Compat
2222
23−import Data.List hiding (concat, concatMap)
2423import Data.Maybe (fromMaybe)
2524
2625import Control.Arrow ((<+>))
@@ -34,103 +33,110 @@ import Language.PureScript.CodeGen.JS.Common
3433import Language.PureScript.Pretty.Common
3534import Language.PureScript.Comments
3635
36+
37+import Language.PureScript.AST (SourceSpan(..))
38+
3739import Numeric
3840
39−literals :: Pattern PrinterState JS String
40−literals = mkPattern' match
41+import Data.Monoid
42+
43+literals :: (Emit gen) => Pattern PrinterState JS gen
44+literals = mkPattern' match'
4145 where
42− match :: JS -> StateT PrinterState Maybe String
43− match (JSNumericLiteral n) = return $ either show show n
44− match (JSStringLiteral s) = return $ string s
45− match (JSBooleanLiteral True) = return "true"
46− match (JSBooleanLiteral False) = return "false"
47− match (JSArrayLiteral xs) = concat <$> sequence
48− [ return "[ "
49− , intercalate ", " <$> forM xs prettyPrintJS'
50− , return " ]"
46+ match' :: (Emit gen) => JS -> StateT PrinterState Maybe gen
47+ match' js = (addMapping' (getSourceSpan js) <>) <$> match js
48+
49+ match :: (Emit gen) => JS -> StateT PrinterState Maybe gen
50+ match (JSNumericLiteral _ n) = return $ emit $ either show show n
51+ match (JSStringLiteral _ s) = return $ string s
52+ match (JSBooleanLiteral _ True) = return $ emit "true"
53+ match (JSBooleanLiteral _ False) = return $ emit "false"
54+ match (JSArrayLiteral _ xs) = mconcat <$> sequence
55+ [ return $ emit "[ "
56+ , intercalate (emit ", ") <$> forM xs prettyPrintJS'
57+ , return $ emit " ]"
5158 ]
52− match (JSObjectLiteral []) = return "{}"
53− match (JSObjectLiteral ps) = concat <$> sequence
54− [ return "{\n"
59+ match (JSObjectLiteral _ []) = return $ emit "{}"
60+ match (JSObjectLiteral _ ps) = mconcat <$> sequence
61+ [ return $ emit "{\n"
5562 , withIndent $ do
56− jss <- forM ps $ \(key, value) -> fmap ((objectPropertyToString key ++ ": ") ++) . prettyPrintJS' $ value
63+ jss <- forM ps $ \(key, value) -> fmap ((objectPropertyToString key <> emit ": ") <>) . prettyPrintJS' $ value
5764 indentString <- currentIndent
58− return $ intercalate ", \n" $ map (indentString ++) jss
59− , return "\n"
65+ return $ intercalate (emit ", \n") $ map (indentString <>) jss
66+ , return $ emit "\n"
6067 , currentIndent
61− , return "}"
68+ , return $ emit "}"
6269 ]
6370 where
64− objectPropertyToString :: String -> String
65− objectPropertyToString s | identNeedsEscaping s = show s
66− | otherwise = s
67− match (JSBlock sts) = concat <$> sequence
68− [ return "{\n"
71+ objectPropertyToString :: (Emit gen) => String -> gen
72+ objectPropertyToString s | identNeedsEscaping s = emit $ show s
73+ | otherwise = emit s
74+ match (JSBlock _ sts) = mconcat <$> sequence
75+ [ return $ emit "{\n"
6976 , withIndent $ prettyStatements sts
70− , return "\n"
77+ , return $ emit "\n"
7178 , currentIndent
72− , return "}"
79+ , return $ emit "}"
7380 ]
74− match (JSVar ident) = return ident
75− match (JSVariableIntroduction ident value) = concat <$> sequence
76− [ return "var "
77− , return ident
78− , maybe (return "") (fmap (" = " ++) . prettyPrintJS') value
81+ match (JSVar _ ident) = return $ emit ident
82+ match (JSVariableIntroduction _ ident value) = mconcat <$> sequence
83+ [ return $ emit $ "var " ++ ident
84+ , maybe (return mempty) (fmap (emit " = " <>) . prettyPrintJS') value
7985 ]
80− match (JSAssignment target value) = concat <$> sequence
86+ match (JSAssignment _ target value) = mconcat <$> sequence
8187 [ prettyPrintJS' target
82− , return " = "
88+ , return $ emit " = "
8389 , prettyPrintJS' value
8490 ]
85− match (JSWhile cond sts) = concat <$> sequence
86− [ return "while ("
91+ match (JSWhile _ cond sts) = mconcat <$> sequence
92+ [ return $ emit "while ("
8793 , prettyPrintJS' cond
88− , return ") "
94+ , return $ emit ") "
8995 , prettyPrintJS' sts
9096 ]
91− match (JSFor ident start end sts) = concat <$> sequence
92− [ return $ "for (var " ++ ident ++ " = "
97+ match (JSFor _ ident start end sts) = mconcat <$> sequence
98+ [ return $ emit $ "for (var " ++ ident ++ " = "
9399 , prettyPrintJS' start
94− , return $ "; " ++ ident ++ " < "
100+ , return $ emit $ "; " ++ ident ++ " < "
95101 , prettyPrintJS' end
96− , return $ "; " ++ ident ++ "++) "
102+ , return $ emit $ "; " ++ ident ++ "++) "
97103 , prettyPrintJS' sts
98104 ]
99− match (JSForIn ident obj sts) = concat <$> sequence
100− [ return $ "for (var " ++ ident ++ " in "
105+ match (JSForIn _ ident obj sts) = mconcat <$> sequence
106+ [ return $ emit $ "for (var " ++ ident ++ " in "
101107 , prettyPrintJS' obj
102− , return ") "
108+ , return $ emit ") "
103109 , prettyPrintJS' sts
104110 ]
105− match (JSIfElse cond thens elses) = concat <$> sequence
106− [ return "if ("
111+ match (JSIfElse _ cond thens elses) = mconcat <$> sequence
112+ [ return $ emit "if ("
107113 , prettyPrintJS' cond
108− , return ") "
114+ , return $ emit ") "
109115 , prettyPrintJS' thens
110− , maybe (return "") (fmap (" else " ++) . prettyPrintJS') elses
116+ , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintJS') elses
111117 ]
112− match (JSReturn value) = concat <$> sequence
113− [ return "return "
118+ match (JSReturn _ value) = mconcat <$> sequence
119+ [ return $ emit "return "
114120 , prettyPrintJS' value
115121 ]
116− match (JSThrow value) = concat <$> sequence
117− [ return "throw "
122+ match (JSThrow _ value) = mconcat <$> sequence
123+ [ return $ emit "throw "
118124 , prettyPrintJS' value
119125 ]
120− match (JSBreak lbl) = return $ "break " ++ lbl
121− match (JSContinue lbl) = return $ "continue " ++ lbl
122− match (JSLabel lbl js) = concat <$> sequence
123− [ return $ lbl ++ ": "
126+ match (JSBreak _ lbl) = return $ emit $ "break " ++ lbl
127+ match (JSContinue _ lbl) = return $ emit $ "continue " ++ lbl
128+ match (JSLabel _ lbl js) = mconcat <$> sequence
129+ [ return $ emit $ lbl ++ ": "
124130 , prettyPrintJS' js
125131 ]
126− match (JSComment com js) = fmap concat $ sequence $
127− [ return "\n"
132+ match (JSComment _ com js) = fmap mconcat $ sequence $
133+ [ return $ emit "\n"
128134 , currentIndent
129− , return "/**\n"
135+ , return $ emit "/**\n"
130136 ] ++
131137 map asLine (concatMap commentLines com) ++
132138 [ currentIndent
133− , return " */\n"
139+ , return $ emit " */\n"
134140 , currentIndent
135141 , prettyPrintJS' js
136142 ]
@@ -139,21 +145,21 @@ literals = mkPattern' match
139145 commentLines (LineComment s) = [s]
140146 commentLines (BlockComment s) = lines s
141147
142− asLine :: String -> StateT PrinterState Maybe String
148+ asLine :: (Emit gen) => String -> StateT PrinterState Maybe gen
143149 asLine s = do
144150 i <- currentIndent
145− return $ i ++ " * " ++ removeComments s ++ "\n"
151+ return $ i <> emit " * " <> (emit . removeComments) s <> emit "\n"
146152
147153 removeComments :: String -> String
148154 removeComments ('*' : '/' : s) = removeComments s
149155 removeComments (c : s) = c : removeComments s
150156
151157 removeComments [] = []
152− match (JSRaw js) = return js
158+ match (JSRaw _ js) = return $ emit js
153159 match _ = mzero
154160
155−string :: String -> String
156−string s = '"' : concatMap encodeChar s ++ "\""
161+string :: (Emit gen) => String -> gen
162+string s = emit $ '"' : concatMap encodeChar s ++ "\""
157163 where
158164 encodeChar :: Char -> String
159165 encodeChar '\b' = "\\b"
@@ -175,114 +181,121 @@ string s = '"' : concatMap encodeChar s ++ "\""
175181 encodeChar c | fromEnum c > 0x7E || fromEnum c < 0x20 = "\\x" ++ showHex (fromEnum c) ""
176182 encodeChar c = [c]
177183
178−conditional :: Pattern PrinterState JS ((JS, JS), JS)
184+conditional :: Pattern PrinterState JS ((Maybe SourceSpan, JS, JS), JS)
179185conditional = mkPattern match
180186 where
181− match (JSConditional cond th el) = Just ((th, el), cond)
187+ match (JSConditional ss cond th el) = Just ((ss, th, el), cond)
182188 match _ = Nothing
183189
184−accessor :: Pattern PrinterState JS (String, JS)
190+accessor :: (Emit gen) => Pattern PrinterState JS (gen, JS)
185191accessor = mkPattern match
186192 where
187− match (JSAccessor prop val) = Just (prop, val)
193+ match (JSAccessor _ prop val) = Just (emit prop, val)
188194 match _ = Nothing
189195
190−indexer :: Pattern PrinterState JS (String, JS)
196+indexer :: (Emit gen) => Pattern PrinterState JS (gen, JS)
191197indexer = mkPattern' match
192198 where
193− match (JSIndexer index val) = (,) <$> prettyPrintJS' index <*> pure val
199+ match (JSIndexer _ index val) = (,) <$> prettyPrintJS' index <*> pure val
200+
194201 match _ = mzero
195202
196−lam :: Pattern PrinterState JS ((Maybe String, [String]), JS)
203+lam :: Pattern PrinterState JS ((Maybe String, [String], Maybe SourceSpan), JS)
197204lam = mkPattern match
198205 where
199− match (JSFunction name args ret) = Just ((name, args), ret)
206+ match (JSFunction ss name args ret) = Just ((name, args, ss), ret)
200207 match _ = Nothing
201208
202−app :: Pattern PrinterState JS (String, JS)
209+app :: (Emit gen) => Pattern PrinterState JS (gen, JS)
203210app = mkPattern' match
204211 where
205− match (JSApp val args) = do
212+ match (JSApp _ val args) = do
206213 jss <- traverse prettyPrintJS' args
207− return (intercalate ", " jss, val)
214+ return (intercalate (emit ", ") jss, val)
208215 match _ = mzero
209216
210217typeOf :: Pattern PrinterState JS ((), JS)
211218typeOf = mkPattern match
212219 where
213− match (JSTypeOf val) = Just ((), val)
220+ match (JSTypeOf _ val) = Just ((), val)
214221 match _ = Nothing
215222
216223instanceOf :: Pattern PrinterState JS (JS, JS)
217224instanceOf = mkPattern match
218225 where
219− match (JSInstanceOf val ty) = Just (val, ty)
226+ match (JSInstanceOf _ val ty) = Just (val, ty)
220227 match _ = Nothing
221228
222−unary' :: UnaryOperator -> (JS -> String) -> Operator PrinterState JS String
223−unary' op mkStr = Wrap match (++)
229+unary' :: (Emit gen) => UnaryOperator -> (JS -> String) -> Operator PrinterState JS gen
230+unary' op mkStr = Wrap match (<>)
224231 where
225− match :: Pattern PrinterState JS (String, JS)
232+ match :: (Emit gen) => Pattern PrinterState JS (gen, JS)
226233 match = mkPattern match'
227234 where
228− match' (JSUnary op' val) | op' == op = Just (mkStr val, val)
235+ match' (JSUnary _ op' val) | op' == op = Just (emit $ mkStr val, val)
229236 match' _ = Nothing
230237
231−unary :: UnaryOperator -> String -> Operator PrinterState JS String
238+unary :: (Emit gen) => UnaryOperator -> String -> Operator PrinterState JS gen
232239unary op str = unary' op (const str)
233240
234−negateOperator :: Operator PrinterState JS String
241+negateOperator :: (Emit gen) => Operator PrinterState JS gen
235242negateOperator = unary' Negate (\v -> if isNegate v then "- " else "-")
236243 where
237− isNegate (JSUnary Negate _) = True
244+ isNegate (JSUnary _ Negate _) = True
238245 isNegate _ = False
239246
240−binary :: BinaryOperator -> String -> Operator PrinterState JS String
241−binary op str = AssocL match (\v1 v2 -> v1 ++ " " ++ str ++ " " ++ v2)
247+binary :: (Emit gen) => BinaryOperator -> String -> Operator PrinterState JS gen
248+binary op str = AssocL match (\v1 v2 -> v1 <> emit (" " ++ str ++ " ") <> v2)
242249 where
243250 match :: Pattern PrinterState JS (JS, JS)
244251 match = mkPattern match'
245252 where
246− match' (JSBinary op' v1 v2) | op' == op = Just (v1, v2)
253+ match' (JSBinary _ op' v1 v2) | op' == op = Just (v1, v2)
247254 match' _ = Nothing
248255
249−prettyStatements :: [JS] -> StateT PrinterState Maybe String
256+prettyStatements :: (Emit gen) => [JS] -> StateT PrinterState Maybe gen
250257prettyStatements sts = do
251258 jss <- forM sts prettyPrintJS'
252259 indentString <- currentIndent
253− return $ intercalate "\n" $ map ((++ ";") . (indentString ++)) jss
260+ return $ intercalate (emit "\n") $ map ((<> emit ";") . (indentString <>)) jss
254261
255262-- |
256263-- Generate a pretty-printed string representing a Javascript expression
257264--
258−prettyPrintJS1 :: JS -> String
265+prettyPrintJS1 :: (Emit gen) => JS -> gen
259266prettyPrintJS1 = fromMaybe (internalError "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyPrintJS'
260267
261268-- |
262269-- Generate a pretty-printed string representing a collection of Javascript expressions at the same indentation level
263270--
271+prettyPrintJSWithSourceMaps :: [JS] -> (String, [SMap])
272+prettyPrintJSWithSourceMaps js =
273+ let StrPos (_, s, mp) = (fromMaybe (internalError "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyStatements) js
274+ in (s, mp)
275+
264276prettyPrintJS :: [JS] -> String
265−prettyPrintJS = fromMaybe (internalError "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyStatements
277+prettyPrintJS = fromMaybe (internalError "Incomplete pattern") . fmap runPlainString . flip evalStateT (PrinterState 0) . prettyStatements
266278
267279-- |
268280-- Generate an indented, pretty-printed string representing a Javascript expression
269281--
270−prettyPrintJS' :: JS -> StateT PrinterState Maybe String
282+prettyPrintJS' :: (Emit gen) => JS -> StateT PrinterState Maybe gen
271283prettyPrintJS' = A.runKleisli $ runPattern matchValue
272284 where
273− matchValue :: Pattern PrinterState JS String
274− matchValue = buildPrettyPrinter operators (literals <+> fmap parens matchValue)
275− operators :: OperatorTable PrinterState JS String
285+ matchValue :: (Emit gen) => Pattern PrinterState JS gen
286+ matchValue = buildPrettyPrinter operators (literals <+> fmap parensPos matchValue)
287+ operators :: (Emit gen) => OperatorTable PrinterState JS gen
276288 operators =
277− OperatorTable [ [ Wrap accessor $ \prop val -> val ++ "." ++ prop ]
278− , [ Wrap indexer $ \index val -> val ++ "[" ++ index ++ "]" ]
279− , [ Wrap app $ \args val -> val ++ "(" ++ args ++ ")" ]
289+ OperatorTable [ [ Wrap accessor $ \prop val -> val <> emit "." <> prop ]
290+ , [ Wrap indexer $ \index val -> val <> emit "[" <> index <> emit "]" ]
291+ , [ Wrap app $ \args val -> val <> emit "(" <> args <> emit ")" ]
280292 , [ unary JSNew "new " ]
281− , [ Wrap lam $ \(name, args) ret -> "function "
293+ , [ Wrap lam $ \(name, args, ss) ret -> addMapping' ss <>
294+ emit ("function "
282295 ++ fromMaybe "" name
283− ++ "(" ++ intercalate ", " args ++ ") "
284− ++ ret ]
285− , [ Wrap typeOf $ \_ s -> "typeof " ++ s ]
296+ ++ "(" ++ intercalate ", " args ++ ") ")
297+ <> ret ]
298+ , [ Wrap typeOf $ \_ s -> emit "typeof " <> s ]
286299 , [ unary Not "!"
287300 , unary BitwiseNot "~"
288301 , unary Positive "+"
@@ -299,7 +312,7 @@ prettyPrintJS' = A.runKleisli $ runPattern matchValue
299312 , binary LessThanOrEqualTo "<="
300313 , binary GreaterThan ">"
301314 , binary GreaterThanOrEqualTo ">="
302− , AssocR instanceOf $ \v1 v2 -> v1 ++ " instanceof " ++ v2 ]
315+ , AssocR instanceOf $ \v1 v2 -> v1 <> emit " instanceof " <> v2 ]
303316 , [ binary EqualTo "==="
304317 , binary NotEqualTo "!==" ]
305318 , [ binary BitwiseAnd "&" ]
@@ -307,5 +320,5 @@ prettyPrintJS' = A.runKleisli $ runPattern matchValue
307320 , [ binary BitwiseOr "|" ]
308321 , [ binary And "&&" ]
309322 , [ binary Or "||" ]
310− , [ Wrap conditional $ \(th, el) cond -> cond ++ " ? " ++ prettyPrintJS1 th ++ " : " ++ prettyPrintJS1 el ]
323+ , [ Wrap conditional $ \(ss, th, el) cond -> cond <> addMapping' ss <> emit " ? " <> prettyPrintJS1 th <> addMapping' ss <> emit " : " <> prettyPrintJS1 el ]
311324 ]
src/Language/PureScript/Pretty/Types.hs+10−22
@@ -1,26 +1,14 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.Pretty.Types
4−-- Copyright : (c) Phil Freeman 2013
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
111-- |
122-- Pretty printer for Types
133--
14−-----------------------------------------------------------------------------
15−
16−module Language.PureScript.Pretty.Types (
17− typeAsBox,
18− prettyPrintType,
19− typeAtomAsBox,
20− prettyPrintTypeAtom,
21− prettyPrintRowWith,
22− prettyPrintRow
23−) where
4+module Language.PureScript.Pretty.Types
5+ ( typeAsBox
6+ , prettyPrintType
7+ , typeAtomAsBox
8+ , prettyPrintTypeAtom
9+ , prettyPrintRowWith
10+ , prettyPrintRow
11+ ) where
2412
2513import Data.Maybe (fromMaybe)
2614
@@ -50,11 +38,11 @@ typeLiterals = mkPattern match
5038 match row@RCons{} = Just $ prettyPrintRowWith '(' ')' row
5139 match _ = Nothing
5240
53−constraintsAsBox :: [(Qualified ProperName, [Type])] -> Box -> Box
41+constraintsAsBox :: [Constraint] -> Box -> Box
5442constraintsAsBox [(pn, tys)] ty = text "(" <> constraintAsBox pn tys <> text ") => " <> ty
5543constraintsAsBox xs ty = vcat left (zipWith (\i (pn, tys) -> text (if i == 0 then "( " else ", ") <> constraintAsBox pn tys) [0 :: Int ..] xs) `before` (text ") => " <> ty)
5644
57−constraintAsBox :: Qualified ProperName -> [Type] -> Box
45+constraintAsBox :: Qualified (ProperName a) -> [Type] -> Box
5846constraintAsBox pn tys = hsep 1 left (text (runProperName (disqualify pn)) : map typeAtomAsBox tys)
5947
6048-- |
src/Language/PureScript/Pretty/Values.hs+49−36
@@ -1,26 +1,12 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.Pretty.Values
4−-- Copyright : (c) Phil Freeman 2013
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
111-- |
122-- Pretty printer for values
133--
14−-----------------------------------------------------------------------------
15−
164module Language.PureScript.Pretty.Values (
175 prettyPrintValue,
186 prettyPrintBinder,
197 prettyPrintBinderAtom
208) where
219
22−import Data.List (intercalate)
23−
2410import Control.Arrow (second)
2511
2612import Language.PureScript.Crash
@@ -57,9 +43,9 @@ prettyPrintValue d (IfThenElse cond th el) =
5743 ])
5844prettyPrintValue d (Accessor prop val) = prettyPrintValueAtom (d - 1) val <> text ("." ++ show prop)
5945prettyPrintValue d (ObjectUpdate o ps) = prettyPrintValueAtom (d - 1) o <> text " " <> list '{' '}' (\(key, val) -> text (key ++ " = ") <> prettyPrintValue (d - 1) val) ps
60−prettyPrintValue d (ObjectUpdater o ps) = maybe (text "_") (prettyPrintValueAtom (d - 1)) o <> text " " <> list '{' '}' (\(key, val) -> text (key ++ " = ") <> maybe (text "_") (prettyPrintValue (d - 1)) val) ps
6146prettyPrintValue d (App val arg) = prettyPrintValueAtom (d - 1) val `beforeWithSpace` prettyPrintValueAtom (d - 1) arg
6247prettyPrintValue d (Abs (Left arg) val) = text ('\\' : showIdent arg ++ " -> ") // moveRight 2 (prettyPrintValue (d - 1) val)
48+prettyPrintValue d (Abs (Right arg) val) = text ('\\' : prettyPrintBinder arg ++ " -> ") // moveRight 2 (prettyPrintValue (d - 1) val)
6349prettyPrintValue d (TypeClassDictionaryConstructorApp className ps) =
6450 text (runProperName (disqualify className) ++ " ") <> prettyPrintValueAtom (d - 1) ps
6551prettyPrintValue d (Case values binders) =
@@ -73,29 +59,49 @@ prettyPrintValue d (Do els) =
7359 text "do " <> vcat left (map (prettyPrintDoNotationElement (d - 1)) els)
7460prettyPrintValue _ (TypeClassDictionary (name, tys) _) = foldl1 beforeWithSpace $ text ("#dict " ++ runProperName (disqualify name)) : map typeAtomAsBox tys
7561prettyPrintValue _ (SuperClassDictionary name _) = text $ "#dict " ++ runProperName (disqualify name)
62+prettyPrintValue _ (TypeClassDictionaryAccessor className ident) =
63+ text "#dict-accessor " <> text (runProperName (disqualify className)) <> text "." <> text (showIdent ident) <> text ">"
7664prettyPrintValue d (TypedValue _ val _) = prettyPrintValue d val
7765prettyPrintValue d (PositionedValue _ _ val) = prettyPrintValue d val
78−prettyPrintValue d expr = prettyPrintValueAtom d expr
66+prettyPrintValue d (Literal l) = prettyPrintLiteralValue d l
67+prettyPrintValue d expr@AnonymousArgument{} = prettyPrintValueAtom d expr
68+prettyPrintValue d expr@Constructor{} = prettyPrintValueAtom d expr
69+prettyPrintValue d expr@Var{} = prettyPrintValueAtom d expr
70+prettyPrintValue d expr@OperatorSection{} = prettyPrintValueAtom d expr
71+prettyPrintValue d expr@BinaryNoParens{} = prettyPrintValueAtom d expr
72+prettyPrintValue d expr@Parens{} = prettyPrintValueAtom d expr
73+prettyPrintValue d expr@UnaryMinus{} = prettyPrintValueAtom d expr
74+prettyPrintValue d expr@ObjectGetter{} = prettyPrintValueAtom d expr
7975
8076-- | Pretty-print an atomic expression, adding parentheses if necessary.
8177prettyPrintValueAtom :: Int -> Expr -> Box
82−prettyPrintValueAtom _ (NumericLiteral n) = text $ either show show n
83−prettyPrintValueAtom _ (StringLiteral s) = text $ show s
84−prettyPrintValueAtom _ (CharLiteral c) = text $ show c
85−prettyPrintValueAtom _ (BooleanLiteral True) = text "true"
86−prettyPrintValueAtom _ (BooleanLiteral False) = text "false"
87−prettyPrintValueAtom d (ArrayLiteral xs) = list '[' ']' (prettyPrintValue (d - 1)) xs
88−prettyPrintValueAtom d (ObjectLiteral ps) = prettyPrintObject (d - 1) $ second Just `map` ps
89−prettyPrintValueAtom d (ObjectConstructor ps) = prettyPrintObject (d - 1) ps
90−prettyPrintValueAtom _ (ObjectGetter prop) = text $ "_." ++ show prop
78+prettyPrintValueAtom d (Literal l) = prettyPrintLiteralValue d l
79+prettyPrintValueAtom _ AnonymousArgument = text "_"
9180prettyPrintValueAtom _ (Constructor name) = text $ runProperName (disqualify name)
9281prettyPrintValueAtom _ (Var ident) = text $ showIdent (disqualify ident)
9382prettyPrintValueAtom d (OperatorSection op (Right val)) = ((text "(" <> prettyPrintValue (d - 1) op) `beforeWithSpace` prettyPrintValue (d - 1) val) `before` text ")"
9483prettyPrintValueAtom d (OperatorSection op (Left val)) = ((text "(" <> prettyPrintValue (d - 1) val) `beforeWithSpace` prettyPrintValue (d - 1) op) `before` text ")"
84+prettyPrintValueAtom d (BinaryNoParens op lhs rhs) =
85+ prettyPrintValue (d - 1) lhs `beforeWithSpace` printOp op `beforeWithSpace` prettyPrintValue (d - 1) rhs
86+ where
87+ printOp (Var (Qualified _ (Op opName))) = text opName
88+ printOp expr = text "`" <> prettyPrintValue (d - 1) expr <> text "`"
9589prettyPrintValueAtom d (TypedValue _ val _) = prettyPrintValueAtom d val
9690prettyPrintValueAtom d (PositionedValue _ _ val) = prettyPrintValueAtom d val
91+prettyPrintValueAtom d (Parens expr) = (text "(" <> prettyPrintValue d expr) `before` text ")"
92+prettyPrintValueAtom d (UnaryMinus expr) = text "(-" <> prettyPrintValue d expr <> text ")"
93+prettyPrintValueAtom _ (ObjectGetter field) = text "_." <> text field
9794prettyPrintValueAtom d expr = (text "(" <> prettyPrintValue d expr) `before` text ")"
9895
96+prettyPrintLiteralValue :: Int -> Literal Expr -> Box
97+prettyPrintLiteralValue _ (NumericLiteral n) = text $ either show show n
98+prettyPrintLiteralValue _ (StringLiteral s) = text $ show s
99+prettyPrintLiteralValue _ (CharLiteral c) = text $ show c
100+prettyPrintLiteralValue _ (BooleanLiteral True) = text "true"
101+prettyPrintLiteralValue _ (BooleanLiteral False) = text "false"
102+prettyPrintLiteralValue d (ArrayLiteral xs) = list '[' ']' (prettyPrintValue (d - 1)) xs
103+prettyPrintLiteralValue d (ObjectLiteral ps) = prettyPrintObject (d - 1) $ second Just `map` ps
104+
99105prettyPrintDeclaration :: Int -> Declaration -> Box
100106prettyPrintDeclaration d _ | d < 0 = ellipsis
101107prettyPrintDeclaration _ (TypeDeclaration ident ty) =
@@ -140,28 +146,35 @@ prettyPrintDoNotationElement d (PositionedDoNotationElement _ _ el) = prettyPrin
140146
141147prettyPrintBinderAtom :: Binder -> String
142148prettyPrintBinderAtom NullBinder = "_"
143−prettyPrintBinderAtom (StringBinder str) = show str
144−prettyPrintBinderAtom (CharBinder c) = show c
145−prettyPrintBinderAtom (NumberBinder num) = either show show num
146−prettyPrintBinderAtom (BooleanBinder True) = "true"
147−prettyPrintBinderAtom (BooleanBinder False) = "false"
149+prettyPrintBinderAtom (LiteralBinder l) = prettyPrintLiteralBinder l
148150prettyPrintBinderAtom (VarBinder ident) = showIdent ident
149151prettyPrintBinderAtom (ConstructorBinder ctor []) = runProperName (disqualify ctor)
150−prettyPrintBinderAtom (ObjectBinder bs) =
152+prettyPrintBinderAtom b@ConstructorBinder{} = parens (prettyPrintBinder b)
153+prettyPrintBinderAtom (NamedBinder ident binder) = showIdent ident ++ "@" ++ prettyPrintBinder binder
154+prettyPrintBinderAtom (PositionedBinder _ _ binder) = prettyPrintBinderAtom binder
155+prettyPrintBinderAtom (TypedBinder _ binder) = prettyPrintBinderAtom binder
156+prettyPrintBinderAtom (OpBinder op) = showIdent (disqualify op)
157+prettyPrintBinderAtom (BinaryNoParensBinder op b1 b2) =
158+ prettyPrintBinderAtom b1 ++ " " ++ prettyPrintBinderAtom op ++ " " ++ prettyPrintBinderAtom b2
159+prettyPrintBinderAtom (ParensInBinder b) = parens (prettyPrintBinder b)
160+
161+prettyPrintLiteralBinder :: Literal Binder -> String
162+prettyPrintLiteralBinder (StringLiteral str) = show str
163+prettyPrintLiteralBinder (CharLiteral c) = show c
164+prettyPrintLiteralBinder (NumericLiteral num) = either show show num
165+prettyPrintLiteralBinder (BooleanLiteral True) = "true"
166+prettyPrintLiteralBinder (BooleanLiteral False) = "false"
167+prettyPrintLiteralBinder (ObjectLiteral bs) =
151168 "{ "
152169 ++ intercalate ", " (map prettyPrintObjectPropertyBinder bs)
153170 ++ " }"
154171 where
155172 prettyPrintObjectPropertyBinder :: (String, Binder) -> String
156173 prettyPrintObjectPropertyBinder (key, binder) = prettyPrintObjectKey key ++ ": " ++ prettyPrintBinder binder
157−prettyPrintBinderAtom (ArrayBinder bs) =
174+prettyPrintLiteralBinder (ArrayLiteral bs) =
158175 "[ "
159176 ++ intercalate ", " (map prettyPrintBinder bs)
160177 ++ " ]"
161−prettyPrintBinderAtom (NamedBinder ident binder) = showIdent ident ++ "@" ++ prettyPrintBinder binder
162−prettyPrintBinderAtom (PositionedBinder _ _ binder) = prettyPrintBinderAtom binder
163−prettyPrintBinderAtom (TypedBinder _ binder) = prettyPrintBinderAtom binder
164−prettyPrintBinderAtom b = parens (prettyPrintBinder b)
165178
166179-- |
167180-- Generate a pretty-printed string representing a Binder
src/Language/PureScript/Publish.hs+23−6
@@ -146,11 +146,20 @@ preparePackage' opts = do
146146getModulesAndBookmarks :: PrepareM ([D.Bookmark], [D.Module])
147147getModulesAndBookmarks = do
148148 (inputFiles, depsFiles) <- liftIO getInputAndDepsFiles
149− liftIO (D.parseAndDesugar inputFiles depsFiles renderModules)
150− >>= either (userError . ParseAndDesugarError) return
149+ (modules', bookmarks) <- parseAndBookmark inputFiles depsFiles
150+
151+ case runExcept (D.convertModulesInPackage modules') of
152+ Right modules -> return (bookmarks, modules)
153+ Left err -> userError (CompileError err)
154+
151155 where
152− renderModules bookmarks modules =
153− return (bookmarks, map D.convertModule modules)
156+ parseAndBookmark inputFiles depsFiles = do
157+ r <- liftIO . runExceptT $ D.parseAndBookmark inputFiles depsFiles
158+ case r of
159+ Right r' ->
160+ return r'
161+ Left err ->
162+ userError (CompileError err)
154163
155164data TreeStatus = Clean | Dirty deriving (Show, Read, Eq, Ord, Enum)
156165
@@ -196,8 +205,7 @@ getBowerInfo = either (userError . BadRepositoryField) return . tryExtract
196205 maybe (Left NotOnGithub) Right (extractGithub repositoryUrl)
197206
198207extractGithub :: String -> Maybe (D.GithubUser, D.GithubRepo)
199−extractGithub =
200− stripPrefix "git://github.com/"
208+extractGithub = stripGitHubPrefixes
201209 >>> fmap (splitOn "/")
202210 >=> takeTwo
203211 >>> fmap (D.GithubUser *** (D.GithubRepo . dropDotGit))
@@ -207,6 +215,15 @@ extractGithub =
207215 takeTwo [x, y] = Just (x, y)
208216 takeTwo _ = Nothing
209217
218+ stripGitHubPrefixes :: String -> Maybe String
219+ stripGitHubPrefixes = stripPrefixes [ "git://github.com/"
220+ , "https://github.com/"
221+ , "git@github.com:"
222+ ]
223+
224+ stripPrefixes :: [String] -> String -> Maybe String
225+ stripPrefixes prefixes str = msum $ (`stripPrefix` str) <$> prefixes
226+
210227 dropDotGit :: String -> String
211228 dropDotGit str
212229 | ".git" `isSuffixOf` str = take (length str - 4) str
src/Language/PureScript/Publish/ErrorsWarnings.hs+4−15
@@ -33,7 +33,6 @@ import Web.Bower.PackageMeta (BowerError, PackageName, runPackageName, showBower
3333import qualified Web.Bower.PackageMeta as Bower
3434
3535import qualified Language.PureScript as P
36−import qualified Language.PureScript.Docs as D
3736
3837import Language.PureScript.Publish.BoxesHelpers
3938
@@ -61,7 +60,7 @@ data UserError
6160 | AmbiguousVersions [Version] -- Invariant: should contain at least two elements
6261 | BadRepositoryField RepositoryFieldError
6362 | MissingDependencies (NonEmpty PackageName)
64− | ParseAndDesugarError D.ParseDesugarError
63+ | CompileError P.MultipleErrors
6564 | DirtyWorkingTree
6665 deriving (Show)
6766
@@ -188,20 +187,10 @@ displayUserError e = case e of
188187 [ "Please install ", them, " first, by running `bower install`."
189188 ])
190189 ]
191− ParseAndDesugarError (D.ParseError err) ->
190+ CompileError err ->
192191 vcat
193− [ para "Parse error:"
194− , indented (P.prettyPrintMultipleErrorsBox False err)
195− ]
196− ParseAndDesugarError (D.SortModulesError err) ->
197− vcat
198− [ para "Error in sortModules:"
199− , indented (P.prettyPrintMultipleErrorsBox False err)
200− ]
201− ParseAndDesugarError (D.DesugarError err) ->
202− vcat
203− [ para "Error while desugaring:"
204− , indented (P.prettyPrintMultipleErrorsBox False err)
192+ [ para "Compile error:"
193+ , indented (vcat (P.prettyPrintMultipleErrorsBox False err))
205194 ]
206195 DirtyWorkingTree ->
207196 para (
src/Language/PureScript/Renamer.hs+9−9
@@ -105,8 +105,8 @@ lookupIdent name = do
105105findDeclIdents :: [Bind Ann] -> [Ident]
106106findDeclIdents = concatMap go
107107 where
108− go (NonRec ident _) = [ident]
109− go (Rec ds) = map fst ds
108+ go (NonRec _ ident _) = [ident]
109+ go (Rec ds) = map (snd . fst) ds
110110
111111-- |
112112-- Renames within each declaration in a module.
@@ -128,19 +128,19 @@ renameInModules = map go
128128-- another in the current scope.
129129--
130130renameInDecl :: Bool -> Bind Ann -> Rename (Bind Ann)
131−renameInDecl isTopLevel (NonRec name val) = do
131+renameInDecl isTopLevel (NonRec a name val) = do
132132 name' <- if isTopLevel then return name else updateScope name
133− NonRec name' <$> renameInValue val
133+ NonRec a name' <$> renameInValue val
134134renameInDecl isTopLevel (Rec ds) = do
135135 ds' <- traverse updateNames ds
136136 Rec <$> traverse updateValues ds'
137137 where
138− updateNames :: (Ident, Expr Ann) -> Rename (Ident, Expr Ann)
139− updateNames (name, val) = do
138+ updateNames :: ((Ann, Ident), Expr Ann) -> Rename ((Ann, Ident), Expr Ann)
139+ updateNames ((a, name), val) = do
140140 name' <- if isTopLevel then return name else updateScope name
141− return (name', val)
142− updateValues :: (Ident, Expr Ann) -> Rename (Ident, Expr Ann)
143− updateValues (name, val) = (,) name <$> renameInValue val
141+ return ((a, name'), val)
142+ updateValues :: ((Ann, Ident), Expr Ann) -> Rename ((Ann, Ident), Expr Ann)
143+ updateValues (aname, val) = (,) aname <$> renameInValue val
144144
145145-- |
146146-- Renames within a value.
src/Language/PureScript/Sugar.hs+1−1
@@ -63,7 +63,7 @@ import Language.PureScript.Sugar.TypeDeclarations as S
6363--
6464-- * Group mutually recursive value and data declarations into binding groups.
6565--
66−desugar :: (Applicative m, MonadSupply m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module]
66+desugar :: (MonadSupply m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module]
6767desugar externs =
6868 map removeSignedLiterals
6969 >>> traverse desugarObjectConstructors
src/Language/PureScript/Sugar/BindingGroups.hs+73−55
@@ -1,60 +1,61 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.BindingGroups
4−-- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
5−-- License : MIT (http://opensource.org/licenses/MIT)
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
1+{-# LANGUAGE FlexibleContexts #-}
2+{-# LANGUAGE ScopedTypeVariables #-}
3+{-# LANGUAGE LambdaCase #-}
4+
115-- |
126-- This module implements the desugaring pass which creates binding groups from sets of
137-- mutually-recursive value declarations and mutually-recursive type declarations.
148--
15−-----------------------------------------------------------------------------
16−
17−{-# LANGUAGE FlexibleContexts #-}
18−{-# LANGUAGE ScopedTypeVariables #-}
19−
20−module Language.PureScript.Sugar.BindingGroups (
21− createBindingGroups,
22− createBindingGroupsModule,
23− collapseBindingGroups,
24− collapseBindingGroupsModule
25−) where
9+module Language.PureScript.Sugar.BindingGroups
10+ ( createBindingGroups
11+ , createBindingGroupsModule
12+ , collapseBindingGroups
13+ , collapseBindingGroupsModule
14+ ) where
2615
2716import Prelude ()
2817import Prelude.Compat
2918
30−import Data.Graph
31−import Data.List (nub, intersect)
32−import Data.Maybe (isJust, mapMaybe)
3319import Control.Monad ((<=<))
3420import Control.Monad.Error.Class (MonadError(..))
3521
22+import Data.Graph
23+import Data.List (nub, intersect)
24+import Data.Maybe (isJust, mapMaybe)
3625import qualified Data.Set as S
3726
38−import Language.PureScript.Crash
3927import Language.PureScript.AST
40−import Language.PureScript.Names
41−import Language.PureScript.Types
28+import Language.PureScript.Crash
4229import Language.PureScript.Environment
4330import Language.PureScript.Errors
31+import Language.PureScript.Names
32+import Language.PureScript.Types
4433
4534-- |
4635-- Replace all sets of mutually-recursive declarations in a module with binding groups
4736--
48−createBindingGroupsModule :: (Functor m, Applicative m, MonadError MultipleErrors m) => [Module] -> m [Module]
49−createBindingGroupsModule = mapM $ \(Module ss coms name ds exps) -> Module ss coms name <$> createBindingGroups name ds <*> pure exps
37+createBindingGroupsModule
38+ :: (MonadError MultipleErrors m)
39+ => [Module]
40+ -> m [Module]
41+createBindingGroupsModule =
42+ mapM $ \(Module ss coms name ds exps) ->
43+ Module ss coms name <$> createBindingGroups name ds <*> pure exps
5044
5145-- |
5246-- Collapse all binding groups in a module to individual declarations
5347--
5448collapseBindingGroupsModule :: [Module] -> [Module]
55−collapseBindingGroupsModule = map $ \(Module ss coms name ds exps) -> Module ss coms name (collapseBindingGroups ds) exps
56−
57−createBindingGroups :: forall m. (Functor m, Applicative m, MonadError MultipleErrors m) => ModuleName -> [Declaration] -> m [Declaration]
49+collapseBindingGroupsModule =
50+ map $ \(Module ss coms name ds exps) ->
51+ Module ss coms name (collapseBindingGroups ds) exps
52+
53+createBindingGroups
54+ :: forall m
55+ . (MonadError MultipleErrors m)
56+ => ModuleName
57+ -> [Declaration]
58+ -> m [Declaration]
5859createBindingGroups moduleName = mapM f <=< handleDecls
5960
6061 where
@@ -71,8 +72,8 @@ createBindingGroups moduleName = mapM f <=< handleDecls
7172 handleDecls ds = do
7273 let values = filter isValueDecl ds
7374 dataDecls = filter isDataDecl ds
74− allProperNames = map getProperName dataDecls
75− dataVerts = map (\d -> (d, getProperName d, usedProperNames moduleName d `intersect` allProperNames)) dataDecls
75+ allProperNames = map getTypeName dataDecls
76+ dataVerts = map (\d -> (d, getTypeName d, usedTypeNames moduleName d `intersect` allProperNames)) dataDecls
7677 dataBindingGroupDecls <- parU (stronglyConnComp dataVerts) toDataBindingGroup
7778 let allIdents = map getIdent values
7879 valueVerts = map (\d -> (d, getIdent d, usedIdents moduleName d `intersect` allIdents)) values
@@ -90,11 +91,15 @@ createBindingGroups moduleName = mapM f <=< handleDecls
9091-- Collapse all binding groups to individual declarations
9192--
9293collapseBindingGroups :: [Declaration] -> [Declaration]
93−collapseBindingGroups = let (f, _, _) = everywhereOnValues id collapseBindingGroupsForValue id in map f . concatMap go
94+collapseBindingGroups =
95+ let (f, _, _) = everywhereOnValues id collapseBindingGroupsForValue id
96+ in map f . concatMap go
9497 where
9598 go (DataBindingGroupDeclaration ds) = ds
96− go (BindingGroupDeclaration ds) = map (\(ident, nameKind, val) -> ValueDeclaration ident nameKind [] (Right val)) ds
97− go (PositionedDeclaration pos com d) = map (PositionedDeclaration pos com) $ go d
99+ go (BindingGroupDeclaration ds) =
100+ map (\(ident, nameKind, val) -> ValueDeclaration ident nameKind [] (Right val)) ds
101+ go (PositionedDeclaration pos com d) =
102+ map (PositionedDeclaration pos com) $ go d
98103 go other = [other]
99104
100105collapseBindingGroupsForValue :: Expr -> Expr
@@ -114,8 +119,10 @@ usedIdents moduleName = nub . usedIdents' S.empty . getValue
114119 (_, usedIdents', _, _, _) = everythingWithScope def usedNamesE def def def
115120
116121 usedNamesE :: S.Set Ident -> Expr -> [Ident]
117− usedNamesE scope (Var (Qualified Nothing name)) | name `S.notMember` scope = [name]
118− usedNamesE scope (Var (Qualified (Just moduleName') name)) | moduleName == moduleName' && name `S.notMember` scope = [name]
122+ usedNamesE scope (Var (Qualified Nothing name))
123+ | name `S.notMember` scope = [name]
124+ usedNamesE scope (Var (Qualified (Just moduleName') name))
125+ | moduleName == moduleName' && name `S.notMember` scope = [name]
119126 usedNamesE _ _ = []
120127
121128usedImmediateIdents :: ModuleName -> Declaration -> [Ident]
@@ -127,21 +134,24 @@ usedImmediateIdents moduleName =
127134
128135 usedNamesE :: Bool -> Expr -> (Bool, [Ident])
129136 usedNamesE True (Var (Qualified Nothing name)) = (True, [name])
130− usedNamesE True (Var (Qualified (Just moduleName') name)) | moduleName == moduleName' = (True, [name])
137+ usedNamesE True (Var (Qualified (Just moduleName') name))
138+ | moduleName == moduleName' = (True, [name])
131139 usedNamesE True (Abs _ _) = (False, [])
132140 usedNamesE scope _ = (scope, [])
133141
134−usedProperNames :: ModuleName -> Declaration -> [ProperName]
135−usedProperNames moduleName =
142+usedTypeNames :: ModuleName -> Declaration -> [ProperName 'TypeName]
143+usedTypeNames moduleName =
136144 let (f, _, _, _, _) = accumTypes (everythingOnTypes (++) usedNames)
137145 in nub . f
138146 where
139− usedNames :: Type -> [ProperName]
140− usedNames (ConstrainedType constraints _) = flip mapMaybe constraints $ \qual ->
141− case qual of
142− (Qualified (Just moduleName') name, _) | moduleName == moduleName' -> Just name
147+ usedNames :: Type -> [ProperName 'TypeName]
148+ usedNames (ConstrainedType constraints _) =
149+ flip mapMaybe constraints $ \case
150+ (Qualified (Just moduleName') name, _)
151+ | moduleName == moduleName' -> Just (coerceProperName name)
143152 _ -> Nothing
144− usedNames (TypeConstructor (Qualified (Just moduleName') name)) | moduleName == moduleName' = [name]
153+ usedNames (TypeConstructor (Qualified (Just moduleName') name))
154+ | moduleName == moduleName' = [name]
145155 usedNames _ = []
146156
147157getIdent :: Declaration -> Ident
@@ -149,17 +159,22 @@ getIdent (ValueDeclaration ident _ _ _) = ident
149159getIdent (PositionedDeclaration _ _ d) = getIdent d
150160getIdent _ = internalError "Expected ValueDeclaration"
151161
152−getProperName :: Declaration -> ProperName
153−getProperName (DataDeclaration _ pn _ _) = pn
154−getProperName (TypeSynonymDeclaration pn _ _) = pn
155−getProperName (PositionedDeclaration _ _ d) = getProperName d
156−getProperName _ = internalError "Expected DataDeclaration"
162+getTypeName :: Declaration -> ProperName 'TypeName
163+getTypeName (DataDeclaration _ pn _ _) = pn
164+getTypeName (TypeSynonymDeclaration pn _ _) = pn
165+getTypeName (PositionedDeclaration _ _ d) = getTypeName d
166+getTypeName _ = internalError "Expected DataDeclaration"
157167
158168-- |
159169-- Convert a group of mutually-recursive dependencies into a BindingGroupDeclaration (or simple ValueDeclaration).
160170--
161171--
162−toBindingGroup :: forall m. (Functor m, MonadError MultipleErrors m) => ModuleName -> SCC Declaration -> m Declaration
172+toBindingGroup
173+ :: forall m
174+ . (MonadError MultipleErrors m)
175+ => ModuleName
176+ -> SCC Declaration
177+ -> m Declaration
163178toBindingGroup _ (AcyclicSCC d) = return d
164179toBindingGroup moduleName (CyclicSCC ds') =
165180 -- Once we have a mutually-recursive group of declarations, we need to sort
@@ -188,7 +203,10 @@ toBindingGroup moduleName (CyclicSCC ds') =
188203 cycleError (ValueDeclaration n _ _ (Right _)) = errorMessage $ CycleInDeclaration n
189204 cycleError _ = internalError "cycleError: Expected ValueDeclaration"
190205
191−toDataBindingGroup :: (MonadError MultipleErrors m) => SCC Declaration -> m Declaration
206+toDataBindingGroup
207+ :: MonadError MultipleErrors m
208+ => SCC Declaration
209+ -> m Declaration
192210toDataBindingGroup (AcyclicSCC d) = return d
193211toDataBindingGroup (CyclicSCC [d]) = case isTypeSynonym d of
194212 Just pn -> throwError . errorMessage $ CycleInTypeSynonym (Just pn)
@@ -197,7 +215,7 @@ toDataBindingGroup (CyclicSCC ds')
197215 | all (isJust . isTypeSynonym) ds' = throwError . errorMessage $ CycleInTypeSynonym Nothing
198216 | otherwise = return $ DataBindingGroupDeclaration ds'
199217
200−isTypeSynonym :: Declaration -> Maybe ProperName
218+isTypeSynonym :: Declaration -> Maybe (ProperName 'TypeName)
201219isTypeSynonym (TypeSynonymDeclaration pn _ _) = Just pn
202220isTypeSynonym (PositionedDeclaration _ _ d) = isTypeSynonym d
203221isTypeSynonym _ = Nothing
src/Language/PureScript/Sugar/CaseDeclarations.hs+15−24
@@ -36,7 +36,7 @@ isLeft (Right _) = False
3636-- |
3737-- Replace all top-level binders in a module with case expressions.
3838--
39−desugarCasesModule :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Module] -> m [Module]
39+desugarCasesModule :: (MonadSupply m, MonadError MultipleErrors m) => [Module] -> m [Module]
4040desugarCasesModule ms = forM ms $ \(Module ss coms name ds exps) ->
4141 rethrow (addHint (ErrorInModule name)) $
4242 Module ss coms name <$> (desugarCases <=< desugarAbs <=< validateCases $ ds) <*> pure exps
@@ -44,7 +44,7 @@ desugarCasesModule ms = forM ms $ \(Module ss coms name ds exps) ->
4444-- |
4545-- Validates that case head and binder lengths match.
4646--
47−validateCases :: forall m. (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]
47+validateCases :: forall m. (MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]
4848validateCases = flip parU f
4949 where
5050 (f, _, _) = everywhereOnValuesM return validate return
@@ -69,7 +69,7 @@ validateCases = flip parU f
6969 positionedBinder (PositionedBinder p _ _) = Just p
7070 positionedBinder _ = Nothing
7171
72−desugarAbs :: forall m. (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]
72+desugarAbs :: forall m. (MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]
7373desugarAbs = flip parU f
7474 where
7575 (f, _, _) = everywhereOnValuesM return replace return
@@ -83,7 +83,7 @@ desugarAbs = flip parU f
8383-- |
8484-- Replace all top-level binders with case expressions.
8585--
86−desugarCases :: forall m. (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]
86+desugarCases :: forall m. (MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]
8787desugarCases = desugarRest <=< fmap join . flip parU toDecls . groupBy inSameGroup
8888 where
8989 desugarRest :: [Declaration] -> m [Declaration]
@@ -109,7 +109,7 @@ inSameGroup (PositionedDeclaration _ _ d1) d2 = inSameGroup d1 d2
109109inSameGroup d1 (PositionedDeclaration _ _ d2) = inSameGroup d1 d2
110110inSameGroup _ _ = False
111111
112−toDecls :: forall m. (Functor m, Applicative m, Monad m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]
112+toDecls :: forall m. (MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]
113113toDecls [ValueDeclaration ident nameKind bs (Right val)] | all isVarBinder bs = do
114114 args <- mapM fromVarBinder bs
115115 let body = foldr (Abs . Left) val args
@@ -147,10 +147,10 @@ toTuple (ValueDeclaration _ _ bs result) = (bs, result)
147147toTuple (PositionedDeclaration _ _ d) = toTuple d
148148toTuple _ = internalError "Not a value declaration"
149149
150−makeCaseDeclaration :: forall m. (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Ident -> [([Binder], Either [(Guard, Expr)] Expr)] -> m Declaration
150+makeCaseDeclaration :: forall m. (MonadSupply m, MonadError MultipleErrors m) => Ident -> [([Binder], Either [(Guard, Expr)] Expr)] -> m Declaration
151151makeCaseDeclaration ident alternatives = do
152152 let namedArgs = map findName . fst <$> alternatives
153− argNames = map join $ foldl1 resolveNames namedArgs
153+ argNames = foldl1 resolveNames namedArgs
154154 args <- if allUnique (catMaybes argNames)
155155 then mapM argName argNames
156156 else replicateM (length argNames) freshIdent'
@@ -160,14 +160,11 @@ makeCaseDeclaration ident alternatives = do
160160 return $ ValueDeclaration ident Public [] (Right value)
161161 where
162162 -- We will construct a table of potential names.
163− -- VarBinders will become Just (Just _) which is a potential name.
164− -- NullBinder will become Just Nothing, which indicates that we may
163+ -- VarBinders will become Just _ which is a potential name.
164+ -- Everything else becomes Nothing, which indicates that we
165165 -- have to generate a name.
166− -- Everything else becomes Nothing, which indicates that we definitely
167− -- have to generate a name.
168− findName :: Binder -> Maybe (Maybe Ident)
169− findName NullBinder = Just Nothing
170− findName (VarBinder name) = Just (Just name)
166+ findName :: Binder -> Maybe Ident
167+ findName (VarBinder name) = Just name
171168 findName (PositionedBinder _ _ binder) = findName binder
172169 findName _ = Nothing
173170
@@ -182,19 +179,13 @@ makeCaseDeclaration ident alternatives = do
182179
183180 -- Combine two lists of potential names from two case alternatives
184181 -- by zipping correspoding columns.
185− resolveNames :: [Maybe (Maybe Ident)] ->
186− [Maybe (Maybe Ident)] ->
187− [Maybe (Maybe Ident)]
182+ resolveNames :: [Maybe Ident] -> [Maybe Ident] -> [Maybe Ident]
188183 resolveNames = zipWith resolveName
189184
190185 -- Resolve a pair of names. VarBinder beats NullBinder, and everything
191186 -- else results in Nothing.
192− resolveName :: Maybe (Maybe Ident) ->
193− Maybe (Maybe Ident) ->
194− Maybe (Maybe Ident)
195− resolveName (Just (Just a)) (Just (Just b))
196− | a == b = Just (Just a)
187+ resolveName :: Maybe Ident -> Maybe Ident -> Maybe Ident
188+ resolveName (Just a) (Just b)
189+ | a == b = Just a
197190 | otherwise = Nothing
198− resolveName (Just Nothing) a = a
199− resolveName a (Just Nothing) = a
200191 resolveName _ _ = Nothing
src/Language/PureScript/Sugar/DoNotation.hs+2−2
@@ -26,10 +26,10 @@ import Control.Monad.Supply.Class
2626-- Replace all @DoNotationBind@ and @DoNotationValue@ constructors with applications of the Prelude.bind function,
2727-- and all @DoNotationLet@ constructors with let expressions.
2828--
29−desugarDoModule :: forall m. (Applicative m, MonadSupply m, MonadError MultipleErrors m) => Module -> m Module
29+desugarDoModule :: forall m. (MonadSupply m, MonadError MultipleErrors m) => Module -> m Module
3030desugarDoModule (Module ss coms mn ds exts) = Module ss coms mn <$> parU ds desugarDo <*> pure exts
3131
32−desugarDo :: forall m. (Applicative m, MonadSupply m, MonadError MultipleErrors m) => Declaration -> m Declaration
32+desugarDo :: forall m. (MonadSupply m, MonadError MultipleErrors m) => Declaration -> m Declaration
3333desugarDo (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> rethrowWithPosition pos (desugarDo d)
3434desugarDo d =
3535 let (f, _, _) = everywhereOnValuesM return replace return
src/Language/PureScript/Sugar/Names.hs+100−36
@@ -1,8 +1,17 @@
11{-# LANGUAGE FlexibleContexts #-}
22{-# LANGUAGE RecordWildCards #-}
33{-# LANGUAGE ScopedTypeVariables #-}
4−
5−module Language.PureScript.Sugar.Names (desugarImports) where
4+{-# LANGUAGE TupleSections #-}
5+
6+module Language.PureScript.Sugar.Names
7+ ( desugarImports
8+ , desugarImportsWithEnv
9+ , Env
10+ , ImportRecord(..)
11+ , ImportProvenance(..)
12+ , Imports(..)
13+ , Exports(..)
14+ ) where
615
716import Prelude ()
817import Prelude.Compat
@@ -10,12 +19,14 @@ import Prelude.Compat
1019import Data.List (find, nub)
1120import Data.Maybe (fromMaybe, mapMaybe)
1221
22+import Control.Arrow (first)
1323import Control.Monad
1424import Control.Monad.Error.Class (MonadError(..))
1525import Control.Monad.Writer (MonadWriter(..), censor)
1626import Control.Monad.State.Lazy
1727
1828import qualified Data.Map as M
29+import qualified Data.Set as S
1930
2031import Language.PureScript.Crash
2132import Language.PureScript.AST
@@ -33,12 +44,21 @@ import Language.PureScript.Linter.Imports
3344-- Replaces all local names with qualified names within a list of modules. The
3445-- modules should be topologically sorted beforehand.
3546--
36−desugarImports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module]
37−desugarImports externs modules = do
47+desugarImports :: forall m. (MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module]
48+desugarImports externs modules =
49+ fmap snd (desugarImportsWithEnv externs modules)
50+
51+desugarImportsWithEnv
52+ :: forall m
53+ . (MonadError MultipleErrors m, MonadWriter MultipleErrors m)
54+ => [ExternsFile]
55+ -> [Module]
56+ -> m (Env, [Module])
57+desugarImportsWithEnv externs modules = do
3858 env <- silence $ foldM externsEnv primEnv externs
3959 modules' <- traverse updateExportRefs modules
40− (modules'', env') <- foldM updateEnv ([], env) modules'
41− traverse (renameInModule' env') modules''
60+ (modules'', env') <- first reverse <$> foldM updateEnv ([], env) modules'
61+ (env',) <$> traverse (renameInModule' env') modules''
4262 where
4363 silence :: m a -> m a
4464 silence = censor (const mempty)
@@ -49,23 +69,23 @@ desugarImports externs modules = do
4969 let members = Exports{..}
5070 ss = internalModuleSourceSpan "<Externs>"
5171 env' = M.insert efModuleName (ss, nullImports, members) env
52− fromEFImport (ExternsImport mn mt qmn) = (mn, [(Nothing, mt, qmn)])
72+ fromEFImport (ExternsImport mn mt qmn) = (mn, [(Nothing, Just mt, qmn)])
5373 imps <- foldM (resolveModuleImport env') nullImports (map fromEFImport efImports)
5474 exps <- resolveExports env' efModuleName imps members efExports
5575 return $ M.insert efModuleName (ss, imps, exps) env
5676 where
5777
58− exportedTypes :: [((ProperName, [ProperName]), ModuleName)]
78+ exportedTypes :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]
5979 exportedTypes = mapMaybe toExportedType efExports
6080 where
6181 toExportedType (TypeRef tyCon dctors) = Just ((tyCon, fromMaybe (mapMaybe forTyCon efDeclarations) dctors), efModuleName)
6282 where
63− forTyCon :: ExternsDeclaration -> Maybe ProperName
83+ forTyCon :: ExternsDeclaration -> Maybe (ProperName 'ConstructorName)
6484 forTyCon (EDDataConstructor pn _ tNm _ _) | tNm == tyCon = Just pn
6585 forTyCon _ = Nothing
6686 toExportedType (PositionedDeclarationRef _ _ r) = toExportedType r
6787 toExportedType _ = Nothing
68− exportedTypeClasses :: [(ProperName, ModuleName)]
88+ exportedTypeClasses :: [(ProperName 'ClassName, ModuleName)]
6989 exportedTypeClasses = mapMaybe toExportedTypeClass efExports
7090 where
7191 toExportedTypeClass (TypeClassRef className) = Just (className, efModuleName)
@@ -94,7 +114,7 @@ desugarImports externs modules = do
94114 warnAndRethrow (addHint (ErrorInModule mn)) $ do
95115 let (_, imps, exps) = fromMaybe (internalError "Module is missing in renameInModule'") $ M.lookup mn env
96116 (m', used) <- flip runStateT M.empty $ renameInModule env imps (elaborateExports exps m)
97− findUnusedImports m env used
117+ lintImports m env used
98118 return m'
99119
100120-- |
@@ -119,14 +139,23 @@ elaborateExports exps (Module ss coms mn decls refs) =
119139-- Replaces all local names with qualified names within a module and checks that all existing
120140-- qualified names are valid.
121141--
122−renameInModule :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadState UsedImports m) => Env -> Imports -> Module -> m Module
142+renameInModule
143+ :: forall m
144+ . (MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadState UsedImports m)
145+ => Env
146+ -> Imports
147+ -> Module
148+ -> m Module
123149renameInModule env imports (Module ss coms mn decls exps) =
124150 Module ss coms mn <$> parU decls go <*> pure exps
125151 where
126152
127153 (go, _, _, _, _) = everywhereWithContextOnValuesM (Nothing, []) updateDecl updateValue updateBinder updateCase defS
128154
129− updateDecl :: (Maybe SourceSpan, [Ident]) -> Declaration -> m ((Maybe SourceSpan, [Ident]), Declaration)
155+ updateDecl
156+ :: (Maybe SourceSpan, [Ident])
157+ -> Declaration
158+ -> m ((Maybe SourceSpan, [Ident]), Declaration)
130159 updateDecl (_, bound) d@(PositionedDeclaration pos _ _) =
131160 return ((Just pos, bound), d)
132161 updateDecl (pos, bound) (DataDeclaration dtype name args dctors) =
@@ -141,9 +170,14 @@ renameInModule env imports (Module ss coms mn decls exps) =
141170 (,) (pos, bound) <$> (TypeDeclaration name <$> updateTypesEverywhere pos ty)
142171 updateDecl (pos, bound) (ExternDeclaration name ty) =
143172 (,) (pos, name : bound) <$> (ExternDeclaration name <$> updateTypesEverywhere pos ty)
173+ updateDecl (pos, bound) (FixityDeclaration fx name alias) =
174+ (,) (pos, bound) <$> (FixityDeclaration fx name <$> traverse (eitherM (`updateValueName` pos) (`updateDataConstructorName` pos)) alias)
144175 updateDecl s d = return (s, d)
145176
146− updateValue :: (Maybe SourceSpan, [Ident]) -> Expr -> m ((Maybe SourceSpan, [Ident]), Expr)
177+ updateValue
178+ :: (Maybe SourceSpan, [Ident])
179+ -> Expr
180+ -> m ((Maybe SourceSpan, [Ident]), Expr)
147181 updateValue (_, bound) v@(PositionedValue pos' _ _) =
148182 return ((Just pos', bound), v)
149183 updateValue (pos, bound) (Abs (Left arg) val') =
@@ -164,11 +198,16 @@ renameInModule env imports (Module ss coms mn decls exps) =
164198 (,) s <$> (TypedValue check val <$> updateTypesEverywhere pos ty)
165199 updateValue s v = return (s, v)
166200
167− updateBinder :: (Maybe SourceSpan, [Ident]) -> Binder -> m ((Maybe SourceSpan, [Ident]), Binder)
201+ updateBinder
202+ :: (Maybe SourceSpan, [Ident])
203+ -> Binder
204+ -> m ((Maybe SourceSpan, [Ident]), Binder)
168205 updateBinder (_, bound) v@(PositionedBinder pos _ _) =
169206 return ((Just pos, bound), v)
170207 updateBinder s@(pos, _) (ConstructorBinder name b) =
171208 (,) s <$> (ConstructorBinder <$> updateDataConstructorName name pos <*> pure b)
209+ updateBinder s@(pos, _) (OpBinder name) =
210+ (,) s <$> (OpBinder <$> updateValueName name pos)
172211 updateBinder s (TypedBinder t b) = do
173212 (s'@ (span', _), b') <- updateBinder s b
174213 t' <- updateTypesEverywhere span' t
@@ -176,7 +215,10 @@ renameInModule env imports (Module ss coms mn decls exps) =
176215 updateBinder s v =
177216 return (s, v)
178217
179− updateCase :: (Maybe SourceSpan, [Ident]) -> CaseAlternative -> m ((Maybe SourceSpan, [Ident]), CaseAlternative)
218+ updateCase
219+ :: (Maybe SourceSpan, [Ident])
220+ -> CaseAlternative
221+ -> m ((Maybe SourceSpan, [Ident]), CaseAlternative)
180222 updateCase (pos, bound) c@(CaseAlternative bs _) =
181223 return ((pos, concatMap binderNames bs ++ bound), c)
182224
@@ -196,16 +238,25 @@ renameInModule env imports (Module ss coms mn decls exps) =
196238 updateConstraints :: Maybe SourceSpan -> [Constraint] -> m [Constraint]
197239 updateConstraints pos = traverse (\(name, ts) -> (,) <$> updateClassName name pos <*> traverse (updateTypesEverywhere pos) ts)
198240
199− updateTypeName :: Qualified ProperName -> Maybe SourceSpan -> m (Qualified ProperName)
200− updateTypeName = update UnknownType (importedTypes imports) (resolveType . exportedTypes) TypeName (("type " ++) . runProperName)
241+ updateTypeName
242+ :: Qualified (ProperName 'TypeName)
243+ -> Maybe SourceSpan
244+ -> m (Qualified (ProperName 'TypeName))
245+ updateTypeName = update UnknownType (importedTypes imports) (resolveType . exportedTypes) TyName (("type " ++) . runProperName)
201246
202− updateDataConstructorName :: Qualified ProperName -> Maybe SourceSpan -> m (Qualified ProperName)
247+ updateDataConstructorName
248+ :: Qualified (ProperName 'ConstructorName)
249+ -> Maybe SourceSpan
250+ -> m (Qualified (ProperName 'ConstructorName))
203251 updateDataConstructorName = update (flip UnknownDataConstructor Nothing) (importedDataConstructors imports) (resolveDctor . exportedTypes) DctorName (("data constructor " ++) . runProperName)
204252
205− updateClassName :: Qualified ProperName -> Maybe SourceSpan -> m (Qualified ProperName)
206− updateClassName = update UnknownTypeClass (importedTypeClasses imports) (resolve . exportedTypeClasses) ClassName (("class " ++) . runProperName)
253+ updateClassName
254+ :: Qualified (ProperName 'ClassName)
255+ -> Maybe SourceSpan
256+ -> m (Qualified (ProperName 'ClassName))
257+ updateClassName = update UnknownTypeClass (importedTypeClasses imports) (resolve . exportedTypeClasses) TyClassName (("class " ++) . runProperName)
207258
208− updateValueName :: Qualified Ident -> Maybe SourceSpan -> m (Qualified Ident)
259+ updateValueName :: Qualified Ident -> Maybe SourceSpan -> m (Qualified Ident)
209260 updateValueName = update UnknownValue (importedValues imports) (resolve . exportedValues) IdentName (("value " ++) . runIdent)
210261
211262 -- Used when performing an update to qualify values and classes with their
@@ -215,12 +266,18 @@ renameInModule env imports (Module ss coms mn decls exps) =
215266
216267 -- Used when performing an update to qualify types with their module of
217268 -- original definition.
218− resolveType :: [((ProperName, [ProperName]), ModuleName)] -> ProperName -> Maybe (Qualified ProperName)
269+ resolveType
270+ :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]
271+ -> ProperName 'TypeName
272+ -> Maybe (Qualified (ProperName 'TypeName))
219273 resolveType tys name = mkQualified name . snd <$> find ((== name) . fst . fst) tys
220274
221275 -- Used when performing an update to qualify data constructors with their
222276 -- module of original definition.
223− resolveDctor :: [((ProperName, [ProperName]), ModuleName)] -> ProperName -> Maybe (Qualified ProperName)
277+ resolveDctor
278+ :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]
279+ -> ProperName 'ConstructorName
280+ -> Maybe (Qualified (ProperName 'ConstructorName))
224281 resolveDctor tys name = mkQualified name . snd <$> find (elem name . snd . fst) tys
225282
226283 -- Update names so unqualified references become qualified, and locally
@@ -229,7 +286,7 @@ renameInModule env imports (Module ss coms mn decls exps) =
229286 update
230287 :: (Ord a, Show a)
231288 => (Qualified a -> SimpleErrorMessage)
232− -> M.Map (Qualified a) [(Qualified a, ModuleName)]
289+ -> M.Map (Qualified a) [ImportRecord a]
233290 -> (Exports -> a -> Maybe (Qualified a))
234291 -> (Qualified a -> Name)
235292 -> (a -> String)
@@ -245,8 +302,7 @@ renameInModule env imports (Module ss coms mn decls exps) =
245302 -- re-exports. If there are multiple options for the name to resolve to
246303 -- in scope, we throw an error.
247304 (Just options, _) -> do
248− checkImportConflicts render options
249− let (Qualified (Just mnNew) _, mnOrig) = head options
305+ (mnNew, mnOrig) <- checkImportConflicts mn render options
250306 modify $ \result -> M.insert mnNew (maybe [toName qname] (toName qname :) (mnNew `M.lookup` result)) result
251307 return $ Qualified (Just mnOrig) name
252308
@@ -255,42 +311,50 @@ renameInModule env imports (Module ss coms mn decls exps) =
255311 -- by qualified importing). If that's not the case, then we just need to
256312 -- check it refers to a symbol in another module.
257313 (Nothing, Just mn'') -> do
258− modExports <- getExports env mn''
259− maybe (throwError . errorMessage $ unknown qname) return (getE modExports name)
314+ case M.lookup mn'' env of
315+ Nothing
316+ | mn'' `S.member` importedVirtualModules imports -> throwUnknown
317+ | otherwise -> throwError . errorMessage $ UnknownModule mn''
318+ Just env' -> maybe throwUnknown return (getE (envModuleExports env') name)
260319
261320 -- If neither of the above cases are true then it's an undefined or
262321 -- unimported symbol.
263− _ -> throwError . errorMessage $ unknown qname
322+ _ -> throwUnknown
264323
265324 where
266325 positioned err = case pos of
267326 Nothing -> err
268327 Just pos' -> rethrowWithPosition pos' err
328+ throwUnknown = throwError . errorMessage $ unknown qname
269329
270330-- |
271331-- Replaces `ProperRef` export values with a `TypeRef` or `TypeClassRef`
272332-- depending on what is availble within the module. Warns when a `ProperRef`
273333-- desugars into a `TypeClassRef`.
274334--
275−updateExportRefs :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Module -> m Module
335+updateExportRefs
336+ :: forall m
337+ . (MonadError MultipleErrors m, MonadWriter MultipleErrors m)
338+ => Module
339+ -> m Module
276340updateExportRefs (Module ss coms mn decls exps) =
277341 Module ss coms mn decls <$> traverse (traverse updateRef) exps
278342 where
279343
280344 updateRef :: DeclarationRef -> m DeclarationRef
281345 updateRef (ProperRef name)
282− | name `elem` classNames = do
283− tell . errorMessage $ DeprecatedClassExport name
284− return $ TypeClassRef name
346+ | ProperName name `elem` classNames = do
347+ tell . errorMessage . DeprecatedClassExport $ ProperName name
348+ return . TypeClassRef $ ProperName name
285349 -- Fall through case here - assume it's a type if it's not a class.
286350 -- If it's a reference to something that doesn't actually exist it will
287351 -- be picked up elsewhere
288− | otherwise = return $ TypeRef name (Just [])
352+ | otherwise = return $ TypeRef (ProperName name) (Just [])
289353 updateRef (PositionedDeclarationRef pos com ref) =
290354 warnWithPosition pos $ PositionedDeclarationRef pos com <$> updateRef ref
291355 updateRef other = return other
292356
293− classNames :: [ProperName]
357+ classNames :: [ProperName 'ClassName]
294358 classNames = mapMaybe go decls
295359 where
296360 go (PositionedDeclaration _ _ d) = go d
src/Language/PureScript/Sugar/Names/Env.hs+72−27
@@ -2,7 +2,9 @@
22{-# LANGUAGE ScopedTypeVariables #-}
33
44module Language.PureScript.Sugar.Names.Env
5− ( Imports(..)
5+ ( ImportRecord(..)
6+ , ImportProvenance(..)
7+ , Imports(..)
68 , nullImports
79 , Exports(..)
810 , nullExports
@@ -19,12 +21,14 @@ module Language.PureScript.Sugar.Names.Env
1921 ) where
2022
2123import Data.Function (on)
22−import Data.List (groupBy, sortBy, nub)
24+import Data.List (groupBy, sortBy, nub, delete)
2325import Data.Maybe (fromJust)
2426import qualified Data.Map as M
27+import qualified Data.Set as S
2528
2629import Control.Monad
2730import Control.Monad.Error.Class (MonadError(..))
31+import Control.Monad.Writer.Class (MonadWriter(..))
2832
2933import Language.PureScript.AST
3034import Language.PureScript.Crash
@@ -32,6 +36,30 @@ import Language.PureScript.Names
3236import Language.PureScript.Environment
3337import Language.PureScript.Errors
3438
39+-- |
40+-- The details for an import: the name of the thing that is being imported
41+-- (`A.x` if importing from `A`), the module that the thing was originally
42+-- defined in (for re-export resolution), and the import provenance (see below).
43+--
44+data ImportRecord a =
45+ ImportRecord
46+ { importName :: Qualified a
47+ , importSourceModule :: ModuleName
48+ , importProvenance :: ImportProvenance
49+ }
50+ deriving (Eq, Ord, Show, Read)
51+
52+-- |
53+-- Used to track how an import was introduced into scope. This allows us to
54+-- handle the one-open-import special case that allows a name conflict to become
55+-- a warning rather than being an unresolvable situation.
56+--
57+data ImportProvenance
58+ = FromImplicit
59+ | FromExplicit
60+ | Local
61+ deriving (Eq, Ord, Show, Read)
62+
3563-- |
3664-- The imported declarations for a module, including the module's own members.
3765--
@@ -40,30 +68,35 @@ data Imports = Imports
4068 -- |
4169 -- Local names for types within a module mapped to to their qualified names
4270 --
43− importedTypes :: M.Map (Qualified ProperName) [(Qualified ProperName, ModuleName)]
71+ importedTypes :: M.Map (Qualified (ProperName 'TypeName)) [ImportRecord (ProperName 'TypeName)]
4472 -- |
4573 -- Local names for data constructors within a module mapped to to their qualified names
4674 --
47− , importedDataConstructors :: M.Map (Qualified ProperName) [(Qualified ProperName, ModuleName)]
75+ , importedDataConstructors :: M.Map (Qualified (ProperName 'ConstructorName)) [ImportRecord (ProperName 'ConstructorName)]
4876 -- |
4977 -- Local names for classes within a module mapped to to their qualified names
5078 --
51− , importedTypeClasses :: M.Map (Qualified ProperName) [(Qualified ProperName, ModuleName)]
79+ , importedTypeClasses :: M.Map (Qualified (ProperName 'ClassName)) [ImportRecord (ProperName 'ClassName)]
5280 -- |
5381 -- Local names for values within a module mapped to to their qualified names
5482 --
55− , importedValues :: M.Map (Qualified Ident) [(Qualified Ident, ModuleName)]
83+ , importedValues :: M.Map (Qualified Ident) [ImportRecord Ident]
84+ -- |
85+ -- The modules that have been imported into the current scope.
86+ --
87+ , importedModules :: S.Set ModuleName
5688 -- |
57− -- The list of modules that have been imported into the current scope.
89+ -- The names of "virtual" modules that come into existence when "import as"
90+ -- is used.
5891 --
59− , importedModules :: [ModuleName]
92+ , importedVirtualModules :: S.Set ModuleName
6093 } deriving (Show, Read)
6194
6295-- |
6396-- An empty 'Imports' value.
6497--
6598nullImports :: Imports
66−nullImports = Imports M.empty M.empty M.empty M.empty []
99+nullImports = Imports M.empty M.empty M.empty M.empty S.empty S.empty
67100
68101-- |
69102-- The exported declarations from a module.
@@ -74,12 +107,12 @@ data Exports = Exports
74107 -- The types exported from each module along with the module they originally
75108 -- came from.
76109 --
77− exportedTypes :: [((ProperName, [ProperName]), ModuleName)]
110+ exportedTypes :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]
78111 -- |
79112 -- The classes exported from each module along with the module they originally
80113 -- came from.
81114 --
82− , exportedTypeClasses :: [(ProperName, ModuleName)]
115+ , exportedTypeClasses :: [(ProperName 'ClassName, ModuleName)]
83116 -- |
84117 -- The values exported from each module along with the module they originally
85118 -- came from.
@@ -137,29 +170,28 @@ primEnv = M.singleton
137170-- Safely adds a type and its data constructors to some exports, returning an
138171-- error if a conflict occurs.
139172--
140−exportType :: (MonadError MultipleErrors m) => Exports -> ProperName -> [ProperName] -> ModuleName -> m Exports
173+exportType :: (MonadError MultipleErrors m) => Exports -> ProperName 'TypeName -> [ProperName 'ConstructorName] -> ModuleName -> m Exports
141174exportType exps name dctors mn = do
142175 let exTypes' = exportedTypes exps
143176 let exTypes = filter ((/= mn) . snd) exTypes'
144177 let exDctors = (snd . fst) `concatMap` exTypes
145178 let exClasses = exportedTypeClasses exps
146−
147179 when (any ((== name) . fst . fst) exTypes) $ throwConflictError ConflictingTypeDecls name
148− when (any ((== name) . fst) exClasses) $ throwConflictError TypeConflictsWithClass name
180+ when (any ((== coerceProperName name) . fst) exClasses) $ throwConflictError TypeConflictsWithClass name
149181 forM_ dctors $ \dctor -> do
150182 when (dctor `elem` exDctors) $ throwConflictError ConflictingCtorDecls dctor
151− when (any ((== dctor) . fst) exClasses) $ throwConflictError CtorConflictsWithClass dctor
183+ when (any ((== coerceProperName dctor) . fst) exClasses) $ throwConflictError CtorConflictsWithClass dctor
152184 return $ exps { exportedTypes = nub $ ((name, dctors), mn) : exTypes' }
153185
154186-- |
155187-- Safely adds a class to some exports, returning an error if a conflict occurs.
156188--
157−exportTypeClass :: (MonadError MultipleErrors m) => Exports -> ProperName -> ModuleName -> m Exports
189+exportTypeClass :: (MonadError MultipleErrors m) => Exports -> ProperName 'ClassName -> ModuleName -> m Exports
158190exportTypeClass exps name mn = do
159191 let exTypes = exportedTypes exps
160192 let exDctors = (snd . fst) `concatMap` exTypes
161− when (any ((== name) . fst . fst) exTypes) $ throwConflictError ClassConflictsWithType name
162− when (name `elem` exDctors) $ throwConflictError ClassConflictsWithCtor name
193+ when (any ((== coerceProperName name) . fst . fst) exTypes) $ throwConflictError ClassConflictsWithType name
194+ when (coerceProperName name `elem` exDctors) $ throwConflictError ClassConflictsWithCtor name
163195 classes <- addExport DuplicateClassExport name mn (exportedTypeClasses exps)
164196 return $ exps { exportedTypeClasses = classes }
165197
@@ -197,16 +229,29 @@ getExports env mn = maybe (throwError . errorMessage $ UnknownModule mn) (return
197229--
198230checkImportConflicts
199231 :: forall m a
200− . (MonadError MultipleErrors m, Ord a)
201− => (a -> String)
202− -> [(Qualified a, ModuleName)]
203− -> m ()
204−checkImportConflicts render xs =
205− let byOrig = groupBy ((==) `on` snd) . sortBy (compare `on` snd) $ xs
232+ . (Show a, MonadError MultipleErrors m, MonadWriter MultipleErrors m, Ord a)
233+ => ModuleName
234+ -> (a -> String)
235+ -> [ImportRecord a]
236+ -> m (ModuleName, ModuleName)
237+checkImportConflicts currentModule render xs =
238+ let
239+ byOrig = sortBy (compare `on` importSourceModule) xs
240+ groups = groupBy ((==) `on` importSourceModule) byOrig
241+ nonImplicit = filter ((/= FromImplicit) . importProvenance) xs
242+ name = render' (importName . head $ xs)
243+ conflictModules = map (getQual . importName . head) groups
206244 in
207− if length byOrig > 1
208− then throwError . errorMessage $ ScopeConflict (render' (fst . head $ xs)) (map (getQual . fst . head) byOrig)
209− else return ()
245+ if length groups > 1
246+ then case nonImplicit of
247+ [ImportRecord (Qualified (Just mnNew) _) mnOrig _] -> do
248+ let warningModule = if mnNew == currentModule then Nothing else Just mnNew
249+ tell . errorMessage $ ScopeShadowing name warningModule $ delete mnNew conflictModules
250+ return (mnNew, mnOrig)
251+ _ -> throwError . errorMessage $ ScopeConflict name conflictModules
252+ else
253+ let ImportRecord (Qualified (Just mnNew) _) mnOrig _ = head byOrig
254+ in return (mnNew, mnOrig)
210255 where
211256 getQual :: Qualified a -> ModuleName
212257 getQual (Qualified (Just mn) _) = mn
src/Language/PureScript/Sugar/Names/Exports.hs+38−15
@@ -31,7 +31,7 @@ import Language.PureScript.Sugar.Names.Env
3131-- |
3232-- Finds all exportable members of a module, disregarding any explicit exports.
3333--
34−findExportable :: forall m. (Applicative m, MonadError MultipleErrors m) => Module -> m Exports
34+findExportable :: forall m. (MonadError MultipleErrors m) => Module -> m Exports
3535findExportable (Module _ _ mn ds _) =
3636 rethrow (addHint (ErrorInModule mn)) $ foldM updateExports nullExports ds
3737 where
@@ -56,7 +56,7 @@ findExportable (Module _ _ mn ds _) =
5656-- Resolves the exports for a module, filtering out members that have not been
5757-- exported and elaborating re-exports of other modules.
5858--
59−resolveExports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Env -> ModuleName -> Imports -> Exports -> [DeclarationRef] -> m Exports
59+resolveExports :: forall m. (MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Env -> ModuleName -> Imports -> Exports -> [DeclarationRef] -> m Exports
6060resolveExports env mn imps exps refs =
6161 rethrow (addHint (ErrorInModule mn)) $ do
6262 filtered <- filterModule mn exps refs
@@ -75,7 +75,7 @@ resolveExports env mn imps exps refs =
7575 ModuleRef name -> warnDupe $ "module " ++ runModuleName name
7676 _ -> return ()
7777
78− warnDupeDctors :: [ProperName] -> m ()
78+ warnDupeDctors :: [ProperName 'ConstructorName] -> m ()
7979 warnDupeDctors = traverse_ (warnDupe . ("data constructor " ++) . runProperName)
8080
8181 warnDupe :: String -> m ()
@@ -110,17 +110,17 @@ resolveExports env mn imps exps refs =
110110 -- Extracts a list of values for a module based on a lookup table. If the
111111 -- boolean is true the values are filtered by the qualification
112112 extract
113− :: (Ord a)
113+ :: (Show a, Ord a)
114114 => Bool
115115 -> ModuleName
116116 -> (a -> String)
117− -> M.Map (Qualified a) [(Qualified a, ModuleName)]
117+ -> M.Map (Qualified a) [ImportRecord a]
118118 -> m [Qualified a]
119− extract useQual name render = fmap (map (fst . head . snd)) . go . M.toList
119+ extract useQual name render = fmap (map (importName . head . snd)) . go . M.toList
120120 where
121121 go = filterM $ \(name', options) -> do
122− let isMatch = if useQual then eqQual name name' else any (eqQual name . fst) options
123− when (isMatch && length options > 1) $ checkImportConflicts render options
122+ let isMatch = if useQual then eqQual name name' else any (eqQual name . importName) options
123+ when (isMatch && length options > 1) $ void $ checkImportConflicts mn render options
124124 return isMatch
125125
126126 -- Check whether a module name refers to a "pseudo module" that came into
@@ -151,10 +151,15 @@ resolveExports env mn imps exps refs =
151151
152152 -- Constructs a list of types with their data constructors and the original
153153 -- module they were defined in from a list of type and data constructor names.
154− resolveTypeExports :: [Qualified ProperName] -> [Qualified ProperName] -> [((ProperName, [ProperName]), ModuleName)]
154+ resolveTypeExports
155+ :: [Qualified (ProperName 'TypeName)]
156+ -> [Qualified (ProperName 'ConstructorName)]
157+ -> [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]
155158 resolveTypeExports tctors dctors = map go tctors
156159 where
157− go :: Qualified ProperName -> ((ProperName, [ProperName]), ModuleName)
160+ go
161+ :: Qualified (ProperName 'TypeName)
162+ -> ((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)
158163 go (Qualified (Just mn'') name) = fromMaybe (internalError "Missing value in resolveTypeExports") $ do
159164 exps' <- envModuleExports <$> mn'' `M.lookup` env
160165 ((_, dctors'), mnOrig) <- find (\((name', _), _) -> name == name') (exportedTypes exps')
@@ -165,7 +170,7 @@ resolveExports env mn imps exps refs =
165170
166171 -- Looks up an imported class and re-qualifies it with the original module it
167172 -- came from.
168− resolveClass :: Qualified ProperName -> (ProperName, ModuleName)
173+ resolveClass :: Qualified (ProperName 'ClassName) -> (ProperName 'ClassName, ModuleName)
169174 resolveClass className = splitQual $ fromMaybe (internalError "Missing value in resolveClass") $
170175 resolve exportedTypeClasses className
171176
@@ -192,7 +197,13 @@ resolveExports env mn imps exps refs =
192197-- Filters the full list of exportable values, types, and classes for a module
193198-- based on a list of export declaration references.
194199--
195−filterModule :: forall m. (Applicative m, MonadError MultipleErrors m) => ModuleName -> Exports -> [DeclarationRef] -> m Exports
200+filterModule
201+ :: forall m
202+ . (MonadError MultipleErrors m)
203+ => ModuleName
204+ -> Exports
205+ -> [DeclarationRef]
206+ -> m Exports
196207filterModule mn exps refs = do
197208 types <- foldM (filterTypes $ exportedTypes exps) [] refs
198209 values <- foldM (filterValues $ exportedValues exps) [] refs
@@ -206,7 +217,11 @@ filterModule mn exps refs = do
206217 -- explicit export. When the ref refers to a type in the list of exportable
207218 -- values, the type and specified data constructors are included in the
208219 -- result.
209− filterTypes :: [((ProperName, [ProperName]), ModuleName)] -> [((ProperName, [ProperName]), ModuleName)] -> DeclarationRef -> m [((ProperName, [ProperName]), ModuleName)]
220+ filterTypes
221+ :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]
222+ -> [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]
223+ -> DeclarationRef
224+ -> m [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]
210225 filterTypes exps' result (PositionedDeclarationRef pos _ r) =
211226 rethrowWithPosition pos $ filterTypes exps' result r
212227 filterTypes exps' result (TypeRef name expDcons) =
@@ -221,7 +236,11 @@ filterModule mn exps refs = do
221236 -- Ensures a data constructor is exportable for a given type. Takes a type
222237 -- name, a list of exportable data constructors for the type, and the name of
223238 -- the data constructor to check.
224− checkDcon :: ProperName -> [ProperName] -> ProperName -> m ()
239+ checkDcon
240+ :: ProperName 'TypeName
241+ -> [ProperName 'ConstructorName]
242+ -> ProperName 'ConstructorName
243+ -> m ()
225244 checkDcon tcon exps' name =
226245 unless (name `elem` exps') $
227246 throwError . errorMessage $ UnknownExportDataConstructor tcon name
@@ -230,7 +249,11 @@ filterModule mn exps refs = do
230249 -- filtered exports, and a `DeclarationRef` for an explicit export. When the
231250 -- ref refers to a class in the list of exportable classes, the class is
232251 -- included in the result.
233− filterClasses :: [(ProperName, ModuleName)] -> [(ProperName, ModuleName)] -> DeclarationRef -> m [(ProperName, ModuleName)]
252+ filterClasses
253+ :: [(ProperName 'ClassName, ModuleName)]
254+ -> [(ProperName 'ClassName, ModuleName)]
255+ -> DeclarationRef
256+ -> m [(ProperName 'ClassName, ModuleName)]
234257 filterClasses exps' result (PositionedDeclarationRef pos _ r) =
235258 rethrowWithPosition pos $ filterClasses exps' result r
236259 filterClasses exps' result (TypeClassRef name) =
src/Language/PureScript/Sugar/Names/Imports.hs+66−44
@@ -23,6 +23,7 @@ import Control.Monad.Error.Class (MonadError(..))
2323import Control.Monad.Writer (MonadWriter(..))
2424
2525import qualified Data.Map as M
26+import qualified Data.Set as S
2627
2728import Language.PureScript.Crash
2829import Language.PureScript.AST
@@ -36,7 +37,7 @@ import Language.PureScript.Sugar.Names.Env
3637--
3738findImports
3839 :: forall m
39− . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
40+ . (MonadError MultipleErrors m, MonadWriter MultipleErrors m)
4041 => [Declaration]
4142 -> m (M.Map ModuleName [(Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)])
4243findImports = foldM (go Nothing) M.empty
@@ -55,7 +56,7 @@ type ImportDef = (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)
5556--
5657resolveImports
5758 :: forall m
58− . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
59+ . (MonadError MultipleErrors m, MonadWriter MultipleErrors m)
5960 => Env
6061 -> Module
6162 -> m (Module, Imports)
@@ -98,7 +99,8 @@ resolveImports env (Module ss coms currentModule decls exps) =
9899
99100 return ()
100101
101− let scope = M.insert currentModule [(Nothing, Implicit True, Nothing)] imports
102+ let imports' = M.map (map (\(ss', dt, mmn) -> (ss', Just dt, mmn))) imports
103+ scope = M.insert currentModule [(Nothing, Nothing, Nothing)] imports'
102104 resolved <- foldM (resolveModuleImport env) nullImports (M.toList scope)
103105 return (Module ss coms currentModule decls' exps, resolved)
104106
@@ -123,7 +125,7 @@ resolveImports env (Module ss coms currentModule decls exps) =
123125 ModuleRef name -> warnDupe pos $ "module " ++ runModuleName name
124126 _ -> return ()
125127
126− warnDupeDctors :: Maybe SourceSpan -> [ProperName] -> m ()
128+ warnDupeDctors :: Maybe SourceSpan -> [ProperName 'ConstructorName] -> m ()
127129 warnDupeDctors pos = traverse_ (warnDupe pos . ("data constructor " ++) . runProperName)
128130
129131 warnDupe :: Maybe SourceSpan -> String -> m ()
@@ -134,11 +136,11 @@ resolveImports env (Module ss coms currentModule decls exps) =
134136
135137 updateImportRef :: Declaration -> m Declaration
136138 updateImportRef (PositionedDeclaration pos com d) =
137− warnWithPosition pos $ PositionedDeclaration pos com <$> updateImportRef d
139+ warnAndRethrowWithPosition pos $ PositionedDeclaration pos com <$> updateImportRef d
138140 updateImportRef (ImportDeclaration mn typ qual isOldSyntax) = do
139141 modExports <- getExports env mn
140142 typ' <- case typ of
141− Implicit b -> return $ Implicit b
143+ Implicit -> return Implicit
142144 Explicit refs -> Explicit <$> updateProperRef mn modExports `traverse` refs
143145 Hiding refs -> Hiding <$> updateProperRef mn modExports `traverse` refs
144146 return $ ImportDeclaration mn typ' qual isOldSyntax
@@ -146,11 +148,11 @@ resolveImports env (Module ss coms currentModule decls exps) =
146148
147149 updateProperRef :: ModuleName -> Exports -> DeclarationRef -> m DeclarationRef
148150 updateProperRef importModule modExports (ProperRef name) =
149− if name `elem` (fst `map` exportedTypeClasses modExports)
151+ if ProperName name `elem` (fst `map` exportedTypeClasses modExports)
150152 then do
151− tell . errorMessage $ DeprecatedClassImport importModule name
152− return $ TypeClassRef name
153− else return $ TypeRef name (Just [])
153+ tell . errorMessage $ DeprecatedClassImport importModule (ProperName name)
154+ return . TypeClassRef $ ProperName name
155+ else return $ TypeRef (ProperName name) (Just [])
154156 updateProperRef importModule modExports (PositionedDeclarationRef pos com ref) =
155157 PositionedDeclarationRef pos com <$> updateProperRef importModule modExports ref
156158 updateProperRef _ _ other = return other
@@ -158,17 +160,22 @@ resolveImports env (Module ss coms currentModule decls exps) =
158160-- | Constructs a set of imports for a single module import.
159161resolveModuleImport
160162 :: forall m
161− . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
163+ . (MonadError MultipleErrors m, MonadWriter MultipleErrors m)
162164 => Env
163165 -> Imports
164− -> (ModuleName, [(Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)])
166+ -> (ModuleName, [(Maybe SourceSpan, Maybe ImportDeclarationType, Maybe ModuleName)])
165167 -> m Imports
166168resolveModuleImport env ie (mn, imps) = foldM go ie imps
167169 where
168− go :: Imports -> (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName) -> m Imports
170+ go :: Imports
171+ -> (Maybe SourceSpan, Maybe ImportDeclarationType, Maybe ModuleName)
172+ -> m Imports
169173 go ie' (pos, typ, impQual) = do
170174 modExports <- positioned $ maybe (throwError . errorMessage $ UnknownModule mn) (return . envModuleExports) $ mn `M.lookup` env
171− let ie'' = ie' { importedModules = mn : importedModules ie' }
175+ let virtualModules = importedVirtualModules ie'
176+ ie'' = ie' { importedModules = S.insert mn (importedModules ie')
177+ , importedVirtualModules = maybe virtualModules (`S.insert` virtualModules) impQual
178+ }
172179 positioned $ resolveImport mn modExports ie'' impQual typ
173180 where
174181 positioned err = case pos of
@@ -180,20 +187,21 @@ resolveModuleImport env ie (mn, imps) = foldM go ie imps
180187--
181188resolveImport
182189 :: forall m
183− . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
190+ . (MonadError MultipleErrors m, MonadWriter MultipleErrors m)
184191 => ModuleName
185192 -> Exports
186193 -> Imports
187194 -> Maybe ModuleName
188− -> ImportDeclarationType
195+ -> Maybe ImportDeclarationType
189196 -> m Imports
190197resolveImport importModule exps imps impQual = resolveByType
191198 where
192199
193− resolveByType :: ImportDeclarationType -> m Imports
194− resolveByType (Implicit _) = importAll importExplicit
195− resolveByType (Explicit refs) = checkRefs False refs >> foldM importExplicit imps refs
196− resolveByType (Hiding refs) = do
200+ resolveByType :: Maybe ImportDeclarationType -> m Imports
201+ resolveByType Nothing = importAll (importRef Local)
202+ resolveByType (Just Implicit) = importAll (importRef FromImplicit)
203+ resolveByType (Just (Explicit refs)) = checkRefs False refs >> foldM (importRef FromExplicit) imps refs
204+ resolveByType (Just (Hiding refs)) = do
197205 imps' <- checkRefs True refs >> importAll (importNonHidden refs)
198206 let isEmptyImport
199207 = M.null (importedTypes imps')
@@ -222,18 +230,27 @@ resolveImport importModule exps imps impQual = resolveByType
222230 check r = internalError $ "Invalid argument to checkRefs: " ++ show r
223231
224232 -- Check that an explicitly imported item exists in the module it is being imported from
225− checkImportExists :: (Eq a) => (ModuleName -> a -> SimpleErrorMessage) -> [a] -> a -> m ()
233+ checkImportExists
234+ :: Eq a
235+ => (ModuleName -> a -> SimpleErrorMessage)
236+ -> [a]
237+ -> a
238+ -> m ()
226239 checkImportExists unknown exports item =
227240 when (item `notElem` exports) $ throwError . errorMessage $ unknown importModule item
228241
229242 -- Ensure that an explicitly imported data constructor exists for the type it is being imported
230243 -- from
231− checkDctorExists :: ProperName -> [ProperName] -> ProperName -> m ()
244+ checkDctorExists
245+ :: ProperName 'TypeName
246+ -> [ProperName 'ConstructorName]
247+ -> ProperName 'ConstructorName
248+ -> m ()
232249 checkDctorExists tcon = checkImportExists (flip UnknownImportDataConstructor tcon)
233250
234251 importNonHidden :: [DeclarationRef] -> Imports -> DeclarationRef -> m Imports
235252 importNonHidden hidden m ref | isHidden ref = return m
236− | otherwise = importExplicit m ref
253+ | otherwise = importRef FromImplicit m ref
237254 where
238255 -- TODO: rework this to be not confusing
239256 isHidden :: DeclarationRef -> Bool
@@ -255,30 +272,29 @@ resolveImport importModule exps imps impQual = resolveByType
255272 imp'' <- foldM (\m (name, _) -> importer m (ValueRef name)) imp' (exportedValues exps)
256273 foldM (\m (name, _) -> importer m (TypeClassRef name)) imp'' (exportedTypeClasses exps)
257274
258− -- Import something explicitly
259− importExplicit :: Imports -> DeclarationRef -> m Imports
260− importExplicit imp (PositionedDeclarationRef pos _ r) =
261− warnAndRethrowWithPosition pos $ importExplicit imp r
262− importExplicit imp (ValueRef name) = do
263− let values' = updateImports (importedValues imp) (exportedValues exps) name
275+ importRef :: ImportProvenance -> Imports -> DeclarationRef -> m Imports
276+ importRef prov imp (PositionedDeclarationRef pos _ r) =
277+ warnAndRethrowWithPosition pos $ importRef prov imp r
278+ importRef prov imp (ValueRef name) = do
279+ let values' = updateImports (importedValues imp) (exportedValues exps) name prov
264280 return $ imp { importedValues = values' }
265− importExplicit imp (TypeRef name dctors) = do
266− let types' = updateImports (importedTypes imp) (first fst `map` exportedTypes exps) name
267− let exportedDctors :: [(ProperName, ModuleName)]
281+ importRef prov imp (TypeRef name dctors) = do
282+ let types' = updateImports (importedTypes imp) (first fst `map` exportedTypes exps) name prov
283+ let exportedDctors :: [(ProperName 'ConstructorName, ModuleName)]
268284 exportedDctors = allExportedDataConstructors name
269− dctorNames :: [ProperName]
285+ dctorNames :: [ProperName 'ConstructorName]
270286 dctorNames = fst `map` exportedDctors
271287 maybe (return ()) (traverse_ $ checkDctorExists name dctorNames) dctors
272288 when (null dctorNames && isNothing dctors) . tell . errorMessage $ MisleadingEmptyTypeImport importModule name
273− let dctors' = foldl (\m -> updateImports m exportedDctors) (importedDataConstructors imp) (fromMaybe dctorNames dctors)
289+ let dctors' = foldl (\m d -> updateImports m exportedDctors d prov) (importedDataConstructors imp) (fromMaybe dctorNames dctors)
274290 return $ imp { importedTypes = types', importedDataConstructors = dctors' }
275− importExplicit imp (TypeClassRef name) = do
276− let typeClasses' = updateImports (importedTypeClasses imp) (exportedTypeClasses exps) name
291+ importRef prov imp (TypeClassRef name) = do
292+ let typeClasses' = updateImports (importedTypeClasses imp) (exportedTypeClasses exps) name prov
277293 return $ imp { importedTypeClasses = typeClasses' }
278− importExplicit _ _ = internalError "Invalid argument to importExplicit"
294+ importRef _ _ _ = internalError "Invalid argument to importRef"
279295
280296 -- Find all exported data constructors for a given type
281− allExportedDataConstructors :: ProperName -> [(ProperName, ModuleName)]
297+ allExportedDataConstructors :: ProperName 'TypeName -> [(ProperName 'ConstructorName, ModuleName)]
282298 allExportedDataConstructors name =
283299 case find ((== name) . fst . fst) (exportedTypes exps) of
284300 Nothing -> internalError "Invalid state in allExportedDataConstructors"
@@ -287,11 +303,17 @@ resolveImport importModule exps imps impQual = resolveByType
287303 -- Add something to an import resolution list
288304 updateImports
289305 :: (Ord a)
290− => M.Map (Qualified a) [(Qualified a, ModuleName)]
306+ => M.Map (Qualified a) [ImportRecord a]
291307 -> [(a, ModuleName)]
292308 -> a
293− -> M.Map (Qualified a) [(Qualified a, ModuleName)]
294− updateImports imps' exps' name =
295− let mnOrig = fromMaybe (internalError "Invalid state in updateImports") (name `lookup` exps')
296− currNames = fromMaybe [] (M.lookup (Qualified impQual name) imps')
297− in M.insert (Qualified impQual name) ((Qualified (Just importModule) name, mnOrig) : currNames) imps'
309+ -> ImportProvenance
310+ -> M.Map (Qualified a) [ImportRecord a]
311+ updateImports imps' exps' name prov =
312+ let
313+ mnOrig = fromMaybe (internalError "Invalid state in updateImports") (name `lookup` exps')
314+ rec = ImportRecord (Qualified (Just importModule) name) mnOrig prov
315+ in
316+ M.alter
317+ (\currNames -> Just $ rec : fromMaybe [] currNames)
318+ (Qualified impQual name)
319+ imps'
src/Language/PureScript/Sugar/ObjectWildcards.hs+41−16
@@ -1,4 +1,5 @@
11{-# LANGUAGE FlexibleContexts #-}
2+{-# LANGUAGE PatternGuards #-}
23{-# LANGUAGE ScopedTypeVariables #-}
34
45module Language.PureScript.Sugar.ObjectWildcards (
@@ -8,46 +9,70 @@ module Language.PureScript.Sugar.ObjectWildcards (
89import Prelude ()
910import Prelude.Compat
1011
11−import Control.Arrow (second)
1212import Control.Monad.Error.Class (MonadError(..))
1313import Control.Monad.Supply.Class
1414
1515import Data.List (partition)
16−import Data.Maybe (isJust, fromJust, catMaybes)
16+import Data.Maybe (catMaybes)
1717
1818import Language.PureScript.AST
1919import Language.PureScript.Errors
2020import Language.PureScript.Names
2121
22−desugarObjectConstructors :: forall m. (Applicative m, MonadSupply m, MonadError MultipleErrors m) => Module -> m Module
22+desugarObjectConstructors
23+ :: forall m
24+ . (MonadSupply m, MonadError MultipleErrors m)
25+ => Module
26+ -> m Module
2327desugarObjectConstructors (Module ss coms mn ds exts) = Module ss coms mn <$> mapM desugarDecl ds <*> pure exts
2428 where
2529
2630 desugarDecl :: Declaration -> m Declaration
27− (desugarDecl, _, _) = everywhereOnValuesM return desugarExpr return
31+ desugarDecl (PositionedDeclaration pos com d) = rethrowWithPosition pos $ PositionedDeclaration pos com <$> desugarDecl d
32+ desugarDecl other = f other
33+ where
34+ (f, _, _) = everywhereOnValuesTopDownM return desugarExpr return
2835
2936 desugarExpr :: Expr -> m Expr
30− desugarExpr (ObjectConstructor ps) = wrapLambda ObjectLiteral ps
31− desugarExpr (ObjectUpdater (Just obj) ps) = wrapLambda (ObjectUpdate obj) ps
32− desugarExpr (ObjectUpdater Nothing ps) = do
37+ desugarExpr AnonymousArgument = throwError . errorMessage $ IncorrectAnonymousArgument
38+ desugarExpr (Parens b)
39+ | b' <- stripPositionInfo b
40+ , BinaryNoParens op val u <- b'
41+ , isAnonymousArgument u = return $ OperatorSection op (Left val)
42+ | b' <- stripPositionInfo b
43+ , BinaryNoParens op u val <- b'
44+ , isAnonymousArgument u = return $ OperatorSection op (Right val)
45+ desugarExpr (Literal (ObjectLiteral ps)) = wrapLambda (Literal . ObjectLiteral) ps
46+ desugarExpr (ObjectUpdate u ps) | isAnonymousArgument u = do
3347 obj <- freshIdent'
3448 Abs (Left obj) <$> wrapLambda (ObjectUpdate (Var (Qualified Nothing obj))) ps
35− desugarExpr (ObjectGetter prop) = do
49+ desugarExpr (ObjectUpdate obj ps) = wrapLambda (ObjectUpdate obj) ps
50+ desugarExpr (Accessor prop u) | isAnonymousArgument u = do
3651 arg <- freshIdent'
3752 return $ Abs (Left arg) (Accessor prop (Var (Qualified Nothing arg)))
3853 desugarExpr e = return e
3954
40− wrapLambda :: ([(String, Expr)] -> Expr) -> [(String, Maybe Expr)] -> m Expr
55+ wrapLambda :: ([(String, Expr)] -> Expr) -> [(String, Expr)] -> m Expr
4156 wrapLambda mkVal ps =
42− let (props, args) = partition (isJust . snd) ps
57+ let (args, props) = partition (isAnonymousArgument . snd) ps
4358 in if null args
44− then return . mkVal $ second fromJust `map` props
59+ then return $ mkVal props
4560 else do
4661 (args', ps') <- unzip <$> mapM mkProp ps
4762 return $ foldr (Abs . Left) (mkVal ps') (catMaybes args')
4863
49− mkProp :: (String, Maybe Expr) -> m (Maybe Ident, (String, Expr))
50− mkProp (name, Just e) = return (Nothing, (name, e))
51− mkProp (name, Nothing) = do
52− arg <- freshIdent'
53− return (Just arg, (name, Var (Qualified Nothing arg)))
64+ stripPositionInfo :: Expr -> Expr
65+ stripPositionInfo (PositionedValue _ _ e) = stripPositionInfo e
66+ stripPositionInfo e = e
67+
68+ isAnonymousArgument :: Expr -> Bool
69+ isAnonymousArgument AnonymousArgument = True
70+ isAnonymousArgument (PositionedValue _ _ e) = isAnonymousArgument e
71+ isAnonymousArgument _ = False
72+
73+ mkProp :: (String, Expr) -> m (Maybe Ident, (String, Expr))
74+ mkProp (name, e)
75+ | isAnonymousArgument e = do
76+ arg <- freshIdent'
77+ return (Just arg, (name, Var (Qualified Nothing arg)))
78+ | otherwise = return (Nothing, (name, e))
src/Language/PureScript/Sugar/Operators.hs+99−86
@@ -2,6 +2,7 @@
22{-# LANGUAGE FlexibleContexts #-}
33{-# LANGUAGE ScopedTypeVariables #-}
44{-# LANGUAGE RecordWildCards #-}
5+{-# LANGUAGE TupleSections #-}
56
67-- |
78-- This module implements the desugaring pass which reapplies binary operators based
@@ -19,52 +20,92 @@ module Language.PureScript.Sugar.Operators (
1920import Prelude ()
2021import Prelude.Compat
2122
22−import Language.PureScript.Crash
2323import Language.PureScript.AST
24+import Language.PureScript.Crash
2425import Language.PureScript.Errors
25−import Language.PureScript.Names
2626import Language.PureScript.Externs
27+import Language.PureScript.Names
28+import Language.PureScript.Sugar.Operators.Binders
29+import Language.PureScript.Sugar.Operators.Expr
30+import Language.PureScript.Traversals (defS)
2731
28−import Control.Monad.State
2932import Control.Monad.Error.Class (MonadError(..))
3033import Control.Monad.Supply.Class
3134
3235import Data.Function (on)
33−import Data.Functor.Identity
3436import Data.List (groupBy, sortBy)
35−import Data.Maybe (mapMaybe, fromMaybe)
37+import Data.Maybe (mapMaybe)
3638import qualified Data.Map as M
3739
38−import qualified Text.Parsec as P
39−import qualified Text.Parsec.Pos as P
40−import qualified Text.Parsec.Expr as P
41−
4240import qualified Language.PureScript.Constants as C
4341
42+-- TODO: in 0.9 operators names can have their own type rather than being in a sum with `Ident`, and `AliasName` no longer needs to be optional
43+
44+-- |
45+-- An operator associated with its declaration position, fixity, and the name
46+-- of the function or data constructor it is an alias for.
47+--
48+type FixityRecord = (Qualified Ident, SourceSpan, Fixity, Maybe AliasName)
49+
50+-- |
51+-- An operator can be an alias for a function or a data constructor.
52+--
53+type AliasName = Either (Qualified Ident) (Qualified (ProperName 'ConstructorName))
54+
4455-- |
4556-- Remove explicit parentheses and reorder binary operator applications
4657--
47−rebracket :: (Applicative m, MonadError MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module]
58+rebracket
59+ :: forall m
60+ . (MonadError MultipleErrors m)
61+ => [ExternsFile]
62+ -> [Module]
63+ -> m [Module]
4864rebracket externs ms = do
4965 let fixities = concatMap externsFixities externs ++ concatMap collectFixities ms
5066 ensureNoDuplicates $ map (\(i, pos, _, _) -> (i, pos)) fixities
5167 let opTable = customOperatorTable $ map (\(i, _, f, _) -> (i, f)) fixities
5268 ms' <- traverse (rebracketModule opTable) ms
5369 let aliased = M.fromList (mapMaybe makeLookupEntry fixities)
54− return $ renameAliasedOperators aliased `map` ms'
70+ mapM (renameAliasedOperators aliased) ms'
5571
5672 where
5773
58− makeLookupEntry :: (Qualified Ident, SourceSpan, Fixity, Maybe Ident) -> Maybe (Qualified Ident, Qualified Ident)
59− makeLookupEntry (qname@(Qualified qual _), _, _, Just alias) = Just (qname, Qualified qual alias)
60− makeLookupEntry _ = Nothing
74+ makeLookupEntry :: FixityRecord -> Maybe (Qualified Ident, AliasName)
75+ makeLookupEntry (qname, _, _, alias) = (qname, ) <$> alias
6176
62− renameAliasedOperators :: M.Map (Qualified Ident) (Qualified Ident) -> Module -> Module
63− renameAliasedOperators aliased (Module ss coms mn ds exts) = Module ss coms mn (map f' ds) exts
77+ renameAliasedOperators :: M.Map (Qualified Ident) AliasName -> Module -> m Module
78+ renameAliasedOperators aliased (Module ss coms mn ds exts) =
79+ Module ss coms mn <$> mapM f' ds <*> pure exts
6480 where
65− (f', _, _) = everywhereOnValues id go id
66− go (Var name) = Var $ fromMaybe name (name `M.lookup` aliased)
67− go other = other
81+ (f', _, _, _, _) = everywhereWithContextOnValuesM Nothing goDecl goExpr goBinder defS defS
82+
83+ goDecl :: Maybe SourceSpan -> Declaration -> m (Maybe SourceSpan, Declaration)
84+ goDecl _ d@(PositionedDeclaration pos _ _) = return (Just pos, d)
85+ goDecl pos other = return (pos, other)
86+
87+ goExpr :: Maybe SourceSpan -> Expr -> m (Maybe SourceSpan, Expr)
88+ goExpr _ e@(PositionedValue pos _ _) = return (Just pos, e)
89+ goExpr pos (Var name) = return (pos, case name `M.lookup` aliased of
90+ Just (Left alias) -> Var alias
91+ Just (Right alias) -> Constructor alias
92+ Nothing -> Var name)
93+ goExpr pos other = return (pos, other)
94+
95+ goBinder :: Maybe SourceSpan -> Binder -> m (Maybe SourceSpan, Binder)
96+ goBinder _ b@(PositionedBinder pos _ _) = return (Just pos, b)
97+ goBinder pos (BinaryNoParensBinder (OpBinder name) lhs rhs) = case name `M.lookup` aliased of
98+ Just (Left alias) ->
99+ maybe id rethrowWithPosition pos $
100+ throwError . errorMessage $ InvalidOperatorInBinder (disqualify name) (disqualify alias)
101+ Just (Right alias) ->
102+ return (pos, ConstructorBinder alias [lhs, rhs])
103+ Nothing ->
104+ maybe id rethrowWithPosition pos $
105+ throwError . errorMessage $ UnknownValue name
106+ goBinder _ (BinaryNoParensBinder _ _ _) =
107+ internalError "BinaryNoParensBinder has no OpBinder"
108+ goBinder pos other = return (pos, other)
68109
69110removeSignedLiterals :: Module -> Module
70111removeSignedLiterals (Module ss coms mn ds exts) = Module ss coms mn (map f' ds) exts
@@ -74,35 +115,46 @@ removeSignedLiterals (Module ss coms mn ds exts) = Module ss coms mn (map f' ds)
74115 go (UnaryMinus val) = App (Var (Qualified Nothing (Ident C.negate))) val
75116 go other = other
76117
77−rebracketModule :: (Applicative m, MonadError MultipleErrors m) => [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]] -> Module -> m Module
118+rebracketModule
119+ :: (MonadError MultipleErrors m)
120+ => [[(Qualified Ident, Associativity)]]
121+ -> Module
122+ -> m Module
78123rebracketModule opTable (Module ss coms mn ds exts) =
79− let (f, _, _) = everywhereOnValuesTopDownM return (matchOperators opTable) return
124+ let (f, _, _) = everywhereOnValuesTopDownM return (matchExprOperators opTable) (matchBinderOperators opTable)
80125 in Module ss coms mn <$> (map removeParens <$> parU ds f) <*> pure exts
81126
82127removeParens :: Declaration -> Declaration
83128removeParens =
84− let (f, _, _) = everywhereOnValues id go id
129+ let (f, _, _) = everywhereOnValues id goExpr goBinder
85130 in f
86131 where
87− go (Parens val) = val
88− go val = val
89−
90−externsFixities :: ExternsFile -> [(Qualified Ident, SourceSpan, Fixity, Maybe Ident)]
132+ goExpr (Parens val) = val
133+ goExpr val = val
134+ goBinder (ParensInBinder b) = b
135+ goBinder b = b
136+
137+externsFixities
138+ :: ExternsFile
139+ -> [FixityRecord]
91140externsFixities ExternsFile{..} =
92− [ (Qualified (Just efModuleName) (Op op), internalModuleSourceSpan "", Fixity assoc prec, alias)
93− | ExternsFixity assoc prec op alias <- efFixities
94− ]
141+ [ (Qualified (Just efModuleName) (Op op), internalModuleSourceSpan "", Fixity assoc prec, alias)
142+ | ExternsFixity assoc prec op alias <- efFixities
143+ ]
95144
96−collectFixities :: Module -> [(Qualified Ident, SourceSpan, Fixity, Maybe Ident)]
145+collectFixities :: Module -> [FixityRecord]
97146collectFixities (Module _ _ moduleName ds _) = concatMap collect ds
98147 where
99− collect :: Declaration -> [(Qualified Ident, SourceSpan, Fixity, Maybe Ident)]
148+ collect :: Declaration -> [FixityRecord]
100149 collect (PositionedDeclaration pos _ (FixityDeclaration fixity name alias)) =
101150 [(Qualified (Just moduleName) (Op name), pos, fixity, alias)]
102151 collect FixityDeclaration{} = internalError "Fixity without srcpos info"
103152 collect _ = []
104153
105−ensureNoDuplicates :: (MonadError MultipleErrors m) => [(Qualified Ident, SourceSpan)] -> m ()
154+ensureNoDuplicates
155+ :: MonadError MultipleErrors m
156+ => [(Qualified Ident, SourceSpan)]
157+ -> m ()
106158ensureNoDuplicates m = go $ sortBy (compare `on` fst) m
107159 where
108160 go [] = return ()
@@ -113,63 +165,24 @@ ensureNoDuplicates m = go $ sortBy (compare `on` fst) m
113165 throwError . errorMessage $ MultipleFixities name
114166 go (_ : rest) = go rest
115167
116−customOperatorTable :: [(Qualified Ident, Fixity)] -> [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]]
168+customOperatorTable
169+ :: [(Qualified Ident, Fixity)]
170+ -> [[(Qualified Ident, Associativity)]]
117171customOperatorTable fixities =
118172 let
119− applyUserOp ident t1 = App (App (Var ident) t1)
120− userOps = map (\(name, Fixity a p) -> (name, applyUserOp name, p, a)) fixities
121− sorted = sortBy (flip compare `on` (\(_, _, p, _) -> p)) userOps
122− groups = groupBy ((==) `on` (\(_, _, p, _) -> p)) sorted
173+ userOps = map (\(name, Fixity a p) -> (name, p, a)) fixities
174+ sorted = sortBy (flip compare `on` (\(_, p, _) -> p)) userOps
175+ groups = groupBy ((==) `on` (\(_, p, _) -> p)) sorted
123176 in
124− map (map (\(name, f, _, a) -> (name, f, a))) groups
125−
126−type Chain = [Either Expr Expr]
127−
128−matchOperators :: forall m. (MonadError MultipleErrors m) => [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]] -> Expr -> m Expr
129−matchOperators ops = parseChains
130− where
131− parseChains :: Expr -> m Expr
132− parseChains b@BinaryNoParens{} = bracketChain (extendChain b)
133− parseChains other = return other
134− extendChain :: Expr -> Chain
135− extendChain (BinaryNoParens op l r) = Left l : Right op : extendChain r
136− extendChain other = [Left other]
137− bracketChain :: Chain -> m Expr
138− bracketChain = either (\_ -> internalError "matchOperators: cannot reorder operators") return . P.parse (P.buildExpressionParser opTable parseValue <* P.eof) "operator expression"
139− opTable = [P.Infix (P.try (parseTicks >>= \op -> return (\t1 t2 -> App (App op t1) t2))) P.AssocLeft]
140− : map (map (\(name, f, a) -> P.Infix (P.try (matchOp name) >> return f) (toAssoc a))) ops
141− ++ [[ P.Infix (P.try (parseOp >>= \ident -> return (\t1 t2 -> App (App (Var ident) t1) t2))) P.AssocLeft ]]
142−
143−toAssoc :: Associativity -> P.Assoc
144−toAssoc Infixl = P.AssocLeft
145−toAssoc Infixr = P.AssocRight
146−toAssoc Infix = P.AssocNone
147−
148−token :: (P.Stream s Identity t) => (t -> Maybe a) -> P.Parsec s u a
149−token = P.token (const "") (const (P.initialPos ""))
150−
151−parseValue :: P.Parsec Chain () Expr
152−parseValue = token (either Just (const Nothing)) P.<?> "expression"
153−
154−parseOp :: P.Parsec Chain () (Qualified Ident)
155−parseOp = token (either (const Nothing) fromOp) P.<?> "operator"
156− where
157− fromOp (Var q@(Qualified _ (Op _))) = Just q
158− fromOp _ = Nothing
159−
160−parseTicks :: P.Parsec Chain () Expr
161−parseTicks = token (either (const Nothing) fromOther) P.<?> "infix function"
162− where
163− fromOther (Var (Qualified _ (Op _))) = Nothing
164− fromOther v = Just v
165−
166−matchOp :: Qualified Ident -> P.Parsec Chain () ()
167−matchOp op = do
168− ident <- parseOp
169− guard $ ident == op
170−
171−desugarOperatorSections :: forall m. (Applicative m, MonadSupply m, MonadError MultipleErrors m) => Module -> m Module
172−desugarOperatorSections (Module ss coms mn ds exts) = Module ss coms mn <$> traverse goDecl ds <*> pure exts
177+ map (map (\(name, _, a) -> (name, a))) groups
178+
179+desugarOperatorSections
180+ :: forall m
181+ . (MonadSupply m, MonadError MultipleErrors m)
182+ => Module
183+ -> m Module
184+desugarOperatorSections (Module ss coms mn ds exts) =
185+ Module ss coms mn <$> traverse goDecl ds <*> pure exts
173186 where
174187
175188 goDecl :: Declaration -> m Declaration
src/Language/PureScript/Sugar/Operators/Binders.hsnew file+43
@@ -0,0 +1,43 @@
1+{-# LANGUAGE FlexibleContexts #-}
2+{-# LANGUAGE ScopedTypeVariables #-}
3+
4+module Language.PureScript.Sugar.Operators.Binders where
5+
6+import Prelude ()
7+import Prelude.Compat
8+
9+import Control.Monad.Error.Class (MonadError(..))
10+
11+import qualified Text.Parsec as P
12+import qualified Text.Parsec.Expr as P
13+
14+import Language.PureScript.Crash
15+import Language.PureScript.AST
16+import Language.PureScript.Errors
17+import Language.PureScript.Names
18+import Language.PureScript.Sugar.Operators.Common
19+
20+matchBinderOperators
21+ :: forall m
22+ . MonadError MultipleErrors m
23+ => [[(Qualified Ident, Associativity)]]
24+ -> Binder
25+ -> m Binder
26+matchBinderOperators ops = parseChains
27+ where
28+ parseChains :: Binder -> m Binder
29+ parseChains b@BinaryNoParensBinder{} = bracketChain (extendChain b)
30+ parseChains other = return other
31+ extendChain :: Binder -> Chain Binder
32+ extendChain (BinaryNoParensBinder op l r) = Left l : Right op : extendChain r
33+ extendChain other = [Left other]
34+ bracketChain :: Chain Binder -> m Binder
35+ bracketChain =
36+ either
37+ (\_ -> internalError "matchBinderOperators: cannot reorder operators")
38+ return
39+ . P.parse opParser "operator expression"
40+ opParser = P.buildExpressionParser (opTable ops fromOp reapply) parseValue <* P.eof
41+ fromOp (OpBinder q@(Qualified _ (Op _))) = Just q
42+ fromOp _ = Nothing
43+ reapply = BinaryNoParensBinder . OpBinder
src/Language/PureScript/Sugar/Operators/Common.hsnew file+53
@@ -0,0 +1,53 @@
1+{-# LANGUAGE FlexibleContexts #-}
2+{-# LANGUAGE ScopedTypeVariables #-}
3+
4+module Language.PureScript.Sugar.Operators.Common where
5+
6+import Prelude ()
7+import Prelude.Compat
8+
9+import Control.Monad.State
10+
11+import Data.Functor.Identity
12+
13+import qualified Text.Parsec as P
14+import qualified Text.Parsec.Pos as P
15+import qualified Text.Parsec.Expr as P
16+
17+import Language.PureScript.AST
18+import Language.PureScript.Names
19+
20+type Chain a = [Either a a]
21+
22+toAssoc :: Associativity -> P.Assoc
23+toAssoc Infixl = P.AssocLeft
24+toAssoc Infixr = P.AssocRight
25+toAssoc Infix = P.AssocNone
26+
27+token :: (P.Stream s Identity t) => (t -> Maybe a) -> P.Parsec s u a
28+token = P.token (const "") (const (P.initialPos ""))
29+
30+parseValue :: P.Parsec (Chain a) () a
31+parseValue = token (either Just (const Nothing)) P.<?> "expression"
32+
33+parseOp
34+ :: (a -> (Maybe (Qualified Ident)))
35+ -> P.Parsec (Chain a) () (Qualified Ident)
36+parseOp fromOp = token (either (const Nothing) fromOp) P.<?> "operator"
37+
38+matchOp
39+ :: (a -> (Maybe (Qualified Ident)))
40+ -> Qualified Ident
41+ -> P.Parsec (Chain a) () ()
42+matchOp fromOp op = do
43+ ident <- parseOp fromOp
44+ guard $ ident == op
45+
46+opTable
47+ :: [[(Qualified Ident, Associativity)]]
48+ -> (a -> Maybe (Qualified Ident))
49+ -> (Qualified Ident -> a -> a -> a)
50+ -> [[P.Operator (Chain a) () Identity a]]
51+opTable ops fromOp reapply =
52+ map (map (\(name, a) -> P.Infix (P.try (matchOp fromOp name) >> return (reapply name)) (toAssoc a))) ops
53+ ++ [[ P.Infix (P.try (parseOp fromOp >>= \ident -> return (reapply ident))) P.AssocLeft ]]
src/Language/PureScript/Sugar/Operators/Expr.hsnew file+52
@@ -0,0 +1,52 @@
1+{-# LANGUAGE FlexibleContexts #-}
2+{-# LANGUAGE ScopedTypeVariables #-}
3+
4+module Language.PureScript.Sugar.Operators.Expr where
5+
6+import Prelude ()
7+import Prelude.Compat
8+
9+import Control.Monad.Error.Class (MonadError(..))
10+
11+import qualified Text.Parsec as P
12+import qualified Text.Parsec.Expr as P
13+
14+import Language.PureScript.Crash
15+import Language.PureScript.AST
16+import Language.PureScript.Errors
17+import Language.PureScript.Names
18+import Language.PureScript.Sugar.Operators.Common
19+
20+matchExprOperators
21+ :: forall m
22+ . MonadError MultipleErrors m
23+ => [[(Qualified Ident, Associativity)]]
24+ -> Expr
25+ -> m Expr
26+matchExprOperators ops = parseChains
27+ where
28+ parseChains :: Expr -> m Expr
29+ parseChains b@BinaryNoParens{} = bracketChain (extendChain b)
30+ parseChains other = return other
31+ extendChain :: Expr -> Chain Expr
32+ extendChain (BinaryNoParens op l r) = Left l : Right op : extendChain r
33+ extendChain other = [Left other]
34+ bracketChain :: Chain Expr -> m Expr
35+ bracketChain =
36+ either
37+ (\_ -> internalError "matchExprOperators: cannot reorder operators")
38+ return
39+ . P.parse opParser "operator expression"
40+ opParser = P.buildExpressionParser opTable' parseValue <* P.eof
41+ opTable' =
42+ [ P.Infix (P.try (parseTicks >>= \op -> return (\t1 t2 -> App (App op t1) t2))) P.AssocLeft ]
43+ : opTable ops fromOp reapply
44+ fromOp (Var q@(Qualified _ (Op _))) = Just q
45+ fromOp _ = Nothing
46+ reapply op t1 t2 = App (App (Var op) t1) t2
47+
48+parseTicks :: P.Parsec (Chain Expr) () Expr
49+parseTicks = token (either (const Nothing) fromOther) P.<?> "infix function"
50+ where
51+ fromOther (Var (Qualified _ (Op _))) = Nothing
52+ fromOther v = Just v
src/Language/PureScript/Sugar/TypeClasses.hs+64−39
@@ -1,22 +1,11 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.Sugar.TypeClasses
4−-- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
5−-- License : MIT (http://opensource.org/licenses/MIT)
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
1+{-# LANGUAGE FlexibleContexts #-}
2+{-# LANGUAGE RecordWildCards #-}
3+{-# LANGUAGE ScopedTypeVariables #-}
4+
115-- |
126-- This module implements the desugaring pass which creates type synonyms for type class dictionaries
137-- and dictionary expressions for type class instances.
148--
15−-----------------------------------------------------------------------------
16−
17−{-# LANGUAGE FlexibleContexts #-}
18−{-# LANGUAGE RecordWildCards #-}
19−
209module Language.PureScript.Sugar.TypeClasses
2110 ( desugarTypeClasses
2211 , typeClassMemberName
@@ -47,7 +36,7 @@ import Data.Maybe (catMaybes, mapMaybe, isJust)
4736
4837import qualified Data.Map as M
4938
50−type MemberMap = M.Map (ModuleName, ProperName) ([(String, Maybe Kind)], [Constraint], [Declaration])
39+type MemberMap = M.Map (ModuleName, ProperName 'ClassName) ([(String, Maybe Kind)], [Constraint], [Declaration])
5140
5241type Desugar = StateT MemberMap
5342
@@ -55,17 +44,27 @@ type Desugar = StateT MemberMap
5544-- Add type synonym declarations for type class dictionary types, and value declarations for type class
5645-- instance dictionary expressions.
5746--
58−desugarTypeClasses :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module]
47+desugarTypeClasses
48+ :: (MonadSupply m, MonadError MultipleErrors m)
49+ => [ExternsFile]
50+ -> [Module]
51+ -> m [Module]
5952desugarTypeClasses externs = flip evalStateT initialState . traverse desugarModule
6053 where
6154 initialState :: MemberMap
6255 initialState = M.fromList (externs >>= \ExternsFile{..} -> mapMaybe (fromExternsDecl efModuleName) efDeclarations)
6356
64− fromExternsDecl :: ModuleName -> ExternsDeclaration -> Maybe ((ModuleName, ProperName), ([(String, Maybe Kind)], [Constraint], [Declaration]))
57+ fromExternsDecl
58+ :: ModuleName
59+ -> ExternsDeclaration
60+ -> Maybe ((ModuleName, ProperName 'ClassName), ([(String, Maybe Kind)], [Constraint], [Declaration]))
6561 fromExternsDecl mn (EDClass name args members implies) = Just ((mn, name), (args, implies, map (uncurry TypeDeclaration) members))
6662 fromExternsDecl _ _ = Nothing
6763
68−desugarModule :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Module -> Desugar m Module
64+desugarModule
65+ :: (MonadSupply m, MonadError MultipleErrors m)
66+ => Module
67+ -> Desugar m Module
6968desugarModule (Module ss coms name decls (Just exps)) = do
7069 (newExpss, declss) <- unzip <$> parU (sortBy classesFirst decls) (desugarDecl name exps)
7170 return $ Module ss coms name (concat declss) $ Just (exps ++ catMaybes newExpss)
@@ -171,7 +170,12 @@ desugarModule _ = internalError "Exports should have been elaborated in name des
171170-- return new Sub(fooString, "");
172171-- };
173172-}
174−desugarDecl :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => ModuleName -> [DeclarationRef] -> Declaration -> Desugar m (Maybe DeclarationRef, [Declaration])
173+desugarDecl
174+ :: (MonadSupply m, MonadError MultipleErrors m)
175+ => ModuleName
176+ -> [DeclarationRef]
177+ -> Declaration
178+ -> Desugar m (Maybe DeclarationRef, [Declaration])
175179desugarDecl mn exps = go
176180 where
177181 go d@(TypeClassDeclaration name args implies members) = do
@@ -187,48 +191,60 @@ desugarDecl mn exps = go
187191 return (dr, map (PositionedDeclaration pos com) ds)
188192 go other = return (Nothing, [other])
189193
190− expRef :: Ident -> Qualified ProperName -> [Type] -> Maybe DeclarationRef
194+ expRef :: Ident -> Qualified (ProperName 'ClassName) -> [Type] -> Maybe DeclarationRef
191195 expRef name className tys
192196 | isExportedClass className && all isExportedType (getConstructors `concatMap` tys) = Just $ TypeInstanceRef name
193197 | otherwise = Nothing
194198
195− isExportedClass :: Qualified ProperName -> Bool
199+ isExportedClass :: Qualified (ProperName 'ClassName) -> Bool
196200 isExportedClass = isExported (elem . TypeClassRef)
197201
198− isExportedType :: Qualified ProperName -> Bool
202+ isExportedType :: Qualified (ProperName 'TypeName) -> Bool
199203 isExportedType = isExported $ \pn -> isJust . find (matchesTypeRef pn)
200204
201− isExported :: (ProperName -> [DeclarationRef] -> Bool) -> Qualified ProperName -> Bool
205+ isExported
206+ :: (ProperName a -> [DeclarationRef] -> Bool)
207+ -> Qualified (ProperName a)
208+ -> Bool
202209 isExported test (Qualified (Just mn') pn) = mn /= mn' || test pn exps
203210 isExported _ _ = internalError "Names should have been qualified in name desugaring"
204211
205− matchesTypeRef :: ProperName -> DeclarationRef -> Bool
212+ matchesTypeRef :: ProperName 'TypeName -> DeclarationRef -> Bool
206213 matchesTypeRef pn (TypeRef pn' _) = pn == pn'
207214 matchesTypeRef _ _ = False
208215
209− getConstructors :: Type -> [Qualified ProperName]
216+ getConstructors :: Type -> [Qualified (ProperName 'TypeName)]
210217 getConstructors = everythingOnTypes (++) getConstructor
211−
212− getConstructor :: Type -> [Qualified ProperName]
213− getConstructor (TypeConstructor tcname) = [tcname]
214− getConstructor _ = []
218+ where
219+ getConstructor (TypeConstructor tcname) = [tcname]
220+ getConstructor _ = []
215221
216222memberToNameAndType :: Declaration -> (Ident, Type)
217223memberToNameAndType (TypeDeclaration ident ty) = (ident, ty)
218224memberToNameAndType (PositionedDeclaration _ _ d) = memberToNameAndType d
219225memberToNameAndType _ = internalError "Invalid declaration in type class definition"
220226
221−typeClassDictionaryDeclaration :: ProperName -> [(String, Maybe Kind)] -> [Constraint] -> [Declaration] -> Declaration
227+typeClassDictionaryDeclaration
228+ :: ProperName 'ClassName
229+ -> [(String, Maybe Kind)]
230+ -> [Constraint]
231+ -> [Declaration]
232+ -> Declaration
222233typeClassDictionaryDeclaration name args implies members =
223234 let superclassTypes = superClassDictionaryNames implies `zip`
224− [ function unit (foldl TypeApp (TypeConstructor superclass) tyArgs)
235+ [ function unit (foldl TypeApp (TypeConstructor (fmap coerceProperName superclass)) tyArgs)
225236 | (superclass, tyArgs) <- implies
226237 ]
227238 members' = map (first runIdent . memberToNameAndType) members
228239 mtys = members' ++ superclassTypes
229− in TypeSynonymDeclaration name args (TypeApp tyObject $ rowFromList (mtys, REmpty))
230−
231−typeClassMemberToDictionaryAccessor :: ModuleName -> ProperName -> [(String, Maybe Kind)] -> Declaration -> Declaration
240+ in TypeSynonymDeclaration (coerceProperName name) args (TypeApp tyObject $ rowFromList (mtys, REmpty))
241+
242+typeClassMemberToDictionaryAccessor
243+ :: ModuleName
244+ -> ProperName 'ClassName
245+ -> [(String, Maybe Kind)]
246+ -> Declaration
247+ -> Declaration
232248typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) =
233249 let className = Qualified (Just mn) name
234250 in ValueDeclaration ident Private [] $ Right $
@@ -241,7 +257,16 @@ typeClassMemberToDictionaryAccessor _ _ _ _ = internalError "Invalid declaration
241257unit :: Type
242258unit = TypeApp tyObject REmpty
243259
244−typeInstanceDictionaryDeclaration :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Ident -> ModuleName -> [Constraint] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar m Declaration
260+typeInstanceDictionaryDeclaration
261+ :: forall m
262+ . (MonadSupply m, MonadError MultipleErrors m)
263+ => Ident
264+ -> ModuleName
265+ -> [Constraint]
266+ -> Qualified (ProperName 'ClassName)
267+ -> [Type]
268+ -> [Declaration]
269+ -> Desugar m Declaration
245270typeInstanceDictionaryDeclaration name mn deps className tys decls =
246271 rethrow (addHint (ErrorInInstance className tys)) $ do
247272 m <- get
@@ -272,8 +297,8 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =
272297 , let tyArgs = map (replaceAllTypeVars (zip (map fst args) tys)) suTyArgs
273298 ]
274299
275− let props = ObjectLiteral (members ++ superclasses)
276− dictTy = foldl TypeApp (TypeConstructor className) tys
300+ let props = Literal $ ObjectLiteral (members ++ superclasses)
301+ dictTy = foldl TypeApp (TypeConstructor (fmap coerceProperName className)) tys
277302 constrainedTy = quantify (if null deps then dictTy else ConstrainedType deps dictTy)
278303 dict = TypeClassDictionaryConstructorApp className props
279304 result = ValueDeclaration name Private [] (Right (TypedValue True dict constrainedTy))
@@ -287,7 +312,7 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =
287312 declName (TypeDeclaration ident _) = Just ident
288313 declName _ = Nothing
289314
290− memberToValue :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [(Ident, Type)] -> Declaration -> Desugar m Expr
315+ memberToValue :: [(Ident, Type)] -> Declaration -> Desugar m Expr
291316 memberToValue tys' (ValueDeclaration ident _ [] (Right val)) = do
292317 _ <- maybe (throwError . errorMessage $ ExtraneousClassMember ident className) return $ lookup ident tys'
293318 return val
src/Language/PureScript/Sugar/TypeClasses/Deriving.hs+337−149
@@ -8,9 +8,7 @@
88-- |
99-- This module implements the generic deriving elaboration that takes place during desugaring.
1010--
11−module Language.PureScript.Sugar.TypeClasses.Deriving (
12− deriveInstances
13−) where
11+module Language.PureScript.Sugar.TypeClasses.Deriving (deriveInstances) where
1412
1513import Prelude ()
1614import Prelude.Compat
@@ -19,6 +17,7 @@ import Data.List (foldl', find, sortBy)
1917import Data.Maybe (fromMaybe)
2018import Data.Ord (comparing)
2119
20+import Control.Arrow (second)
2221import Control.Monad (replicateM)
2322import Control.Monad.Supply.Class (MonadSupply)
2423import Control.Monad.Error.Class (MonadError(..))
@@ -32,28 +31,46 @@ import Language.PureScript.Types
3231import qualified Language.PureScript.Constants as C
3332
3433-- | Elaborates deriving instance declarations by code generation.
35−deriveInstances :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadSupply m) => Module -> m Module
34+deriveInstances
35+ :: (MonadError MultipleErrors m, MonadSupply m)
36+ => Module
37+ -> m Module
3638deriveInstances (Module ss coms mn ds exts) = Module ss coms mn <$> mapM (deriveInstance mn ds) ds <*> pure exts
3739
3840-- | Takes a declaration, and if the declaration is a deriving TypeInstanceDeclaration,
3941-- elaborates that into an instance declaration via code generation.
40−deriveInstance :: (Functor m, MonadError MultipleErrors m, MonadSupply m) => ModuleName -> [Declaration] -> Declaration -> m Declaration
42+deriveInstance
43+ :: (MonadError MultipleErrors m, MonadSupply m)
44+ => ModuleName
45+ -> [Declaration]
46+ -> Declaration
47+ -> m Declaration
4148deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@[ty] DerivedInstance)
4249 | className == Qualified (Just dataGeneric) (ProperName C.generic)
4350 , Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor ty
4451 , mn == fromMaybe mn mn'
4552 = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveGeneric mn ds tyCon args
53+ | className == Qualified (Just (ModuleName [ ProperName "Prelude" ])) (ProperName "Eq")
54+ , Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty
55+ , mn == fromMaybe mn mn'
56+ = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveEq mn ds tyCon
57+ | className == Qualified (Just (ModuleName [ ProperName "Prelude" ])) (ProperName "Ord")
58+ , Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty
59+ , mn == fromMaybe mn mn'
60+ = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveOrd mn ds tyCon
4661deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance)
4762 = throwError . errorMessage $ CannotDerive className tys
4863deriveInstance mn ds (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> deriveInstance mn ds d
4964deriveInstance _ _ e = return e
5065
51−unwrapTypeConstructor :: Type -> Maybe (Qualified ProperName, [Type])
52−unwrapTypeConstructor (TypeConstructor tyCon) = Just (tyCon, [])
53−unwrapTypeConstructor (TypeApp ty arg) = do
54− (tyCon, args) <- unwrapTypeConstructor ty
55− return (tyCon, arg : args)
56−unwrapTypeConstructor _ = Nothing
66+unwrapTypeConstructor :: Type -> Maybe (Qualified (ProperName 'TypeName), [Type])
67+unwrapTypeConstructor = fmap (second reverse) . go
68+ where
69+ go (TypeConstructor tyCon) = Just (tyCon, [])
70+ go (TypeApp ty arg) = do
71+ (tyCon, args) <- go ty
72+ return (tyCon, arg : args)
73+ go _ = Nothing
5774
5875dataGeneric :: ModuleName
5976dataGeneric = ModuleName [ ProperName "Data", ProperName "Generic" ]
@@ -64,18 +81,306 @@ dataMaybe = ModuleName [ ProperName "Data", ProperName "Maybe" ]
6481typesProxy :: ModuleName
6582typesProxy = ModuleName [ ProperName "Type", ProperName "Proxy" ]
6683
67−deriveGeneric :: (Functor m, MonadError MultipleErrors m, MonadSupply m) => ModuleName -> [Declaration] -> ProperName -> [Type] -> m [Declaration]
68−deriveGeneric mn ds tyConNm args = do
84+deriveGeneric
85+ :: forall m. (MonadError MultipleErrors m, MonadSupply m)
86+ => ModuleName
87+ -> [Declaration]
88+ -> ProperName 'TypeName
89+ -> [Type]
90+ -> m [Declaration]
91+deriveGeneric mn ds tyConNm dargs = do
6992 tyCon <- findTypeDecl tyConNm ds
70− toSpine <- mkSpineFunction mn tyCon
71− fromSpine <- mkFromSpineFunction mn tyCon
72− let toSignature = mkSignatureFunction mn tyCon args
93+ toSpine <- mkSpineFunction tyCon
94+ fromSpine <- mkFromSpineFunction tyCon
95+ let toSignature = mkSignatureFunction tyCon dargs
7396 return [ ValueDeclaration (Ident C.toSpine) Public [] (Right toSpine)
7497 , ValueDeclaration (Ident C.fromSpine) Public [] (Right fromSpine)
7598 , ValueDeclaration (Ident C.toSignature) Public [] (Right toSignature)
7699 ]
77−
78−findTypeDecl :: (Functor m, MonadError MultipleErrors m) => ProperName -> [Declaration] -> m Declaration
100+ where
101+ mkSpineFunction :: Declaration -> m Expr
102+ mkSpineFunction (DataDeclaration _ _ _ args) = do
103+ x <- freshIdent'
104+ lamCase x <$> mapM mkCtorClause args
105+ where
106+ prodConstructor :: Expr -> Expr
107+ prodConstructor = App (Constructor (Qualified (Just dataGeneric) (ProperName "SProd")))
108+
109+ recordConstructor :: Expr -> Expr
110+ recordConstructor = App (Constructor (Qualified (Just dataGeneric) (ProperName "SRecord")))
111+
112+ mkCtorClause :: (ProperName 'ConstructorName, [Type]) -> m CaseAlternative
113+ mkCtorClause (ctorName, tys) = do
114+ idents <- replicateM (length tys) freshIdent'
115+ return $ CaseAlternative [ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)] (Right (caseResult idents))
116+ where
117+ caseResult idents =
118+ App (prodConstructor (Literal . StringLiteral . showQualified runProperName $ Qualified (Just mn) ctorName))
119+ . Literal . ArrayLiteral
120+ $ zipWith toSpineFun (map (Var . Qualified Nothing) idents) tys
121+
122+ toSpineFun :: Expr -> Type -> Expr
123+ toSpineFun i r | Just rec <- objectType r =
124+ lamNull . recordConstructor . Literal . ArrayLiteral
125+ . map
126+ (\(str,typ) ->
127+ Literal $ ObjectLiteral
128+ [ ("recLabel", Literal (StringLiteral str))
129+ , ("recValue", toSpineFun (Accessor str i) typ)
130+ ]
131+ )
132+ $ decomposeRec rec
133+ toSpineFun i _ = lamNull $ App (mkGenVar (Ident C.toSpine)) i
134+ mkSpineFunction (PositionedDeclaration _ _ d) = mkSpineFunction d
135+ mkSpineFunction _ = internalError "mkSpineFunction: expected DataDeclaration"
136+
137+ mkSignatureFunction :: Declaration -> [Type] -> Expr
138+ mkSignatureFunction (DataDeclaration _ name tyArgs args) classArgs = lamNull . mkSigProd $ map mkProdClause args
139+ where
140+ mkSigProd :: [Expr] -> Expr
141+ mkSigProd =
142+ App
143+ (App
144+ (Constructor (Qualified (Just dataGeneric) (ProperName "SigProd")))
145+ (Literal (StringLiteral (showQualified runProperName (Qualified (Just mn) name))))
146+ )
147+ . Literal
148+ . ArrayLiteral
149+
150+ mkSigRec :: [Expr] -> Expr
151+ mkSigRec = App (Constructor (Qualified (Just dataGeneric) (ProperName "SigRecord"))) . Literal . ArrayLiteral
152+
153+ proxy :: Type -> Type
154+ proxy = TypeApp (TypeConstructor (Qualified (Just typesProxy) (ProperName "Proxy")))
155+
156+ mkProdClause :: (ProperName 'ConstructorName, [Type]) -> Expr
157+ mkProdClause (ctorName, tys) =
158+ Literal $ ObjectLiteral
159+ [ ("sigConstructor", Literal (StringLiteral (showQualified runProperName (Qualified (Just mn) ctorName))))
160+ , ("sigValues", Literal . ArrayLiteral . map (mkProductSignature . instantiate) $ tys)
161+ ]
162+
163+ mkProductSignature :: Type -> Expr
164+ mkProductSignature r | Just rec <- objectType r =
165+ lamNull . mkSigRec $
166+ [ Literal $ ObjectLiteral
167+ [ ("recLabel", Literal (StringLiteral str))
168+ , ("recValue", mkProductSignature typ)
169+ ]
170+ | (str, typ) <- decomposeRec rec
171+ ]
172+ mkProductSignature typ = lamNull $ App (mkGenVar (Ident C.toSignature))
173+ (TypedValue False (mkGenVar (Ident "anyProxy")) (proxy typ))
174+ instantiate = replaceAllTypeVars (zipWith (\(arg, _) ty -> (arg, ty)) tyArgs classArgs)
175+ mkSignatureFunction (PositionedDeclaration _ _ d) classArgs = mkSignatureFunction d classArgs
176+ mkSignatureFunction _ _ = internalError "mkSignatureFunction: expected DataDeclaration"
177+
178+ mkFromSpineFunction :: Declaration -> m Expr
179+ mkFromSpineFunction (DataDeclaration _ _ _ args) = do
180+ x <- freshIdent'
181+ lamCase x <$> (addCatch <$> mapM mkAlternative args)
182+ where
183+ mkJust :: Expr -> Expr
184+ mkJust = App (Constructor (Qualified (Just dataMaybe) (ProperName "Just")))
185+
186+ mkNothing :: Expr
187+ mkNothing = Constructor (Qualified (Just dataMaybe) (ProperName "Nothing"))
188+
189+ prodBinder :: [Binder] -> Binder
190+ prodBinder = ConstructorBinder (Qualified (Just dataGeneric) (ProperName "SProd"))
191+
192+ recordBinder :: [Binder] -> Binder
193+ recordBinder = ConstructorBinder (Qualified (Just dataGeneric) (ProperName "SRecord"))
194+
195+ mkAlternative :: (ProperName 'ConstructorName, [Type]) -> m CaseAlternative
196+ mkAlternative (ctorName, tys) = do
197+ idents <- replicateM (length tys) freshIdent'
198+ return $
199+ CaseAlternative
200+ [ prodBinder
201+ [ LiteralBinder (StringLiteral (showQualified runProperName (Qualified (Just mn) ctorName)))
202+ , LiteralBinder (ArrayLiteral (map VarBinder idents))
203+ ]
204+ ]
205+ . Right
206+ $ liftApplicative
207+ (mkJust $ Constructor (Qualified (Just mn) ctorName))
208+ (zipWith fromSpineFun (map (Var . Qualified Nothing) idents) tys)
209+
210+ addCatch :: [CaseAlternative] -> [CaseAlternative]
211+ addCatch = (++ [catchAll])
212+ where
213+ catchAll = CaseAlternative [NullBinder] (Right mkNothing)
214+
215+ fromSpineFun :: Expr -> Type -> Expr
216+ fromSpineFun e r
217+ | Just rec <- objectType r
218+ = App (lamCase (Ident "r") [ mkRecCase (decomposeRec rec)
219+ , CaseAlternative [NullBinder] (Right mkNothing)
220+ ])
221+ (App e (mkPrelVar (Ident "unit")))
222+ fromSpineFun e _ = App (mkGenVar (Ident C.fromSpine)) (App e (mkPrelVar (Ident "unit")))
223+
224+ mkRecCase :: [(String, Type)] -> CaseAlternative
225+ mkRecCase rs =
226+ CaseAlternative
227+ [ recordBinder [ LiteralBinder (ArrayLiteral (map (VarBinder . Ident . fst) rs)) ] ]
228+ . Right
229+ $ liftApplicative (mkRecFun rs) (map (\(x, y) -> fromSpineFun (Accessor "recValue" (mkVar (Ident x))) y) rs)
230+
231+ mkRecFun :: [(String, Type)] -> Expr
232+ mkRecFun xs = mkJust $ foldr lam recLiteral (map (Ident . fst) xs)
233+ where recLiteral = Literal . ObjectLiteral $ map (\(s,_) -> (s, mkVar (Ident s))) xs
234+ mkFromSpineFunction (PositionedDeclaration _ _ d) = mkFromSpineFunction d
235+ mkFromSpineFunction _ = internalError "mkFromSpineFunction: expected DataDeclaration"
236+
237+ -- Helpers
238+
239+ liftApplicative :: Expr -> [Expr] -> Expr
240+ liftApplicative = foldl' (\x e -> App (App (mkPrelVar (Ident "apply")) x) e)
241+
242+ mkPrelVar :: Ident -> Expr
243+ mkPrelVar = mkVarMn (Just (ModuleName [ProperName C.prelude]))
244+
245+ mkGenVar :: Ident -> Expr
246+ mkGenVar = mkVarMn (Just (ModuleName [ProperName "Data", ProperName C.generic]))
247+
248+deriveEq ::
249+ forall m. (MonadError MultipleErrors m, MonadSupply m)
250+ => ModuleName
251+ -> [Declaration]
252+ -> ProperName 'TypeName
253+ -> m [Declaration]
254+deriveEq mn ds tyConNm = do
255+ tyCon <- findTypeDecl tyConNm ds
256+ eqFun <- mkEqFunction tyCon
257+ return [ ValueDeclaration (Ident C.eq) Public [] (Right eqFun) ]
258+ where
259+ mkEqFunction :: Declaration -> m Expr
260+ mkEqFunction (DataDeclaration _ _ _ args) = do
261+ x <- freshIdent "x"
262+ y <- freshIdent "y"
263+ lamCase2 x y <$> (addCatch <$> mapM mkCtorClause args)
264+ mkEqFunction (PositionedDeclaration _ _ d) = mkEqFunction d
265+ mkEqFunction _ = internalError "mkEqFunction: expected DataDeclaration"
266+
267+ preludeConj :: Expr -> Expr -> Expr
268+ preludeConj = App . App (Var (Qualified (Just (ModuleName [ProperName C.prelude])) (Ident C.conj)))
269+
270+ preludeEq :: Expr -> Expr -> Expr
271+ preludeEq = App . App (Var (Qualified (Just (ModuleName [ProperName C.prelude])) (Ident C.eq)))
272+
273+ addCatch :: [CaseAlternative] -> [CaseAlternative]
274+ addCatch xs
275+ | length xs /= 1 = xs ++ [catchAll]
276+ | otherwise = xs -- Avoid redundant case
277+ where
278+ catchAll = CaseAlternative [NullBinder, NullBinder] (Right (Literal (BooleanLiteral False)))
279+
280+ mkCtorClause :: (ProperName 'ConstructorName, [Type]) -> m CaseAlternative
281+ mkCtorClause (ctorName, tys) = do
282+ identsL <- replicateM (length tys) (freshIdent "l")
283+ identsR <- replicateM (length tys) (freshIdent "r")
284+ let tests = zipWith3 toEqTest (map (Var . Qualified Nothing) identsL) (map (Var . Qualified Nothing) identsR) tys
285+ return $ CaseAlternative [caseBinder identsL, caseBinder identsR] (Right (conjAll tests))
286+ where
287+ caseBinder idents = ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)
288+
289+ conjAll :: [Expr] -> Expr
290+ conjAll [] = Literal (BooleanLiteral True)
291+ conjAll xs = foldl1 preludeConj xs
292+
293+ toEqTest :: Expr -> Expr -> Type -> Expr
294+ toEqTest l r ty | Just rec <- objectType ty =
295+ conjAll
296+ . map (\(str, typ) -> toEqTest (Accessor str l) (Accessor str r) typ)
297+ $ decomposeRec rec
298+ toEqTest l r _ = preludeEq l r
299+
300+deriveOrd ::
301+ forall m. (MonadError MultipleErrors m, MonadSupply m)
302+ => ModuleName
303+ -> [Declaration]
304+ -> ProperName 'TypeName
305+ -> m [Declaration]
306+deriveOrd mn ds tyConNm = do
307+ tyCon <- findTypeDecl tyConNm ds
308+ compareFun <- mkCompareFunction tyCon
309+ return [ ValueDeclaration (Ident C.compare) Public [] (Right compareFun) ]
310+ where
311+ mkCompareFunction :: Declaration -> m Expr
312+ mkCompareFunction (DataDeclaration _ _ _ args) = do
313+ x <- freshIdent "x"
314+ y <- freshIdent "y"
315+ lamCase2 x y <$> (addCatch . concat <$> mapM mkCtorClauses (splitLast args))
316+ mkCompareFunction (PositionedDeclaration _ _ d) = mkCompareFunction d
317+ mkCompareFunction _ = internalError "mkCompareFunction: expected DataDeclaration"
318+
319+ splitLast :: [a] -> [(a, Bool)]
320+ splitLast [] = []
321+ splitLast [x] = [(x, True)]
322+ splitLast (x : xs) = (x, False) : splitLast xs
323+
324+ addCatch :: [CaseAlternative] -> [CaseAlternative]
325+ addCatch xs
326+ | null xs = [catchAll] -- No type constructors
327+ | otherwise = xs
328+ where
329+ catchAll = CaseAlternative [NullBinder, NullBinder] (Right (preludeCtor "EQ"))
330+
331+ preludeCtor :: String -> Expr
332+ preludeCtor = Constructor . Qualified (Just (ModuleName [ProperName C.prelude])) . ProperName
333+
334+ preludeCompare :: Expr -> Expr -> Expr
335+ preludeCompare = App . App (Var (Qualified (Just (ModuleName [ProperName C.prelude])) (Ident C.compare)))
336+
337+ mkCtorClauses :: ((ProperName 'ConstructorName, [Type]), Bool) -> m [CaseAlternative]
338+ mkCtorClauses ((ctorName, tys), isLast) = do
339+ identsL <- replicateM (length tys) (freshIdent "l")
340+ identsR <- replicateM (length tys) (freshIdent "r")
341+ let tests = zipWith3 toOrdering (map (Var . Qualified Nothing) identsL) (map (Var . Qualified Nothing) identsR) tys
342+ extras | not isLast = [ CaseAlternative [ ConstructorBinder (Qualified (Just mn) ctorName) (replicate (length tys) NullBinder)
343+ , NullBinder
344+ ]
345+ (Right (preludeCtor "LT"))
346+ , CaseAlternative [ NullBinder
347+ , ConstructorBinder (Qualified (Just mn) ctorName) (replicate (length tys) NullBinder)
348+ ]
349+ (Right (preludeCtor "GT"))
350+ ]
351+ | otherwise = []
352+ return $ CaseAlternative [ caseBinder identsL
353+ , caseBinder identsR
354+ ]
355+ (Right (appendAll tests))
356+ : extras
357+
358+ where
359+ caseBinder idents = ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)
360+
361+ appendAll :: [Expr] -> Expr
362+ appendAll [] = preludeCtor "EQ"
363+ appendAll [x] = x
364+ appendAll (x : xs) = Case [x] [ CaseAlternative [ ConstructorBinder (Qualified (Just (ModuleName [ProperName C.prelude])) (ProperName "LT")) [] ]
365+ (Right (preludeCtor "LT"))
366+ , CaseAlternative [ ConstructorBinder (Qualified (Just (ModuleName [ProperName C.prelude])) (ProperName "GT")) [] ]
367+ (Right (preludeCtor "GT"))
368+ , CaseAlternative [ NullBinder ]
369+ (Right (appendAll xs))
370+ ]
371+
372+ toOrdering :: Expr -> Expr -> Type -> Expr
373+ toOrdering l r ty | Just rec <- objectType ty =
374+ appendAll
375+ . map (\(str, typ) -> toOrdering (Accessor str l) (Accessor str r) typ)
376+ $ decomposeRec rec
377+ toOrdering l r _ = preludeCompare l r
378+
379+findTypeDecl
380+ :: (MonadError MultipleErrors m)
381+ => ProperName 'TypeName
382+ -> [Declaration]
383+ -> m Declaration
79384findTypeDecl tyConNm = maybe (throwError . errorMessage $ CannotFindDerivingType tyConNm) return . find isTypeDecl
80385 where
81386 isTypeDecl :: Declaration -> Bool
@@ -83,146 +388,29 @@ findTypeDecl tyConNm = maybe (throwError . errorMessage $ CannotFindDerivingType
83388 isTypeDecl (PositionedDeclaration _ _ d) = isTypeDecl d
84389 isTypeDecl _ = False
85390
86−mkSpineFunction :: forall m. (Functor m, MonadSupply m) => ModuleName -> Declaration -> m Expr
87−mkSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> mapM mkCtorClause args
88− where
89− prodConstructor :: Expr -> Expr
90− prodConstructor = App (Constructor (Qualified (Just dataGeneric) (ProperName "SProd")))
91−
92− recordConstructor :: Expr -> Expr
93− recordConstructor = App (Constructor (Qualified (Just dataGeneric) (ProperName "SRecord")))
94−
95− mkCtorClause :: (ProperName, [Type]) -> m CaseAlternative
96− mkCtorClause (ctorName, tys) = do
97− idents <- replicateM (length tys) freshIdent'
98− return $ CaseAlternative [ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)] (Right (caseResult idents))
99− where
100− caseResult idents =
101− App (prodConstructor (StringLiteral . showQualified runProperName $ Qualified (Just mn) ctorName))
102− . ArrayLiteral
103− $ zipWith toSpineFun (map (Var . Qualified Nothing) idents) tys
104−
105− toSpineFun :: Expr -> Type -> Expr
106− toSpineFun i r | Just rec <- objectType r =
107− lamNull . recordConstructor . ArrayLiteral .
108− map (\(str,typ) -> ObjectLiteral [("recLabel", StringLiteral str), ("recValue", toSpineFun (Accessor str i) typ)])
109− $ decomposeRec rec
110− toSpineFun i _ = lamNull $ App (mkGenVar C.toSpine) i
111−mkSpineFunction mn (PositionedDeclaration _ _ d) = mkSpineFunction mn d
112−mkSpineFunction _ _ = internalError "mkSpineFunction: expected DataDeclaration"
113−
114−mkSignatureFunction :: ModuleName -> Declaration -> [Type] -> Expr
115−mkSignatureFunction mn (DataDeclaration _ name tyArgs args) classArgs = lamNull . mkSigProd $ map mkProdClause args
116− where
117− mkSigProd :: [Expr] -> Expr
118− mkSigProd = App (App (Constructor (Qualified (Just dataGeneric) (ProperName "SigProd")))
119− (StringLiteral (showQualified runProperName (Qualified (Just mn) name)))
120− ) . ArrayLiteral
121−
122− mkSigRec :: [Expr] -> Expr
123− mkSigRec = App (Constructor (Qualified (Just dataGeneric) (ProperName "SigRecord"))) . ArrayLiteral
124−
125− proxy :: Type -> Type
126− proxy = TypeApp (TypeConstructor (Qualified (Just typesProxy) (ProperName "Proxy")))
127−
128− mkProdClause :: (ProperName, [Type]) -> Expr
129− mkProdClause (ctorName, tys) = ObjectLiteral [ ("sigConstructor", StringLiteral (showQualified runProperName (Qualified (Just mn) ctorName)))
130− , ("sigValues", ArrayLiteral . map (mkProductSignature . instantiate) $ tys)
131− ]
132−
133− mkProductSignature :: Type -> Expr
134− mkProductSignature r | Just rec <- objectType r =
135− lamNull . mkSigRec $ [ ObjectLiteral [ ("recLabel", StringLiteral str)
136− , ("recValue", mkProductSignature typ)
137− ]
138− | (str, typ) <- decomposeRec rec
139− ]
140− mkProductSignature typ = lamNull $ App (mkGenVar C.toSignature)
141− (TypedValue False (mkGenVar "anyProxy") (proxy typ))
142− instantiate = replaceAllTypeVars (zipWith (\(arg, _) ty -> (arg, ty)) tyArgs classArgs)
143−mkSignatureFunction mn (PositionedDeclaration _ _ d) classArgs = mkSignatureFunction mn d classArgs
144−mkSignatureFunction _ _ _ = internalError "mkSignatureFunction: expected DataDeclaration"
145−
146−mkFromSpineFunction :: forall m. (Functor m, MonadSupply m) => ModuleName -> Declaration -> m Expr
147−mkFromSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> (addCatch <$> mapM mkAlternative args)
148− where
149− mkJust :: Expr -> Expr
150− mkJust = App (Constructor (Qualified (Just dataMaybe) (ProperName "Just")))
151−
152− mkNothing :: Expr
153− mkNothing = Constructor (Qualified (Just dataMaybe) (ProperName "Nothing"))
154−
155− prodBinder :: [Binder] -> Binder
156− prodBinder = ConstructorBinder (Qualified (Just dataGeneric) (ProperName "SProd"))
157−
158− recordBinder :: [Binder] -> Binder
159− recordBinder = ConstructorBinder (Qualified (Just dataGeneric) (ProperName "SRecord"))
160−
161− mkAlternative :: (ProperName, [Type]) -> m CaseAlternative
162− mkAlternative (ctorName, tys) = do
163− idents <- replicateM (length tys) freshIdent'
164− return $ CaseAlternative [ prodBinder [ StringBinder (showQualified runProperName (Qualified (Just mn) ctorName)), ArrayBinder (map VarBinder idents)]]
165− . Right
166− $ liftApplicative (mkJust $ Constructor (Qualified (Just mn) ctorName))
167− (zipWith fromSpineFun (map (Var . Qualified Nothing) idents) tys)
168−
169− addCatch :: [CaseAlternative] -> [CaseAlternative]
170− addCatch = (++ [catchAll])
171− where
172− catchAll = CaseAlternative [NullBinder] (Right mkNothing)
173−
174− fromSpineFun e r
175− | Just rec <- objectType r
176− = App (lamCase "r" [ mkRecCase (decomposeRec rec)
177− , CaseAlternative [NullBinder] (Right mkNothing)
178− ])
179− (App e (mkPrelVar "unit"))
180−
181− fromSpineFun e _ = App (mkGenVar C.fromSpine) (App e (mkPrelVar "unit"))
182−
183− mkRecCase rs = CaseAlternative [ recordBinder [ ArrayBinder (map (VarBinder . Ident . fst) rs)
184− ]
185− ]
186− . Right
187− $ liftApplicative (mkRecFun rs) (map (\(x, y) -> fromSpineFun (Accessor "recValue" (mkVar x)) y) rs)
188−
189− mkRecFun :: [(String, Type)] -> Expr
190− mkRecFun xs = mkJust $ foldr lam recLiteral (map fst xs)
191− where recLiteral = ObjectLiteral $ map (\(s,_) -> (s,mkVar s)) xs
192−mkFromSpineFunction mn (PositionedDeclaration _ _ d) = mkFromSpineFunction mn d
193−mkFromSpineFunction _ _ = internalError "mkFromSpineFunction: expected DataDeclaration"
194−
195−-- Helpers
196−
197−objectType :: Type -> Maybe Type
198−objectType (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName "Object"))) rec) = Just rec
199−objectType _ = Nothing
200−
201−lam :: String -> Expr -> Expr
202−lam s = Abs (Left (Ident s))
391+lam :: Ident -> Expr -> Expr
392+lam = Abs . Left
203393
204394lamNull :: Expr -> Expr
205−lamNull = lam "$q"
395+lamNull = lam (Ident "$q") -- TODO: use GenIdent
206396
207−lamCase :: String -> [CaseAlternative] -> Expr
397+lamCase :: Ident -> [CaseAlternative] -> Expr
208398lamCase s = lam s . Case [mkVar s]
209399
210−liftApplicative :: Expr -> [Expr] -> Expr
211−liftApplicative = foldl' (\x e -> App (App (mkPrelVar "apply") x) e)
400+lamCase2 :: Ident -> Ident -> [CaseAlternative] -> Expr
401+lamCase2 s t = lam s . lam t . Case [mkVar s, mkVar t]
212402
213−mkVarMn :: Maybe ModuleName -> String -> Expr
214−mkVarMn mn s = Var (Qualified mn (Ident s))
403+mkVarMn :: Maybe ModuleName -> Ident -> Expr
404+mkVarMn mn = Var . Qualified mn
215405
216−mkVar :: String -> Expr
406+mkVar :: Ident -> Expr
217407mkVar = mkVarMn Nothing
218408
219−mkPrelVar :: String -> Expr
220−mkPrelVar = mkVarMn (Just (ModuleName [ProperName C.prelude]))
221−
222−mkGenVar :: String -> Expr
223−mkGenVar = mkVarMn (Just (ModuleName [ProperName "Data", ProperName C.generic]))
409+objectType :: Type -> Maybe Type
410+objectType (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName "Object"))) rec) = Just rec
411+objectType _ = Nothing
224412
225413decomposeRec :: Type -> [(String, Type)]
226414decomposeRec = sortBy (comparing fst) . go
227− where go (RCons str typ typs) = (str, typ) : decomposeRec typs
228− go _ = []
415+ where go (RCons str typ typs) = (str, typ) : decomposeRec typs
416+ go _ = []
src/Language/PureScript/Sugar/TypeDeclarations.hs+1−1
@@ -36,7 +36,7 @@ import Language.PureScript.Traversals
3636-- |
3737-- Replace all top level type declarations in a module with type annotations
3838--
39−desugarTypeDeclarationsModule :: forall m. (Functor m, Applicative m, MonadError MultipleErrors m) => [Module] -> m [Module]
39+desugarTypeDeclarationsModule :: forall m. (MonadError MultipleErrors m) => [Module] -> m [Module]
4040desugarTypeDeclarationsModule ms = forM ms $ \(Module ss coms name ds exps) ->
4141 rethrow (addHint (ErrorInModule name)) $
4242 Module ss coms name <$> desugarTypeDeclarations ds <*> pure exps
src/Language/PureScript/TypeChecker.hs+125−99
@@ -19,7 +19,7 @@ import Language.PureScript.TypeChecker.Types as T
1919import Language.PureScript.TypeChecker.Synonyms as T
2020
2121import Data.Maybe
22−import Data.List (nub, (\\), sort, group)
22+import Data.List (nub, nubBy, (\\), sort, group)
2323import Data.Foldable (for_, traverse_)
2424
2525import qualified Data.Map as M
@@ -30,24 +30,24 @@ import Control.Monad.State.Class (MonadState(..), modify)
3030import Control.Monad.Error.Class (MonadError(..))
3131import Control.Monad.Writer.Class (MonadWriter(..))
3232
33−import Language.PureScript.Crash
34−import Language.PureScript.Types
35−import Language.PureScript.Names
36−import Language.PureScript.Kinds
3733import Language.PureScript.AST
38−import Language.PureScript.TypeClassDictionaries
34+import Language.PureScript.Crash
3935import Language.PureScript.Environment
4036import Language.PureScript.Errors
37+import Language.PureScript.Kinds
38+import Language.PureScript.Names
39+import Language.PureScript.TypeClassDictionaries
40+import Language.PureScript.Types
4141
42−addDataType ::
43− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
44− ModuleName ->
45− DataDeclType ->
46− ProperName ->
47− [(String, Maybe Kind)] ->
48− [(ProperName, [Type])] ->
49− Kind ->
50− m ()
42+addDataType
43+ :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
44+ => ModuleName
45+ -> DataDeclType
46+ -> ProperName 'TypeName
47+ -> [(String, Maybe Kind)]
48+ -> [(ProperName 'ConstructorName, [Type])]
49+ -> Kind
50+ -> m ()
5151addDataType moduleName dtype name args dctors ctorKind = do
5252 env <- getEnv
5353 putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (ctorKind, DataType args dctors) (types env) }
@@ -55,15 +55,15 @@ addDataType moduleName dtype name args dctors ctorKind = do
5555 warnAndRethrow (addHint (ErrorInDataConstructor dctor)) $
5656 addDataConstructor moduleName dtype name (map fst args) dctor tys
5757
58−addDataConstructor ::
59− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
60− ModuleName ->
61− DataDeclType ->
62− ProperName ->
63− [String] ->
64− ProperName ->
65− [Type] ->
66− m ()
58+addDataConstructor
59+ :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
60+ => ModuleName
61+ -> DataDeclType
62+ -> ProperName 'TypeName
63+ -> [String]
64+ -> ProperName 'ConstructorName
65+ -> [Type]
66+ -> m ()
6767addDataConstructor moduleName dtype name args dctor tys = do
6868 env <- getEnv
6969 traverse_ checkTypeSynonyms tys
@@ -73,50 +73,50 @@ addDataConstructor moduleName dtype name args dctor tys = do
7373 let fields = [Ident ("value" ++ show n) | n <- [0..(length tys - 1)]]
7474 putEnv $ env { dataConstructors = M.insert (Qualified (Just moduleName) dctor) (dtype, name, polyType, fields) (dataConstructors env) }
7575
76−addTypeSynonym ::
77− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
78− ModuleName ->
79− ProperName ->
80− [(String, Maybe Kind)] ->
81− Type ->
82− Kind ->
83− m ()
76+addTypeSynonym
77+ :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
78+ => ModuleName
79+ -> ProperName 'TypeName
80+ -> [(String, Maybe Kind)]
81+ -> Type
82+ -> Kind
83+ -> m ()
8484addTypeSynonym moduleName name args ty kind = do
8585 env <- getEnv
8686 checkTypeSynonyms ty
8787 putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (kind, TypeSynonym) (types env)
8888 , typeSynonyms = M.insert (Qualified (Just moduleName) name) (args, ty) (typeSynonyms env) }
8989
90−valueIsNotDefined ::
91− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
92− ModuleName ->
93− Ident ->
94− m ()
90+valueIsNotDefined
91+ :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
92+ => ModuleName
93+ -> Ident
94+ -> m ()
9595valueIsNotDefined moduleName name = do
9696 env <- getEnv
9797 case M.lookup (moduleName, name) (names env) of
9898 Just _ -> throwError . errorMessage $ RedefinedIdent name
9999 Nothing -> return ()
100100
101−addValue ::
102− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
103− ModuleName ->
104− Ident ->
105− Type ->
106− NameKind ->
107− m ()
101+addValue
102+ :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
103+ => ModuleName
104+ -> Ident
105+ -> Type
106+ -> NameKind
107+ -> m ()
108108addValue moduleName name ty nameKind = do
109109 env <- getEnv
110110 putEnv (env { names = M.insert (moduleName, name) (ty, nameKind, Defined) (names env) })
111111
112−addTypeClass ::
113− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
114− ModuleName ->
115− ProperName ->
116− [(String, Maybe Kind)] ->
117− [Constraint] ->
118− [Declaration] ->
119− m ()
112+addTypeClass
113+ :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
114+ => ModuleName
115+ -> ProperName 'ClassName
116+ -> [(String, Maybe Kind)]
117+ -> [Constraint]
118+ -> [Declaration]
119+ -> m ()
120120addTypeClass moduleName pn args implies ds =
121121 let members = map toPair ds in
122122 modify $ \st -> st { checkEnv = (checkEnv st) { typeClasses = M.insert (Qualified (Just moduleName) pn) (args, members, implies) (typeClasses . checkEnv $ st) } }
@@ -125,30 +125,30 @@ addTypeClass moduleName pn args implies ds =
125125 toPair (PositionedDeclaration _ _ d) = toPair d
126126 toPair _ = internalError "Invalid declaration in TypeClassDeclaration"
127127
128−addTypeClassDictionaries ::
129− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
130− Maybe ModuleName ->
131− M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope) ->
132− m ()
128+addTypeClassDictionaries
129+ :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
130+ => Maybe ModuleName
131+ -> M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope)
132+ -> m ()
133133addTypeClassDictionaries mn entries =
134134 modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = insertState st } }
135135 where insertState st = M.insertWith (M.unionWith M.union) mn entries (typeClassDictionaries . checkEnv $ st)
136136
137−checkDuplicateTypeArguments ::
138− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
139− [String] ->
140− m ()
137+checkDuplicateTypeArguments
138+ :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
139+ => [String]
140+ -> m ()
141141checkDuplicateTypeArguments args = for_ firstDup $ \dup ->
142142 throwError . errorMessage $ DuplicateTypeArgument dup
143143 where
144144 firstDup :: Maybe String
145145 firstDup = listToMaybe $ args \\ nub args
146146
147−checkTypeClassInstance ::
148− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
149− ModuleName ->
150− Type ->
151− m ()
147+checkTypeClassInstance
148+ :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
149+ => ModuleName
150+ -> Type
151+ -> m ()
152152checkTypeClassInstance _ (TypeVar _) = return ()
153153checkTypeClassInstance _ (TypeConstructor ctor) = do
154154 env <- getEnv
@@ -160,10 +160,10 @@ checkTypeClassInstance _ ty = throwError . errorMessage $ InvalidInstanceHead ty
160160-- |
161161-- Check that type synonyms are fully-applied in a type
162162--
163−checkTypeSynonyms ::
164− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
165− Type ->
166− m ()
163+checkTypeSynonyms
164+ :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
165+ => Type
166+ -> m ()
167167checkTypeSynonyms = void . replaceAllTypeSynonyms
168168
169169-- |
@@ -179,12 +179,13 @@ checkTypeSynonyms = void . replaceAllTypeSynonyms
179179--
180180-- * Process module imports
181181--
182−typeCheckAll :: forall m.
183− (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
184− ModuleName ->
185− [DeclarationRef] ->
186− [Declaration] ->
187− m [Declaration]
182+typeCheckAll
183+ :: forall m
184+ . (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
185+ => ModuleName
186+ -> [DeclarationRef]
187+ -> [Declaration]
188+ -> m [Declaration]
188189typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds
189190 where
190191 go :: Declaration -> m Declaration
@@ -197,7 +198,7 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds
197198 addDataType moduleName dtype name args' dctors ctorKind
198199 return $ DataDeclaration dtype name args dctors
199200 where
200− checkNewtype :: [(ProperName, [Type])] -> m ()
201+ checkNewtype :: [(ProperName 'ConstructorName, [Type])] -> m ()
201202 checkNewtype [(_, [_])] = return ()
202203 checkNewtype [(_, _)] = throwError . errorMessage $ InvalidNewtype name
203204 checkNewtype _ = throwError . errorMessage $ InvalidNewtype name
@@ -229,14 +230,14 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds
229230 let args' = args `withKinds` kind
230231 addTypeSynonym moduleName name args' ty kind
231232 return $ TypeSynonymDeclaration name args ty
232− go (TypeDeclaration{}) = internalError "Type declarations should have been removed"
233+ go TypeDeclaration{} = internalError "Type declarations should have been removed"
233234 go (ValueDeclaration name nameKind [] (Right val)) =
234235 warnAndRethrow (addHint (ErrorInValueDeclaration name)) $ do
235236 valueIsNotDefined moduleName name
236237 [(_, (val', ty))] <- typesOf moduleName [(name, val)]
237238 addValue moduleName name ty nameKind
238239 return $ ValueDeclaration name nameKind [] $ Right val'
239− go (ValueDeclaration{}) = internalError "Binders were not desugared"
240+ go ValueDeclaration{} = internalError "Binders were not desugared"
240241 go (BindingGroupDeclaration vals) =
241242 warnAndRethrow (addHint (ErrorInBindingGroup (map (\(ident, _, _) -> ident) vals))) $ do
242243 for_ (map (\(ident, _, _) -> ident) vals) $ \name ->
@@ -263,8 +264,8 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds
263264 Just _ -> throwError . errorMessage $ RedefinedIdent name
264265 Nothing -> putEnv (env { names = M.insert (moduleName, name) (ty, External, Defined) (names env) })
265266 return d
266− go (d@(FixityDeclaration{})) = return d
267− go (d@(ImportDeclaration{})) = return d
267+ go (d@FixityDeclaration{}) = return d
268+ go (d@ImportDeclaration{}) = return d
268269 go (d@(TypeClassDeclaration pn args implies tys)) = do
269270 addTypeClass moduleName pn args implies tys
270271 return d
@@ -280,9 +281,14 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds
280281 warnAndRethrowWithPosition pos $ PositionedDeclaration pos com <$> go d
281282
282283 checkFixities :: Declaration -> m ()
283− checkFixities (FixityDeclaration _ name (Just alias)) = do
284− ty <- lookupVariable moduleName (Qualified (Just moduleName) alias)
284+ checkFixities (FixityDeclaration _ name (Just (Left alias))) = do
285+ ty <- lookupVariable moduleName alias
285286 addValue moduleName (Op name) ty Public
287+ checkFixities (FixityDeclaration _ name (Just (Right alias))) = do
288+ env <- getEnv
289+ case M.lookup alias (dataConstructors env) of
290+ Nothing -> throwError . errorMessage $ UnknownDataConstructor alias Nothing
291+ Just (_, _, ty, _) -> addValue moduleName (Op name) ty Public
286292 checkFixities (FixityDeclaration _ name _) = do
287293 env <- getEnv
288294 guardWith (errorMessage (OrphanFixityDeclaration name)) $ M.member (moduleName, Op name) $ names env
@@ -308,7 +314,7 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds
308314 | otherwise = firstDuplicate xs
309315 firstDuplicate _ = Nothing
310316
311− checkOrphanInstance :: Ident -> Qualified ProperName -> [Type] -> m ()
317+ checkOrphanInstance :: Ident -> Qualified (ProperName 'ClassName) -> [Type] -> m ()
312318 checkOrphanInstance dictName className@(Qualified (Just mn') _) tys'
313319 | moduleName == mn' || any checkType tys' = return ()
314320 | otherwise = throwError . errorMessage $ OrphanInstance dictName className tys'
@@ -335,10 +341,11 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds
335341-- Type check an entire module and ensure all types and classes defined within the module that are
336342-- required by exported members are also exported.
337343--
338−typeCheckModule :: forall m.
339− (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
340− Module ->
341− m Module
344+typeCheckModule
345+ :: forall m
346+ . (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
347+ => Module
348+ -> m Module
342349typeCheckModule (Module _ _ _ _ Nothing) = internalError "exports should have been elaborated"
343350typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint (ErrorInModule mn)) $ do
344351 modify (\s -> s { checkCurrentModule = Just mn })
@@ -347,7 +354,7 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint
347354 checkTypesAreExported e
348355 checkClassMembersAreExported e
349356 checkClassesAreExported e
350− checkNonAliasesAreExported e
357+ checkNonAliasesAreExported (exportedDataConstructors exps) e
351358 return $ Module ss coms mn decls' (Just exps)
352359 where
353360
@@ -372,7 +379,7 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint
372379 checkExport :: DeclarationRef -> (Type -> [DeclarationRef]) -> Type -> m ()
373380 checkExport dr extract ty = case filter (not . exported) (extract ty) of
374381 [] -> return ()
375− hidden -> throwError . errorMessage $ TransitiveExportError dr hidden
382+ hidden -> throwError . errorMessage $ TransitiveExportError dr (nubBy nubEq hidden)
376383 where
377384 exported e = any (exports e) exps
378385 exports (TypeRef pn1 _) (TypeRef pn2 _) = pn1 == pn2
@@ -381,6 +388,11 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint
381388 exports (PositionedDeclarationRef _ _ r1) r2 = exports r1 r2
382389 exports r1 (PositionedDeclarationRef _ _ r2) = exports r1 r2
383390 exports _ _ = False
391+ -- We avoid Eq for `nub`bing as the dctor part of `TypeRef` evaluates to
392+ -- `error` for the values generated here (we don't need them anyway)
393+ nubEq (TypeRef pn1 _) (TypeRef pn2 _) = pn1 == pn2
394+ nubEq r1 r2 = r1 == r2
395+
384396
385397 -- Check that all the type constructors defined in the current module that appear in member types
386398 -- have also been exported from the module
@@ -403,7 +415,7 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint
403415 where
404416 go (ConstrainedType cs _) = mapMaybe (fmap TypeClassRef . extractCurrentModuleClass . fst) cs
405417 go _ = []
406− extractCurrentModuleClass :: Qualified ProperName -> Maybe ProperName
418+ extractCurrentModuleClass :: Qualified (ProperName 'ClassName) -> Maybe (ProperName 'ClassName)
407419 extractCurrentModuleClass (Qualified (Just mn') name) | mn == mn' = Just name
408420 extractCurrentModuleClass _ = Nothing
409421
@@ -423,16 +435,30 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint
423435 extractMemberName _ = internalError "Unexpected declaration in typeclass member list"
424436 checkClassMembersAreExported _ = return ()
425437
426− checkNonAliasesAreExported :: DeclarationRef -> m ()
427− checkNonAliasesAreExported dr@(ValueRef (Op name)) =
438+ checkNonAliasesAreExported :: [ProperName 'ConstructorName] -> DeclarationRef -> m ()
439+ checkNonAliasesAreExported exportedDctors dr@(ValueRef (Op name)) =
428440 case listToMaybe (mapMaybe getAlias decls) of
429− Just alias ->
430− when (not $ any (== ValueRef alias) exps) $
431− throwError . errorMessage $ TransitiveExportError dr [ValueRef alias]
441+ Just (Left ident) ->
442+ unless (ValueRef ident `elem` exps) $
443+ throwError . errorMessage $ TransitiveExportError dr [ValueRef ident]
444+ Just (Right ctor) ->
445+ unless (ctor `elem` exportedDctors) $
446+ throwError . errorMessage $ TransitiveDctorExportError dr ctor
432447 _ -> return ()
433448 where
434− getAlias :: Declaration -> Maybe Ident
449+ getAlias :: Declaration -> Maybe (Either Ident (ProperName 'ConstructorName))
435450 getAlias (PositionedDeclaration _ _ d) = getAlias d
436− getAlias (FixityDeclaration _ name' alias) | name == name' = alias
451+ getAlias (FixityDeclaration _ name' (Just alias)) | name == name' =
452+ case alias of
453+ Left (Qualified (Just mn') ident) | mn == mn' -> Just (Left ident)
454+ Right (Qualified (Just mn') ctor) | mn == mn' -> Just (Right ctor)
455+ _ -> Nothing
437456 getAlias _ = Nothing
438− checkNonAliasesAreExported _ = return ()
457+ checkNonAliasesAreExported _ _ = return ()
458+
459+ exportedDataConstructors :: [DeclarationRef] -> [ProperName 'ConstructorName]
460+ exportedDataConstructors = foldMap extractCtor
461+ where
462+ extractCtor :: DeclarationRef -> [ProperName 'ConstructorName]
463+ extractCtor (TypeRef _ (Just ctors)) = ctors
464+ extractCtor _ = []
src/Language/PureScript/TypeChecker/Entailment.hs+14−27
@@ -1,24 +1,10 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.TypeChecker.Entailment
4−-- Copyright : (c) Phil Freeman 2013
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−-- Type class entailment
13−--
14−-----------------------------------------------------------------------------
15−
161{-# LANGUAGE ScopedTypeVariables #-}
172{-# LANGUAGE FlexibleContexts #-}
183
19−module Language.PureScript.TypeChecker.Entailment (
20− entails
21−) where
4+-- |
5+-- Type class entailment
6+--
7+module Language.PureScript.TypeChecker.Entailment (entails) where
228
239import Prelude ()
2410import Prelude.Compat
@@ -46,15 +32,16 @@ import qualified Language.PureScript.Constants as C
4632-- Check that the current set of type class dictionaries entail the specified type class goal, and, if so,
4733-- return a type class dictionary reference.
4834--
49−entails :: forall m.
50− (Functor m, Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
51− ModuleName ->
52− M.Map (Maybe ModuleName) (M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope)) ->
53− Constraint ->
54− m Expr
35+entails
36+ :: forall m
37+ . (MonadError MultipleErrors m, MonadWriter MultipleErrors m)
38+ => ModuleName
39+ -> M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope))
40+ -> Constraint
41+ -> m Expr
5542entails moduleName context = solve
5643 where
57− forClassName :: Qualified ProperName -> [Type] -> [TypeClassDictionaryInScope]
44+ forClassName :: Qualified (ProperName 'ClassName) -> [Type] -> [TypeClassDictionaryInScope]
5845 forClassName cn@(Qualified (Just mn) _) tys = concatMap (findDicts cn) (Nothing : Just mn : map Just (mapMaybe ctorModules tys))
5946 forClassName _ _ = internalError "forClassName: expected qualified class name"
6047
@@ -64,7 +51,7 @@ entails moduleName context = solve
6451 ctorModules (TypeApp ty _) = ctorModules ty
6552 ctorModules _ = Nothing
6653
67− findDicts :: Qualified ProperName -> Maybe ModuleName -> [TypeClassDictionaryInScope]
54+ findDicts :: Qualified (ProperName 'ClassName) -> Maybe ModuleName -> [TypeClassDictionaryInScope]
6855 findDicts cn = maybe [] M.elems . (>>= M.lookup cn) . flip M.lookup context
6956
7057 solve :: Constraint -> m Expr
@@ -72,7 +59,7 @@ entails moduleName context = solve
7259 dict <- go 0 className tys
7360 return $ dictionaryValueToValue dict
7461 where
75− go :: Int -> Qualified ProperName -> [Type] -> m DictionaryValue
62+ go :: Int -> Qualified (ProperName 'ClassName) -> [Type] -> m DictionaryValue
7663 go work className' tys' | work > 1000 = throwError . errorMessage $ PossiblyInfiniteInstance className' tys'
7764 go work className' tys' = do
7865 let instances = do
src/Language/PureScript/TypeChecker/Kinds.hs+65−52
@@ -1,18 +1,3 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.TypeChecker.Kinds
4−-- Copyright : (c) Phil Freeman 2013
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−-- This module implements the kind checker
13−--
14−-----------------------------------------------------------------------------
15−
161{-# LANGUAGE MultiParamTypeClasses #-}
172{-# LANGUAGE FlexibleInstances #-}
183{-# LANGUAGE FlexibleContexts #-}
@@ -20,12 +5,15 @@
205{-# LANGUAGE ScopedTypeVariables #-}
216{-# LANGUAGE RankNTypes #-}
227
23−module Language.PureScript.TypeChecker.Kinds (
24− kindOf,
25− kindOfWithScopedVars,
26− kindsOf,
27− kindsOfAll
28−) where
8+-- |
9+-- This module implements the kind checker
10+--
11+module Language.PureScript.TypeChecker.Kinds
12+ ( kindOf
13+ , kindOfWithScopedVars
14+ , kindsOf
15+ , kindsOfAll
16+ ) where
2917
3018import Prelude ()
3119import Prelude.Compat
@@ -54,7 +42,11 @@ freshKind = do
5442 return $ KUnknown k
5543
5644-- | Update the substitution to solve a kind constraint
57−solveKind :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Int -> Kind -> m ()
45+solveKind
46+ :: (MonadError MultipleErrors m, MonadState CheckState m)
47+ => Int
48+ -> Kind
49+ -> m ()
5850solveKind u k = do
5951 occursCheck u k
6052 modify $ \cs -> cs { checkSubstitution =
@@ -75,7 +67,11 @@ substituteKind sub = everywhereOnKinds go
7567 go other = other
7668
7769-- | Make sure that an unknown does not occur in a kind
78−occursCheck :: (Functor m, Applicative m, MonadError MultipleErrors m) => Int -> Kind -> m ()
70+occursCheck
71+ :: (MonadError MultipleErrors m)
72+ => Int
73+ -> Kind
74+ -> m ()
7975occursCheck _ KUnknown{} = return ()
8076occursCheck u k = void $ everywhereOnKindsM go k
8177 where
@@ -83,7 +79,11 @@ occursCheck u k = void $ everywhereOnKindsM go k
8379 go other = return other
8480
8581-- | Unify two kinds
86−unifyKinds :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Kind -> Kind -> m ()
82+unifyKinds
83+ :: (MonadError MultipleErrors m, MonadState CheckState m)
84+ => Kind
85+ -> Kind
86+ -> m ()
8787unifyKinds k1 k2 = do
8888 sub <- gets checkSubstitution
8989 go (substituteKind sub k1) (substituteKind sub k2)
@@ -100,15 +100,15 @@ unifyKinds k1 k2 = do
100100 go k1' k2' = throwError . errorMessage $ KindsDoNotUnify k1' k2'
101101
102102-- | Infer the kind of a single type
103−kindOf ::
104− (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m) =>
105− Type ->
106− m Kind
103+kindOf
104+ :: (MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m)
105+ => Type
106+ -> m Kind
107107kindOf ty = fst <$> kindOfWithScopedVars ty
108108
109109-- | Infer the kind of a single type, returning the kinds of any scoped type variables
110110kindOfWithScopedVars ::
111− (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m) =>
111+ (MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m) =>
112112 Type ->
113113 m (Kind, [(String, Kind)])
114114kindOfWithScopedVars ty =
@@ -120,14 +120,14 @@ kindOfWithScopedVars ty =
120120 )
121121
122122-- | Infer the kind of a type constructor with a collection of arguments and a collection of associated data constructors
123−kindsOf ::
124− (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m) =>
125− Bool ->
126− ModuleName ->
127− ProperName ->
128− [(String, Maybe Kind)] ->
129− [Type] ->
130− m Kind
123+kindsOf
124+ :: (MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m)
125+ => Bool
126+ -> ModuleName
127+ -> ProperName 'TypeName
128+ -> [(String, Maybe Kind)]
129+ -> [Type]
130+ -> m Kind
131131kindsOf isData moduleName name args ts = fmap tidyUp . liftUnify $ do
132132 tyCon <- freshKind
133133 kargs <- replicateM (length args) freshKind
@@ -138,23 +138,23 @@ kindsOf isData moduleName name args ts = fmap tidyUp . liftUnify $ do
138138 where
139139 tidyUp (k, sub) = starIfUnknown $ substituteKind sub k
140140
141−freshKindVar ::
142− (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) =>
143− (String, Maybe Kind) ->
144− Kind ->
145− m (ProperName, Kind)
141+freshKindVar
142+ :: (MonadError MultipleErrors m, MonadState CheckState m)
143+ => (String, Maybe Kind)
144+ -> Kind
145+ -> m (ProperName 'TypeName, Kind)
146146freshKindVar (arg, Nothing) kind = return (ProperName arg, kind)
147147freshKindVar (arg, Just kind') kind = do
148148 unifyKinds kind kind'
149149 return (ProperName arg, kind')
150150
151151-- | Simultaneously infer the kinds of several mutually recursive type constructors
152−kindsOfAll ::
153− (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m) =>
154− ModuleName ->
155− [(ProperName, [(String, Maybe Kind)], Type)] ->
156− [(ProperName, [(String, Maybe Kind)], [Type])] ->
157− m ([Kind], [Kind])
152+kindsOfAll
153+ :: (MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m)
154+ => ModuleName
155+ -> [(ProperName 'TypeName, [(String, Maybe Kind)], Type)]
156+ -> [(ProperName 'TypeName, [(String, Maybe Kind)], [Type])]
157+ -> m ([Kind], [Kind])
158158kindsOfAll moduleName syns tys = fmap tidyUp . liftUnify $ do
159159 synVars <- replicateM (length syns) freshKind
160160 let dict = zipWith (\(name, _, _) var -> (name, var)) syns synVars
@@ -177,7 +177,13 @@ kindsOfAll moduleName syns tys = fmap tidyUp . liftUnify $ do
177177 tidyUp ((ks1, ks2), sub) = (map (starIfUnknown . substituteKind sub) ks1, map (starIfUnknown . substituteKind sub) ks2)
178178
179179-- | Solve the set of kind constraints associated with the data constructors for a type constructor
180−solveTypes :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Bool -> [Type] -> [Kind] -> Kind -> m Kind
180+solveTypes
181+ :: (MonadError MultipleErrors m, MonadState CheckState m)
182+ => Bool
183+ -> [Type]
184+ -> [Kind]
185+ -> Kind
186+ -> m Kind
181187solveTypes isData ts kargs tyCon = do
182188 ks <- traverse (fmap fst . infer) ts
183189 when isData $ do
@@ -195,10 +201,17 @@ starIfUnknown (FunKind k1 k2) = FunKind (starIfUnknown k1) (starIfUnknown k2)
195201starIfUnknown k = k
196202
197203-- | Infer a kind for a type
198−infer :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Type -> m (Kind, [(String, Kind)])
204+infer
205+ :: (MonadError MultipleErrors m, MonadState CheckState m)
206+ => Type
207+ -> m (Kind, [(String, Kind)])
199208infer ty = rethrow (addHint (ErrorCheckingKind ty)) $ infer' ty
200209
201−infer' :: forall m. (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Type -> m (Kind, [(String, Kind)])
210+infer'
211+ :: forall m
212+ . (MonadError MultipleErrors m, MonadState CheckState m)
213+ => Type
214+ -> m (Kind, [(String, Kind)])
202215infer' (ForAll ident ty _) = do
203216 k1 <- freshKind
204217 Just moduleName <- checkCurrentModule <$> get
@@ -250,7 +263,7 @@ infer' other = (, []) <$> go other
250263 return $ Row k1
251264 go (ConstrainedType deps ty) = do
252265 forM_ deps $ \(className, tys) -> do
253− k <- go $ foldl TypeApp (TypeConstructor className) tys
266+ k <- go $ foldl TypeApp (TypeConstructor (fmap coerceProperName className)) tys
254267 unifyKinds k Star
255268 k <- go ty
256269 unifyKinds k Star
src/Language/PureScript/TypeChecker/Monad.hs+69−38
@@ -1,18 +1,3 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.TypeChecker.Monad
4−-- Copyright : (c) Phil Freeman 2013
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−-- Monads for type checking and type inference and associated data types
13−--
14−-----------------------------------------------------------------------------
15−
161{-# LANGUAGE GeneralizedNewtypeDeriving #-}
172{-# LANGUAGE FlexibleInstances #-}
183{-# LANGUAGE RankNTypes #-}
@@ -20,6 +5,9 @@
205{-# LANGUAGE FlexibleContexts #-}
216{-# LANGUAGE GADTs #-}
227
8+-- |
9+-- Monads for type checking and type inference and associated data types
10+--
2311module Language.PureScript.TypeChecker.Monad where
2412
2513import Prelude ()
@@ -69,7 +57,11 @@ emptyCheckState env = CheckState env 0 0 0 0 Nothing emptySubstitution
6957type Unknown = Int
7058
7159-- | Temporarily bind a collection of names to values
72−bindNames :: (MonadState CheckState m) => M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility) -> m a -> m a
60+bindNames
61+ :: MonadState CheckState m
62+ => M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility)
63+ -> m a
64+ -> m a
7365bindNames newNames action = do
7466 orig <- get
7567 modify $ \st -> st { checkEnv = (checkEnv st) { names = newNames `M.union` (names . checkEnv $ st) } }
@@ -78,7 +70,11 @@ bindNames newNames action = do
7870 return a
7971
8072-- | Temporarily bind a collection of names to types
81−bindTypes :: (MonadState CheckState m) => M.Map (Qualified ProperName) (Kind, TypeKind) -> m a -> m a
73+bindTypes
74+ :: MonadState CheckState m
75+ => M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind)
76+ -> m a
77+ -> m a
8278bindTypes newNames action = do
8379 orig <- get
8480 modify $ \st -> st { checkEnv = (checkEnv st) { types = newNames `M.union` (types . checkEnv $ st) } }
@@ -87,7 +83,12 @@ bindTypes newNames action = do
8783 return a
8884
8985-- | Temporarily bind a collection of names to types
90−withScopedTypeVars :: (Functor m, Applicative m, MonadState CheckState m, MonadWriter MultipleErrors m) => ModuleName -> [(String, Kind)] -> m a -> m a
86+withScopedTypeVars
87+ :: (MonadState CheckState m, MonadWriter MultipleErrors m)
88+ => ModuleName
89+ -> [(String, Kind)]
90+ -> m a
91+ -> m a
9192withScopedTypeVars mn ks ma = do
9293 orig <- get
9394 forM_ ks $ \(name, _) ->
@@ -96,7 +97,11 @@ withScopedTypeVars mn ks ma = do
9697 bindTypes (M.fromList (map (\(name, k) -> (Qualified (Just mn) (ProperName name), (k, ScopedTypeVar))) ks)) ma
9798
9899-- | Temporarily make a collection of type class dictionaries available
99−withTypeClassDictionaries :: (MonadState CheckState m) => [TypeClassDictionaryInScope] -> m a -> m a
100+withTypeClassDictionaries
101+ :: MonadState CheckState m
102+ => [TypeClassDictionaryInScope]
103+ -> m a
104+ -> m a
100105withTypeClassDictionaries entries action = do
101106 orig <- get
102107 let mentries = M.fromListWith (M.unionWith M.union) [ (mn, M.singleton className (M.singleton (tcdName entry) entry)) | entry@TypeClassDictionaryInScope{ tcdName = Qualified mn _, tcdClassName = className } <- entries ]
@@ -106,38 +111,48 @@ withTypeClassDictionaries entries action = do
106111 return a
107112
108113-- | Get the currently available map of type class dictionaries
109−getTypeClassDictionaries ::
110− (Functor m, MonadState CheckState m) =>
111− m (M.Map (Maybe ModuleName) (M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope)))
114+getTypeClassDictionaries
115+ :: (MonadState CheckState m)
116+ => m (M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope)))
112117getTypeClassDictionaries = typeClassDictionaries . checkEnv <$> get
113118
114119-- | Lookup type class dictionaries in a module.
115−lookupTypeClassDictionaries ::
116− (Functor m, MonadState CheckState m) =>
117− Maybe ModuleName ->
118− m (M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope))
120+lookupTypeClassDictionaries
121+ :: (MonadState CheckState m)
122+ => Maybe ModuleName
123+ -> m (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope))
119124lookupTypeClassDictionaries mn = fromMaybe M.empty . M.lookup mn . typeClassDictionaries . checkEnv <$> get
120125
121126-- | Temporarily bind a collection of names to local variables
122−bindLocalVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(Ident, Type, NameVisibility)] -> m a -> m a
127+bindLocalVariables
128+ :: (MonadState CheckState m)
129+ => ModuleName
130+ -> [(Ident, Type, NameVisibility)]
131+ -> m a
132+ -> m a
123133bindLocalVariables moduleName bindings =
124134 bindNames (M.fromList $ flip map bindings $ \(name, ty, visibility) -> ((moduleName, name), (ty, Private, visibility)))
125135
126136-- | Temporarily bind a collection of names to local type variables
127−bindLocalTypeVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(ProperName, Kind)] -> m a -> m a
137+bindLocalTypeVariables
138+ :: (MonadState CheckState m)
139+ => ModuleName
140+ -> [(ProperName 'TypeName, Kind)]
141+ -> m a
142+ -> m a
128143bindLocalTypeVariables moduleName bindings =
129144 bindTypes (M.fromList $ flip map bindings $ \(pn, kind) -> (Qualified (Just moduleName) pn, (kind, LocalTypeVariable)))
130145
131146-- | Update the visibility of all names to Defined
132−makeBindingGroupVisible :: (Functor m, MonadState CheckState m) => m ()
147+makeBindingGroupVisible :: (MonadState CheckState m) => m ()
133148makeBindingGroupVisible = modifyEnv $ \e -> e { names = M.map (\(ty, nk, _) -> (ty, nk, Defined)) (names e) }
134149
135150-- | Update the visibility of all names to Defined in the scope of the provided action
136−withBindingGroupVisible :: (Functor m, MonadState CheckState m) => m a -> m a
151+withBindingGroupVisible :: (MonadState CheckState m) => m a -> m a
137152withBindingGroupVisible action = preservingNames $ makeBindingGroupVisible >> action
138153
139154-- | Perform an action while preserving the names from the @Environment@.
140−preservingNames :: (Functor m, MonadState CheckState m) => m a -> m a
155+preservingNames :: (MonadState CheckState m) => m a -> m a
141156preservingNames action = do
142157 orig <- gets (names . checkEnv)
143158 a <- action
@@ -145,7 +160,11 @@ preservingNames action = do
145160 return a
146161
147162-- | Lookup the type of a value by name in the @Environment@
148−lookupVariable :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m Type
163+lookupVariable
164+ :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m)
165+ => ModuleName
166+ -> Qualified Ident
167+ -> m Type
149168lookupVariable currentModule (Qualified moduleName var) = do
150169 env <- getEnv
151170 case M.lookup (fromMaybe currentModule moduleName, var) (names env) of
@@ -153,7 +172,11 @@ lookupVariable currentModule (Qualified moduleName var) = do
153172 Just (ty, _, _) -> return ty
154173
155174-- | Lookup the visibility of a value by name in the @Environment@
156−getVisibility :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m NameVisibility
175+getVisibility
176+ :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m)
177+ => ModuleName
178+ -> Qualified Ident
179+ -> m NameVisibility
157180getVisibility currentModule (Qualified moduleName var) = do
158181 env <- getEnv
159182 case M.lookup (fromMaybe currentModule moduleName, var) (names env) of
@@ -161,7 +184,11 @@ getVisibility currentModule (Qualified moduleName var) = do
161184 Just (_, _, vis) -> return vis
162185
163186-- | Assert that a name is visible
164−checkVisibility :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m ()
187+checkVisibility
188+ :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m)
189+ => ModuleName
190+ -> Qualified Ident
191+ -> m ()
165192checkVisibility currentModule name@(Qualified _ var) = do
166193 vis <- getVisibility currentModule name
167194 case vis of
@@ -169,7 +196,11 @@ checkVisibility currentModule name@(Qualified _ var) = do
169196 _ -> return ()
170197
171198-- | Lookup the kind of a type by name in the @Environment@
172−lookupTypeVariable :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified ProperName -> m Kind
199+lookupTypeVariable
200+ :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m)
201+ => ModuleName
202+ -> Qualified (ProperName 'TypeName)
203+ -> m Kind
173204lookupTypeVariable currentModule (Qualified moduleName name) = do
174205 env <- getEnv
175206 case M.lookup (Qualified (Just $ fromMaybe currentModule moduleName) name) (types env) of
@@ -177,7 +208,7 @@ lookupTypeVariable currentModule (Qualified moduleName name) = do
177208 Just (k, _) -> return k
178209
179210-- | Get the current @Environment@
180−getEnv :: (Functor m, MonadState CheckState m) => m Environment
211+getEnv :: (MonadState CheckState m) => m Environment
181212getEnv = checkEnv <$> get
182213
183214-- | Update the @Environment@
@@ -203,14 +234,14 @@ guardWith e False = throwError e
203234
204235-- | Run a computation in the substitution monad, generating a return value and the final substitution.
205236liftUnify ::
206− (Functor m, MonadState CheckState m, MonadWriter MultipleErrors m, MonadError MultipleErrors m) =>
237+ (MonadState CheckState m, MonadWriter MultipleErrors m, MonadError MultipleErrors m) =>
207238 m a ->
208239 m (a, Substitution)
209240liftUnify = liftUnifyWarnings (const id)
210241
211242-- | Run a computation in the substitution monad, generating a return value, the final substitution and updating warnings values.
212243liftUnifyWarnings ::
213− (Functor m, MonadState CheckState m, MonadWriter MultipleErrors m, MonadError MultipleErrors m) =>
244+ (MonadState CheckState m, MonadWriter MultipleErrors m, MonadError MultipleErrors m) =>
214245 (Substitution -> ErrorMessage -> ErrorMessage) ->
215246 m a ->
216247 m (a, Substitution)
src/Language/PureScript/TypeChecker/Rows.hs+1−1
@@ -36,7 +36,7 @@ import Language.PureScript.TypeChecker.Monad
3636import Language.PureScript.Types
3737
3838-- | Ensure rows do not contain duplicate labels
39−checkDuplicateLabels :: forall m. (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Expr -> m ()
39+checkDuplicateLabels :: forall m. (MonadError MultipleErrors m, MonadState CheckState m) => Expr -> m ()
4040checkDuplicateLabels =
4141 let (_, f, _) = everywhereOnValuesM def go def
4242 in void . f
src/Language/PureScript/TypeChecker/Skolems.hs+1−1
@@ -53,7 +53,7 @@ newSkolemConstant = do
5353-- |
5454-- Introduce skolem scope at every occurence of a ForAll
5555--
56−introduceSkolemScope :: (Functor m, Applicative m, MonadState CheckState m) => Type -> m Type
56+introduceSkolemScope :: (MonadState CheckState m) => Type -> m Type
5757introduceSkolemScope = everywhereOnTypesM go
5858 where
5959 go (ForAll ident ty Nothing) = ForAll ident ty <$> (Just <$> newSkolemScope)
src/Language/PureScript/TypeChecker/Subsumption.hs+2−2
@@ -39,11 +39,11 @@ import Language.PureScript.TypeChecker.Unify
3939import Language.PureScript.Types
4040
4141-- | Check that one type subsumes another, rethrowing errors to provide a better error message
42−subsumes :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Maybe Expr -> Type -> Type -> m (Maybe Expr)
42+subsumes :: (MonadError MultipleErrors m, MonadState CheckState m) => Maybe Expr -> Type -> Type -> m (Maybe Expr)
4343subsumes val ty1 ty2 = rethrow (addHint (ErrorInSubsumption ty1 ty2)) $ subsumes' val ty1 ty2
4444
4545-- | Check tahat one type subsumes another
46−subsumes' :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) =>
46+subsumes' :: (MonadError MultipleErrors m, MonadState CheckState m) =>
4747 Maybe Expr ->
4848 Type ->
4949 Type ->
src/Language/PureScript/TypeChecker/Synonyms.hs+1−1
@@ -57,7 +57,7 @@ replaceAllTypeSynonyms' env = everywhereOnTypesTopDownM try
5757 go c args (TypeApp f arg) = go (c + 1) (arg : args) f
5858 go _ _ _ = return Nothing
5959
60−replaceAllTypeSynonyms :: (e ~ MultipleErrors, Functor m, Monad m, MonadState CheckState m, MonadError e m) => Type -> m Type
60+replaceAllTypeSynonyms :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m) => Type -> m Type
6161replaceAllTypeSynonyms d = do
6262 env <- getEnv
6363 either throwError return $ replaceAllTypeSynonyms' env d
src/Language/PureScript/TypeChecker/Types.hs+65−51
@@ -61,7 +61,7 @@ import Language.PureScript.Types
6161-- | Infer the types of multiple mutually-recursive values, and return elaborated values including
6262-- type class dictionaries and type annotations.
6363typesOf ::
64− (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
64+ (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
6565 ModuleName ->
6666 [(Ident, Expr)] ->
6767 m [(Ident, (Expr, Type))]
@@ -93,7 +93,7 @@ type TypeData = M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility)
9393type UntypedData = [(Ident, Type)]
9494
9595typeDictionaryForBindingGroup ::
96− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
96+ (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
9797 ModuleName ->
9898 [(Ident, Expr)] ->
9999 m ([(Ident, Expr)], [(Ident, (Expr, Type, Bool))], TypeData, UntypedData)
@@ -118,7 +118,7 @@ typeDictionaryForBindingGroup moduleName vals = do
118118 return (untyped, typed, dict, untypedDict)
119119
120120checkTypedBindingGroupElement ::
121− (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
121+ (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
122122 ModuleName ->
123123 (Ident, (Expr, Type, Bool)) ->
124124 TypeData ->
@@ -137,7 +137,7 @@ checkTypedBindingGroupElement mn (ident, (val', ty, checkType)) dict = do
137137 return (ident, (val'', ty''))
138138
139139typeForBindingGroupElement ::
140− (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
140+ (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
141141 Bool ->
142142 (Ident, Expr) ->
143143 TypeData ->
@@ -168,7 +168,7 @@ overTypes f = let (_, f', _) = everywhereOnValues id g id in f'
168168
169169-- | Replace type class dictionary placeholders with inferred type class dictionaries
170170replaceTypeClassDictionaries ::
171− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
171+ (MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
172172 ModuleName ->
173173 Expr ->
174174 m Expr
@@ -181,7 +181,7 @@ replaceTypeClassDictionaries mn =
181181
182182-- | Check the kind of a type, failing if it is not of kind *.
183183checkTypeKind ::
184− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m) =>
184+ (MonadState CheckState m, MonadError MultipleErrors m) =>
185185 Type ->
186186 Kind ->
187187 m ()
@@ -193,7 +193,7 @@ checkTypeKind ty kind = guardWith (errorMessage (ExpectedType ty kind)) $ kind =
193193-- This is necessary during type checking to avoid unifying a polymorphic type with a
194194-- unification variable.
195195instantiatePolyTypeWithUnknowns ::
196− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m) =>
196+ (MonadState CheckState m, MonadError MultipleErrors m) =>
197197 Expr ->
198198 Type ->
199199 m (Expr, Type)
@@ -207,32 +207,32 @@ instantiatePolyTypeWithUnknowns val ty = return (val, ty)
207207
208208-- | Infer a type for a value, rethrowing any error to provide a more useful error message
209209infer ::
210− (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
210+ (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
211211 Expr ->
212212 m Expr
213213infer val = rethrow (addHint (ErrorInferringType val)) $ infer' val
214214
215215-- | Infer a type for a value
216216infer' ::
217− (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
217+ (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
218218 Expr ->
219219 m Expr
220−infer' v@(NumericLiteral (Left _)) = return $ TypedValue True v tyInt
221−infer' v@(NumericLiteral (Right _)) = return $ TypedValue True v tyNumber
222−infer' v@(StringLiteral _) = return $ TypedValue True v tyString
223−infer' v@(CharLiteral _) = return $ TypedValue True v tyChar
224−infer' v@(BooleanLiteral _) = return $ TypedValue True v tyBoolean
225−infer' (ArrayLiteral vals) = do
220+infer' v@(Literal (NumericLiteral (Left _))) = return $ TypedValue True v tyInt
221+infer' v@(Literal (NumericLiteral (Right _))) = return $ TypedValue True v tyNumber
222+infer' v@(Literal (StringLiteral _)) = return $ TypedValue True v tyString
223+infer' v@(Literal (CharLiteral _)) = return $ TypedValue True v tyChar
224+infer' v@(Literal (BooleanLiteral _)) = return $ TypedValue True v tyBoolean
225+infer' (Literal (ArrayLiteral vals)) = do
226226 ts <- traverse infer vals
227227 els <- freshType
228228 forM_ ts $ \(TypedValue _ _ t) -> unifyTypes els t
229− return $ TypedValue True (ArrayLiteral ts) (TypeApp tyArray els)
230−infer' (ObjectLiteral ps) = do
229+ return $ TypedValue True (Literal (ArrayLiteral ts)) (TypeApp tyArray els)
230+infer' (Literal (ObjectLiteral ps)) = do
231231 ensureNoDuplicateProperties ps
232232 ts <- traverse (infer . snd) ps
233233 let fields = zipWith (\name (TypedValue _ _ t) -> (name, t)) (map fst ps) ts
234234 ty = TypeApp tyObject $ rowFromList (fields, REmpty)
235− return $ TypedValue True (ObjectLiteral (zip (map fst ps) ts)) ty
235+ return $ TypedValue True (Literal (ObjectLiteral (zip (map fst ps) ts))) ty
236236infer' (ObjectUpdate o ps) = do
237237 ensureNoDuplicateProperties ps
238238 row <- freshType
@@ -297,11 +297,13 @@ infer' (TypedValue checkType val ty) = do
297297 ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty
298298 val' <- if checkType then withScopedTypeVars moduleName args (check val ty') else return val
299299 return $ TypedValue True val' ty'
300−infer' (PositionedValue pos _ val) = warnAndRethrowWithPosition pos $ infer' val
300+infer' (PositionedValue pos c val) = warnAndRethrowWithPosition pos $ do
301+ TypedValue t v ty <- infer' val
302+ return $ TypedValue t (PositionedValue pos c v) ty
301303infer' _ = internalError "Invalid argument to infer"
302304
303305inferLetBinding ::
304− (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
306+ (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
305307 [Declaration] ->
306308 [Declaration] ->
307309 Expr ->
@@ -339,16 +341,16 @@ inferLetBinding _ _ _ _ = internalError "Invalid argument to inferLetBinding"
339341
340342-- | Infer the types of variables brought into scope by a binder
341343inferBinder :: forall m.
342− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
344+ (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
343345 Type ->
344346 Binder ->
345347 m (M.Map Ident Type)
346348inferBinder _ NullBinder = return M.empty
347−inferBinder val (StringBinder _) = unifyTypes val tyString >> return M.empty
348−inferBinder val (CharBinder _) = unifyTypes val tyChar >> return M.empty
349−inferBinder val (NumberBinder (Left _)) = unifyTypes val tyInt >> return M.empty
350−inferBinder val (NumberBinder (Right _)) = unifyTypes val tyNumber >> return M.empty
351−inferBinder val (BooleanBinder _) = unifyTypes val tyBoolean >> return M.empty
349+inferBinder val (LiteralBinder (StringLiteral _)) = unifyTypes val tyString >> return M.empty
350+inferBinder val (LiteralBinder (CharLiteral _)) = unifyTypes val tyChar >> return M.empty
351+inferBinder val (LiteralBinder (NumericLiteral (Left _))) = unifyTypes val tyInt >> return M.empty
352+inferBinder val (LiteralBinder (NumericLiteral (Right _))) = unifyTypes val tyNumber >> return M.empty
353+inferBinder val (LiteralBinder (BooleanLiteral _)) = unifyTypes val tyBoolean >> return M.empty
352354inferBinder val (VarBinder name) = return $ M.singleton name val
353355inferBinder val (ConstructorBinder ctor binders) = do
354356 env <- getEnv
@@ -367,7 +369,7 @@ inferBinder val (ConstructorBinder ctor binders) = do
367369 where
368370 go args (TypeApp (TypeApp fn arg) ret) | fn == tyFunction = go (arg : args) ret
369371 go args ret = (args, ret)
370−inferBinder val (ObjectBinder props) = do
372+inferBinder val (LiteralBinder (ObjectLiteral props)) = do
371373 row <- freshType
372374 rest <- freshType
373375 m1 <- inferRowProperties row rest props
@@ -381,7 +383,7 @@ inferBinder val (ObjectBinder props) = do
381383 m1 <- inferBinder propTy binder
382384 m2 <- inferRowProperties nrow (RCons name propTy row) binders
383385 return $ m1 `M.union` m2
384−inferBinder val (ArrayBinder binders) = do
386+inferBinder val (LiteralBinder (ArrayLiteral binders)) = do
385387 el <- freshType
386388 m1 <- M.unions <$> traverse (inferBinder el) binders
387389 unifyTypes val (TypeApp tyArray el)
@@ -400,6 +402,12 @@ inferBinder val (TypedBinder ty binder) = do
400402 ty1 <- replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty
401403 unifyTypes val ty1
402404 inferBinder val binder
405+inferBinder _ OpBinder{} =
406+ internalError "OpBinder should have been desugared before inferBinder"
407+inferBinder _ BinaryNoParensBinder{} =
408+ internalError "BinaryNoParensBinder should have been desugared before inferBinder"
409+inferBinder _ ParensInBinder{} =
410+ internalError "ParensInBinder should have been desugared before inferBinder"
403411
404412-- | Returns true if a binder requires its argument type to be a monotype.
405413-- | If this is the case, we need to instantiate any polymorphic types before checking binders.
@@ -412,7 +420,7 @@ binderRequiresMonotype _ = True
412420
413421-- | Instantiate polytypes only when necessitated by a binder.
414422instantiateForBinders ::
415− (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
423+ (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
416424 [Expr] ->
417425 [CaseAlternative] ->
418426 m ([Expr], [Type])
@@ -429,7 +437,7 @@ instantiateForBinders vals cas = unzip <$> zipWithM (\val inst -> do
429437-- Check the types of the return values in a set of binders in a case statement
430438--
431439checkBinders ::
432− (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
440+ (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
433441 [Type] ->
434442 Type ->
435443 [CaseAlternative] ->
@@ -459,7 +467,7 @@ checkBinders nvals ret (CaseAlternative binders result : bs) = do
459467-- Check the type of a value, rethrowing errors to provide a better error message
460468--
461469check ::
462− (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
470+ (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
463471 Expr ->
464472 Type ->
465473 m Expr
@@ -468,11 +476,12 @@ check val ty = rethrow (addHint (ErrorCheckingType val ty)) $ check' val ty
468476-- |
469477-- Check the type of a value
470478--
471−check' :: forall m.
472− (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
473− Expr ->
474− Type ->
475− m Expr
479+check'
480+ :: forall m
481+ . (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
482+ => Expr
483+ -> Type
484+ -> m Expr
476485check' val (ForAll ident ty _) = do
477486 scope <- newSkolemScope
478487 sko <- newSkolemConstant
@@ -492,7 +501,11 @@ check' val t@(ConstrainedType constraints ty) = do
492501 where
493502 -- | Add a dictionary for the constraint to the scope, and dictionaries
494503 -- for all implied superclass instances.
495− newDictionaries :: [(Qualified ProperName, Integer)] -> Qualified Ident -> (Qualified ProperName, [Type]) -> m [TypeClassDictionaryInScope]
504+ newDictionaries
505+ :: [(Qualified (ProperName 'ClassName), Integer)]
506+ -> Qualified Ident
507+ -> (Qualified (ProperName 'ClassName), [Type])
508+ -> m [TypeClassDictionaryInScope]
496509 newDictionaries path name (className, instanceTy) = do
497510 tcs <- gets (typeClasses . checkEnv)
498511 let (args, _, superclasses) = fromMaybe (internalError "newDictionaries: type class lookup failed") $ M.lookup className tcs
@@ -511,19 +524,19 @@ check' val u@(TUnknown _) = do
511524 (val'', ty') <- instantiatePolyTypeWithUnknowns val' ty
512525 unifyTypes ty' u
513526 return $ TypedValue True val'' ty'
514−check' v@(NumericLiteral (Left _)) t | t == tyInt =
527+check' v@(Literal (NumericLiteral (Left _))) t | t == tyInt =
515528 return $ TypedValue True v t
516−check' v@(NumericLiteral (Right _)) t | t == tyNumber =
529+check' v@(Literal (NumericLiteral (Right _))) t | t == tyNumber =
517530 return $ TypedValue True v t
518−check' v@(StringLiteral _) t | t == tyString =
531+check' v@(Literal (StringLiteral _)) t | t == tyString =
519532 return $ TypedValue True v t
520−check' v@(CharLiteral _) t | t == tyChar =
533+check' v@(Literal (CharLiteral _)) t | t == tyChar =
521534 return $ TypedValue True v t
522−check' v@(BooleanLiteral _) t | t == tyBoolean =
535+check' v@(Literal (BooleanLiteral _)) t | t == tyBoolean =
523536 return $ TypedValue True v t
524−check' (ArrayLiteral vals) t@(TypeApp a ty) = do
537+check' (Literal (ArrayLiteral vals)) t@(TypeApp a ty) = do
525538 unifyTypes a tyArray
526− array <- ArrayLiteral <$> forM vals (`check` ty)
539+ array <- Literal . ArrayLiteral <$> forM vals (`check` ty)
527540 return $ TypedValue True array t
528541check' (Abs (Left arg) ret) ty@(TypeApp (TypeApp t argTy) retTy) = do
529542 unifyTypes t tyFunction
@@ -574,10 +587,10 @@ check' (IfThenElse cond th el) ty = do
574587 th' <- check th ty
575588 el' <- check el ty
576589 return $ TypedValue True (IfThenElse cond' th' el') ty
577−check' e@(ObjectLiteral ps) t@(TypeApp obj row) | obj == tyObject = do
590+check' e@(Literal (ObjectLiteral ps)) t@(TypeApp obj row) | obj == tyObject = do
578591 ensureNoDuplicateProperties ps
579592 ps' <- checkProperties e ps row False
580− return $ TypedValue True (ObjectLiteral ps') t
593+ return $ TypedValue True (Literal (ObjectLiteral ps')) t
581594check' (TypeClassDictionaryConstructorApp name ps) t = do
582595 ps' <- check' ps t
583596 return $ TypedValue True (TypeClassDictionaryConstructorApp name ps') t
@@ -612,8 +625,9 @@ check' val kt@(KindedType ty kind) = do
612625 checkTypeKind ty kind
613626 val' <- check' val ty
614627 return $ TypedValue True val' kt
615−check' (PositionedValue pos _ val) ty =
616− warnAndRethrowWithPosition pos $ check' val ty
628+check' (PositionedValue pos c val) ty = warnAndRethrowWithPosition pos $ do
629+ TypedValue t v ty' <- check' val ty
630+ return $ TypedValue t (PositionedValue pos c v) ty'
617631check' val ty = do
618632 TypedValue _ val' ty' <- infer val
619633 mt <- subsumes (Just val') ty' ty
@@ -627,7 +641,7 @@ check' val ty = do
627641-- The @lax@ parameter controls whether or not every record member has to be provided. For object updates, this is not the case.
628642--
629643checkProperties ::
630− (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
644+ (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
631645 Expr ->
632646 [(String, Expr)] ->
633647 Type ->
@@ -659,7 +673,7 @@ checkProperties expr ps row lax = let (ts, r') = rowToList row in go ps ts r' wh
659673
660674-- | Check the type of a function application, rethrowing errors to provide a better error message
661675checkFunctionApplication ::
662− (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
676+ (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
663677 Expr ->
664678 Type ->
665679 Expr ->
@@ -671,7 +685,7 @@ checkFunctionApplication fn fnTy arg ret = rethrow (addHint (ErrorInApplication
671685
672686-- | Check the type of a function application
673687checkFunctionApplication' ::
674− (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
688+ (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
675689 Expr ->
676690 Type ->
677691 Expr ->
src/Language/PureScript/TypeChecker/Unify.hs+5−5
@@ -56,7 +56,7 @@ freshType = do
5656 return $ TUnknown t
5757
5858-- | Update the substitution to solve a type constraint
59−solveType :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Int -> Type -> m ()
59+solveType :: (MonadError MultipleErrors m, MonadState CheckState m) => Int -> Type -> m ()
6060solveType u t = do
6161 occursCheck u t
6262 modify $ \cs -> cs { checkSubstitution =
@@ -77,7 +77,7 @@ substituteType sub = everywhereOnTypes go
7777 go other = other
7878
7979-- | Make sure that an unknown does not occur in a type
80−occursCheck :: (Functor m, Applicative m, MonadError MultipleErrors m) => Int -> Type -> m ()
80+occursCheck :: (MonadError MultipleErrors m) => Int -> Type -> m ()
8181occursCheck _ TUnknown{} = return ()
8282occursCheck u t = void $ everywhereOnTypesM go t
8383 where
@@ -93,7 +93,7 @@ unknownsInType t = everythingOnTypes (.) go t []
9393 go _ = id
9494
9595-- | Unify two types, updating the current substitution
96−unifyTypes :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Type -> Type -> m ()
96+unifyTypes :: (MonadError MultipleErrors m, MonadState CheckState m) => Type -> Type -> m ()
9797unifyTypes t1 t2 = do
9898 sub <- gets checkSubstitution
9999 rethrow (addHint (ErrorUnifyingTypes t1 t2)) $ unifyTypes' (substituteType sub t1) (substituteType sub t2)
@@ -139,7 +139,7 @@ unifyTypes t1 t2 = do
139139-- trailing row unification variable, if appropriate, otherwise leftover labels result in a unification
140140-- error.
141141--
142−unifyRows :: forall m. (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Type -> Type -> m ()
142+unifyRows :: forall m. (MonadError MultipleErrors m, MonadState CheckState m) => Type -> Type -> m ()
143143unifyRows r1 r2 =
144144 let
145145 (s1, r1') = rowToList r1
@@ -205,7 +205,7 @@ replaceVarWithUnknown ident ty = do
205205-- |
206206-- Replace type wildcards with unknowns
207207--
208−replaceTypeWildcards :: (Functor m, Applicative m, MonadWriter MultipleErrors m, MonadState CheckState m) => Type -> m Type
208+replaceTypeWildcards :: (MonadWriter MultipleErrors m, MonadState CheckState m) => Type -> m Type
209209replaceTypeWildcards = everywhereOnTypesM replace
210210 where
211211 replace TypeWildcard = do
src/Language/PureScript/TypeClassDictionaries.hs+5−22
@@ -1,23 +1,5 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.TypeClassDictionaries
4−-- Copyright : (c) 2014 Phil Freeman
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−--
13−-----------------------------------------------------------------------------
14−
15−{-# LANGUAGE DeriveDataTypeable #-}
16−
171module Language.PureScript.TypeClassDictionaries where
182
19−import Data.Data
20−
213import Language.PureScript.Names
224import Language.PureScript.Types
235
@@ -29,14 +11,15 @@ data TypeClassDictionaryInScope
2911 -- | The identifier with which the dictionary can be accessed at runtime
3012 tcdName :: Qualified Ident
3113 -- | How to obtain this instance via superclass relationships
32− , tcdPath :: [(Qualified ProperName, Integer)]
14+ , tcdPath :: [(Qualified (ProperName 'ClassName), Integer)]
3315 -- | The name of the type class to which this type class instance applies
34− , tcdClassName :: Qualified ProperName
16+ , tcdClassName :: Qualified (ProperName 'ClassName)
3517 -- | The types to which this type class instance applies
3618 , tcdInstanceTypes :: [Type]
3719 -- | Type class dependencies which must be satisfied to construct this dictionary
3820 , tcdDependencies :: Maybe [Constraint]
39− } deriving (Show, Read, Data, Typeable)
21+ }
22+ deriving (Show, Read)
4023
4124-- |
4225-- A simplified representation of expressions which are used to represent type
@@ -58,5 +41,5 @@ data DictionaryValue
5841 -- |
5942 -- A subclass dictionary
6043 --
61− | SubclassDictionaryValue DictionaryValue (Qualified ProperName) Integer
44+ | SubclassDictionaryValue DictionaryValue (Qualified (ProperName 'ClassName)) Integer
6245 deriving (Show, Read, Ord, Eq)
src/Language/PureScript/Types.hs+11−23
@@ -1,28 +1,14 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.Types
4−-- Copyright : (c) Phil Freeman 2013
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−-- Data types for types
13−--
14−-----------------------------------------------------------------------------
15−
16−{-# LANGUAGE DeriveDataTypeable #-}
171{-# LANGUAGE GeneralizedNewtypeDeriving #-}
182{-# LANGUAGE TemplateHaskell #-}
193
4+-- |
5+-- Data types for types
6+--
207module Language.PureScript.Types where
218
229import Prelude ()
2310import Prelude.Compat
2411
25−import Data.Data
2612import Data.List (nub)
2713import Data.Maybe (fromMaybe)
2814import qualified Data.Aeson as A
@@ -39,7 +25,8 @@ import Language.PureScript.AST.SourcePos
3925-- |
4026-- An identifier for the scope of a skolem variable
4127--
42−newtype SkolemScope = SkolemScope { runSkolemScope :: Int } deriving (Show, Read, Eq, Ord, Data, Typeable, A.ToJSON, A.FromJSON)
28+newtype SkolemScope = SkolemScope { runSkolemScope :: Int }
29+ deriving (Show, Read, Eq, Ord, A.ToJSON, A.FromJSON)
4330
4431-- |
4532-- The type of types
@@ -60,7 +47,7 @@ data Type
6047 -- |
6148 -- A type constructor
6249 --
63− | TypeConstructor (Qualified ProperName)
50+ | TypeConstructor (Qualified (ProperName 'TypeName))
6451 -- |
6552 -- A type application
6653 --
@@ -101,12 +88,13 @@ data Type
10188 -- |
10289 -- A placeholder used in pretty printing
10390 --
104− | PrettyPrintForAll [String] Type deriving (Show, Read,Eq, Ord, Data, Typeable)
91+ | PrettyPrintForAll [String] Type
92+ deriving (Show, Read, Eq, Ord)
10593
10694-- |
10795-- A typeclass constraint
10896--
109−type Constraint = (Qualified ProperName, [Type])
97+type Constraint = (Qualified (ProperName 'ClassName), [Type])
11098
11199$(A.deriveJSON A.defaultOptions ''Type)
112100
@@ -260,7 +248,7 @@ everywhereOnTypesTopDown f = go . f
260248 go (PrettyPrintForAll args t) = PrettyPrintForAll args (go (f t))
261249 go other = f other
262250
263−everywhereOnTypesM :: (Functor m, Applicative m, Monad m) => (Type -> m Type) -> Type -> m Type
251+everywhereOnTypesM :: Monad m => (Type -> m Type) -> Type -> m Type
264252everywhereOnTypesM f = go
265253 where
266254 go (TypeApp t1 t2) = (TypeApp <$> go t1 <*> go t2) >>= f
@@ -273,7 +261,7 @@ everywhereOnTypesM f = go
273261 go (PrettyPrintForAll args t) = (PrettyPrintForAll args <$> go t) >>= f
274262 go other = f other
275263
276−everywhereOnTypesTopDownM :: (Functor m, Applicative m, Monad m) => (Type -> m Type) -> Type -> m Type
264+everywhereOnTypesTopDownM :: Monad m => (Type -> m Type) -> Type -> m Type
277265everywhereOnTypesTopDownM f = go <=< f
278266 where
279267 go (TypeApp t1 t2) = TypeApp <$> (f t1 >>= go) <*> (f t2 >>= go)
stack-lts-2.yamldeleted−9
@@ -1,9 +0,0 @@
1−flags: {}
2−packages:
3−- '.'
4−extra-deps:
5−- aeson-better-errors-0.8.0
6−- bower-json-0.7.0.0
7−- boxes-0.1.4
8−- pattern-arrows-0.0.2
9−resolver: lts-2.22
stack-lts-3.yamldeleted−5
@@ -1,5 +0,0 @@
1−flags: {}
2−packages:
3−- '.'
4−extra-deps:
5−resolver: lts-3.6
stack-lts-5.yamlnew file+5
@@ -0,0 +1,5 @@
1+resolver: lts-5.4
2+packages:
3+- '.'
4+extra-deps: []
5+flags: {}
stack-nightly.yaml+2−2
@@ -1,5 +1,5 @@
11flags: {}
22packages:
33- '.'
4−extra-deps:
5−resolver: nightly-2015-09-29
4+extra-deps: []
5+resolver: nightly-2016-02-25
stack.yaml+1−1
@@ -1 +1 @@
1−stack-lts-3.yaml
1+stack-lts-5.yaml
tests/Language/PureScript/Ide/FilterSpec.hsnew file+59
@@ -0,0 +1,59 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module Language.PureScript.Ide.FilterSpec where
3+
4+import Data.Text (Text)
5+import Language.PureScript.Ide.Filter
6+import Language.PureScript.Ide.Types
7+import Test.Hspec
8+
9+modules :: [Module]
10+modules =
11+ [
12+ ("Module.A", [FunctionDecl "function1" ""]),
13+ ("Module.B", [DataDecl "data1" ""]),
14+ ("Module.C", [ModuleDecl "Module.C" []]),
15+ ("Module.D", [Dependency "Module.C" [] Nothing, FunctionDecl "asd" ""])
16+ ]
17+
18+runEq :: Text -> [Module]
19+runEq s = runFilter (equalityFilter s) modules
20+runPrefix :: Text -> [Module]
21+runPrefix s = runFilter (prefixFilter s) modules
22+runModule :: [ModuleIdent] -> [Module]
23+runModule ms = runFilter (moduleFilter ms) modules
24+runDependency :: [ModuleIdent] -> [Module]
25+runDependency ms = runFilter (dependencyFilter ms) modules
26+
27+spec :: Spec
28+spec = do
29+ describe "equality Filter" $ do
30+ it "removes empty modules" $
31+ runEq "test" `shouldBe` []
32+ it "keeps function declarations that are equal" $
33+ runEq "function1" `shouldBe` [head modules]
34+ -- TODO: It would be more sensible to match Constructors
35+ it "keeps data declarations that are equal" $
36+ runEq "data1" `shouldBe` [modules !! 1]
37+ describe "prefixFilter" $ do
38+ it "keeps everything on empty string" $
39+ runPrefix "" `shouldBe` modules
40+ it "keeps functionname prefix matches" $
41+ runPrefix "fun" `shouldBe` [head modules]
42+ it "keeps data decls prefix matches" $
43+ runPrefix "dat" `shouldBe` [modules !! 1]
44+ it "keeps module decl prefix matches" $
45+ runPrefix "Mod" `shouldBe` [modules !! 2]
46+ describe "moduleFilter" $ do
47+ it "removes everything on empty input" $
48+ runModule [] `shouldBe` []
49+ it "only keeps the specified modules" $
50+ runModule ["Module.A", "Module.C"] `shouldBe` [head modules, modules !! 2]
51+ it "ignores modules that are not in scope" $
52+ runModule ["Module.A", "Module.C", "Unknown"] `shouldBe` [head modules, modules !! 2]
53+ describe "dependencyFilter" $ do
54+ it "removes everything on empty input" $
55+ runDependency [] `shouldBe` []
56+ it "only keeps the specified modules if they have no imports" $
57+ runDependency ["Module.A", "Module.B"] `shouldBe` [head modules, modules !! 1]
58+ it "keeps the specified modules and their imports" $
59+ runDependency ["Module.A", "Module.D"] `shouldBe` [head modules, modules !! 2, modules !! 3]
tests/Language/PureScript/Ide/MatcherSpec.hsnew file+31
@@ -0,0 +1,31 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+
3+module Language.PureScript.Ide.MatcherSpec where
4+
5+import Data.Text (Text)
6+import Language.PureScript.Ide.Matcher
7+import Language.PureScript.Ide.Types
8+import Test.Hspec
9+
10+completions :: [Completion]
11+completions = [
12+ Completion ("", "firstResult", ""),
13+ Completion ("", "secondResult", ""),
14+ Completion ("", "fiult", "")
15+ ]
16+
17+mkResult :: [Int] -> [Completion]
18+mkResult = map (completions !!)
19+
20+runFlex :: Text -> [Completion]
21+runFlex s = runMatcher (flexMatcher s) completions
22+
23+spec :: Spec
24+spec = do
25+ describe "Flex Matcher" $ do
26+ it "doesn't match on an empty string" $
27+ runFlex "" `shouldBe` []
28+ it "matches on equality" $
29+ runFlex "firstResult" `shouldBe` mkResult [0]
30+ it "scores short matches higher and sorts accordingly" $
31+ runFlex "filt" `shouldBe` mkResult [2, 0]
tests/Language/PureScript/Ide/ReexportsSpec.hsnew file+77
@@ -0,0 +1,77 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module Language.PureScript.Ide.ReexportsSpec where
3+
4+import Control.Exception (evaluate)
5+import Data.List (sort)
6+import qualified Data.Map as Map
7+import Language.PureScript.Ide.Reexports
8+import Language.PureScript.Ide.Types
9+import Test.Hspec
10+
11+decl1 :: ExternDecl
12+decl1 = FunctionDecl "filter" "asdasd"
13+decl2 :: ExternDecl
14+decl2 = DataDecl "Tree" "* -> *"
15+decl3 :: ExternDecl
16+decl3 = DataDecl "TreeAsd" "* -> *"
17+dep1 :: ExternDecl
18+dep1 = Dependency "Test.Foo" [] (Just "T")
19+dep2 :: ExternDecl
20+dep2 = Dependency "Test.Bar" [] (Just "T")
21+
22+circularModule :: Module
23+circularModule = ("Circular", [Export "Circular"])
24+
25+module1 :: Module
26+module1 = ("Module1", [Export "Module2", Export "Module3", decl1])
27+
28+module2 :: Module
29+module2 = ("Module2", [decl2])
30+
31+module3 :: Module
32+module3 = ("Module3", [decl3])
33+
34+module4 :: Module
35+module4 = ("Module4", [Export "T", decl1, dep1, dep2])
36+
37+result :: Module
38+result = ("Module1", [decl1, decl2, Export "Module3"])
39+
40+db :: Map.Map ModuleIdent [ExternDecl]
41+db = Map.fromList [module1, module2, module3]
42+
43+shouldBeEqualSorted :: Module -> Module -> Expectation
44+shouldBeEqualSorted (n1, d1) (n2, d2) = (n1, sort d1) `shouldBe` (n2, sort d2)
45+
46+spec :: Spec
47+spec = do
48+ describe "Reexports" $ do
49+ it "finds all reexports" $
50+ getReexports module1 `shouldBe` [Export "Module2", Export "Module3"]
51+
52+ it "replaces a reexport with another module" $
53+ replaceReexport (Export "Module2") module1 module2 `shouldBeEqualSorted` result
54+
55+ it "adds another module even if there is no export statement" $
56+ replaceReexport (Export "Module2") ("Module1", [decl1, Export "Module3"]) module2
57+ `shouldBeEqualSorted` result
58+
59+ it "only adds a declaration once" $
60+ let replaced = replaceReexport (Export "Module2") module1 module2
61+ in replaceReexport (Export "Module2") replaced module2 `shouldBeEqualSorted` result
62+
63+ it "should error when given a non-Export to replace" $
64+ evaluate (replaceReexport decl1 module1 module2)
65+ `shouldThrow` errorCall "Should only get Exports here."
66+ it "replaces all Exports with their corresponding declarations" $
67+ replaceReexports module1 db `shouldBe` ("Module1", [decl1, decl2, decl3])
68+
69+ it "does not list itself as a reexport" $
70+ getReexports circularModule `shouldBe` []
71+
72+ it "does not include circular references when replacing reexports" $
73+ replaceReexports circularModule (uncurry Map.singleton circularModule )
74+ `shouldBe` ("Circular", [])
75+
76+ it "replaces exported aliases with imported module" $
77+ getReexports module4 `shouldBe` [Export "Test.Foo", Export "Test.Bar"]
tests/Language/PureScript/IdeSpec.hsnew file+35
@@ -0,0 +1,35 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE PackageImports #-}
3+module Language.PureScript.IdeSpec where
4+
5+import Control.Concurrent.STM
6+import Control.Monad.Reader
7+import Data.List
8+import qualified Data.Map as Map
9+import Language.PureScript.Ide
10+import Language.PureScript.Ide.Types
11+import Test.Hspec
12+
13+testState :: PscIdeState
14+testState = PscIdeState (Map.fromList [("Data.Array", []), ("Control.Monad.Eff", [])]) (Map.empty)
15+
16+defaultConfig :: Configuration
17+defaultConfig =
18+ Configuration
19+ {
20+ confOutputPath = "output/"
21+ , confDebug = False
22+ }
23+
24+spec :: SpecWith ()
25+spec = do
26+ describe "list" $ do
27+ describe "loadedModules" $ do
28+ it "returns an empty list when no modules are loaded" $ do
29+ st <- newTVarIO emptyPscIdeState
30+ result <- runReaderT printModules (PscIdeEnvironment st defaultConfig)
31+ result `shouldBe` ModuleList []
32+ it "returns the list of loaded modules" $ do
33+ st <- newTVarIO testState
34+ ModuleList result <- runReaderT printModules (PscIdeEnvironment st defaultConfig)
35+ sort result `shouldBe` sort ["Data.Array", "Control.Monad.Eff"]
tests/Main.hs+22−199
@@ -16,211 +16,34 @@
1616{-# LANGUAGE TupleSections #-}
1717{-# LANGUAGE FlexibleInstances #-}
1818
19−-- Failing tests can specify the kind of error that should be thrown with a
20−-- @shouldFailWith declaration. For example:
21−--
22−-- "-- @shouldFailWith TypesDoNotUnify"
23−--
24−-- will cause the test to fail unless that module fails to compile with exactly
25−-- one TypesDoNotUnify error.
26−--
27−-- If a module is expected to produce multiple type errors, then use multiple
28−-- @shouldFailWith lines; for example:
29−--
30−-- -- @shouldFailWith TypesDoNotUnify
31−-- -- @shouldFailWith TypesDoNotUnify
32−-- -- @shouldFailWith TransitiveExportError
33−
3419module Main (main) where
3520
3621import Prelude ()
3722import Prelude.Compat
3823
39−import qualified Language.PureScript as P
40−import qualified Language.PureScript.CodeGen.JS as J
41−import qualified Language.PureScript.CoreFn as CF
42−
43−import Data.Char (isSpace)
44−import Data.Maybe (mapMaybe, fromMaybe)
45−import Data.List (isSuffixOf, sort, stripPrefix)
46−import Data.Time.Clock (UTCTime())
47−
48−import qualified Data.Map as M
49−
50−import Control.Monad
51−import Control.Monad.IO.Class (liftIO)
52−import Control.Arrow ((>>>))
53−
54−import Control.Monad.Reader
55−import Control.Monad.Writer.Strict
56−import Control.Monad.Trans.Maybe
57−import Control.Monad.Trans.Except
58−import Control.Monad.Error.Class
59−
60−import System.Exit
61−import System.Process
62−import System.FilePath
63−import System.Directory
64−import System.IO.UTF8
65−import qualified System.Info
66−import qualified System.FilePath.Glob as Glob
67−
68−import Text.Parsec (ParseError)
69−
70−import TestsSetup
71−import TestPscPublish
72−
73−modulesDir :: FilePath
74−modulesDir = ".test_modules" </> "node_modules"
75−
76−makeActions :: M.Map P.ModuleName FilePath -> P.MakeActions P.Make
77−makeActions foreigns = (P.buildMakeActions modulesDir (P.internalError "makeActions: input file map was read.") foreigns False)
78− { P.getInputTimestamp = getInputTimestamp
79− , P.getOutputTimestamp = getOutputTimestamp
80− }
81− where
82− getInputTimestamp :: P.ModuleName -> P.Make (Either P.RebuildPolicy (Maybe UTCTime))
83− getInputTimestamp mn
84− | isSupportModule (P.runModuleName mn) = return (Left P.RebuildNever)
85− | otherwise = return (Left P.RebuildAlways)
86− where
87− isSupportModule = flip elem supportModules
88−
89− getOutputTimestamp :: P.ModuleName -> P.Make (Maybe UTCTime)
90− getOutputTimestamp mn = do
91− let filePath = modulesDir </> P.runModuleName mn
92− exists <- liftIO $ doesDirectoryExist filePath
93− return (if exists then Just (P.internalError "getOutputTimestamp: read timestamp") else Nothing)
94−
95−readInput :: [FilePath] -> IO [(FilePath, String)]
96−readInput inputFiles = forM inputFiles $ \inputFile -> do
97− text <- readUTF8File inputFile
98− return (inputFile, text)
99−
100−type TestM = WriterT [(FilePath, String)] IO
101−
102−runTest :: P.Make a -> IO (Either P.MultipleErrors a)
103−runTest = fmap fst . P.runMake P.defaultOptions
104−
105−compile :: [FilePath] -> M.Map P.ModuleName FilePath -> IO (Either P.MultipleErrors P.Environment)
106−compile inputFiles foreigns = runTest $ do
107− fs <- liftIO $ readInput inputFiles
108− ms <- P.parseModulesFromFiles id fs
109− P.make (makeActions foreigns) (map snd ms)
110−
111−assert :: [FilePath] ->
112− M.Map P.ModuleName FilePath ->
113− (Either P.MultipleErrors P.Environment -> IO (Maybe String)) ->
114− TestM ()
115−assert inputFiles foreigns f = do
116− e <- liftIO $ compile inputFiles foreigns
117− maybeErr <- liftIO $ f e
118− case maybeErr of
119− Just err -> tell [(last inputFiles, err)]
120− Nothing -> return ()
121−
122−assertCompiles :: [FilePath] -> M.Map P.ModuleName FilePath -> TestM ()
123−assertCompiles inputFiles foreigns = do
124− liftIO . putStrLn $ "Assert " ++ last inputFiles ++ " compiles successfully"
125− assert inputFiles foreigns $ \e ->
126− case e of
127− Left errs -> return . Just . P.prettyPrintMultipleErrors False $ errs
128− Right _ -> do
129− process <- findNodeProcess
130− let entryPoint = modulesDir </> "index.js"
131− writeFile entryPoint "require('Main').main()"
132− result <- traverse (\node -> readProcessWithExitCode node [entryPoint] "") process
133− case result of
134− Just (ExitSuccess, out, _) -> putStrLn out >> return Nothing
135− Just (ExitFailure _, _, err) -> return $ Just err
136− Nothing -> return $ Just "Couldn't find node.js executable"
137−
138−assertDoesNotCompile :: [FilePath] -> M.Map P.ModuleName FilePath -> TestM ()
139−assertDoesNotCompile inputFiles foreigns = do
140− let testFile = last inputFiles
141− liftIO . putStrLn $ "Assert " ++ testFile ++ " does not compile"
142− shouldFailWith <- getShouldFailWith testFile
143− assert inputFiles foreigns $ \e ->
144− case e of
145− Left errs -> do
146− putStrLn (P.prettyPrintMultipleErrors False errs)
147− return $ if null shouldFailWith
148− then Just $ "shouldFailWith declaration is missing (errors were: "
149− ++ show (map P.errorCode (P.runMultipleErrors errs))
150− ++ ")"
151− else checkShouldFailWith shouldFailWith errs
152− Right _ ->
153− return $ Just "Should not have compiled"
154−
155− where
156− getShouldFailWith =
157− readUTF8File
158− >>> liftIO
159− >>> fmap ( lines
160− >>> mapMaybe (stripPrefix "-- @shouldFailWith ")
161− >>> map trim
162− )
163−
164− checkShouldFailWith expected errs =
165− let actual = map P.errorCode $ P.runMultipleErrors errs
166− in if sort expected == sort actual
167− then Nothing
168− else Just $ "Expected these errors: " ++ show expected ++ ", but got these: " ++ show actual
169−
170− trim =
171− dropWhile isSpace >>> reverse >>> dropWhile isSpace >>> reverse
24+import qualified TestCompiler
25+import qualified TestPscPublish
26+import qualified TestDocs
27+import qualified TestPsci
28+import qualified TestPscIde
17229
17330main :: IO ()
17431main = do
175− testCompiler
176− testPscPublish
32+ heading "Main compiler test suite"
33+ TestCompiler.main
34+ heading "Documentation test suite"
35+ TestDocs.main
36+ heading "psc-publish test suite"
37+ TestPscPublish.main
38+ heading "psci test suite"
39+ TestPsci.main
40+ heading "psc-ide test suite"
41+ TestPscIde.main
17742
178−testCompiler :: IO ()
179−testCompiler = do
180− fetchSupportCode
181− cwd <- getCurrentDirectory
182−
183− let supportDir = cwd </> "tests" </> "support" </> "flattened"
184− let supportFiles ext = Glob.globDir1 (Glob.compile ("*." ++ ext)) supportDir
185−
186− supportPurs <- supportFiles "purs"
187− supportJS <- supportFiles "js"
188−
189− foreignFiles <- forM supportJS (\f -> (f,) <$> readUTF8File f)
190− Right (foreigns, _) <- runExceptT $ runWriterT $ P.parseForeignModulesFromFiles foreignFiles
191−
192− let passing = cwd </> "examples" </> "passing"
193− passingTestCases <- sort . filter (".purs" `isSuffixOf`) <$> getDirectoryContents passing
194− let failing = cwd </> "examples" </> "failing"
195− failingTestCases <- sort . filter (".purs" `isSuffixOf`) <$> getDirectoryContents failing
196−
197− failures <- execWriterT $ do
198− forM_ passingTestCases $ \inputFile ->
199− assertCompiles (supportPurs ++ [passing </> inputFile]) foreigns
200− forM_ failingTestCases $ \inputFile ->
201− assertDoesNotCompile (supportPurs ++ [failing </> inputFile]) foreigns
202−
203− if null failures
204− then exitSuccess
205− else do
206− putStrLn "Failures:"
207− forM_ failures $ \(fp, err) ->
208− let fp' = fromMaybe fp $ stripPrefix (failing ++ [pathSeparator]) fp
209− in putStrLn $ fp' ++ ": " ++ err
210− exitFailure
211−
212−testPscPublish :: IO ()
213−testPscPublish = do
214− testPackage "tests/support/prelude"
215−
216−supportModules :: [String]
217−supportModules =
218− [ "Control.Monad.Eff.Class"
219− , "Control.Monad.Eff.Console"
220− , "Control.Monad.Eff"
221− , "Control.Monad.Eff.Unsafe"
222− , "Control.Monad.ST"
223− , "Data.Function"
224− , "Prelude"
225− , "Test.Assert"
226− ]
43+ where
44+ heading msg = do
45+ putStrLn ""
46+ putStrLn $ replicate 79 '#'
47+ putStrLn $ "# " ++ msg
48+ putStrLn $ replicate 79 '#'
49+ putStrLn ""
tests/PscIdeSpec.hsnew file+1
@@ -0,0 +1 @@
1+{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=PscIdeSpec #-}
tests/TestCompiler.hsnew file+194
@@ -0,0 +1,194 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE DoAndIfThenElse #-}
3+{-# LANGUAGE TupleSections #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+
6+module TestCompiler where
7+
8+-- Failing tests can specify the kind of error that should be thrown with a
9+-- @shouldFailWith declaration. For example:
10+--
11+-- "-- @shouldFailWith TypesDoNotUnify"
12+--
13+-- will cause the test to fail unless that module fails to compile with exactly
14+-- one TypesDoNotUnify error.
15+--
16+-- If a module is expected to produce multiple type errors, then use multiple
17+-- @shouldFailWith lines; for example:
18+--
19+-- -- @shouldFailWith TypesDoNotUnify
20+-- -- @shouldFailWith TypesDoNotUnify
21+-- -- @shouldFailWith TransitiveExportError
22+
23+import Prelude ()
24+import Prelude.Compat
25+
26+import qualified Language.PureScript as P
27+
28+import Data.Char (isSpace)
29+import Data.Maybe (mapMaybe, fromMaybe)
30+import Data.List (isSuffixOf, sort, stripPrefix)
31+import Data.Time.Clock (UTCTime())
32+
33+import qualified Data.Map as M
34+
35+import Control.Monad
36+import Control.Arrow ((>>>))
37+
38+import Control.Monad.Reader
39+import Control.Monad.Writer.Strict
40+import Control.Monad.Trans.Except
41+
42+import System.Exit
43+import System.Process hiding (cwd)
44+import System.FilePath
45+import System.Directory
46+import System.IO.UTF8
47+import qualified System.FilePath.Glob as Glob
48+
49+import TestUtils
50+
51+main :: IO ()
52+main = do
53+ cwd <- getCurrentDirectory
54+
55+ let supportDir = cwd </> "tests" </> "support" </> "flattened"
56+ let supportFiles ext = Glob.globDir1 (Glob.compile ("*." ++ ext)) supportDir
57+
58+ supportPurs <- supportFiles "purs"
59+ supportJS <- supportFiles "js"
60+
61+ foreignFiles <- forM supportJS (\f -> (f,) <$> readUTF8File f)
62+ Right (foreigns, _) <- runExceptT $ runWriterT $ P.parseForeignModulesFromFiles foreignFiles
63+
64+ let passing = cwd </> "examples" </> "passing"
65+ passingTestCases <- sort . filter (".purs" `isSuffixOf`) <$> getDirectoryContents passing
66+ let failing = cwd </> "examples" </> "failing"
67+ failingTestCases <- sort . filter (".purs" `isSuffixOf`) <$> getDirectoryContents failing
68+
69+ failures <- execWriterT $ do
70+ forM_ passingTestCases $ \inputFile ->
71+ assertCompiles (supportPurs ++ [passing </> inputFile]) foreigns
72+ forM_ failingTestCases $ \inputFile ->
73+ assertDoesNotCompile (supportPurs ++ [failing </> inputFile]) foreigns
74+
75+ if null failures
76+ then pure ()
77+ else do
78+ putStrLn "Failures:"
79+ forM_ failures $ \(fp, err) ->
80+ let fp' = fromMaybe fp $ stripPrefix (failing ++ [pathSeparator]) fp
81+ in putStrLn $ fp' ++ ": " ++ err
82+ exitFailure
83+
84+modulesDir :: FilePath
85+modulesDir = ".test_modules" </> "node_modules"
86+
87+makeActions :: M.Map P.ModuleName FilePath -> P.MakeActions P.Make
88+makeActions foreigns = (P.buildMakeActions modulesDir (P.internalError "makeActions: input file map was read.") foreigns False)
89+ { P.getInputTimestamp = getInputTimestamp
90+ , P.getOutputTimestamp = getOutputTimestamp
91+ }
92+ where
93+ getInputTimestamp :: P.ModuleName -> P.Make (Either P.RebuildPolicy (Maybe UTCTime))
94+ getInputTimestamp mn
95+ | isSupportModule (P.runModuleName mn) = return (Left P.RebuildNever)
96+ | otherwise = return (Left P.RebuildAlways)
97+ where
98+ isSupportModule = flip elem supportModules
99+
100+ getOutputTimestamp :: P.ModuleName -> P.Make (Maybe UTCTime)
101+ getOutputTimestamp mn = do
102+ let filePath = modulesDir </> P.runModuleName mn
103+ exists <- liftIO $ doesDirectoryExist filePath
104+ return (if exists then Just (P.internalError "getOutputTimestamp: read timestamp") else Nothing)
105+
106+readInput :: [FilePath] -> IO [(FilePath, String)]
107+readInput inputFiles = forM inputFiles $ \inputFile -> do
108+ text <- readUTF8File inputFile
109+ return (inputFile, text)
110+
111+type TestM = WriterT [(FilePath, String)] IO
112+
113+runTest :: P.Make a -> IO (Either P.MultipleErrors a)
114+runTest = fmap fst . P.runMake P.defaultOptions
115+
116+compile :: [FilePath] -> M.Map P.ModuleName FilePath -> IO (Either P.MultipleErrors P.Environment)
117+compile inputFiles foreigns = runTest $ do
118+ fs <- liftIO $ readInput inputFiles
119+ ms <- P.parseModulesFromFiles id fs
120+ P.make (makeActions foreigns) (map snd ms)
121+
122+assert :: [FilePath] ->
123+ M.Map P.ModuleName FilePath ->
124+ (Either P.MultipleErrors P.Environment -> IO (Maybe String)) ->
125+ TestM ()
126+assert inputFiles foreigns f = do
127+ e <- liftIO $ compile inputFiles foreigns
128+ maybeErr <- liftIO $ f e
129+ case maybeErr of
130+ Just err -> tell [(last inputFiles, err)]
131+ Nothing -> return ()
132+
133+assertCompiles :: [FilePath] -> M.Map P.ModuleName FilePath -> TestM ()
134+assertCompiles inputFiles foreigns = do
135+ liftIO . putStrLn $ "Assert " ++ last inputFiles ++ " compiles successfully"
136+ assert inputFiles foreigns $ \e ->
137+ case e of
138+ Left errs -> return . Just . P.prettyPrintMultipleErrors False $ errs
139+ Right _ -> do
140+ process <- findNodeProcess
141+ let entryPoint = modulesDir </> "index.js"
142+ writeFile entryPoint "require('Main').main()"
143+ result <- traverse (\node -> readProcessWithExitCode node [entryPoint] "") process
144+ case result of
145+ Just (ExitSuccess, out, _) -> putStrLn out >> return Nothing
146+ Just (ExitFailure _, _, err) -> return $ Just err
147+ Nothing -> return $ Just "Couldn't find node.js executable"
148+
149+assertDoesNotCompile :: [FilePath] -> M.Map P.ModuleName FilePath -> TestM ()
150+assertDoesNotCompile inputFiles foreigns = do
151+ let testFile = last inputFiles
152+ liftIO . putStrLn $ "Assert " ++ testFile ++ " does not compile"
153+ shouldFailWith <- getShouldFailWith testFile
154+ assert inputFiles foreigns $ \e ->
155+ case e of
156+ Left errs -> do
157+ putStrLn (P.prettyPrintMultipleErrors False errs)
158+ return $ if null shouldFailWith
159+ then Just $ "shouldFailWith declaration is missing (errors were: "
160+ ++ show (map P.errorCode (P.runMultipleErrors errs))
161+ ++ ")"
162+ else checkShouldFailWith shouldFailWith errs
163+ Right _ ->
164+ return $ Just "Should not have compiled"
165+
166+ where
167+ getShouldFailWith =
168+ readUTF8File
169+ >>> liftIO
170+ >>> fmap ( lines
171+ >>> mapMaybe (stripPrefix "-- @shouldFailWith ")
172+ >>> map trim
173+ )
174+
175+ checkShouldFailWith expected errs =
176+ let actual = map P.errorCode $ P.runMultipleErrors errs
177+ in if sort expected == sort actual
178+ then Nothing
179+ else Just $ "Expected these errors: " ++ show expected ++ ", but got these: " ++ show actual
180+
181+ trim =
182+ dropWhile isSpace >>> reverse >>> dropWhile isSpace >>> reverse
183+
184+supportModules :: [String]
185+supportModules =
186+ [ "Control.Monad.Eff.Class"
187+ , "Control.Monad.Eff.Console"
188+ , "Control.Monad.Eff"
189+ , "Control.Monad.Eff.Unsafe"
190+ , "Control.Monad.ST"
191+ , "Data.Function"
192+ , "Prelude"
193+ , "Test.Assert"
194+ ]
tests/TestDocs.hsnew file+269
@@ -0,0 +1,269 @@
1+{-# LANGUAGE RecordWildCards #-}
2+{-# LANGUAGE ViewPatterns #-}
3+{-# LANGUAGE DataKinds #-}
4+
5+module TestDocs where
6+
7+import Prelude ()
8+import Prelude.Compat
9+
10+import Data.Version (Version(..))
11+
12+import Data.Monoid
13+import Data.Maybe (fromMaybe)
14+import Data.List ((\\))
15+import Data.Foldable
16+import System.Exit
17+
18+import qualified Language.PureScript as P
19+import qualified Language.PureScript.Docs as Docs
20+import qualified Language.PureScript.Publish as Publish
21+
22+import TestUtils
23+
24+publishOpts :: Publish.PublishOptions
25+publishOpts = Publish.defaultPublishOptions
26+ { Publish.publishGetVersion = return testVersion
27+ , Publish.publishWorkingTreeDirty = return ()
28+ }
29+ where testVersion = ("v999.0.0", Version [999,0,0] [])
30+
31+main :: IO ()
32+main = do
33+ pushd "examples/docs" $ do
34+ Docs.Package{..} <- Publish.preparePackage publishOpts
35+ forM_ testCases $ \(P.moduleNameFromString -> mn, pragmas) ->
36+ let mdl = takeJust ("module not found in docs: " ++ P.runModuleName mn)
37+ (find ((==) mn . Docs.modName) pkgModules)
38+ in forM_ pragmas (flip runAssertionIO mdl)
39+
40+takeJust :: String -> Maybe a -> a
41+takeJust msg = maybe (error msg) id
42+
43+data Assertion
44+ -- | Assert that a particular declaration is documented with the given
45+ -- children
46+ = ShouldBeDocumented P.ModuleName String [String]
47+ -- | Assert that a particular declaration is not documented
48+ | ShouldNotBeDocumented P.ModuleName String
49+ -- | Assert that a particular declaration exists, but without a particular
50+ -- child.
51+ | ChildShouldNotBeDocumented P.ModuleName String String
52+ -- | Assert that a particular declaration has a particular type class
53+ -- constraint.
54+ | ShouldBeConstrained P.ModuleName String String
55+ -- | Assert that a particular value declaration exists, and its type
56+ -- satisfies the given predicate.
57+ | ValueShouldHaveTypeSignature P.ModuleName String (ShowFn (P.Type -> Bool))
58+ deriving (Show)
59+
60+newtype ShowFn a = ShowFn a
61+
62+instance Show (ShowFn a) where
63+ show _ = "<function>"
64+
65+data AssertionFailure
66+ -- | A declaration was not documented, but should have been
67+ = NotDocumented P.ModuleName String
68+ -- | A child declaration was not documented, but should have been
69+ | ChildrenNotDocumented P.ModuleName String [String]
70+ -- | A declaration was documented, but should not have been
71+ | Documented P.ModuleName String
72+ -- | A child declaration was documented, but should not have been
73+ | ChildDocumented P.ModuleName String String
74+ -- | A constraint was missing.
75+ | ConstraintMissing P.ModuleName String String
76+ -- | A declaration had the wrong "type" (ie, value, type, type class)
77+ -- Fields: declaration title, expected "type", actual "type".
78+ | WrongDeclarationType P.ModuleName String String String
79+ -- | A value declaration had the wrong type (in the sense of "type
80+ -- checking"), eg, because the inferred type was used when the explicit type
81+ -- should have been.
82+ -- Fields: module name, declaration name, actual type.
83+ | ValueDeclarationWrongType P.ModuleName String P.Type
84+ deriving (Show)
85+
86+data AssertionResult
87+ = Pass
88+ | Fail AssertionFailure
89+ deriving (Show)
90+
91+runAssertion :: Assertion -> Docs.Module -> AssertionResult
92+runAssertion assertion Docs.Module{..} =
93+ case assertion of
94+ ShouldBeDocumented mn decl children ->
95+ case findChildren decl (declarationsFor mn) of
96+ Nothing ->
97+ Fail (NotDocumented mn decl)
98+ Just actualChildren ->
99+ case children \\ actualChildren of
100+ [] -> Pass
101+ cs -> Fail (ChildrenNotDocumented mn decl cs)
102+
103+ ShouldNotBeDocumented mn decl ->
104+ case findChildren decl (declarationsFor mn) of
105+ Just _ ->
106+ Fail (Documented mn decl)
107+ Nothing ->
108+ Pass
109+
110+ ChildShouldNotBeDocumented mn decl child ->
111+ case findChildren decl (declarationsFor mn) of
112+ Just children ->
113+ if child `elem` children
114+ then Fail (ChildDocumented mn decl child)
115+ else Pass
116+ Nothing ->
117+ Fail (NotDocumented mn decl)
118+
119+ ShouldBeConstrained mn decl tyClass ->
120+ case find ((==) decl . Docs.declTitle) (declarationsFor mn) of
121+ Nothing ->
122+ Fail (NotDocumented mn decl)
123+ Just Docs.Declaration{..} ->
124+ case declInfo of
125+ Docs.ValueDeclaration ty ->
126+ if checkConstrained ty tyClass
127+ then Pass
128+ else Fail (ConstraintMissing mn decl tyClass)
129+ _ ->
130+ Fail (WrongDeclarationType mn decl "value"
131+ (Docs.declInfoToString declInfo))
132+
133+ ValueShouldHaveTypeSignature mn decl (ShowFn tyPredicate) ->
134+ case find ((==) decl . Docs.declTitle) (declarationsFor mn) of
135+ Nothing ->
136+ Fail (NotDocumented mn decl)
137+ Just Docs.Declaration{..} ->
138+ case declInfo of
139+ Docs.ValueDeclaration ty ->
140+ if tyPredicate ty
141+ then Pass
142+ else Fail
143+ (ValueDeclarationWrongType mn decl ty)
144+ _ ->
145+ Fail (WrongDeclarationType mn decl "value"
146+ (Docs.declInfoToString declInfo))
147+
148+ where
149+ declarationsFor mn =
150+ if mn == modName
151+ then modDeclarations
152+ else fromMaybe [] (lookup mn modReExports)
153+
154+ findChildren title =
155+ fmap childrenTitles . find ((==) title . Docs.declTitle)
156+
157+ childrenTitles = map Docs.cdeclTitle . Docs.declChildren
158+
159+checkConstrained :: P.Type -> String -> Bool
160+checkConstrained ty tyClass =
161+ -- Note that we don't recurse on ConstrainedType if none of the constraints
162+ -- match; this is by design, as constraints should be moved to the front
163+ -- anyway.
164+ case ty of
165+ P.ConstrainedType cs _ | any (matches tyClass) cs ->
166+ True
167+ P.ForAll _ ty' _ ->
168+ checkConstrained ty' tyClass
169+ _ ->
170+ False
171+ where
172+ matches className =
173+ (==) className . P.runProperName . P.disqualify . fst
174+
175+runAssertionIO :: Assertion -> Docs.Module -> IO ()
176+runAssertionIO assertion mdl = do
177+ putStrLn ("In " ++ P.runModuleName (Docs.modName mdl) ++ ": " ++ show assertion)
178+ case runAssertion assertion mdl of
179+ Pass -> pure ()
180+ Fail reason -> do
181+ putStrLn ("Failed: " <> show reason)
182+ exitFailure
183+
184+testCases :: [(String, [Assertion])]
185+testCases =
186+ [ ("Example",
187+ [ -- From dependencies
188+ ShouldBeDocumented (n "Prelude") "Unit" []
189+ , ShouldNotBeDocumented (n "Prelude") "unit"
190+
191+ -- From local files
192+ , ShouldBeDocumented (n "Example2") "one" []
193+ , ShouldNotBeDocumented (n "Example2") "two"
194+ ])
195+ , ("Example2",
196+ [ ShouldBeDocumented (n "Example2") "one" []
197+ , ShouldBeDocumented (n "Example2") "two" []
198+ ])
199+
200+ , ("UTF8",
201+ [ ShouldBeDocumented (n "UTF8") "thing" []
202+ ])
203+
204+ , ("Transitive1",
205+ [ ShouldBeDocumented (n "Transitive2") "transitive3" []
206+ ])
207+
208+ , ("NotAllCtors",
209+ [ ShouldBeDocumented (n "Prelude") "Boolean2" ["True"]
210+ , ChildShouldNotBeDocumented (n "Prelude") "Boolean2" "False"
211+ ])
212+
213+ , ("DuplicateNames",
214+ [ ShouldBeDocumented (n "Prelude") "Unit" []
215+ , ShouldBeDocumented (n "DuplicateNames") "unit" []
216+ , ShouldNotBeDocumented (n "Prelude") "unit"
217+ ])
218+
219+ , ("MultiVirtual",
220+ [ ShouldBeDocumented (n "MultiVirtual1") "foo" []
221+ , ShouldBeDocumented (n "MultiVirtual2") "bar" []
222+ , ShouldBeDocumented (n "MultiVirtual2") "baz" []
223+ ])
224+
225+ , ("Clash",
226+ [ ShouldBeDocumented (n "Clash1") "value" []
227+ , ShouldBeDocumented (n "Clash1") "Type" []
228+ , ShouldBeDocumented (n "Clash1") "TypeClass" ["typeClassMember"]
229+ ])
230+
231+ , ("SolitaryTypeClassMember",
232+ [ ShouldBeDocumented (n "SomeTypeClass") "member" []
233+ , ShouldNotBeDocumented (n "SomeTypeClass") "SomeClass"
234+ , ShouldBeConstrained (n "SomeTypeClass") "member" "SomeClass"
235+ ])
236+
237+ , ("ReExportedTypeClass",
238+ [ ShouldBeDocumented (n "SomeTypeClass") "SomeClass" ["member"]
239+ ])
240+
241+ , ("TypeClassWithoutMembers",
242+ [ ShouldBeDocumented (n "Intermediate") "SomeClass" []
243+ , ChildShouldNotBeDocumented (n "Intermediate") "SomeClass" "member"
244+ ])
245+
246+ -- Remove this after 0.9.
247+ , ("OldOperators",
248+ [ ShouldBeDocumented (n "OldOperators2") "(>>)" []
249+ ])
250+
251+ , ("NewOperators",
252+ [ ShouldBeDocumented (n "NewOperators2") "(>>>)" []
253+ ])
254+
255+ , ("ExplicitTypeSignatures",
256+ [ ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "explicit" (ShowFn (hasTypeVar "something"))
257+ , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "anInt" (ShowFn ((==) P.tyInt))
258+ , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "aNumber" (ShowFn ((==) P.tyNumber))
259+ ])
260+ ]
261+
262+ where
263+ n = P.moduleNameFromString
264+
265+ hasTypeVar varName =
266+ getAny . P.everythingOnTypes (<>) (Any . isVar varName)
267+
268+ isVar varName (P.TypeVar name) | varName == name = True
269+ isVar _ _ = False
tests/TestPscIde.hsnew file+7
@@ -0,0 +1,7 @@
1+module TestPscIde where
2+
3+import qualified PscIdeSpec
4+import Test.Hspec
5+
6+main :: IO ()
7+main = hspec PscIdeSpec.spec
tests/TestPscPublish.hs+12−11
@@ -20,13 +20,11 @@ import Data.Version
2020import Language.PureScript.Docs
2121import Language.PureScript.Publish
2222
23−pushd :: forall a. FilePath -> IO a -> IO a
24−pushd dir act = do
25− original <- getCurrentDirectory
26− setCurrentDirectory dir
27− result <- try act :: IO (Either IOException a)
28− setCurrentDirectory original
29− either throwIO return result
23+import TestUtils
24+
25+main :: IO ()
26+main = do
27+ testPackage "tests/support/prelude"
3028
3129data TestResult
3230 = ParseFailed String
@@ -48,6 +46,7 @@ roundTrip pkg =
4846testRunOptions :: PublishOptions
4947testRunOptions = defaultPublishOptions
5048 { publishGetVersion = return testVersion
49+ , publishWorkingTreeDirty = return ()
5150 }
5251 where testVersion = ("v999.0.0", Version [999,0,0] [])
5352
@@ -58,8 +57,10 @@ testPackage dir = do
5857 pushd dir $ do
5958 r <- roundTrip <$> preparePackage testRunOptions
6059 case r of
61− Pass _ -> pure ()
60+ Pass _ -> do
61+ putStrLn ("psc-publish test passed for: " ++ dir)
62+ pure ()
6263 other -> do
63− hPutStrLn stderr ("psc-publish tests failed on " ++ dir ++ ":")
64− hPutStrLn stderr (show other)
65− exitFailure
64+ putStrLn ("psc-publish tests failed on " ++ dir ++ ":")
65+ putStrLn (show other)
66+ exitFailure
psci/tests/Main.hs → tests/TestPsci.hsrenamed+8−11
@@ -1,7 +1,7 @@
11{-# LANGUAGE RecordWildCards #-}
22{-# LANGUAGE TupleSections #-}
33
4−module Main where
4+module TestPsci where
55
66import Prelude ()
77import Prelude.Compat
@@ -23,15 +23,12 @@ import Test.HUnit
2323
2424import qualified Language.PureScript as P
2525
26−import PSCi
27−import Completion
28−import Types
29−
30−import TestsSetup
26+import PSCi.Module (loadAllModules)
27+import PSCi.Completion
28+import PSCi.Types
3129
3230main :: IO ()
3331main = do
34− fetchSupportCode
3532 Counts{..} <- runTestTT allTests
3633 when (errors + failures > 0) exitFailure
3734
@@ -65,8 +62,8 @@ completionTestData =
6562 , ("import qualified Control.Monad.Eff.", map ("import qualified Control.Monad.Eff" ++) [".Unsafe", ".Class", ".Console"])
6663
6764 -- :load, :module should complete file paths
68− , (":l psci/tests/data/", [":l psci/tests/data/Sample.purs"])
69− , (":module psci/tests/data/", [":module psci/tests/data/Sample.purs"])
65+ , (":l tests/support/psci/", [":l tests/support/psci/Sample.purs"])
66+ , (":module tests/support/psci/", [":module tests/support/psci/Sample.purs"])
7067
7168 -- :quit, :help, :reset should not complete
7269 , (":help ", [])
@@ -141,11 +138,11 @@ getPSCiState = do
141138 Left err ->
142139 print err >> exitFailure
143140 Right modules ->
144− let imports = [controlMonadSTasST, (P.ModuleName [P.ProperName "Prelude"], P.Implicit True, Nothing)]
141+ let imports = [controlMonadSTasST, (P.ModuleName [P.ProperName "Prelude"], P.Implicit, Nothing)]
145142 in return (mkPSCiState imports modules foreigns [] [])
146143
147144controlMonadSTasST :: ImportedModule
148−controlMonadSTasST = (s "Control.Monad.ST", P.Implicit True, Just (s "ST"))
145+controlMonadSTasST = (s "Control.Monad.ST", P.Implicit, Just (s "ST"))
149146 where
150147 s = P.moduleNameFromString
151148
tests/common/TestsSetup.hs → tests/TestUtils.hsrenamed+23−3
@@ -10,7 +10,9 @@
1010-- |
1111--
1212-----------------------------------------------------------------------------
13−module TestsSetup where
13+{-# LANGUAGE ScopedTypeVariables #-}
14+
15+module TestUtils where
1416
1517import Prelude ()
1618import Prelude.Compat
@@ -18,6 +20,7 @@ import Prelude.Compat
1820import Data.Maybe (fromMaybe)
1921import Control.Monad
2022import Control.Monad.Trans.Maybe
23+import Control.Exception
2124
2225import System.Process
2326import System.Directory
@@ -30,8 +33,16 @@ findNodeProcess = runMaybeT . msum $ map (MaybeT . findExecutable) names
3033 where
3134 names = ["nodejs", "node"]
3235
33−fetchSupportCode :: IO ()
34−fetchSupportCode = do
36+-- |
37+-- Fetches code necessary to run the tests with. The resulting support code
38+-- should then be checked in, so that npm/bower etc is not required to run the
39+-- tests.
40+--
41+-- Simply rerun this (via ghci is probably easiest) when the support code needs
42+-- updating.
43+--
44+updateSupportCode :: IO ()
45+updateSupportCode = do
3546 node <- fromMaybe (internalError "cannot find node executable") <$> findNodeProcess
3647 setCurrentDirectory "tests/support"
3748 if System.Info.os == "mingw32"
@@ -43,3 +54,12 @@ fetchSupportCode = do
4354 callProcess "node_modules/.bin/bower" ["--allow-root", "install", "--config.interactive=false"]
4455 callProcess node ["setup.js"]
4556 setCurrentDirectory "../.."
57+
58+pushd :: forall a. FilePath -> IO a -> IO a
59+pushd dir act = do
60+ original <- getCurrentDirectory
61+ setCurrentDirectory dir
62+ result <- try act :: IO (Either IOException a)
63+ setCurrentDirectory original
64+ either throwIO return result
65+
tests/support/flattened/Control-Monad-Eff-Class.pursnew file+24
@@ -0,0 +1,24 @@
1+module Control.Monad.Eff.Class
2+ ( MonadEff
3+ , liftEff
4+ ) where
5+
6+import Prelude
7+
8+import Control.Monad.Eff
9+
10+-- | The `MonadEff` class captures those monads which support native effects.
11+-- |
12+-- | Instances are provided for `Eff` itself, and the standard monad transformers.
13+-- |
14+-- | `liftEff` can be used in any appropriate monad transformer stack to lift an action
15+-- | of type `Eff eff a` into the monad.
16+-- |
17+-- | Note that `MonadEff` is parameterized by the row of effects, so type inference can be
18+-- | tricky. It is generally recommended to either work with a polymorphic row of effects,
19+-- | or a concrete, closed row of effects such as `(trace :: Trace)`.
20+class (Monad m) <= MonadEff eff m where
21+ liftEff :: forall a. Eff eff a -> m a
22+
23+instance monadEffEff :: MonadEff eff (Eff eff) where
24+ liftEff = id
tests/support/flattened/Control-Monad-Eff-Console.jsnew file+18
@@ -0,0 +1,18 @@
1+/* global exports, console */
2+"use strict";
3+
4+// module Control.Monad.Eff.Console
5+
6+exports.log = function (s) {
7+ return function () {
8+ console.log(s);
9+ return {};
10+ };
11+};
12+
13+exports.error = function (s) {
14+ return function () {
15+ console.error(s);
16+ return {};
17+ };
18+};
tests/support/flattened/Control-Monad-Eff-Console.pursnew file+18
@@ -0,0 +1,18 @@
1+module Control.Monad.Eff.Console where
2+
3+import Prelude
4+
5+import Control.Monad.Eff
6+
7+-- | The `CONSOLE` effect represents those computations which write to the console.
8+foreign import data CONSOLE :: !
9+
10+-- | Write a message to the console.
11+foreign import log :: forall eff. String -> Eff (console :: CONSOLE | eff) Unit
12+
13+-- | Write an error to the console.
14+foreign import error :: forall eff. String -> Eff (console :: CONSOLE | eff) Unit
15+
16+-- | Write a value to the console, using its `Show` instance to produce a `String`.
17+print :: forall a eff. (Show a) => a -> Eff (console :: CONSOLE | eff) Unit
18+print = log <<< show
tests/support/flattened/Control-Monad-Eff-Unsafe.jsnew file+8
@@ -0,0 +1,8 @@
1+/* global exports */
2+"use strict";
3+
4+// module Control.Monad.Eff.Unsafe
5+
6+exports.unsafeInterleaveEff = function (f) {
7+ return f;
8+};
tests/support/flattened/Control-Monad-Eff-Unsafe.pursnew file+10
@@ -0,0 +1,10 @@
1+module Control.Monad.Eff.Unsafe where
2+
3+import Prelude
4+
5+import Control.Monad.Eff
6+
7+-- | Change the type of an effectful computation, allowing it to be run in another context.
8+-- |
9+-- | Note: use of this function can result in arbitrary side-effects.
10+foreign import unsafeInterleaveEff :: forall eff1 eff2 a. Eff eff1 a -> Eff eff2 a
tests/support/flattened/Control-Monad-Eff.jsnew file+62
@@ -0,0 +1,62 @@
1+/* global exports */
2+"use strict";
3+
4+// module Control.Monad.Eff
5+
6+exports.returnE = function (a) {
7+ return function () {
8+ return a;
9+ };
10+};
11+
12+exports.bindE = function (a) {
13+ return function (f) {
14+ return function () {
15+ return f(a())();
16+ };
17+ };
18+};
19+
20+exports.runPure = function (f) {
21+ return f();
22+};
23+
24+exports.untilE = function (f) {
25+ return function () {
26+ while (!f());
27+ return {};
28+ };
29+};
30+
31+exports.whileE = function (f) {
32+ return function (a) {
33+ return function () {
34+ while (f()) {
35+ a();
36+ }
37+ return {};
38+ };
39+ };
40+};
41+
42+exports.forE = function (lo) {
43+ return function (hi) {
44+ return function (f) {
45+ return function () {
46+ for (var i = lo; i < hi; i++) {
47+ f(i)();
48+ }
49+ };
50+ };
51+ };
52+};
53+
54+exports.foreachE = function (as) {
55+ return function (f) {
56+ return function () {
57+ for (var i = 0, l = as.length; i < l; i++) {
58+ f(as[i])();
59+ }
60+ };
61+ };
62+};
tests/support/flattened/Control-Monad-Eff.pursnew file+67
@@ -0,0 +1,67 @@
1+module Control.Monad.Eff
2+ ( Eff()
3+ , Pure()
4+ , runPure
5+ , untilE, whileE, forE, foreachE
6+ ) where
7+
8+import Prelude
9+
10+-- | The `Eff` type constructor is used to represent _native_ effects.
11+-- |
12+-- | See [Handling Native Effects with the Eff Monad](https://github.com/purescript/purescript/wiki/Handling-Native-Effects-with-the-Eff-Monad) for more details.
13+-- |
14+-- | The first type parameter is a row of effects which represents the contexts in which a computation can be run, and the second type parameter is the return type.
15+foreign import data Eff :: # ! -> * -> *
16+
17+foreign import returnE :: forall e a. a -> Eff e a
18+
19+foreign import bindE :: forall e a b. Eff e a -> (a -> Eff e b) -> Eff e b
20+
21+-- | The `Pure` type synonym represents _pure_ computations, i.e. ones in which all effects have been handled.
22+-- |
23+-- | The `runPure` function can be used to run pure computations and obtain their result.
24+type Pure a = forall e. Eff e a
25+
26+-- | Run a pure computation and return its result.
27+-- |
28+-- | Note: since this function has a rank-2 type, it may cause problems to apply this function using the `$` operator. The recommended approach
29+-- | is to use parentheses instead.
30+foreign import runPure :: forall a. Pure a -> a
31+
32+instance functorEff :: Functor (Eff e) where
33+ map = liftA1
34+
35+instance applyEff :: Apply (Eff e) where
36+ apply = ap
37+
38+instance applicativeEff :: Applicative (Eff e) where
39+ pure = returnE
40+
41+instance bindEff :: Bind (Eff e) where
42+ bind = bindE
43+
44+instance monadEff :: Monad (Eff e)
45+
46+-- | Loop until a condition becomes `true`.
47+-- |
48+-- | `untilE b` is an effectful computation which repeatedly runs the effectful computation `b`,
49+-- | until its return value is `true`.
50+foreign import untilE :: forall e. Eff e Boolean -> Eff e Unit
51+
52+-- | Loop while a condition is `true`.
53+-- |
54+-- | `whileE b m` is effectful computation which runs the effectful computation `b`. If its result is
55+-- | `true`, it runs the effectful computation `m` and loops. If not, the computation ends.
56+foreign import whileE :: forall e a. Eff e Boolean -> Eff e a -> Eff e Unit
57+
58+-- | Loop over a consecutive collection of numbers.
59+-- |
60+-- | `forE lo hi f` runs the computation returned by the function `f` for each of the inputs
61+-- | between `lo` (inclusive) and `hi` (exclusive).
62+foreign import forE :: forall e. Number -> Number -> (Number -> Eff e Unit) -> Eff e Unit
63+
64+-- | Loop over an array of values.
65+-- |
66+-- | `foreach xs f` runs the computation returned by the function `f` for each of the inputs `xs`.
67+foreign import foreachE :: forall e a. Array a -> (a -> Eff e Unit) -> Eff e Unit
tests/support/flattened/Control-Monad-ST.jsnew file+38
@@ -0,0 +1,38 @@
1+/* global exports */
2+"use strict";
3+
4+// module Control.Monad.ST
5+
6+exports.newSTRef = function (val) {
7+ return function () {
8+ return { value: val };
9+ };
10+};
11+
12+exports.readSTRef = function (ref) {
13+ return function () {
14+ return ref.value;
15+ };
16+};
17+
18+exports.modifySTRef = function (ref) {
19+ return function (f) {
20+ return function () {
21+ /* jshint boss: true */
22+ return ref.value = f(ref.value);
23+ };
24+ };
25+};
26+
27+exports.writeSTRef = function (ref) {
28+ return function (a) {
29+ return function () {
30+ /* jshint boss: true */
31+ return ref.value = a;
32+ };
33+ };
34+};
35+
36+exports.runST = function (f) {
37+ return f;
38+};
tests/support/flattened/Control-Monad-ST.pursnew file+42
@@ -0,0 +1,42 @@
1+module Control.Monad.ST where
2+
3+import Prelude
4+
5+import Control.Monad.Eff (Eff(), runPure)
6+
7+-- | The `ST` effect represents _local mutation_, i.e. mutation which does not "escape" into the surrounding computation.
8+-- |
9+-- | An `ST` computation is parameterized by a phantom type which is used to restrict the set of reference cells it is allowed to access.
10+-- |
11+-- | The `runST` function can be used to handle the `ST` effect.
12+foreign import data ST :: * -> !
13+
14+-- | The type `STRef s a` represents a mutable reference holding a value of type `a`, which can be used with the `ST s` effect.
15+foreign import data STRef :: * -> * -> *
16+
17+-- | Create a new mutable reference.
18+foreign import newSTRef :: forall a h r. a -> Eff (st :: ST h | r) (STRef h a)
19+
20+-- | Read the current value of a mutable reference.
21+foreign import readSTRef :: forall a h r. STRef h a -> Eff (st :: ST h | r) a
22+
23+-- | Modify the value of a mutable reference by applying a function to the current value.
24+foreign import modifySTRef :: forall a h r. STRef h a -> (a -> a) -> Eff (st :: ST h | r) a
25+
26+-- | Set the value of a mutable reference.
27+foreign import writeSTRef :: forall a h r. STRef h a -> a -> Eff (st :: ST h | r) a
28+
29+-- | Run an `ST` computation.
30+-- |
31+-- | Note: the type of `runST` uses a rank-2 type to constrain the phantom type `s`, such that the computation must not leak any mutable references
32+-- | to the surrounding computation.
33+-- |
34+-- | It may cause problems to apply this function using the `$` operator. The recommended approach is to use parentheses instead.
35+foreign import runST :: forall a r. (forall h. Eff (st :: ST h | r) a) -> Eff r a
36+
37+-- | A convenience function which combines `runST` with `runPure`, which can be used when the only required effect is `ST`.
38+-- |
39+-- | Note: since this function has a rank-2 type, it may cause problems to apply this function using the `$` operator. The recommended approach
40+-- | is to use parentheses instead.
41+pureST :: forall a. (forall h r. Eff (st :: ST h | r) a) -> a
42+pureST st = runPure (runST st)
tests/support/flattened/Data-Function.jsnew file+233
@@ -0,0 +1,233 @@
1+/* global exports */
2+"use strict";
3+
4+// module Data.Function
5+
6+exports.mkFn0 = function (fn) {
7+ return function () {
8+ return fn({});
9+ };
10+};
11+
12+exports.mkFn1 = function (fn) {
13+ return function (a) {
14+ return fn(a);
15+ };
16+};
17+
18+exports.mkFn2 = function (fn) {
19+ /* jshint maxparams: 2 */
20+ return function (a, b) {
21+ return fn(a)(b);
22+ };
23+};
24+
25+exports.mkFn3 = function (fn) {
26+ /* jshint maxparams: 3 */
27+ return function (a, b, c) {
28+ return fn(a)(b)(c);
29+ };
30+};
31+
32+exports.mkFn4 = function (fn) {
33+ /* jshint maxparams: 4 */
34+ return function (a, b, c, d) {
35+ return fn(a)(b)(c)(d);
36+ };
37+};
38+
39+exports.mkFn5 = function (fn) {
40+ /* jshint maxparams: 5 */
41+ return function (a, b, c, d, e) {
42+ return fn(a)(b)(c)(d)(e);
43+ };
44+};
45+
46+exports.mkFn6 = function (fn) {
47+ /* jshint maxparams: 6 */
48+ return function (a, b, c, d, e, f) {
49+ return fn(a)(b)(c)(d)(e)(f);
50+ };
51+};
52+
53+exports.mkFn7 = function (fn) {
54+ /* jshint maxparams: 7 */
55+ return function (a, b, c, d, e, f, g) {
56+ return fn(a)(b)(c)(d)(e)(f)(g);
57+ };
58+};
59+
60+exports.mkFn8 = function (fn) {
61+ /* jshint maxparams: 8 */
62+ return function (a, b, c, d, e, f, g, h) {
63+ return fn(a)(b)(c)(d)(e)(f)(g)(h);
64+ };
65+};
66+
67+exports.mkFn9 = function (fn) {
68+ /* jshint maxparams: 9 */
69+ return function (a, b, c, d, e, f, g, h, i) {
70+ return fn(a)(b)(c)(d)(e)(f)(g)(h)(i);
71+ };
72+};
73+
74+exports.mkFn10 = function (fn) {
75+ /* jshint maxparams: 10 */
76+ return function (a, b, c, d, e, f, g, h, i, j) {
77+ return fn(a)(b)(c)(d)(e)(f)(g)(h)(i)(j);
78+ };
79+};
80+
81+exports.runFn0 = function (fn) {
82+ return fn();
83+};
84+
85+exports.runFn1 = function (fn) {
86+ return function (a) {
87+ return fn(a);
88+ };
89+};
90+
91+exports.runFn2 = function (fn) {
92+ return function (a) {
93+ return function (b) {
94+ return fn(a, b);
95+ };
96+ };
97+};
98+
99+exports.runFn3 = function (fn) {
100+ return function (a) {
101+ return function (b) {
102+ return function (c) {
103+ return fn(a, b, c);
104+ };
105+ };
106+ };
107+};
108+
109+exports.runFn4 = function (fn) {
110+ return function (a) {
111+ return function (b) {
112+ return function (c) {
113+ return function (d) {
114+ return fn(a, b, c, d);
115+ };
116+ };
117+ };
118+ };
119+};
120+
121+exports.runFn5 = function (fn) {
122+ return function (a) {
123+ return function (b) {
124+ return function (c) {
125+ return function (d) {
126+ return function (e) {
127+ return fn(a, b, c, d, e);
128+ };
129+ };
130+ };
131+ };
132+ };
133+};
134+
135+exports.runFn6 = function (fn) {
136+ return function (a) {
137+ return function (b) {
138+ return function (c) {
139+ return function (d) {
140+ return function (e) {
141+ return function (f) {
142+ return fn(a, b, c, d, e, f);
143+ };
144+ };
145+ };
146+ };
147+ };
148+ };
149+};
150+
151+exports.runFn7 = function (fn) {
152+ return function (a) {
153+ return function (b) {
154+ return function (c) {
155+ return function (d) {
156+ return function (e) {
157+ return function (f) {
158+ return function (g) {
159+ return fn(a, b, c, d, e, f, g);
160+ };
161+ };
162+ };
163+ };
164+ };
165+ };
166+ };
167+};
168+
169+exports.runFn8 = function (fn) {
170+ return function (a) {
171+ return function (b) {
172+ return function (c) {
173+ return function (d) {
174+ return function (e) {
175+ return function (f) {
176+ return function (g) {
177+ return function (h) {
178+ return fn(a, b, c, d, e, f, g, h);
179+ };
180+ };
181+ };
182+ };
183+ };
184+ };
185+ };
186+ };
187+};
188+
189+exports.runFn9 = function (fn) {
190+ return function (a) {
191+ return function (b) {
192+ return function (c) {
193+ return function (d) {
194+ return function (e) {
195+ return function (f) {
196+ return function (g) {
197+ return function (h) {
198+ return function (i) {
199+ return fn(a, b, c, d, e, f, g, h, i);
200+ };
201+ };
202+ };
203+ };
204+ };
205+ };
206+ };
207+ };
208+ };
209+};
210+
211+exports.runFn10 = function (fn) {
212+ return function (a) {
213+ return function (b) {
214+ return function (c) {
215+ return function (d) {
216+ return function (e) {
217+ return function (f) {
218+ return function (g) {
219+ return function (h) {
220+ return function (i) {
221+ return function (j) {
222+ return fn(a, b, c, d, e, f, g, h, i, j);
223+ };
224+ };
225+ };
226+ };
227+ };
228+ };
229+ };
230+ };
231+ };
232+ };
233+};
tests/support/flattened/Data-Function.pursnew file+113
@@ -0,0 +1,113 @@
1+module Data.Function where
2+
3+import Prelude
4+
5+-- | The `on` function is used to change the domain of a binary operator.
6+-- |
7+-- | For example, we can create a function which compares two records based on the values of their `x` properties:
8+-- |
9+-- | ```purescript
10+-- | compareX :: forall r. { x :: Number | r } -> { x :: Number | r } -> Ordering
11+-- | compareX = compare `on` _.x
12+-- | ```
13+on :: forall a b c. (b -> b -> c) -> (a -> b) -> a -> a -> c
14+on f g x y = g x `f` g y
15+
16+-- | A function of zero arguments
17+foreign import data Fn0 :: * -> *
18+
19+-- | A function of one argument
20+foreign import data Fn1 :: * -> * -> *
21+
22+-- | A function of two arguments
23+foreign import data Fn2 :: * -> * -> * -> *
24+
25+-- | A function of three arguments
26+foreign import data Fn3 :: * -> * -> * -> * -> *
27+
28+-- | A function of four arguments
29+foreign import data Fn4 :: * -> * -> * -> * -> * -> *
30+
31+-- | A function of five arguments
32+foreign import data Fn5 :: * -> * -> * -> * -> * -> * -> *
33+
34+-- | A function of six arguments
35+foreign import data Fn6 :: * -> * -> * -> * -> * -> * -> * -> *
36+
37+-- | A function of seven arguments
38+foreign import data Fn7 :: * -> * -> * -> * -> * -> * -> * -> * -> *
39+
40+-- | A function of eight arguments
41+foreign import data Fn8 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> *
42+
43+-- | A function of nine arguments
44+foreign import data Fn9 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> *
45+
46+-- | A function of ten arguments
47+foreign import data Fn10 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> *
48+
49+-- | Create a function of no arguments
50+foreign import mkFn0 :: forall a. (Unit -> a) -> Fn0 a
51+
52+-- | Create a function of one argument
53+foreign import mkFn1 :: forall a b. (a -> b) -> Fn1 a b
54+
55+-- | Create a function of two arguments from a curried function
56+foreign import mkFn2 :: forall a b c. (a -> b -> c) -> Fn2 a b c
57+
58+-- | Create a function of three arguments from a curried function
59+foreign import mkFn3 :: forall a b c d. (a -> b -> c -> d) -> Fn3 a b c d
60+
61+-- | Create a function of four arguments from a curried function
62+foreign import mkFn4 :: forall a b c d e. (a -> b -> c -> d -> e) -> Fn4 a b c d e
63+
64+-- | Create a function of five arguments from a curried function
65+foreign import mkFn5 :: forall a b c d e f. (a -> b -> c -> d -> e -> f) -> Fn5 a b c d e f
66+
67+-- | Create a function of six arguments from a curried function
68+foreign import mkFn6 :: forall a b c d e f g. (a -> b -> c -> d -> e -> f -> g) -> Fn6 a b c d e f g
69+
70+-- | Create a function of seven arguments from a curried function
71+foreign import mkFn7 :: forall a b c d e f g h. (a -> b -> c -> d -> e -> f -> g -> h) -> Fn7 a b c d e f g h
72+
73+-- | Create a function of eight arguments from a curried function
74+foreign import mkFn8 :: forall a b c d e f g h i. (a -> b -> c -> d -> e -> f -> g -> h -> i) -> Fn8 a b c d e f g h i
75+
76+-- | Create a function of nine arguments from a curried function
77+foreign import mkFn9 :: forall a b c d e f g h i j. (a -> b -> c -> d -> e -> f -> g -> h -> i -> j) -> Fn9 a b c d e f g h i j
78+
79+-- | Create a function of ten arguments from a curried function
80+foreign import mkFn10 :: forall a b c d e f g h i j k. (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k) -> Fn10 a b c d e f g h i j k
81+
82+-- | Apply a function of no arguments
83+foreign import runFn0 :: forall a. Fn0 a -> a
84+
85+-- | Apply a function of one argument
86+foreign import runFn1 :: forall a b. Fn1 a b -> a -> b
87+
88+-- | Apply a function of two arguments
89+foreign import runFn2 :: forall a b c. Fn2 a b c -> a -> b -> c
90+
91+-- | Apply a function of three arguments
92+foreign import runFn3 :: forall a b c d. Fn3 a b c d -> a -> b -> c -> d
93+
94+-- | Apply a function of four arguments
95+foreign import runFn4 :: forall a b c d e. Fn4 a b c d e -> a -> b -> c -> d -> e
96+
97+-- | Apply a function of five arguments
98+foreign import runFn5 :: forall a b c d e f. Fn5 a b c d e f -> a -> b -> c -> d -> e -> f
99+
100+-- | Apply a function of six arguments
101+foreign import runFn6 :: forall a b c d e f g. Fn6 a b c d e f g -> a -> b -> c -> d -> e -> f -> g
102+
103+-- | Apply a function of seven arguments
104+foreign import runFn7 :: forall a b c d e f g h. Fn7 a b c d e f g h -> a -> b -> c -> d -> e -> f -> g -> h
105+
106+-- | Apply a function of eight arguments
107+foreign import runFn8 :: forall a b c d e f g h i. Fn8 a b c d e f g h i -> a -> b -> c -> d -> e -> f -> g -> h -> i
108+
109+-- | Apply a function of nine arguments
110+foreign import runFn9 :: forall a b c d e f g h i j. Fn9 a b c d e f g h i j -> a -> b -> c -> d -> e -> f -> g -> h -> i -> j
111+
112+-- | Apply a function of ten arguments
113+foreign import runFn10 :: forall a b c d e f g h i j k. Fn10 a b c d e f g h i j k -> a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k
tests/support/flattened/Prelude.jsnew file+228
@@ -0,0 +1,228 @@
1+/* global exports */
2+"use strict";
3+
4+// module Prelude
5+
6+//- Functor --------------------------------------------------------------------
7+
8+exports.arrayMap = function (f) {
9+ return function (arr) {
10+ var l = arr.length;
11+ var result = new Array(l);
12+ for (var i = 0; i < l; i++) {
13+ result[i] = f(arr[i]);
14+ }
15+ return result;
16+ };
17+};
18+
19+//- Bind -----------------------------------------------------------------------
20+
21+exports.arrayBind = function (arr) {
22+ return function (f) {
23+ var result = [];
24+ for (var i = 0, l = arr.length; i < l; i++) {
25+ Array.prototype.push.apply(result, f(arr[i]));
26+ }
27+ return result;
28+ };
29+};
30+
31+//- Monoid ---------------------------------------------------------------------
32+
33+exports.concatString = function (s1) {
34+ return function (s2) {
35+ return s1 + s2;
36+ };
37+};
38+
39+exports.concatArray = function (xs) {
40+ return function (ys) {
41+ return xs.concat(ys);
42+ };
43+};
44+
45+//- Semiring -------------------------------------------------------------------
46+
47+exports.intAdd = function (x) {
48+ return function (y) {
49+ /* jshint bitwise: false */
50+ return x + y | 0;
51+ };
52+};
53+
54+exports.intMul = function (x) {
55+ return function (y) {
56+ /* jshint bitwise: false */
57+ return x * y | 0;
58+ };
59+};
60+
61+exports.numAdd = function (n1) {
62+ return function (n2) {
63+ return n1 + n2;
64+ };
65+};
66+
67+exports.numMul = function (n1) {
68+ return function (n2) {
69+ return n1 * n2;
70+ };
71+};
72+
73+//- ModuloSemiring -------------------------------------------------------------
74+
75+exports.intDiv = function (x) {
76+ return function (y) {
77+ /* jshint bitwise: false */
78+ return x / y | 0;
79+ };
80+};
81+
82+exports.intMod = function (x) {
83+ return function (y) {
84+ return x % y;
85+ };
86+};
87+
88+exports.numDiv = function (n1) {
89+ return function (n2) {
90+ return n1 / n2;
91+ };
92+};
93+
94+//- Ring -----------------------------------------------------------------------
95+
96+exports.intSub = function (x) {
97+ return function (y) {
98+ /* jshint bitwise: false */
99+ return x - y | 0;
100+ };
101+};
102+
103+exports.numSub = function (n1) {
104+ return function (n2) {
105+ return n1 - n2;
106+ };
107+};
108+
109+//- Eq -------------------------------------------------------------------------
110+
111+exports.refEq = function (r1) {
112+ return function (r2) {
113+ return r1 === r2;
114+ };
115+};
116+
117+exports.refIneq = function (r1) {
118+ return function (r2) {
119+ return r1 !== r2;
120+ };
121+};
122+
123+exports.eqArrayImpl = function (f) {
124+ return function (xs) {
125+ return function (ys) {
126+ if (xs.length !== ys.length) return false;
127+ for (var i = 0; i < xs.length; i++) {
128+ if (!f(xs[i])(ys[i])) return false;
129+ }
130+ return true;
131+ };
132+ };
133+};
134+
135+exports.ordArrayImpl = function (f) {
136+ return function (xs) {
137+ return function (ys) {
138+ var i = 0;
139+ var xlen = xs.length;
140+ var ylen = ys.length;
141+ while (i < xlen && i < ylen) {
142+ var x = xs[i];
143+ var y = ys[i];
144+ var o = f(x)(y);
145+ if (o !== 0) {
146+ return o;
147+ }
148+ i++;
149+ }
150+ if (xlen === ylen) {
151+ return 0;
152+ } else if (xlen > ylen) {
153+ return -1;
154+ } else {
155+ return 1;
156+ }
157+ };
158+ };
159+};
160+
161+//- Ord ------------------------------------------------------------------------
162+
163+exports.unsafeCompareImpl = function (lt) {
164+ return function (eq) {
165+ return function (gt) {
166+ return function (x) {
167+ return function (y) {
168+ return x < y ? lt : x > y ? gt : eq;
169+ };
170+ };
171+ };
172+ };
173+};
174+
175+//- Bounded --------------------------------------------------------------------
176+
177+exports.topInt = 2147483647;
178+exports.bottomInt = -2147483648;
179+
180+exports.topChar = String.fromCharCode(65535);
181+exports.bottomChar = String.fromCharCode(0);
182+
183+//- BooleanAlgebra -------------------------------------------------------------
184+
185+exports.boolOr = function (b1) {
186+ return function (b2) {
187+ return b1 || b2;
188+ };
189+};
190+
191+exports.boolAnd = function (b1) {
192+ return function (b2) {
193+ return b1 && b2;
194+ };
195+};
196+
197+exports.boolNot = function (b) {
198+ return !b;
199+};
200+
201+//- Show -----------------------------------------------------------------------
202+
203+exports.showIntImpl = function (n) {
204+ return n.toString();
205+};
206+
207+exports.showNumberImpl = function (n) {
208+ /* jshint bitwise: false */
209+ return n === (n | 0) ? n + ".0" : n.toString();
210+};
211+
212+exports.showCharImpl = function (c) {
213+ return c === "'" ? "'\\''" : "'" + c + "'";
214+};
215+
216+exports.showStringImpl = function (s) {
217+ return JSON.stringify(s);
218+};
219+
220+exports.showArrayImpl = function (f) {
221+ return function (xs) {
222+ var ss = [];
223+ for (var i = 0, l = xs.length; i < l; i++) {
224+ ss[i] = f(xs[i]);
225+ }
226+ return "[" + ss.join(",") + "]";
227+ };
228+};
tests/support/flattened/Prelude.pursnew file+872

This diff is too big to show here.

tests/support/flattened/Test-Assert.jsnew file+27

This diff is too big to show here.

tests/support/flattened/Test-Assert.pursnew file+46

This diff is too big to show here.

psci/tests/data/Sample.purs → tests/support/psci/Sample.pursrenamed

The content is the same.

travis/after.sh+5−17

This diff is too big to show here.

travis/configure.sh+1−1

This diff is too big to show here.