474a886 · rowtype-yoga/purescript-native

.gitignore+2−1

compare with golang

unifiedsplit

@@ -14,5 +14,6 @@ bower_components/

14node_modules

15tmp/

16.stack-work/

17−tests/support/flattened/

18output

17output

18+examples/docs/docs/

19+core-tests/full-core-docs.md

.travis.yml+13−26

@@ -1,36 +1,21 @@

1language: c

2−sudo: false

2+dist: trusty

3+sudo: required

3matrix:

4matrix:

4 include:

5 include:

5− - env: GHCVER=7.8.4 COVERAGE_SUITE=tests

6+ - env: GHCVER=7.10.3 CABALVER=1.22 STACKAGE=lts-5.4 RUNSDISTTESTS=YES

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"

7+ compiler: ": #GHC 7.10.3 lts-5.4"

23− addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.2,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}}

8+ addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}}

24− - env: GHCVER=7.10.2 STACKAGE=nightly-2015-09-29

9+ - env: GHCVER=7.10.3 CABALVER=1.22 STACKAGE=nightly-2016-02-25

25− compiler: ": #GHC 7.10.2 nightly-2015-09-29"

10+ compiler: ": #GHC 7.10.3 nightly-2016-02-25"

26− addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.2,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}}

11+ addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}}

27− - env: GHCVER=7.10.3

12+ - env: GHCVER=7.10.3 CABALVER=1.22 DEPLOY=yes

28 compiler: ": #GHC 7.10.3"

13 compiler: ": #GHC 7.10.3"

29 addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}}

14 addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}}

30before_install:

15before_install:

31 - unset CC

16 - unset CC

32 - export PATH="/opt/ghc/$GHCVER/bin:$PATH"

17 - export PATH="/opt/ghc/$GHCVER/bin:$PATH"

33− - export PATH="/opt/cabal/1.22/bin:$PATH"

18+ - export PATH="/opt/cabal/$CABALVER/bin:$PATH"

34 - export PATH="$HOME/.cabal/bin:$PATH"

19 - export PATH="$HOME/.cabal/bin:$PATH"

35 - export PATH="/opt/happy/1.19.5/bin:/$PATH"

20 - export PATH="/opt/happy/1.19.5/bin:/$PATH"

36 - export PATH="/opt/alex/3.1.4/bin:/$PATH"

21 - export PATH="/opt/alex/3.1.4/bin:/$PATH"

@@ -51,12 +36,14 @@ install:

51 - mkdir -p .cabal-sandbox

36 - mkdir -p .cabal-sandbox

52 - cabal sandbox init --sandbox .cabal-sandbox

37 - cabal sandbox init --sandbox .cabal-sandbox

53 # Download stackage cabal.config, not sure whether filtering is necessary

38 # 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

55 - cabal install --only-dependencies --enable-tests

40 - cabal install --only-dependencies --enable-tests

56 - cabal install hpc-coveralls

41 - cabal install hpc-coveralls

57 # Snapshot state of the sandbox now, so we don't need to make new one for test install

42 # Snapshot state of the sandbox now, so we don't need to make new one for test install

58 - rm -rf ~/cabal-sandboxes/$GHCVER-${STACKAGE:-none}

43 - rm -rf ~/cabal-sandboxes/$GHCVER-${STACKAGE:-none}

59 - cp -r .cabal-sandbox ~/cabal-sandboxes/$GHCVER-${STACKAGE:-none}

44 - cp -r .cabal-sandbox ~/cabal-sandboxes/$GHCVER-${STACKAGE:-none}

45+ # Install bower globally (for psc-docs/psc-publish tests)

46+ - npm install -g bower

60script:

47script:

61 - ./travis/configure.sh

48 - ./travis/configure.sh

62 - cabal build --ghc-options="-Werror"

49 - 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

12- [@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.

13- [@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.

14- [@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).

15- [@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).

18- [@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).

16- [@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).

20- [@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).

17- [@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).

21- [@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).

18- [@eamelink](https://github.com/eamelink) (Erik Bakker) - My existing contributions and all future contributions until further notice are Copyright Erik Bakker, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license.

22- [@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

21- [@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).

25- [@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).

22- [@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).

26- [@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).

23- [@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).

27- [@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).

24- [@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).

29- [@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).

25- [@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).

30- [@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).

26- [@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.

31- [@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

41- [@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).

46- [@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).

42- [@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.

47- [@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.

43- [@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).

48- [@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).

44- [@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).

50- [@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).

45- [@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).

51- [@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).

46- [@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).

52- [@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

50- [@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).

56- [@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).

51- [@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).

57- [@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).

52- [@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.

58- [@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).

53- [@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).

62- [@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).

54- [@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).

63- [@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).

55- [@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).

65- [@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).

56- [@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).

66- [@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).

57- [@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.

67- [@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.

58- [@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).

68- [@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).

63

69

64### Companies

70### Companies

65

71

INSTALL.md+4−8

@@ -6,8 +6,8 @@ alternatively Stack Overflow.

6

7## Using prebuilt binaries

8

9−The prebuilt binaries are compiled with GHC 7.8.4, and therefore they should

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.8.4, such as:

10+run on any operating system supported by GHC 7.10.3, such as:

11

12* Windows 2000 or later,

13* OS X 10.7 or later,

@@ -23,11 +23,11 @@ requirements.

23

24## Compiling from source

25

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

27use stack:

28

29```

30−$ stack install purescript

30+$ stack install --resolver=nightly purescript

31```

32

33This 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

39If you don't have ghc installed yet, stack will prompt you to run `stack setup`

40which will install ghc for you.

41

42−The PureScript compiler has been known to run on OS X 10.6 when built with GHC

43−7.6.

44−

45−

46## The "curses" library

42## The "curses" library

47

43

48`psci` depends on the `curses` library (via the Haskell package `terminfo`). If

44`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

63 safe

64 scientific

65 semigroups

66+ sourcemap

66 split

67 split

67 stm

68 stm

68 syb

69 syb

@@ -1589,6 +1590,39 @@ semigroups LICENSE file:

1589 ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE

1590 ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE

1590 POSSIBILITY OF SUCH DAMAGE.

1591 POSSIBILITY OF SUCH DAMAGE.

1591

1592

1593+sourcemap LICENSE file:

1594+

1596+

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+

1592split LICENSE file:

1626split LICENSE file:

1593

1627

bundle/README+9−6

@@ -10,12 +10,15 @@ Installation Instructions

10

11This bundle contains the following executables:

12

13−- psc The PureScript compiler

13+- psc The PureScript compiler

14−- psci The PureScript interactive REPL (requires NodeJS)

14+- psci The PureScript interactive REPL (requires NodeJS)

15−- psc-docs A Markdown documentation generator for PureScript code

15+- psc-docs A Markdown documentation generator for PureScript code

16−- psc-bundle Bundles together CommonJS modules produced by `psc` into a

16+- psc-bundle Bundles together CommonJS modules produced by `psc` into a

17− single JavaScript file; useful for running in the browser.

17+ single JavaScript file; useful for running in the browser.

18−- psc-publish Generates documentation packages for uploading to Pursuit

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

19

22

20Copy these files anywhere on your PATH.

23Copy these files anywhere on your PATH.

21

24

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

21strip ../dist/build/psc-docs/psc-docs

22strip ../dist/build/psc-publish/psc-publish

23strip ../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

24

26

25# Copy files to staging directory

27# Copy files to staging directory

26−cp ../dist/build/psc/psc build/purescript/

28+cp ../dist/build/psc/psc build/purescript/

27−cp ../dist/build/psci/psci build/purescript/

29+cp ../dist/build/psci/psci build/purescript/

28−cp ../dist/build/psc-docs/psc-docs build/purescript/

30+cp ../dist/build/psc-docs/psc-docs build/purescript/

29−cp ../dist/build/psc-publish/psc-publish 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/

30−cp ../dist/build/psc-bundle/psc-bundle build/purescript/

34+cp ../dist/build/psc-ide-client/psc-ide-client build/purescript/

31−cp README build/purescript/

35+cp README build/purescript/

32−cp ../LICENSE build/purescript/

36+cp ../LICENSE build/purescript/

33−cp ../INSTALL.md build/purescript/

37+cp ../INSTALL.md build/purescript/

34

38

35# Make the binary bundle

39# Make the binary bundle

36pushd build > /dev/null

40pushd build > /dev/null

bundle/winbuild.sh+12−8

@@ -17,16 +17,20 @@ strip ../dist/build/psci/psci.exe

17strip ../dist/build/psc-docs/psc-docs.exe

18strip ../dist/build/psc-publish/psc-publish.exe

19strip ../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

20

22

21# Copy files to staging directory

23# Copy files to staging directory

22−cp ../dist/build/psc/psc.exe build/purescript/

24+cp ../dist/build/psc/psc.exe build/purescript/

23−cp ../dist/build/psci/psci.exe build/purescript/

25+cp ../dist/build/psci/psci.exe build/purescript/

24−cp ../dist/build/psc-docs/psc-docs.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/

25−cp ../dist/build/psc-publish/psc-publish.exe build/purescript/

29+cp ../dist/build/psc-ide-server/psc-ide-server.exe build/purescript/

26−cp ../dist/build/psc-bundle/psc-bundle.exe build/purescript/

30+cp ../dist/build/psc-ide-client/psc-ide-client.exe build/purescript/

27−cp README build/purescript/

31+cp README build/purescript/

28−cp ../LICENSE build/purescript/

32+cp ../LICENSE build/purescript/

29−cp ../INSTALL.md build/purescript/

33+cp ../INSTALL.md build/purescript/

30

34

31# Make the binary bundle

35# Make the binary bundle

32pushd build

36pushd build

core-tests/test-everything.sh+5−3

@@ -18,9 +18,7 @@ if [ "$force_reinstall" = "true" ] && [ -d "bower_components" ]; then

18 rm -r bower_components

19fi

20

21−npm install bower

22−

23−node_modules/.bin/bower i \

21+bower i \

24 purescript-prelude \

22 purescript-prelude \

25 purescript-eff \

23 purescript-eff \

26 purescript-st \

24 purescript-st \

@@ -75,3 +73,7 @@ fi

75../dist/build/psc/psc tests/*/*.purs \

73../dist/build/psc/psc tests/*/*.purs \

76 'bower_components/purescript-*/src/**/*.purs' \

74 'bower_components/purescript-*/src/**/*.purs' \

77 --ffi 'bower_components/purescript-*/src/**/*.js'

75 --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

4 thing :: Int

5 thing = 1

6

7−module Main where

7+module B where

8−

9− import A

10

8

11 thing :: Int

9 thing :: Int

12 thing = 2

10 thing = 2

13

11

12+module Main where

13+

14+ import A (thing)

15+ import B (thing)

16+

14− -- Error due to referencing `thing` which is in scope as A.thing and Main.thing

17+ -- Error due to referencing `thing` which is explicitly in scope as A.thing

18+ -- and B.thing

15 what :: Int

19 what :: Int

16 what = thing

20 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 @@

3module Main where

4

5n :: 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 @@

14-----------------------------------------------------------------------------

15

16{-# LANGUAGE TupleSections #-}

17+{-# LANGUAGE DataKinds #-}

17

18

18module Main where

19module Main where

19

20

@@ -38,7 +39,7 @@ data HierarchyOptions = HierarchyOptions

38 , hierarchyOutput :: Maybe FilePath

39 , hierarchyOutput :: Maybe FilePath

39 }

40 }

40

41

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)) }

42 deriving Eq

43 deriving Eq

43

44

44instance Show SuperMap where

45instance Show SuperMap where

psc-bundle/Main.hs+2−2

@@ -51,7 +51,7 @@ data Options = Options

51 } deriving Show

52

53-- | 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

55guessModuleIdentifier filename = ModuleIdentifier (takeFileName (takeDirectory filename)) <$> guessModuleType (takeFileName filename)

56 where

57 guessModuleType "index.js" = pure Regular

@@ -61,7 +61,7 @@ guessModuleIdentifier filename = ModuleIdentifier (takeFileName (takeDirectory f

61-- | The main application function.

62-- This function parses the input files, performs dead code elimination, filters empty modules

63-- 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

65app Options{..} = do

66 inputFiles <- concat <$> mapM (liftIO . glob) optionsInputFiles

67 when (null inputFiles) . liftIO $ do

psc-docs/Main.hs+47−39

@@ -16,6 +16,7 @@

16module Main where

17

18import Control.Applicative

19+import Control.Monad.Trans.Except (runExceptT)

19import Control.Arrow (first, second)

20import Control.Arrow (first, second)

20import Control.Category ((>>>))

21import Control.Category ((>>>))

21import Control.Monad.Writer

22import Control.Monad.Writer

@@ -68,61 +69,68 @@ docgen (PSCDocsOptions fmt inputGlob output) = do

68 Etags -> dumpTags input dumpEtags

69 Etags -> dumpTags input dumpEtags

69 Ctags -> dumpTags input dumpCtags

70 Ctags -> dumpTags input dumpCtags

70 Markdown -> do

71 Markdown -> do

71− e <- D.parseAndDesugar input [] (\_ ms -> return ms)

72+ ms <- runExceptT (D.parseAndBookmark input []

72− case e of

73+ >>= (fst >>> D.convertModulesInPackage))

73− Left (D.ParseError err) -> do

74+ >>= successOrExit

74− hPutStrLn stderr $ show err

75+

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

76+ case output of

84− EverythingToStdOut ->

77+ EverythingToStdOut ->

85− putStrLn (D.renderModulesAsMarkdown ms')

78+ putStrLn (D.runDocs (D.modulesAsMarkdown ms))

86− ToStdOut names -> do

79+ ToStdOut names -> do

87− let (ms, missing) = takeModulesByName ms' names

80+ let (ms', missing) = takeByName ms names

88− guardMissing missing

81+ guardMissing missing

89− putStrLn (D.renderModulesAsMarkdown ms)

82+ putStrLn (D.runDocs (D.modulesAsMarkdown ms'))

90− ToFiles names -> do

83+ ToFiles names -> do

91− let (ms, missing) = takeModulesByName' ms' names

84+ let (ms', missing) = takeByName' ms names

92− guardMissing missing

85+ guardMissing missing

86+

93− let ms'' = groupBy ((==) `on` fst) . sortBy (compare `on` fst) $ map swap ms

87+ let ms'' = groupBy ((==) `on` fst) . sortBy (compare `on` fst) $ map swap ms'

94− forM_ ms'' $ \grp -> do

88+ forM_ ms'' $ \grp -> do

95− let fp = fst (head grp)

89+ let fp = fst (head grp)

96− createDirectoryIfMissing True (takeDirectory fp)

90+ createDirectoryIfMissing True (takeDirectory fp)

97− writeFile fp (D.renderModulesAsMarkdown $ snd `map` grp)

91+ writeFile fp (D.runDocs (D.modulesAsMarkdown (map snd grp)))

92+

98 where

93 where

99 guardMissing [] = return ()

94 guardMissing [] = return ()

100 guardMissing [mn] = do

95 guardMissing [mn] = do

101− hPutStrLn stderr ("psc-docs: error: unknown module \"" ++ show mn ++ "\"")

96+ hPutStrLn stderr ("psc-docs: error: unknown module \"" ++ P.runModuleName mn ++ "\"")

102 exitFailure

97 exitFailure

103 guardMissing mns = do

98 guardMissing mns = do

104 hPutStrLn stderr "psc-docs: error: unknown modules:"

99 hPutStrLn stderr "psc-docs: error: unknown modules:"

105 forM_ mns $ \mn ->

100 forM_ mns $ \mn ->

106− hPutStrLn stderr (" * " ++ show mn)

101+ hPutStrLn stderr (" * " ++ P.runModuleName mn)

107 exitFailure

102 exitFailure

108

103

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+

109-- |

116-- |

110-- Given a list of module names and a list of modules, return a list of modules

117-- Given a list of module names and a list of modules, return a list of modules

111-- whose names appeared in the given name list, together with a list of names

118-- whose names appeared in the given name list, together with a list of names

112-- for which no module could be found in the module list.

119-- for which no module could be found in the module list.

113--

120--

114−takeModulesByName :: [P.Module] -> [P.ModuleName] -> ([P.Module], [P.ModuleName])

121+takeModulesByName :: (Eq n) => (m -> n) -> [m] -> [n] -> ([m], [n])

115−takeModulesByName modules names =

122+takeModulesByName getModuleName modules names =

116− first (map fst) (takeModulesByName' modules (map (,()) names))

123+ first (map fst) (takeModulesByName' getModuleName modules (map (,()) names))

117

124

118-- |

125-- |

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.

120--

128--

121−takeModulesByName' :: [P.Module] -> [(P.ModuleName, a)] -> ([(P.Module, a)], [P.ModuleName])

129+takeModulesByName' :: (Eq n) => (m -> n) -> [m] -> [(n, a)] -> ([(m, a)], [n])

122−takeModulesByName' modules = foldl go ([], [])

130+takeModulesByName' getModuleName modules = foldl go ([], [])

123 where

131 where

124 go (ms, missing) (name, x) =

132 go (ms, missing) (name, x) =

125− case find ((== name) . P.getModuleName) modules of

133+ case find ((== name) . getModuleName) modules of

126 Just m -> ((m, x) : ms, missing)

134 Just m -> ((m, x) : ms, missing)

127 Nothing -> (ms, name : missing)

135 Nothing -> (ms, name : missing)

128

136

@@ -236,16 +244,16 @@ examples =

236 PP.vcat $ map PP.text

244 PP.vcat $ map PP.text

237 [ "Examples:"

245 [ "Examples:"

238 , " print documentation for Data.List to stdout:"

246 , " 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\" \\"

240 , " --docgen Data.List"

248 , " --docgen Data.List"

241 , ""

249 , ""

242 , " write documentation for Data.List to docs/Data.List.md:"

250 , " 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\" \\"

244 , " --docgen Data.List:docs/Data.List.md"

252 , " --docgen Data.List:docs/Data.List.md"

245 , ""

253 , ""

246 , " write documentation for Data.List to docs/Data.List.md, and"

254 , " write documentation for Data.List to docs/Data.List.md, and"

247 , " documentation for Data.List.Lazy to docs/Data.List.Lazy.md:"

255 , " 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\" \\"

249 , " --docgen Data.List:docs/Data.List.md \\"

257 , " --docgen Data.List:docs/Data.List.md \\"

250 , " --docgen Data.List.Lazy:docs/Data.List.Lazy.md"

258 , " --docgen Data.List.Lazy:docs/Data.List.Lazy.md"

251 ]

259 ]

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

30 , endColumn :: Int

31 }

32

33+data ErrorSuggestion = ErrorSuggestion { replacement :: String }

34+

33data JSONError = JSONError

35data JSONError = JSONError

34 { position :: Maybe ErrorPosition

36 { position :: Maybe ErrorPosition

35 , message :: String

37 , message :: String

36 , errorCode :: String

38 , errorCode :: String

39+ , errorLink :: String

37 , filename :: Maybe String

40 , filename :: Maybe String

38 , moduleName :: Maybe String

41 , moduleName :: Maybe String

42+ , suggestion :: Maybe ErrorSuggestion

39 }

43 }

40

44

41data JSONResult = JSONResult

45data JSONResult = JSONResult

@@ -46,6 +50,8 @@ data JSONResult = JSONResult

46$(A.deriveJSON A.defaultOptions ''ErrorPosition)

50$(A.deriveJSON A.defaultOptions ''ErrorPosition)

47$(A.deriveJSON A.defaultOptions ''JSONError)

51$(A.deriveJSON A.defaultOptions ''JSONError)

48$(A.deriveJSON A.defaultOptions ''JSONResult)

52$(A.deriveJSON A.defaultOptions ''JSONResult)

53+$(A.deriveJSON A.defaultOptions ''ErrorSuggestion)

54+

49

55

50toJSONErrors :: Bool -> P.Level -> P.MultipleErrors -> [JSONError]

56toJSONErrors :: Bool -> P.Level -> P.MultipleErrors -> [JSONError]

51toJSONErrors verbose level = map (toJSONError verbose level) . P.runMultipleErrors

57toJSONErrors verbose level = map (toJSONError verbose level) . P.runMultipleErrors

@@ -53,10 +59,12 @@ toJSONErrors verbose level = map (toJSONError verbose level) . P.runMultipleErro

53toJSONError :: Bool -> P.Level -> P.ErrorMessage -> JSONError

59toJSONError :: Bool -> P.Level -> P.ErrorMessage -> JSONError

54toJSONError verbose level e =

60toJSONError verbose level e =

55 JSONError (toErrorPosition <$> sspan)

61 JSONError (toErrorPosition <$> sspan)

56− (P.renderBox (P.prettyPrintSingleError' verbose level (P.stripModuleAndSpan e)))

62+ (P.renderBox (P.prettyPrintSingleError verbose level False (P.stripModuleAndSpan e)))

57 (P.errorCode e)

63 (P.errorCode e)

64+ (P.wikiUri e)

58 (P.spanName <$> sspan)

65 (P.spanName <$> sspan)

59 (P.runModuleName <$> P.errorModule e)

66 (P.runModuleName <$> P.errorModule e)

67+ (toSuggestion <$> (P.errorSuggestion $ P.unwrapErrorMessage e))

60 where

68 where

61 sspan :: Maybe P.SourceSpan

69 sspan :: Maybe P.SourceSpan

62 sspan = P.errorSpan e

70 sspan = P.errorSpan e

@@ -67,3 +75,6 @@ toJSONError verbose level e =

67 (P.sourcePosColumn (P.spanStart ss))

75 (P.sourcePosColumn (P.spanStart ss))

68 (P.sourcePosLine (P.spanEnd ss))

76 (P.sourcePosLine (P.spanEnd ss))

69 (P.sourcePosColumn (P.spanEnd ss))

77 (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

76

77compile :: PSCMakeOptions -> IO ()

78compile PSCMakeOptions{..} = do

79− input <- globWarningOnMisses warnFileTypeNotFound pscmInput

79+ input <- globWarningOnMisses (unless pscmJSONErrors . warnFileTypeNotFound) pscmInput

80− when (null input) $ do

80+ when (null input && not pscmJSONErrors) $ do

81 hPutStrLn stderr "psc: No input files."

82 exitFailure

83 let (jsFiles, pursFiles) = partition (isSuffixOf ".js") input

84 moduleFiles <- readInput (InputOptions pursFiles)

85− inputForeign <- globWarningOnMisses warnFileTypeNotFound pscmForeignInput

85+ inputForeign <- globWarningOnMisses (unless pscmJSONErrors . warnFileTypeNotFound) pscmForeignInput

86 foreignFiles <- forM (inputForeign ++ jsFiles) (\inFile -> (inFile,) <$> readUTF8File inFile)

87 (makeErrors, makeWarnings) <- runMake pscmOpts $ do

88 (ms, foreigns) <- parseInputs moduleFiles foreignFiles

@@ -107,7 +107,7 @@ globWarningOnMisses warn = concatMapM globWithWarning

107readInput :: InputOptions -> IO [(Either P.RebuildPolicy FilePath, String)]

108readInput InputOptions{..} = forM ioInputFiles $ \inFile -> (Right inFile, ) <$> readUTF8File inFile

109

110−parseInputs :: (Functor m, Applicative m, MonadError P.MultipleErrors m, MonadWriter P.MultipleErrors m)

110+parseInputs :: (MonadError P.MultipleErrors m, MonadWriter P.MultipleErrors m)

111 => [(Either P.RebuildPolicy FilePath, String)]

112 -> [(FilePath, P.ForeignJS)]

113 -> m ([(Either P.RebuildPolicy FilePath, P.Module)], M.Map P.ModuleName FilePath)

@@ -177,6 +177,11 @@ jsonErrors :: Parser Bool

177jsonErrors = switch $

178 long "json-errors"

179 <> help "Print errors to stderr as JSON"

180+sourceMaps :: Parser Bool

181+sourceMaps = switch $

182+ long "source-maps"

183+ <> help "Generate source maps"

184+

180

185

181options :: Parser P.Options

186options :: Parser P.Options

182options = P.Options <$> noTco

187options = P.Options <$> noTco

@@ -186,6 +191,7 @@ options = P.Options <$> noTco

186 <*> verboseErrors

191 <*> verboseErrors

187 <*> (not <$> comments)

192 <*> (not <$> comments)

188 <*> requirePath

193 <*> requirePath

194+ <*> sourceMaps

189

195

190pscMakeOptions :: Parser PSCMakeOptions

196pscMakeOptions :: Parser PSCMakeOptions

191pscMakeOptions = PSCMakeOptions <$> many inputFile

197pscMakeOptions = PSCMakeOptions <$> many inputFile

psci/IO.hsdeleted−21

@@ -1,21 +0,0 @@

1−-----------------------------------------------------------------------------

2−--

3−-- Module : IO

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 @@

2{-# LANGUAGE GeneralizedNewtypeDeriving #-}

3{-# LANGUAGE RecordWildCards #-}

4{-# LANGUAGE TupleSections #-}

5+{-# LANGUAGE DataKinds #-}

5

6

6-- |

7-- |

7-- PureScript Compiler Interactive.

8-- PureScript Compiler Interactive.

8--

9--

9−module PSCi where

10+module PSCi (runPSCi) where

10

11

11import Prelude ()

12import Prelude ()

12import Prelude.Compat

13import Prelude.Compat

13

14

14import Data.Foldable (traverse_)

15import Data.Foldable (traverse_)

15−import Data.Maybe (mapMaybe)

16−import Data.List (intersperse, intercalate, nub, sort)

16+import Data.List (intercalate, nub, sort, find)

17import Data.Tuple (swap)

18−import Data.Version (showVersion)

19import qualified Data.Map as M

18import qualified Data.Map as M

20

19

21import Control.Arrow (first)

20import Control.Arrow (first)

@@ -23,102 +22,87 @@ import Control.Monad

23import Control.Monad.Error.Class (MonadError(..))

22import Control.Monad.Error.Class (MonadError(..))

24import Control.Monad.Trans.Class

23import Control.Monad.Trans.Class

25import Control.Monad.Trans.Except (ExceptT(), runExceptT)

24import Control.Monad.Trans.Except (ExceptT(), runExceptT)

26−import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)

27import Control.Monad.Trans.State.Strict

25import Control.Monad.Trans.State.Strict

28import Control.Monad.IO.Class (liftIO)

26import Control.Monad.IO.Class (liftIO)

29import Control.Monad.Writer.Strict (Writer(), runWriter)

27import Control.Monad.Writer.Strict (Writer(), runWriter)

30

28

31−import Options.Applicative as Opts

32−

33import System.Console.Haskeline

29import System.Console.Haskeline

34−import System.Directory (doesFileExist, findExecutable, getHomeDirectory, getCurrentDirectory)

30+import System.Directory (doesFileExist, getHomeDirectory, getCurrentDirectory)

35import System.Exit

31import System.Exit

36−import System.FilePath (pathSeparator, (</>), isPathSeparator)

32+import System.FilePath ((</>))

37import System.FilePath.Glob (glob)

33import System.FilePath.Glob (glob)

38import System.Process (readProcessWithExitCode)

34import System.Process (readProcessWithExitCode)

39import System.IO.Error (tryIOError)

35import System.IO.Error (tryIOError)

40−import qualified Text.PrettyPrint.Boxes as Box

41

36

42import qualified Language.PureScript as P

37import qualified Language.PureScript as P

43import qualified Language.PureScript.Names as N

38import 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

86

39

87−-- |

40+import PSCi.Completion (completion)

88−-- Locates the node executable.

41+import PSCi.Parser (parseCommand)

89−-- Checks for either @nodejs@ or @node@.

42+import PSCi.Option

90−--

43+import PSCi.Types

91−findNodeProcess :: IO (Maybe String)

44+import PSCi.Message

92−findNodeProcess = onFirstFileMatching findExecutable names

45+import PSCi.IO

93− where names = ["nodejs", "node"]

46+import PSCi.Printer

47+import PSCi.Module

94

48

95-- |

49-- |

96−-- Grabs the filename where the history is stored.

50+-- PSCI monad

97--

51--

98−getHistoryFilename :: IO FilePath

52+newtype PSCI a = PSCI { runPSCI :: InputT (StateT PSCiState IO) a } deriving (Functor, Applicative, Monad)

99−getHistoryFilename = do

53+

100− home <- getHomeDirectory

54+psciIO :: IO a -> PSCI a

101− let filename = home </> ".purescript" </> "psci_history"

55+psciIO io = PSCI . lift $ lift io

102− mkdirp filename

103− return filename

104

56

105-- |

57-- |

106−-- Loads a file for use with imports.

58+-- The runner

107--

59--

108−loadModule :: FilePath -> IO (Either String [P.Module])

60+runPSCi :: IO ()

109−loadModule filename = do

61+runPSCi = getOpt >>= loop

110− content <- readFile filename

111− return $ either (Left . P.prettyPrintMultipleErrors False) (Right . map snd) $ P.parseModulesFromFiles id [(filename, content)]

112

62

113-- |

63-- |

114−-- Load all modules.

64+-- The PSCI main loop.

115--

65--

116−loadAllModules :: [FilePath] -> IO (Either P.MultipleErrors [(FilePath, P.Module)])

66+loop :: PSCiOptions -> IO ()

117−loadAllModules files = do

67+loop PSCiOptions{..} = do

118− filesAndContent <- forM files $ \filename -> do

68+ config <- loadUserConfig

119− content <- readFile filename

69+ inputFiles <- concat <$> traverse glob psciInputFile

120− return (filename, content)

70+ foreignFiles <- concat <$> traverse glob psciForeignInputFiles

121− return $ P.parseModulesFromFiles id filesAndContent

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

122

106

123-- |

107-- |

124-- Load all modules, updating the application state

108-- Load all modules, updating the application state

@@ -128,116 +112,9 @@ loadAllImportedModules = do

128 files <- PSCI . lift $ fmap psciImportedFilenames get

112 files <- PSCI . lift $ fmap psciImportedFilenames get

129 modulesOrFirstError <- psciIO $ loadAllModules files

113 modulesOrFirstError <- psciIO $ loadAllModules files

130 case modulesOrFirstError of

114 case modulesOrFirstError of

131− Left errs -> printErrors errs

115+ Left errs -> PSCI $ printErrors errs

132 Right modules -> PSCI . lift . modify $ updateModules modules

116 Right modules -> PSCI . lift . modify $ updateModules modules

133

117

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−

241-- | This is different than the runMake in 'Language.PureScript.Make' in that it specifies the

118-- | This is different than the runMake in 'Language.PureScript.Make' in that it specifies the

242-- options and ignores the warning messages.

119-- options and ignores the warning messages.

243runMake :: P.Make a -> IO (Either P.MultipleErrors a)

120runMake :: P.Make a -> IO (Either P.MultipleErrors a)

@@ -257,6 +134,58 @@ make st@PSCiState{..} ms = P.make actions' (map snd loadedModules ++ ms)

257 loadedModules = psciLoadedModules st

134 loadedModules = psciLoadedModules st

258 allModules = map (first Right) loadedModules ++ map (Left P.RebuildAlways,) ms

135 allModules = map (first Right) loadedModules ++ map (Left P.RebuildAlways,) ms

259

136

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+

260-- |

189-- |

261-- Takes a value expression and evaluates it with the current state.

190-- Takes a value expression and evaluates it with the current state.

262--

191--

@@ -267,7 +196,7 @@ handleExpression val = do

267 let nodeArgs = psciNodeFlags st ++ [indexFile]

196 let nodeArgs = psciNodeFlags st ++ [indexFile]

268 e <- psciIO . runMake $ make st [supportModule, m]

197 e <- psciIO . runMake $ make st [supportModule, m]

269 case e of

198 case e of

270− Left errs -> printErrors errs

199+ Left errs -> PSCI $ printErrors errs

271 Right _ -> do

200 Right _ -> do

272 psciIO $ writeFile indexFile "require('$PSCI')['$main']();"

201 psciIO $ writeFile indexFile "require('$PSCI')['$main']();"

273 process <- psciIO findNodeProcess

202 process <- psciIO findNodeProcess

@@ -285,10 +214,10 @@ handleDecls :: [P.Declaration] -> PSCI ()

285handleDecls ds = do

214handleDecls ds = do

286 st <- PSCI $ lift get

215 st <- PSCI $ lift get

287 let st' = updateLets ds st

216 let st' = updateLets ds st

288− let m = createTemporaryModule False st' (P.ObjectLiteral [])

217+ let m = createTemporaryModule False st' (P.Literal (P.ObjectLiteral []))

289 e <- psciIO . runMake $ make st' [m]

218 e <- psciIO . runMake $ make st' [m]

290 case e of

219 case e of

291− Left err -> printErrors err

220+ Left err -> PSCI $ printErrors err

292 Right _ -> PSCI $ lift (put st')

221 Right _ -> PSCI $ lift (put st')

293

222

294-- |

223-- |

@@ -317,8 +246,7 @@ handleShowImportedModules = do

317 Just mn' -> "qualified " ++ N.runModuleName mn ++ " as " ++ N.runModuleName mn'

246 Just mn' -> "qualified " ++ N.runModuleName mn ++ " as " ++ N.runModuleName mn'

318 Nothing -> N.runModuleName mn ++ " " ++ showDeclType declType

247 Nothing -> N.runModuleName mn ++ " " ++ showDeclType declType

319

248

320− showDeclType (P.Implicit True) = " (..)"

249+ showDeclType P.Implicit = ""

321− showDeclType (P.Implicit False) = ""

322 showDeclType (P.Explicit refs) = refsList refs

250 showDeclType (P.Explicit refs) = refsList refs

323 showDeclType (P.Hiding refs) = " hiding " ++ refsList refs

251 showDeclType (P.Hiding refs) = " hiding " ++ refsList refs

324 refsList refs = " (" ++ commaList (map showRef refs) ++ ")"

252 refsList refs = " (" ++ commaList (map showRef refs) ++ ")"

@@ -327,7 +255,7 @@ handleShowImportedModules = do

327 showRef (P.TypeRef pn dctors) = N.runProperName pn ++ "(" ++ maybe ".." (commaList . map N.runProperName) dctors ++ ")"

255 showRef (P.TypeRef pn dctors) = N.runProperName pn ++ "(" ++ maybe ".." (commaList . map N.runProperName) dctors ++ ")"

328 showRef (P.ValueRef ident) = N.runIdent ident

256 showRef (P.ValueRef ident) = N.runIdent ident

329 showRef (P.TypeClassRef pn) = N.runProperName pn

257 showRef (P.TypeClassRef pn) = N.runProperName pn

330− showRef (P.ProperRef pn) = N.runProperName pn

258+ showRef (P.ProperRef pn) = pn

331 showRef (P.TypeInstanceRef ident) = N.runIdent ident

259 showRef (P.TypeInstanceRef ident) = N.runIdent ident

332 showRef (P.ModuleRef name) = "module " ++ N.runModuleName name

260 showRef (P.ModuleRef name) = "module " ++ N.runModuleName name

333 showRef (P.PositionedDeclarationRef _ _ ref) = showRef ref

261 showRef (P.PositionedDeclarationRef _ _ ref) = showRef ref

@@ -344,7 +272,7 @@ handleImport im = do

344 let m = createTemporaryModuleForImports st

272 let m = createTemporaryModuleForImports st

345 e <- psciIO . runMake $ make st [m]

273 e <- psciIO . runMake $ make st [m]

346 case e of

274 case e of

347− Left errs -> printErrors errs

275+ Left errs -> PSCI $ printErrors errs

348 Right _ -> do

276 Right _ -> do

349 PSCI $ lift $ put st

277 PSCI $ lift $ put st

350 return ()

278 return ()

@@ -358,115 +286,12 @@ handleTypeOf val = do

358 let m = createTemporaryModule False st val

286 let m = createTemporaryModule False st val

359 e <- psciIO . runMake $ make st [m]

287 e <- psciIO . runMake $ make st [m]

360 case e of

288 case e of

361− Left errs -> printErrors errs

289+ Left errs -> PSCI $ printErrors errs

362 Right env' ->

290 Right env' ->

363 case M.lookup (P.ModuleName [P.ProperName "$PSCI"], P.Ident "it") (P.names env') of

291 case M.lookup (P.ModuleName [P.ProperName "$PSCI"], P.Ident "it") (P.names env') of

364 Just (ty, _, _) -> PSCI . outputStrLn . P.prettyPrintType $ ty

292 Just (ty, _, _) -> PSCI . outputStrLn . P.prettyPrintType $ ty

365 Nothing -> PSCI $ outputStrLn "Could not find type"

293 Nothing -> PSCI $ outputStrLn "Could not find type"

366

294

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−

470-- |

295-- |

471-- Browse a module and displays its signature (if module exists).

296-- Browse a module and displays its signature (if module exists).

472--

297--

@@ -475,15 +300,24 @@ handleBrowse moduleName = do

475 st <- PSCI $ lift get

300 st <- PSCI $ lift get

476 env <- psciIO . runMake $ make st []

301 env <- psciIO . runMake $ make st []

477 case env of

302 case env of

478− Left errs -> printErrors errs

303+ Left errs -> PSCI $ printErrors errs

479 Right env' ->

304 Right env' ->

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 =

480− if moduleName `notElem` (nub . map ((\ (P.Module _ _ modName _ _ ) -> modName) . snd)) (psciLoadedModules st)

316+ any ((== modName) . P.getModuleName . snd) . psciLoadedModules

317+ failNotInEnv modName =

481− then PSCI $ outputStrLn $ "Module '" ++ N.runModuleName moduleName ++ "' is not valid."

318+ PSCI $ outputStrLn $ "Module '" ++ N.runModuleName modName ++ "' is not valid."

482− else printModuleSignatures moduleName env'

319+ lookupUnQualifiedModName quaModName st =

483−

320+ (\(modName,_,_) -> modName) <$> find ( \(_, _, mayQuaName) -> mayQuaName == Just quaModName) (psciImportedModules st)

484−-- | Pretty-print errors

485−printErrors :: P.MultipleErrors -> PSCI ()

486−printErrors = PSCI . outputStrLn . P.prettyPrintMultipleErrors False

487

321

488-- |

322-- |

489-- Takes a value and prints its kind

323-- Takes a value and prints its kind

@@ -495,7 +329,7 @@ handleKindOf typ = do

495 mName = P.ModuleName [P.ProperName "$PSCI"]

329 mName = P.ModuleName [P.ProperName "$PSCI"]

496 e <- psciIO . runMake $ make st [m]

330 e <- psciIO . runMake $ make st [m]

497 case e of

331 case e of

498− Left errs -> printErrors errs

332+ Left errs -> PSCI $ printErrors errs

499 Right env' ->

333 Right env' ->

500 case M.lookup (P.Qualified (Just mName) $ P.ProperName "IT") (P.typeSynonyms env') of

334 case M.lookup (P.Qualified (Just mName) $ P.ProperName "IT") (P.typeSynonyms env') of

501 Just (_, typ') -> do

335 Just (_, typ') -> do

@@ -509,63 +343,7 @@ handleKindOf typ = do

509 Right (kind, _) -> PSCI . outputStrLn . P.prettyPrintKind $ kind

343 Right (kind, _) -> PSCI . outputStrLn . P.prettyPrintKind $ kind

510 Nothing -> PSCI $ outputStrLn "Could not find kind"

344 Nothing -> PSCI $ outputStrLn "Could not find kind"

511

345

512−-- Commands

346+-- Misc

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

569

347

570-- |

348-- |

571-- Attempts to read initial commands from '.psci' in the present working

349-- Attempts to read initial commands from '.psci' in the present working

@@ -588,92 +366,6 @@ loadUserConfig = onFirstFileMatching readCommands pathGetters

588 else

366 else

589 return Nothing

367 return Nothing

590

368

591−

592-- | Checks if the Console module is defined

369-- | Checks if the Console module is defined

593consoleIsDefined :: [P.Module] -> Bool

370consoleIsDefined :: [P.Module] -> Bool

594consoleIsDefined = any ((== P.ModuleName (map P.ProperName [ "Control", "Monad", "Eff", "Console" ])) . P.getModuleName)

371consoleIsDefined = 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+{-# LANGUAGE DataKinds #-}

2+

1−module Completion where

3+module PSCi.Completion where

2

4

3import Prelude ()

5import Prelude ()

4import Prelude.Compat

6import Prelude.Compat

@@ -17,8 +19,8 @@ import System.Console.Haskeline

17import qualified Language.PureScript as P

19import qualified Language.PureScript as P

18import qualified Language.PureScript.Names as N

20import qualified Language.PureScript.Names as N

19

21

20−import qualified Directive as D

22+import qualified PSCi.Directive as D

21−import Types

23+import PSCi.Types

22

24

23-- Completions may read the state, but not modify it.

25-- Completions may read the state, but not modify it.

24type CompletionM = ReaderT PSCiState IO

26type CompletionM = ReaderT PSCiState IO

@@ -171,7 +173,7 @@ getAllQualifications sho m (declName, decl) = do

171 qualificationsUsing (_, importType, asQ') =

173 qualificationsUsing (_, importType, asQ') =

172 let q = qualifyWith asQ'

174 let q = qualifyWith asQ'

173 in case importType of

175 in case importType of

174− P.Implicit _ -> [q]

176+ P.Implicit -> [q]

175 P.Explicit refs -> [q | referencedBy refs]

177 P.Explicit refs -> [q | referencedBy refs]

176 P.Hiding refs -> [q | not $ referencedBy refs]

178 P.Hiding refs -> [q | not $ referencedBy refs]

177

179

@@ -184,10 +186,10 @@ getAllImportsOf = asks . allImportsOf

184nubOnFst :: Eq a => [(a, b)] -> [(a, b)]

186nubOnFst :: Eq a => [(a, b)] -> [(a, b)]

185nubOnFst = nubBy ((==) `on` fst)

187nubOnFst = nubBy ((==) `on` fst)

186

188

187−typeDecls :: P.Module -> [(N.ProperName, P.Declaration)]

189+typeDecls :: P.Module -> [(N.ProperName 'N.TypeName, P.Declaration)]

188typeDecls = mapMaybe getTypeName . filter P.isDataDecl . P.exportedDeclarations

190typeDecls = mapMaybe getTypeName . filter P.isDataDecl . P.exportedDeclarations

189 where

191 where

190− getTypeName :: P.Declaration -> Maybe (N.ProperName, P.Declaration)

192+ getTypeName :: P.Declaration -> Maybe (N.ProperName 'N.TypeName, P.Declaration)

191 getTypeName d@(P.TypeSynonymDeclaration name _ _) = Just (name, d)

193 getTypeName d@(P.TypeSynonymDeclaration name _ _) = Just (name, d)

192 getTypeName d@(P.DataDeclaration _ name _ _) = Just (name, d)

194 getTypeName d@(P.DataDeclaration _ name _ _) = Just (name, d)

193 getTypeName (P.PositionedDeclaration _ _ d) = getTypeName d

195 getTypeName (P.PositionedDeclaration _ _ d) = getTypeName d

@@ -204,10 +206,10 @@ identNames = nubOnFst . concatMap getDeclNames . P.exportedDeclarations

204 getDeclNames (P.PositionedDeclaration _ _ d) = getDeclNames d

206 getDeclNames (P.PositionedDeclaration _ _ d) = getDeclNames d

205 getDeclNames _ = []

207 getDeclNames _ = []

206

208

207−dctorNames :: P.Module -> [(N.ProperName, P.Declaration)]

209+dctorNames :: P.Module -> [(N.ProperName 'N.ConstructorName, P.Declaration)]

208dctorNames = nubOnFst . concatMap go . P.exportedDeclarations

210dctorNames = nubOnFst . concatMap go . P.exportedDeclarations

209 where

211 where

210− go :: P.Declaration -> [(N.ProperName, P.Declaration)]

212+ go :: P.Declaration -> [(N.ProperName 'N.ConstructorName, P.Declaration)]

211 go decl@(P.DataDeclaration _ _ _ ctors) = map (\n -> (n, decl)) (map fst ctors)

213 go decl@(P.DataDeclaration _ _ _ ctors) = map (\n -> (n, decl)) (map fst ctors)

212 go (P.PositionedDeclaration _ _ d) = go d

214 go (P.PositionedDeclaration _ _ d) = go d

213 go _ = []

215 go _ = []

psci/Directive.hs → psci/PSCi/Directive.hsrenamed+6−2

@@ -13,13 +13,17 @@

13--

14-----------------------------------------------------------------------------

15

16−module Directive where

16+module PSCi.Directive where

17+

18+import Prelude ()

19+import Prelude.Compat

20+

17

21

18import Data.Maybe (fromJust, listToMaybe)

22import Data.Maybe (fromJust, listToMaybe)

19import Data.List (isPrefixOf)

23import Data.List (isPrefixOf)

20import Data.Tuple (swap)

24import Data.Tuple (swap)

21

25

22−import Types

26+import PSCi.Types

23

27

24-- |

28-- |

25-- List of all avaliable directives.

29-- List of all avaliable directives.

psci/PSCi/IO.hsnew file+68

@@ -0,0 +1,68 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : IO

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 @@

13--

14-----------------------------------------------------------------------------

15

16−module Parser

16+module PSCi.Parser

17 ( parseCommand

18 ) where

19

@@ -28,8 +28,8 @@ import Text.Parsec hiding ((<|>))

28import qualified Language.PureScript as P

29import Language.PureScript.Parser.Common (mark, same)

30

31−import qualified Directive as D

31+import qualified PSCi.Directive as D

32−import Types

32+import PSCi.Types

33

34-- |

35-- 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 @@

13--

14-----------------------------------------------------------------------------

15

16−module Types where

16+module PSCi.Types where

17+

18+import Prelude ()

19+import Prelude.Compat

17

20

18import Control.Arrow (second)

21import Control.Arrow (second)

19import Data.Map (Map)

22import Data.Map (Map)

@@ -51,11 +54,11 @@ mkPSCiState :: [ImportedModule]

51 -> [P.Declaration]

54 -> [P.Declaration]

52 -> [String]

55 -> [String]

53 -> PSCiState

56 -> PSCiState

54−mkPSCiState imported loaded foreign lets nodeFlags =

57+mkPSCiState imported loaded foreigns lets nodeFlags =

55 (initialPSCiState

58 (initialPSCiState

56 |> each imported updateImportedModules

59 |> each imported updateImportedModules

57 |> updateModules loaded)

60 |> updateModules loaded)

58− { psciForeignFiles = foreign

61+ { psciForeignFiles = foreigns

59 , psciLetBindings = lets

62 , psciLetBindings = lets

60 , psciNodeFlags = nodeFlags

63 , psciNodeFlags = nodeFlags

61 }

64 }

purescript.cabal+121−44

@@ -1,5 +1,5 @@

1name: purescript

2−version: 0.8.0.0

2+version: 0.8.2.0

3cabal-version: >=1.8

4build-type: Simple

5license: MIT

@@ -14,20 +14,29 @@ Homepage: http://www.purescript.org/

14author: Phil Freeman <paf31@cantab.net>,

15 Gary Burgess <gary.burgess@gmail.com>,

16 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>

18

19

19−tested-with: GHC==7.8

20+tested-with: GHC==7.10.3

20

21

21extra-source-files: examples/passing/*.purs

22extra-source-files: examples/passing/*.purs

22 , examples/failing/*.purs

23 , examples/failing/*.purs

24+ , examples/docs/bower_components/purescript-prelude/src/*.purs

25+ , examples/docs/bower.json

26+ , examples/docs/src/*.purs

23 , tests/support/setup.js

27 , tests/support/setup.js

24 , tests/support/package.json

28 , 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

25 , tests/support/bower.json

33 , tests/support/bower.json

26 , tests/support/setup-win.cmd

34 , 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

28 , stack.yaml

38 , stack.yaml

29− , stack-lts-2.yaml

39+ , stack-lts-5.yaml

30− , stack-lts-3.yaml

31 , stack-nightly.yaml

40 , stack-nightly.yaml

32 , README.md

41 , README.md

33 , INSTALL.md

42 , INSTALL.md

@@ -39,7 +48,7 @@ source-repository head

39 location: https://github.com/purescript/purescript.git

48 location: https://github.com/purescript/purescript.git

40

49

41library

50library

42− build-depends: base >=4.6 && <5,

51+ build-depends: base >=4.8 && <5,

43 base-compat >=0.6.0,

52 base-compat >=0.6.0,

44 lifted-base >= 0.2.3 && < 0.2.4,

53 lifted-base >= 0.2.3 && < 0.2.4,

45 monad-control >= 1.0.0.0 && < 1.1,

54 monad-control >= 1.0.0.0 && < 1.1,

@@ -51,13 +60,13 @@ library

51 filepath -any,

60 filepath -any,

52 mtl >= 2.1.0 && < 2.3.0,

61 mtl >= 2.1.0 && < 2.3.0,

53 parsec -any,

62 parsec -any,

54− transformers >= 0.3.0 && < 0.5,

63+ transformers >= 0.3.0 && < 0.6,

55 transformers-compat >= 0.3.0,

64 transformers-compat >= 0.3.0,

56 utf8-string >= 1 && < 2,

65 utf8-string >= 1 && < 2,

57 pattern-arrows >= 0.0.2 && < 0.1,

66 pattern-arrows >= 0.0.2 && < 0.1,

58 time -any,

67 time -any,

59 boxes >= 0.1.4 && < 0.2.0,

68 boxes >= 0.1.4 && < 0.2.0,

60− aeson >= 0.8 && < 0.11,

69+ aeson >= 0.8 && < 0.12,

61 vector -any,

70 vector -any,

62 bower-json >= 0.7,

71 bower-json >= 0.7,

63 aeson-better-errors >= 0.8,

72 aeson-better-errors >= 0.8,

@@ -67,16 +76,26 @@ library

67 language-javascript == 0.5.*,

76 language-javascript == 0.5.*,

68 syb -any,

77 syb -any,

69 Glob >= 0.7 && < 0.8,

78 Glob >= 0.7 && < 0.8,

70− process >= 1.2.0 && < 1.4,

79+ process >= 1.2.0 && < 1.5,

71 safe >= 0.3.9 && < 0.4,

80 safe >= 0.3.9 && < 0.4,

72 semigroups >= 0.16.2 && < 0.19,

81 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

74

92

75 exposed-modules: Language.PureScript

93 exposed-modules: Language.PureScript

76 Language.PureScript.AST

94 Language.PureScript.AST

77 Language.PureScript.AST.Binders

95 Language.PureScript.AST.Binders

78 Language.PureScript.AST.Declarations

96 Language.PureScript.AST.Declarations

79 Language.PureScript.AST.Operators

97 Language.PureScript.AST.Operators

98+ Language.PureScript.AST.Literals

80 Language.PureScript.AST.SourcePos

99 Language.PureScript.AST.SourcePos

81 Language.PureScript.AST.Traversals

100 Language.PureScript.AST.Traversals

82 Language.PureScript.AST.Exported

101 Language.PureScript.AST.Exported

@@ -100,7 +119,6 @@ library

100 Language.PureScript.CoreFn.Binders

119 Language.PureScript.CoreFn.Binders

101 Language.PureScript.CoreFn.Desugar

120 Language.PureScript.CoreFn.Desugar

102 Language.PureScript.CoreFn.Expr

121 Language.PureScript.CoreFn.Expr

103− Language.PureScript.CoreFn.Literals

104 Language.PureScript.CoreFn.Meta

122 Language.PureScript.CoreFn.Meta

105 Language.PureScript.CoreFn.Module

123 Language.PureScript.CoreFn.Module

106 Language.PureScript.CoreFn.Traversals

124 Language.PureScript.CoreFn.Traversals

@@ -140,6 +158,9 @@ library

140 Language.PureScript.Sugar.Names.Exports

158 Language.PureScript.Sugar.Names.Exports

141 Language.PureScript.Sugar.ObjectWildcards

159 Language.PureScript.Sugar.ObjectWildcards

142 Language.PureScript.Sugar.Operators

160 Language.PureScript.Sugar.Operators

161+ Language.PureScript.Sugar.Operators.Common

162+ Language.PureScript.Sugar.Operators.Expr

163+ Language.PureScript.Sugar.Operators.Binders

143 Language.PureScript.Sugar.TypeClasses

164 Language.PureScript.Sugar.TypeClasses

144 Language.PureScript.Sugar.TypeClasses.Deriving

165 Language.PureScript.Sugar.TypeClasses.Deriving

145 Language.PureScript.Sugar.TypeDeclarations

166 Language.PureScript.Sugar.TypeDeclarations

@@ -159,13 +180,15 @@ library

159

180

160 Language.PureScript.Docs

181 Language.PureScript.Docs

161 Language.PureScript.Docs.Convert

182 Language.PureScript.Docs.Convert

183+ Language.PureScript.Docs.Convert.Single

184+ Language.PureScript.Docs.Convert.ReExports

162 Language.PureScript.Docs.Render

185 Language.PureScript.Docs.Render

163 Language.PureScript.Docs.Types

186 Language.PureScript.Docs.Types

164 Language.PureScript.Docs.RenderedCode

187 Language.PureScript.Docs.RenderedCode

165 Language.PureScript.Docs.RenderedCode.Types

188 Language.PureScript.Docs.RenderedCode.Types

166 Language.PureScript.Docs.RenderedCode.Render

189 Language.PureScript.Docs.RenderedCode.Render

167 Language.PureScript.Docs.AsMarkdown

190 Language.PureScript.Docs.AsMarkdown

168− Language.PureScript.Docs.ParseAndDesugar

191+ Language.PureScript.Docs.ParseAndBookmark

169 Language.PureScript.Docs.Utils.MonoidExtras

192 Language.PureScript.Docs.Utils.MonoidExtras

170

193

171 Language.PureScript.Publish

194 Language.PureScript.Publish

@@ -173,11 +196,29 @@ library

173 Language.PureScript.Publish.ErrorsWarnings

196 Language.PureScript.Publish.ErrorsWarnings

174 Language.PureScript.Publish.BoxesHelpers

197 Language.PureScript.Publish.BoxesHelpers

175

198

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+

176 Control.Monad.Logger

215 Control.Monad.Logger

177 Control.Monad.Supply

216 Control.Monad.Supply

178 Control.Monad.Supply.Class

217 Control.Monad.Supply.Class

179

218

180 System.IO.UTF8

219 System.IO.UTF8

220+

221+ extensions: DataKinds

181 exposed: True

222 exposed: True

182 buildable: True

223 buildable: True

183 hs-source-dirs: src

224 hs-source-dirs: src

@@ -187,18 +228,18 @@ library

187executable psc

228executable psc

188 build-depends: base >=4 && <5, base-compat >=0.6.0,

229 build-depends: base >=4 && <5, base-compat >=0.6.0,

189 containers -any, directory -any, filepath -any,

230 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,

191 time -any, transformers -any, transformers-compat -any, Glob >= 0.7 && < 0.8,

232 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

193 main-is: Main.hs

234 main-is: Main.hs

194 buildable: True

235 buildable: True

195 hs-source-dirs: psc

236 hs-source-dirs: psc

196− other-modules: JSON

237+ other-modules: JSON, Paths_purescript

197 ghc-options: -Wall -O2 -fno-warn-unused-do-bind -threaded -rtsopts "-with-rtsopts=-N"

238 ghc-options: -Wall -O2 -fno-warn-unused-do-bind -threaded -rtsopts "-with-rtsopts=-N"

198

239

199executable psci

240executable psci

200 build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,

241 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,

202 haskeline >= 0.7.0.0, purescript -any, transformers -any,

243 haskeline >= 0.7.0.0, purescript -any, transformers -any,

203 transformers-compat -any, process -any, time -any, Glob -any, base-compat >=0.6.0,

244 transformers-compat -any, process -any, time -any, Glob -any, base-compat >=0.6.0,

204 boxes >= 0.1.4 && < 0.2.0

245 boxes >= 0.1.4 && < 0.2.0

@@ -206,20 +247,27 @@ executable psci

206 main-is: Main.hs

247 main-is: Main.hs

207 buildable: True

248 buildable: True

208 hs-source-dirs: psci psci/main

249 hs-source-dirs: psci psci/main

209− other-modules: Types

250+ other-modules: PSCi

251+ PSCi.Types

210− Parser

252+ PSCi.Parser

211− Directive

253+ PSCi.Directive

212− Completion

254+ PSCi.Completion

213− PSCi

255+ PSCi.IO

214− IO

256+ PSCi.Message

257+ PSCi.Option

258+ PSCi.Module

259+ PSCi.Printer

260+ Paths_purescript

215 ghc-options: -Wall -O2

261 ghc-options: -Wall -O2

216

262

217executable psc-docs

263executable psc-docs

218 build-depends: base >=4 && <5, purescript -any,

264 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,

220 split -any, ansi-wl-pprint -any, directory -any,

266 split -any, ansi-wl-pprint -any, directory -any,

221− filepath -any, Glob -any

267+ filepath -any, Glob -any, transformers -any,

268+ transformers-compat -any

222 main-is: Main.hs

269 main-is: Main.hs

270+ other-modules: Paths_purescript

223 buildable: True

271 buildable: True

224 hs-source-dirs: psc-docs

272 hs-source-dirs: psc-docs

225 other-modules: Ctags

273 other-modules: Ctags

@@ -230,15 +278,17 @@ executable psc-docs

230executable psc-publish

278executable psc-publish

231 build-depends: base >=4 && <5, purescript -any, bytestring -any, aeson -any, optparse-applicative -any

279 build-depends: base >=4 && <5, purescript -any, bytestring -any, aeson -any, optparse-applicative -any

232 main-is: Main.hs

280 main-is: Main.hs

281+ other-modules: Paths_purescript

233 buildable: True

282 buildable: True

234 hs-source-dirs: psc-publish

283 hs-source-dirs: psc-publish

235 ghc-options: -Wall -O2

284 ghc-options: -Wall -O2

236

285

237executable psc-hierarchy

286executable 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,

239 process -any, mtl -any, parsec -any, filepath -any, directory -any,

288 process -any, mtl -any, parsec -any, filepath -any, directory -any,

240 Glob -any

289 Glob -any

241 main-is: Main.hs

290 main-is: Main.hs

291+ other-modules: Paths_purescript

242 buildable: True

292 buildable: True

243 hs-source-dirs: hierarchy

293 hs-source-dirs: hierarchy

244 other-modules:

294 other-modules:

@@ -246,7 +296,7 @@ executable psc-hierarchy

246

296

247executable psc-bundle

297executable psc-bundle

248 main-is: Main.hs

298 main-is: Main.hs

249− other-modules:

299+ other-modules: Paths_purescript

250 other-extensions:

300 other-extensions:

251 build-depends: base >=4 && <5,

301 build-depends: base >=4 && <5,

252 purescript -any,

302 purescript -any,

@@ -255,33 +305,60 @@ executable psc-bundle

255 mtl -any,

305 mtl -any,

256 transformers -any,

306 transformers -any,

257 transformers-compat -any,

307 transformers-compat -any,

258− optparse-applicative >= 0.10.0,

308+ optparse-applicative >= 0.12.1,

259 Glob -any

309 Glob -any

260 ghc-options: -Wall -O2

310 ghc-options: -Wall -O2

261 hs-source-dirs: psc-bundle

311 hs-source-dirs: psc-bundle

262

312

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+

263test-suite tests

346test-suite tests

264 build-depends: base >=4 && <5, containers -any, directory -any,

347 build-depends: base >=4 && <5, containers -any, directory -any,

265 filepath -any, mtl -any, parsec -any, purescript -any,

348 filepath -any, mtl -any, parsec -any, purescript -any,

266 transformers -any, process -any, transformers-compat -any, time -any,

349 transformers -any, process -any, transformers-compat -any, time -any,

267 Glob -any, aeson-better-errors -any, bytestring -any, aeson -any,

350 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

269 type: exitcode-stdio-1.0

354 type: exitcode-stdio-1.0

270 main-is: Main.hs

355 main-is: Main.hs

271− other-modules: TestsSetup

356+ other-modules: TestUtils

357+ TestCompiler

358+ TestDocs

272 TestPscPublish

359 TestPscPublish

360+ TestPsci

361+ TestPscIde

362+ PscIdeSpec

273 buildable: True

363 buildable: True

274− hs-source-dirs: tests tests/common

364+ hs-source-dirs: tests psci

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

src/Control/Monad/Logger.hs+1−1

@@ -30,7 +30,7 @@ import Control.Monad.Base (MonadBase(..))

30import Control.Monad.Trans.Control (MonadBaseControl(..))

31

32-- | 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 }

34

35-- | Run a Logger computation, starting with an empty log.

36runLogger' :: (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(..))

27import Control.Monad.Reader

28import Control.Monad.Writer

29

30−newtype SupplyT m a = SupplyT { unSupplyT :: StateT Integer m a }

30+newtype SupplyT m a = SupplyT { unSupplyT :: StateT Integer m a }

31 deriving (Functor, Applicative, Monad, MonadTrans, MonadError e, MonadWriter w, MonadReader r)

32

33runSupplyT :: Integer -> SupplyT m a -> m (a, Integer)

src/Language/PureScript.hs−1

@@ -13,7 +13,6 @@

13--

14-----------------------------------------------------------------------------

15

16−{-# LANGUAGE DataKinds #-}

17{-# LANGUAGE FlexibleContexts #-}

16{-# LANGUAGE FlexibleContexts #-}

18{-# LANGUAGE ScopedTypeVariables #-}

17{-# LANGUAGE ScopedTypeVariables #-}

19

18

src/Language/PureScript/AST.hs+4−14

@@ -1,24 +1,14 @@

1−-----------------------------------------------------------------------------

1+-- |

2+-- The initial PureScript AST

2--

3--

3−-- Module : Language.PureScript.AST

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−

15module Language.PureScript.AST (

4module Language.PureScript.AST (

16 module AST

5 module AST

17) where

6) where

18

7

19import Language.PureScript.AST.Binders as AST

8import Language.PureScript.AST.Binders as AST

20import Language.PureScript.AST.Declarations as AST

9import Language.PureScript.AST.Declarations as AST

10+import Language.PureScript.AST.Exported as AST

11+import Language.PureScript.AST.Literals as AST

21import Language.PureScript.AST.Operators as AST

12import Language.PureScript.AST.Operators as AST

22import Language.PureScript.AST.SourcePos as AST

13import Language.PureScript.AST.SourcePos as AST

23import Language.PureScript.AST.Traversals as AST

14import 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−-----------------------------------------------------------------------------

1+-- |

2−--

3−-- Module : Language.PureScript.AST.Binders

5−-- License : MIT

6−--

7−-- Maintainer : Phil Freeman <paf31@cantab.net>

8−-- Stability : experimental

9−-- Portability :

10−--

11−-- | Case binders

2+-- Case binders

12--

3--

13−-----------------------------------------------------------------------------

14−

15−{-# LANGUAGE DeriveDataTypeable #-}

16−

17module Language.PureScript.AST.Binders where

4module Language.PureScript.AST.Binders where

18

5

19−import qualified Data.Data as D

20−

21import Language.PureScript.AST.SourcePos

6import Language.PureScript.AST.SourcePos

7+import Language.PureScript.AST.Literals

22import Language.PureScript.Names

8import Language.PureScript.Names

23import Language.PureScript.Comments

9import Language.PureScript.Comments

24import Language.PureScript.Types

10import Language.PureScript.Types

@@ -32,21 +18,9 @@ data Binder

32 --

18 --

33 = NullBinder

19 = NullBinder

34 -- |

20 -- |

35− -- A binder which matches a boolean literal

21+ -- A binder which matches a 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

48 --

22 --

49− | NumberBinder (Either Integer Double)

23+ | LiteralBinder (Literal Binder)

50 -- |

24 -- |

51 -- A binder which binds an identifier

25 -- A binder which binds an identifier

52 --

26 --

@@ -54,15 +28,25 @@ data Binder

54 -- |

28 -- |

55 -- A binder which matches a data constructor

29 -- A binder which matches a data constructor

56 --

30 --

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)

58 -- |

37 -- |

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.

60 --

40 --

61− | ObjectBinder [(String, Binder)]

41+ | BinaryNoParensBinder Binder Binder Binder

62 -- |

42 -- |

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.

64 --

48 --

65− | ArrayBinder [Binder]

49+ | ParensInBinder Binder

66 -- |

50 -- |

67 -- A binder which binds its input to an identifier

51 -- A binder which binds its input to an identifier

68 --

52 --

@@ -74,7 +58,8 @@ data Binder

74 -- |

58 -- |

75 -- A binder with a type annotation

59 -- A binder with a type annotation

76 --

60 --

77− | TypedBinder Type Binder deriving (Show, Read, Eq, D.Data, D.Typeable)

61+ | TypedBinder Type Binder

62+ deriving (Show, Read, Eq)

78

63

79-- |

64-- |

80-- Collect all names introduced in binders in an expression

65-- Collect all names introduced in binders in an expression

@@ -82,11 +67,15 @@ data Binder

82binderNames :: Binder -> [Ident]

67binderNames :: Binder -> [Ident]

83binderNames = go []

68binderNames = go []

84 where

69 where

70+ go ns (LiteralBinder b) = lit ns b

85 go ns (VarBinder name) = name : ns

71 go ns (VarBinder name) = name : ns

86 go ns (ConstructorBinder _ bs) = foldl go ns bs

72 go ns (ConstructorBinder _ bs) = foldl go ns bs

87− go ns (ObjectBinder bs) = foldl go ns (map snd bs)

73+ go ns (BinaryNoParensBinder b1 b2 b3) = foldl go ns [b1, b2, b3]

88− go ns (ArrayBinder bs) = foldl go ns bs

74+ go ns (ParensInBinder b) = go ns b

89 go ns (NamedBinder name b) = go (name : ns) b

75 go ns (NamedBinder name b) = go (name : ns) b

90 go ns (PositionedBinder _ _ b) = go ns b

76 go ns (PositionedBinder _ _ b) = go ns b

91 go ns (TypedBinder _ b) = go ns b

77 go ns (TypedBinder _ b) = go ns b

92 go ns _ = ns

78 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 #-}

2{-# LANGUAGE ScopedTypeVariables #-}

1{-# LANGUAGE ScopedTypeVariables #-}

3{-# LANGUAGE TemplateHaskell #-}

2{-# LANGUAGE TemplateHaskell #-}

4{-# LANGUAGE LambdaCase #-}

3{-# LANGUAGE LambdaCase #-}

@@ -15,12 +14,12 @@ import Data.Aeson.TH

15import Data.List (nub, (\\))

14import Data.List (nub, (\\))

16import Data.Maybe (mapMaybe)

15import Data.Maybe (mapMaybe)

17

16

18−import qualified Data.Data as D

19import qualified Data.Map as M

17import qualified Data.Map as M

20

18

21import Control.Monad.Identity

19import Control.Monad.Identity

22

20

23import Language.PureScript.AST.Binders

21import Language.PureScript.AST.Binders

22+import Language.PureScript.AST.Literals

24import Language.PureScript.AST.Operators

23import Language.PureScript.AST.Operators

25import Language.PureScript.AST.SourcePos

24import Language.PureScript.AST.SourcePos

26import Language.PureScript.Types

25import Language.PureScript.Types

@@ -35,7 +34,8 @@ import Language.PureScript.Environment

35-- a list of declarations, and a list of the declarations that are

34-- a list of declarations, and a list of the declarations that are

36-- explicitly exported. If the export list is Nothing, everything is exported.

35-- explicitly exported. If the export list is Nothing, everything is exported.

37--

36--

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)

39

40-- | Return a module's name.

41getModuleName :: Module -> ModuleName

@@ -47,7 +47,7 @@ getModuleName (Module _ _ name _ _) = name

47addDefaultImport :: ModuleName -> Module -> Module

48addDefaultImport toImport m@(Module ss coms mn decls exps) =

49 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

51 where

52 isExistingImport (ImportDeclaration mn' _ _ _) | mn' == toImport = True

53 isExistingImport (PositionedDeclaration _ _ d) = isExistingImport d

@@ -60,7 +60,7 @@ data DeclarationRef

60 -- |

61 -- A type constructor with data constructors

62 --

63− = TypeRef ProperName (Maybe [ProperName])

63+ = TypeRef (ProperName 'TypeName) (Maybe [ProperName 'ConstructorName])

64 -- |

65 -- A value

66 --

@@ -68,7 +68,7 @@ data DeclarationRef

68 -- |

69 -- A type class

70 --

71− | TypeClassRef ProperName

71+ | TypeClassRef (ProperName 'ClassName)

72 -- |

73 -- A type class instance, created during typeclass desugaring (name, class name, instance types)

74 --

@@ -80,12 +80,12 @@ data DeclarationRef

80 -- |

81 -- An unspecified ProperName ref. This will be replaced with a TypeClassRef

82 -- or TypeRef during name desugaring.

83− | ProperRef ProperName

83+ | ProperRef String

84 -- |

85 -- A declaration reference with source position information

86 --

87 | PositionedDeclarationRef SourceSpan [Comment] DeclarationRef

88− deriving (Show, Read, D.Data, D.Typeable)

88+ deriving (Show, Read)

89

90instance Eq DeclarationRef where

91 (TypeRef name dctors) == (TypeRef name' dctors') = name == name' && dctors == dctors'

@@ -108,7 +108,7 @@ isModuleRef _ = False

108-- are the duplicate refs with data constructors elided, and then a separate

109-- list of duplicate data constructors.

110--

111−findDuplicateRefs :: [DeclarationRef] -> ([DeclarationRef], [ProperName])

111+findDuplicateRefs :: [DeclarationRef] -> ([DeclarationRef], [ProperName 'ConstructorName])

112findDuplicateRefs refs =

113 let positionless = stripPosInfo `map` refs

114 simplified = simplifyTypeRefs `map` positionless

@@ -130,11 +130,9 @@ findDuplicateRefs refs =

130--

131data ImportDeclarationType

132 -- |

133− -- An import with no explicit list: `import M`. The boolean signifies whether

133+ -- An import with no explicit list: `import M`.

134− -- the import was imported with `(..)` or not. Without `(..)` a warning is

135− -- raised for each member implicitly imported.

136 --

134 --

137− = Implicit Bool

135+ = Implicit

138 -- |

136 -- |

139 -- An import with an explicit list of references to import: `import M (foo)`

137 -- An import with an explicit list of references to import: `import M (foo)`

140 --

138 --

@@ -143,12 +141,16 @@ data ImportDeclarationType

143 -- An import with a list of references to hide: `import M hiding (foo)`

141 -- An import with a list of references to hide: `import M hiding (foo)`

144 --

142 --

145 | Hiding [DeclarationRef]

143 | Hiding [DeclarationRef]

146− deriving (Eq, Show, Read, D.Data, D.Typeable)

144+ deriving (Eq, Show, Read)

147

145

148isImplicit :: ImportDeclarationType -> Bool

146isImplicit :: ImportDeclarationType -> Bool

149−isImplicit (Implicit _) = True

147+isImplicit Implicit = True

150isImplicit _ = False

148isImplicit _ = False

151

149

150+isExplicit :: ImportDeclarationType -> Bool

151+isExplicit (Explicit _) = True

152+isExplicit _ = False

153+

152-- |

154-- |

153-- The data type of declarations

155-- The data type of declarations

154--

156--

@@ -156,7 +158,7 @@ data Declaration

156 -- |

158 -- |

157 -- A data type declaration (data or newtype, name, arguments, data constructors)

159 -- A data type declaration (data or newtype, name, arguments, data constructors)

158 --

160 --

159− = DataDeclaration DataDeclType ProperName [(String, Maybe Kind)] [(ProperName, [Type])]

161+ = DataDeclaration DataDeclType (ProperName 'TypeName) [(String, Maybe Kind)] [(ProperName 'ConstructorName, [Type])]

160 -- |

162 -- |

161 -- A minimal mutually recursive set of data type declarations

163 -- A minimal mutually recursive set of data type declarations

162 --

164 --

@@ -164,7 +166,7 @@ data Declaration

164 -- |

166 -- |

165 -- A type synonym declaration (name, arguments, type)

167 -- A type synonym declaration (name, arguments, type)

166 --

168 --

167− | TypeSynonymDeclaration ProperName [(String, Maybe Kind)] Type

169+ | TypeSynonymDeclaration (ProperName 'TypeName) [(String, Maybe Kind)] Type

168 -- |

170 -- |

169 -- A type declaration for a value (name, ty)

171 -- A type declaration for a value (name, ty)

170 --

172 --

@@ -184,11 +186,11 @@ data Declaration

184 -- |

186 -- |

185 -- A data type foreign import (name, kind)

187 -- A data type foreign import (name, kind)

186 --

188 --

187− | ExternDataDeclaration ProperName Kind

189+ | ExternDataDeclaration (ProperName 'TypeName) Kind

188 -- |

190 -- |

189 -- A fixity declaration (fixity data, operator name, value the operator is an alias for)

191 -- A fixity declaration (fixity data, operator name, value the operator is an alias for)

190 --

192 --

191− | FixityDeclaration Fixity String (Maybe Ident)

193+ | FixityDeclaration Fixity String (Maybe (Either (Qualified Ident) (Qualified (ProperName 'ConstructorName))))

192 -- |

194 -- |

193 -- A module import (module name, qualified/unqualified/hiding, optional "qualified as" name)

195 -- A module import (module name, qualified/unqualified/hiding, optional "qualified as" name)

194 -- TODO: also a boolean specifying whether the old `qualified` syntax was used, so a warning can be raised in desugaring (remove for 0.9)

196 -- 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

197 -- |

199 -- |

198 -- A type class declaration (name, argument, implies, member declarations)

200 -- A type class declaration (name, argument, implies, member declarations)

199 --

201 --

200− | TypeClassDeclaration ProperName [(String, Maybe Kind)] [Constraint] [Declaration]

202+ | TypeClassDeclaration (ProperName 'ClassName) [(String, Maybe Kind)] [Constraint] [Declaration]

201 -- |

203 -- |

202 -- A type instance declaration (name, dependencies, class name, instance types, member

204 -- A type instance declaration (name, dependencies, class name, instance types, member

203 -- declarations)

205 -- declarations)

204 --

206 --

205− | TypeInstanceDeclaration Ident [Constraint] (Qualified ProperName) [Type] TypeInstanceBody

207+ | TypeInstanceDeclaration Ident [Constraint] (Qualified (ProperName 'ClassName)) [Type] TypeInstanceBody

206 -- |

208 -- |

207 -- A declaration with source position information

209 -- A declaration with source position information

208 --

210 --

209 | PositionedDeclaration SourceSpan [Comment] Declaration

211 | PositionedDeclaration SourceSpan [Comment] Declaration

210− deriving (Show, Read, D.Data, D.Typeable)

212+ deriving (Show, Read)

211

213

212-- | The members of a type class instance declaration

214-- | The members of a type class instance declaration

213data TypeInstanceBody

215data TypeInstanceBody

@@ -215,7 +217,7 @@ data TypeInstanceBody

215 = DerivedInstance

217 = DerivedInstance

216 -- | This is a regular (explicit) instance

218 -- | This is a regular (explicit) instance

217 | ExplicitInstance [Declaration]

219 | ExplicitInstance [Declaration]

218− deriving (Show, Read, D.Data, D.Typeable)

220+ deriving (Show, Read)

219

221

220mapTypeInstanceBody :: ([Declaration] -> [Declaration]) -> TypeInstanceBody -> TypeInstanceBody

222mapTypeInstanceBody :: ([Declaration] -> [Declaration]) -> TypeInstanceBody -> TypeInstanceBody

221mapTypeInstanceBody f = runIdentity . traverseTypeInstanceBody (Identity . f)

223mapTypeInstanceBody f = runIdentity . traverseTypeInstanceBody (Identity . f)

@@ -308,21 +310,9 @@ type Guard = Expr

308--

310--

309data Expr

311data Expr

310 -- |

312 -- |

311− -- A numeric literal

313+ -- A literal value

312− --

313− = NumericLiteral (Either Integer Double)

314− -- |

315− -- A string literal

316− --

317− | StringLiteral String

318− -- |

319− -- A character literal

320 --

314 --

321− | CharLiteral Char

315+ = Literal (Literal Expr)

322− -- |

323− -- A boolean literal

324− --

325− | BooleanLiteral Bool

326 -- |

316 -- |

327 -- A prefix -, will be desugared

317 -- A prefix -, will be desugared

328 --

318 --

@@ -336,6 +326,9 @@ data Expr

336 -- Explicit parentheses. During the rebracketing phase of desugaring, this data constructor

326 -- Explicit parentheses. During the rebracketing phase of desugaring, this data constructor

337 -- will be removed.

327 -- will be removed.

338 --

328 --

329+ -- Note: although it seems this constructor is not used, it _is_ useful, since it prevents

330+ -- certain traversals from matching.

331+ --

339 | Parens Expr

332 | Parens Expr

340 -- |

333 -- |

341 -- Operator section. This will be removed during desugaring and replaced with a partially applied

334 -- Operator section. This will be removed during desugaring and replaced with a partially applied

@@ -343,19 +336,6 @@ data Expr

343 --

336 --

344 | OperatorSection Expr (Either Expr Expr)

337 | OperatorSection Expr (Either Expr Expr)

345 -- |

338 -- |

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− -- |

359 -- An object property getter (e.g. `_.x`). This will be removed during

339 -- An object property getter (e.g. `_.x`). This will be removed during

360 -- desugaring and expanded into a lambda that reads a property from an object.

340 -- desugaring and expanded into a lambda that reads a property from an object.

361 --

341 --

@@ -369,11 +349,6 @@ data Expr

369 --

349 --

370 | ObjectUpdate Expr [(String, Expr)]

350 | ObjectUpdate Expr [(String, Expr)]

371 -- |

351 -- |

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− -- |

377 -- Function introduction

352 -- Function introduction

378 --

353 --

379 | Abs (Either Ident Binder) Expr

354 | Abs (Either Ident Binder) Expr

@@ -392,7 +367,7 @@ data Expr

392 -- |

367 -- |

393 -- A data constructor

368 -- A data constructor

394 --

369 --

395− | Constructor (Qualified ProperName)

370+ | Constructor (Qualified (ProperName 'ConstructorName))

396 -- |

371 -- |

397 -- A case expression. During the case expansion phase of desugaring, top-level binders will get

372 -- A case expression. During the case expansion phase of desugaring, top-level binders will get

398 -- desugared into case expressions, hence the need for guards and multiple binders per branch here.

373 -- desugared into case expressions, hence the need for guards and multiple binders per branch here.

@@ -414,7 +389,7 @@ data Expr

414 -- An application of a typeclass dictionary constructor. The value should be

389 -- An application of a typeclass dictionary constructor. The value should be

415 -- an ObjectLiteral.

390 -- an ObjectLiteral.

416 --

391 --

417− | TypeClassDictionaryConstructorApp (Qualified ProperName) Expr

392+ | TypeClassDictionaryConstructorApp (Qualified (ProperName 'ClassName)) Expr

418 -- |

393 -- |

419 -- A placeholder for a type class dictionary to be inserted later. At the end of type checking, these

394 -- A placeholder for a type class dictionary to be inserted later. At the end of type checking, these

420 -- placeholders will be replaced with actual expressions representing type classes dictionaries which

395 -- placeholders will be replaced with actual expressions representing type classes dictionaries which

@@ -422,19 +397,24 @@ data Expr

422 -- at superclass implementations when searching for a dictionary, the type class name and

397 -- at superclass implementations when searching for a dictionary, the type class name and

423 -- instance type, and the type class dictionaries in scope.

398 -- instance type, and the type class dictionaries in scope.

424 --

399 --

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)))

426 -- |

401 -- |

427 -- A typeclass dictionary accessor, the implementation is left unspecified until CoreFn desugaring.

402 -- A typeclass dictionary accessor, the implementation is left unspecified until CoreFn desugaring.

428 --

403 --

429− | TypeClassDictionaryAccessor (Qualified ProperName) Ident

404+ | TypeClassDictionaryAccessor (Qualified (ProperName 'ClassName)) Ident

430 -- |

405 -- |

431 -- A placeholder for a superclass dictionary to be turned into a TypeClassDictionary during typechecking

406 -- A placeholder for a superclass dictionary to be turned into a TypeClassDictionary during typechecking

432 --

407 --

433− | SuperClassDictionary (Qualified ProperName) [Type]

408+ | SuperClassDictionary (Qualified (ProperName 'ClassName)) [Type]

409+ -- |

410+ -- A placeholder for an anonymous function argument

411+ --

412+ | AnonymousArgument

434 -- |

413 -- |

435 -- A value with source position information

414 -- A value with source position information

436 --

415 --

437− | PositionedValue SourceSpan [Comment] Expr deriving (Show, Read, D.Data, D.Typeable)

416+ | PositionedValue SourceSpan [Comment] Expr

417+ deriving (Show, Read)

438

418

439-- |

419-- |

440-- An alternative in a case statement

420-- An alternative in a case statement

@@ -448,7 +428,7 @@ data CaseAlternative = CaseAlternative

448 -- The result expression or a collect of guarded expressions

428 -- The result expression or a collect of guarded expressions

449 --

429 --

450 , caseAlternativeResult :: Either [(Guard, Expr)] Expr

430 , caseAlternativeResult :: Either [(Guard, Expr)] Expr

451− } deriving (Show, Read, D.Data, D.Typeable)

431+ } deriving (Show, Read)

452

432

453-- |

433-- |

454-- A statement in a do-notation block

434-- A statement in a do-notation block

@@ -469,7 +449,8 @@ data DoNotationElement

469 -- |

449 -- |

470 -- A do notation element with source position information

450 -- A do notation element with source position information

471 --

451 --

472− | PositionedDoNotationElement SourceSpan [Comment] DoNotationElement deriving (Show, Read, D.Data, D.Typeable)

452+ | PositionedDoNotationElement SourceSpan [Comment] DoNotationElement

453+ deriving (Show, Read)

473

454

474$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''DeclarationRef)

455$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''DeclarationRef)

475$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ImportDeclarationType)

456$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ImportDeclarationType)

src/Language/PureScript/AST/Exported.hs+36−21

@@ -1,8 +1,7 @@

1−

2−module Language.PureScript.AST.Exported (

1+module Language.PureScript.AST.Exported

3− exportedDeclarations,

2+ ( exportedDeclarations

4− isExported

3+ , isExported

5−) where

4+ ) where

6

5

7import Control.Category ((>>>))

6import Control.Category ((>>>))

8import Data.Maybe (mapMaybe)

7import Data.Maybe (mapMaybe)

@@ -23,12 +22,12 @@ import Language.PureScript.Names

23-- instances will be incorrectly removed in some cases.

22-- instances will be incorrectly removed in some cases.

24--

23--

25exportedDeclarations :: Module -> [Declaration]

24exportedDeclarations :: Module -> [Declaration]

26−exportedDeclarations (Module _ _ _ decls exps) = go decls

25+exportedDeclarations (Module _ _ mn decls exps) = go decls

27 where

26 where

28 go = flattenDecls

27 go = flattenDecls

29 >>> filter (isExported exps)

28 >>> filter (isExported exps)

30 >>> map (filterDataConstructors exps)

29 >>> map (filterDataConstructors exps)

31− >>> filterInstances exps

30+ >>> filterInstances mn exps

32

31

33-- |

32-- |

34-- Filter out all data constructors from a declaration which are not exported.

33-- Filter out all data constructors from a declaration which are not exported.

@@ -52,10 +51,15 @@ filterDataConstructors _ other = other

52-- produce incorrect results if this is not the case - for example, type class

51-- produce incorrect results if this is not the case - for example, type class

53-- instances will be incorrectly removed in some cases.

52-- instances will be incorrectly removed in some cases.

54--

53--

54+filterInstances

55+ :: ModuleName

55−filterInstances :: Maybe [DeclarationRef] -> [Declaration] -> [Declaration]

56+ -> Maybe [DeclarationRef]

57+ -> [Declaration]

58+ -> [Declaration]

56−filterInstances Nothing = id

59+filterInstances _ Nothing = id

57−filterInstances (Just exps) =

60+filterInstances mn (Just exps) =

58− let refs = mapMaybe typeName exps ++ mapMaybe typeClassName exps

61+ let refs = Left `map` mapMaybe typeClassName exps

62+ ++ Right `map` mapMaybe typeName exps

59 in filter (all (visibleOutside refs) . typeInstanceConstituents)

63 in filter (all (visibleOutside refs) . typeInstanceConstituents)

60 where

64 where

61 -- Given a Qualified ProperName, and a list of all exported types and type

65 -- Given a Qualified ProperName, and a list of all exported types and type

@@ -65,13 +69,24 @@ filterInstances (Just exps) =

65 -- * the name is defined in the same module and is exported,

69 -- * the name is defined in the same module and is exported,

66 -- * the name is defined in a different module (and must be exported from

70 -- * the name is defined in a different module (and must be exported from

67 -- that module; the code would fail to compile otherwise).

71 -- that module; the code would fail to compile otherwise).

68− visibleOutside _ (Qualified (Just _) _) = True

72+ visibleOutside

69− visibleOutside refs (Qualified Nothing n) = n `elem` refs

73+ :: [Either (ProperName 'ClassName) (ProperName 'TypeName)]

70−

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)

71 typeName (TypeRef n _) = Just n

85 typeName (TypeRef n _) = Just n

72 typeName (PositionedDeclarationRef _ _ r) = typeName r

86 typeName (PositionedDeclarationRef _ _ r) = typeName r

73 typeName _ = Nothing

87 typeName _ = Nothing

74

88

89+ typeClassName :: DeclarationRef -> Maybe (ProperName 'ClassName)

75 typeClassName (TypeClassRef n) = Just n

90 typeClassName (TypeClassRef n) = Just n

76 typeClassName (PositionedDeclarationRef _ _ r) = typeClassName r

91 typeClassName (PositionedDeclarationRef _ _ r) = typeClassName r

77 typeClassName _ = Nothing

92 typeClassName _ = Nothing

@@ -79,17 +94,17 @@ filterInstances (Just exps) =

79-- |

94-- |

80-- Get all type and type class names referenced by a type instance declaration.

95-- Get all type and type class names referenced by a type instance declaration.

81--

96--

82−typeInstanceConstituents :: Declaration -> [Qualified ProperName]

97+typeInstanceConstituents :: Declaration -> [Either (Qualified (ProperName 'ClassName)) (Qualified (ProperName 'TypeName))]

83typeInstanceConstituents (TypeInstanceDeclaration _ constraints className tys _) =

98typeInstanceConstituents (TypeInstanceDeclaration _ constraints className tys _) =

84− className : (concatMap fromConstraint constraints ++ concatMap fromType tys)

99+ Left className : (concatMap fromConstraint constraints ++ concatMap fromType tys)

85 where

100 where

86

101

87− fromConstraint (name, tys') = name : concatMap fromType tys'

102+ fromConstraint (name, tys') = Left name : concatMap fromType tys'

88 fromType = everythingOnTypes (++) go

103 fromType = everythingOnTypes (++) go

89

104

90 -- Note that type synonyms are disallowed in instance declarations, so

105 -- Note that type synonyms are disallowed in instance declarations, so

91 -- we don't need to handle them here.

106 -- we don't need to handle them here.

92− go (TypeConstructor n) = [n]

107+ go (TypeConstructor n) = [Right n]

93 go (ConstrainedType cs _) = concatMap fromConstraint cs

108 go (ConstrainedType cs _) = concatMap fromConstraint cs

94 go _ = []

109 go _ = []

95

110

@@ -118,8 +133,8 @@ isExported (Just exps) decl = any (matches decl) exps

118 matches (TypeSynonymDeclaration ident _ _) (TypeRef ident' _) = ident == ident'

133 matches (TypeSynonymDeclaration ident _ _) (TypeRef ident' _) = ident == ident'

119 matches (TypeClassDeclaration ident _ _ _) (TypeClassRef ident') = ident == ident'

134 matches (TypeClassDeclaration ident _ _ _) (TypeClassRef ident') = ident == ident'

120

135

121− matches (DataDeclaration _ ident _ _) (ProperRef ident') = ident == ident'

136+ matches (DataDeclaration _ ident _ _) (ProperRef ident') = runProperName ident == ident'

122− matches (TypeClassDeclaration ident _ _ _) (ProperRef ident') = ident == ident'

137+ matches (TypeClassDeclaration ident _ _ _) (ProperRef ident') = runProperName ident == ident'

123

138

124 matches (PositionedDeclaration _ _ d) r = d `matches` r

139 matches (PositionedDeclaration _ _ d) r = d `matches` r

125 matches d (PositionedDeclarationRef _ _ r) = d `matches` r

140 matches d (PositionedDeclarationRef _ _ r) = d `matches` r

@@ -129,7 +144,7 @@ isExported (Just exps) decl = any (matches decl) exps

129-- Test if a data constructor for a given type is exported, given a module's

144-- Test if a data constructor for a given type is exported, given a module's

130-- export list. Prefer 'exportedDeclarations' to this function, where possible.

145-- export list. Prefer 'exportedDeclarations' to this function, where possible.

131--

146--

132−isDctorExported :: ProperName -> Maybe [DeclarationRef] -> ProperName -> Bool

147+isDctorExported :: ProperName 'TypeName -> Maybe [DeclarationRef] -> ProperName 'ConstructorName -> Bool

133isDctorExported _ Nothing _ = True

148isDctorExported _ Nothing _ = True

134isDctorExported ident (Just exps) ctor = test `any` exps

149isDctorExported ident (Just exps) ctor = test `any` exps

135 where

150 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

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−

15{-# LANGUAGE OverloadedStrings #-}

1{-# LANGUAGE OverloadedStrings #-}

16−{-# LANGUAGE DeriveDataTypeable #-}

17

2

3+-- |

4+-- Operators fixity and associativity

5+--

18module Language.PureScript.AST.Operators where

6module Language.PureScript.AST.Operators where

19

7

20−import qualified Data.Data as D

21import Data.Aeson ((.=))

8import Data.Aeson ((.=))

22import qualified Data.Aeson as A

9import qualified Data.Aeson as A

23

10

@@ -31,7 +18,8 @@ type Precedence = Integer

31-- |

18-- |

32-- Associativity for infix operators

19-- Associativity for infix operators

33--

20--

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)

35

23

36showAssoc :: Associativity -> String

24showAssoc :: Associativity -> String

37showAssoc Infixl = "infixl"

25showAssoc Infixl = "infixl"

@@ -53,7 +41,8 @@ instance A.FromJSON Associativity where

53-- |

41-- |

54-- Fixity data for infix operators

42-- Fixity data for infix operators

55--

43--

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)

57

46

58instance A.ToJSON Fixity where

47instance A.ToJSON Fixity where

59 toJSON (Fixity associativity precedence) =

48 toJSON (Fixity associativity precedence) =

src/Language/PureScript/AST/SourcePos.hs+5−18

@@ -1,28 +1,15 @@

1−-----------------------------------------------------------------------------

2−--

3−-- Module : Language.PureScript.AST.SourcePos

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 #-}

16{-# LANGUAGE ScopedTypeVariables #-}

1{-# LANGUAGE ScopedTypeVariables #-}

17{-# LANGUAGE RecordWildCards #-}

2{-# LANGUAGE RecordWildCards #-}

18{-# LANGUAGE OverloadedStrings #-}

3{-# LANGUAGE OverloadedStrings #-}

19

4

5+-- |

6+-- Source position information

7+--

20module Language.PureScript.AST.SourcePos where

8module Language.PureScript.AST.SourcePos where

21

9

22import Prelude ()

10import Prelude ()

23import Prelude.Compat

11import Prelude.Compat

24

12

25−import qualified Data.Data as D

26import Data.Aeson ((.=), (.:))

13import Data.Aeson ((.=), (.:))

27import qualified Data.Aeson as A

14import qualified Data.Aeson as A

28

15

@@ -38,7 +25,7 @@ data SourcePos = SourcePos

38 -- Column number

25 -- Column number

39 --

26 --

40 , sourcePosColumn :: Int

27 , sourcePosColumn :: Int

41− } deriving (Show, Read, Eq, Ord, D.Data, D.Typeable)

28+ } deriving (Show, Read, Eq, Ord)

42

29

43displaySourcePos :: SourcePos -> String

30displaySourcePos :: SourcePos -> String

44displaySourcePos sp =

31displaySourcePos sp =

@@ -66,7 +53,7 @@ data SourceSpan = SourceSpan

66 -- End of the span

53 -- End of the span

67 --

54 --

68 , spanEnd :: SourcePos

55 , spanEnd :: SourcePos

69− } deriving (Show, Read, Eq, Ord, D.Data, D.Typeable)

56+ } deriving (Show, Read, Eq, Ord)

70

57

71displayStartEndPos :: SourceSpan -> String

58displayStartEndPos :: SourceSpan -> String

72displayStartEndPos sp =

59displayStartEndPos sp =

src/Language/PureScript/AST/Traversals.hs+211−123

@@ -1,17 +1,8 @@

1−-----------------------------------------------------------------------------

1+{-# LANGUAGE ScopedTypeVariables #-}

2−--

3−-- Module : Language.PureScript.AST.Traversals

5−-- License : MIT

6−--

7−-- Maintainer : Phil Freeman <paf31@cantab.net>

8−-- Stability : experimental

9−-- Portability :

10−--

11−-- | AST traversal helpers

12−--

13−-----------------------------------------------------------------------------

14

2

3+-- |

4+-- AST traversal helpers

5+--

15module Language.PureScript.AST.Traversals where

6module Language.PureScript.AST.Traversals where

16

7

17import Prelude ()

8import Prelude ()

@@ -23,18 +14,23 @@ import Data.Foldable (fold)

23import qualified Data.Set as S

14import qualified Data.Set as S

24

15

25import Control.Monad

16import Control.Monad

26−import Control.Arrow ((***), (+++), second)

17+import Control.Arrow ((***), (+++))

27

18

28import Language.PureScript.AST.Binders

19import Language.PureScript.AST.Binders

20+import Language.PureScript.AST.Literals

29import Language.PureScript.AST.Declarations

21import Language.PureScript.AST.Declarations

30import Language.PureScript.Types

22import Language.PureScript.Types

31import Language.PureScript.Traversals

23import Language.PureScript.Traversals

32import Language.PureScript.Names

24import Language.PureScript.Names

33

25

26+everywhereOnValues

34−everywhereOnValues :: (Declaration -> Declaration) ->

27+ :: (Declaration -> Declaration)

35− (Expr -> Expr) ->

28+ -> (Expr -> Expr)

36− (Binder -> Binder) ->

29+ -> (Binder -> Binder)

37− (Declaration -> Declaration, Expr -> Expr, Binder -> Binder)

30+ -> ( Declaration -> Declaration

31+ , Expr -> Expr

32+ , Binder -> Binder

33+ )

38everywhereOnValues f g h = (f', g', h')

34everywhereOnValues f g h = (f', g', h')

39 where

35 where

40 f' :: Declaration -> Declaration

36 f' :: Declaration -> Declaration

@@ -47,18 +43,15 @@ everywhereOnValues f g h = (f', g', h')

47 f' other = f other

43 f' other = f other

48

44

49 g' :: Expr -> Expr

45 g' :: Expr -> Expr

46+ g' (Literal l) = g (Literal (lit g' l))

50 g' (UnaryMinus v) = g (UnaryMinus (g' v))

47 g' (UnaryMinus v) = g (UnaryMinus (g' v))

51 g' (BinaryNoParens op v1 v2) = g (BinaryNoParens (g' op) (g' v1) (g' v2))

48 g' (BinaryNoParens op v1 v2) = g (BinaryNoParens (g' op) (g' v1) (g' v2))

52 g' (Parens v) = g (Parens (g' v))

49 g' (Parens v) = g (Parens (g' v))

53 g' (OperatorSection op (Left v)) = g (OperatorSection (g' op) (Left $ g' v))

50 g' (OperatorSection op (Left v)) = g (OperatorSection (g' op) (Left $ g' v))

54 g' (OperatorSection op (Right v)) = g (OperatorSection (g' op) (Right $ g' v))

51 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))

58 g' (TypeClassDictionaryConstructorApp name v) = g (TypeClassDictionaryConstructorApp name (g' v))

52 g' (TypeClassDictionaryConstructorApp name v) = g (TypeClassDictionaryConstructorApp name (g' v))

59 g' (Accessor prop v) = g (Accessor prop (g' v))

53 g' (Accessor prop v) = g (Accessor prop (g' v))

60 g' (ObjectUpdate obj vs) = g (ObjectUpdate (g' obj) (map (fmap g') vs))

54 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))

62 g' (Abs name v) = g (Abs name (g' v))

55 g' (Abs name v) = g (Abs name (g' v))

63 g' (App v1 v2) = g (App (g' v1) (g' v2))

56 g' (App v1 v2) = g (App (g' v1) (g' v2))

64 g' (IfThenElse v1 v2 v3) = g (IfThenElse (g' v1) (g' v2) (g' v3))

57 g' (IfThenElse v1 v2 v3) = g (IfThenElse (g' v1) (g' v2) (g' v3))

@@ -71,13 +64,19 @@ everywhereOnValues f g h = (f', g', h')

71

64

72 h' :: Binder -> Binder

65 h' :: Binder -> Binder

73 h' (ConstructorBinder ctor bs) = h (ConstructorBinder ctor (map h' bs))

66 h' (ConstructorBinder ctor bs) = h (ConstructorBinder ctor (map h' bs))

74− h' (ObjectBinder bs) = h (ObjectBinder (map (fmap h') bs))

67+ h' (BinaryNoParensBinder b1 b2 b3) = h (BinaryNoParensBinder (h' b1) (h' b2) (h' b3))

75− h' (ArrayBinder bs) = h (ArrayBinder (map h' bs))

68+ h' (ParensInBinder b) = h (ParensInBinder (h' b))

69+ h' (LiteralBinder l) = h (LiteralBinder (lit h' l))

76 h' (NamedBinder name b) = h (NamedBinder name (h' b))

70 h' (NamedBinder name b) = h (NamedBinder name (h' b))

77 h' (PositionedBinder pos com b) = h (PositionedBinder pos com (h' b))

71 h' (PositionedBinder pos com b) = h (PositionedBinder pos com (h' b))

78 h' (TypedBinder t b) = h (TypedBinder t (h' b))

72 h' (TypedBinder t b) = h (TypedBinder t (h' b))

79 h' other = h other

73 h' other = h other

80

74

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+

81 handleCaseAlternative :: CaseAlternative -> CaseAlternative

80 handleCaseAlternative :: CaseAlternative -> CaseAlternative

82 handleCaseAlternative ca =

81 handleCaseAlternative ca =

83 ca { caseAlternativeBinders = map h' (caseAlternativeBinders ca)

82 ca { caseAlternativeBinders = map h' (caseAlternativeBinders ca)

@@ -90,13 +89,20 @@ everywhereOnValues f g h = (f', g', h')

90 handleDoNotationElement (DoNotationLet ds) = DoNotationLet (map f' ds)

89 handleDoNotationElement (DoNotationLet ds) = DoNotationLet (map f' ds)

91 handleDoNotationElement (PositionedDoNotationElement pos com e) = PositionedDoNotationElement pos com (handleDoNotationElement e)

90 handleDoNotationElement (PositionedDoNotationElement pos com e) = PositionedDoNotationElement pos com (handleDoNotationElement e)

92

91

93−everywhereOnValuesTopDownM :: (Functor m, Applicative m, Monad m) =>

92+everywhereOnValuesTopDownM

93+ :: forall m

94+ . (Monad m)

94− (Declaration -> m Declaration) ->

95+ => (Declaration -> m Declaration)

95− (Expr -> m Expr) ->

96+ -> (Expr -> m Expr)

96− (Binder -> m Binder) ->

97+ -> (Binder -> m Binder)

97− (Declaration -> m Declaration, Expr -> m Expr, Binder -> m Binder)

98+ -> ( Declaration -> m Declaration

99+ , Expr -> m Expr

100+ , Binder -> m Binder

101+ )

98everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)

102everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)

99 where

103 where

104+

105+ f' :: Declaration -> m Declaration

100 f' (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> traverse (f' <=< f) ds

106 f' (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> traverse (f' <=< f) ds

101 f' (ValueDeclaration name nameKind bs val) = ValueDeclaration name nameKind <$> traverse (h' <=< h) bs <*> eitherM (traverse (pairM (g' <=< g) (g' <=< g))) (g' <=< g) val

107 f' (ValueDeclaration name nameKind bs val) = ValueDeclaration name nameKind <$> traverse (h' <=< h) bs <*> eitherM (traverse (pairM (g' <=< g) (g' <=< g))) (g' <=< g) val

102 f' (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> traverse (\(name, nameKind, val) -> (,,) name nameKind <$> (g val >>= g')) ds

108 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)

105 f' (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> (f d >>= f')

111 f' (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> (f d >>= f')

106 f' other = f other

112 f' other = f other

107

113

114+ g' :: Expr -> m Expr

115+ g' (Literal l) = Literal <$> lit (g >=> g') l

108 g' (UnaryMinus v) = UnaryMinus <$> (g v >>= g')

116 g' (UnaryMinus v) = UnaryMinus <$> (g v >>= g')

109 g' (BinaryNoParens op v1 v2) = BinaryNoParens <$> (g op >>= g') <*> (g v1 >>= g') <*> (g v2 >>= g')

117 g' (BinaryNoParens op v1 v2) = BinaryNoParens <$> (g op >>= g') <*> (g v1 >>= g') <*> (g v2 >>= g')

110 g' (Parens v) = Parens <$> (g v >>= g')

118 g' (Parens v) = Parens <$> (g v >>= g')

111 g' (OperatorSection op (Left v)) = OperatorSection <$> (g op >>= g') <*> (Left <$> (g v >>= g'))

119 g' (OperatorSection op (Left v)) = OperatorSection <$> (g op >>= g') <*> (Left <$> (g v >>= g'))

112 g' (OperatorSection op (Right v)) = OperatorSection <$> (g op >>= g') <*> (Right <$> (g v >>= g'))

120 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

116 g' (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> (g v >>= g')

121 g' (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> (g v >>= g')

117 g' (Accessor prop v) = Accessor prop <$> (g v >>= g')

122 g' (Accessor prop v) = Accessor prop <$> (g v >>= g')

118 g' (ObjectUpdate obj vs) = ObjectUpdate <$> (g obj >>= g') <*> traverse (sndM (g' <=< g)) vs

123 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

120 g' (Abs name v) = Abs name <$> (g v >>= g')

124 g' (Abs name v) = Abs name <$> (g v >>= g')

121 g' (App v1 v2) = App <$> (g v1 >>= g') <*> (g v2 >>= g')

125 g' (App v1 v2) = App <$> (g v1 >>= g') <*> (g v2 >>= g')

122 g' (IfThenElse v1 v2 v3) = IfThenElse <$> (g v1 >>= g') <*> (g v2 >>= g') <*> (g v3 >>= g')

126 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)

127 g' (PositionedValue pos com v) = PositionedValue pos com <$> (g v >>= g')

131 g' (PositionedValue pos com v) = PositionedValue pos com <$> (g v >>= g')

128 g' other = g other

132 g' other = g other

129

133

134+ h' :: Binder -> m Binder

135+ h' (LiteralBinder l) = LiteralBinder <$> lit (h >=> h') l

130 h' (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> traverse (h' <=< h) bs

136 h' (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> traverse (h' <=< h) bs

131− h' (ObjectBinder bs) = ObjectBinder <$> traverse (sndM (h' <=< h)) bs

137+ h' (BinaryNoParensBinder b1 b2 b3) = BinaryNoParensBinder <$> (h b1 >>= h') <*> (h b2 >>= h') <*> (h b3 >>= h')

132− h' (ArrayBinder bs) = ArrayBinder <$> traverse (h' <=< h) bs

138+ h' (ParensInBinder b) = ParensInBinder <$> (h b >>= h')

133 h' (NamedBinder name b) = NamedBinder name <$> (h b >>= h')

139 h' (NamedBinder name b) = NamedBinder name <$> (h b >>= h')

134 h' (PositionedBinder pos com b) = PositionedBinder pos com <$> (h b >>= h')

140 h' (PositionedBinder pos com b) = PositionedBinder pos com <$> (h b >>= h')

135 h' (TypedBinder t b) = TypedBinder t <$> (h b >>= h')

141 h' (TypedBinder t b) = TypedBinder t <$> (h b >>= h')

136 h' other = h other

142 h' other = h other

137

143

138− handleCaseAlternative (CaseAlternative bs val) = CaseAlternative <$> traverse (h' <=< h) bs

144+ lit :: (a -> m a) -> Literal a -> m (Literal a)

139− <*> eitherM (traverse (pairM (g' <=< g) (g' <=< g))) (g' <=< g) val

145+ lit go (ObjectLiteral as) = ObjectLiteral <$> traverse (sndM go) as

146+ lit go (ArrayLiteral as) = ArrayLiteral <$> traverse go as

147+ lit _ other = pure other

140

148

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

141 handleDoNotationElement (DoNotationValue v) = DoNotationValue <$> (g' <=< g) v

156 handleDoNotationElement (DoNotationValue v) = DoNotationValue <$> (g' <=< g) v

142 handleDoNotationElement (DoNotationBind b v) = DoNotationBind <$> (h' <=< h) b <*> (g' <=< g) v

157 handleDoNotationElement (DoNotationBind b v) = DoNotationBind <$> (h' <=< h) b <*> (g' <=< g) v

143 handleDoNotationElement (DoNotationLet ds) = DoNotationLet <$> traverse (f' <=< f) ds

158 handleDoNotationElement (DoNotationLet ds) = DoNotationLet <$> traverse (f' <=< f) ds

144 handleDoNotationElement (PositionedDoNotationElement pos com e) = PositionedDoNotationElement pos com <$> handleDoNotationElement e

159 handleDoNotationElement (PositionedDoNotationElement pos com e) = PositionedDoNotationElement pos com <$> handleDoNotationElement e

145

160

146−everywhereOnValuesM :: (Functor m, Applicative m, Monad m) =>

161+everywhereOnValuesM

162+ :: forall m

163+ . (Monad m)

147− (Declaration -> m Declaration) ->

164+ => (Declaration -> m Declaration)

148− (Expr -> m Expr) ->

165+ -> (Expr -> m Expr)

149− (Binder -> m Binder) ->

166+ -> (Binder -> m Binder)

150− (Declaration -> m Declaration, Expr -> m Expr, Binder -> m Binder)

167+ -> ( Declaration -> m Declaration

168+ , Expr -> m Expr

169+ , Binder -> m Binder

170+ )

151everywhereOnValuesM f g h = (f', g', h')

171everywhereOnValuesM f g h = (f', g', h')

152 where

172 where

173+

174+ f' :: Declaration -> m Declaration

153 f' (DataBindingGroupDeclaration ds) = (DataBindingGroupDeclaration <$> traverse f' ds) >>= f

175 f' (DataBindingGroupDeclaration ds) = (DataBindingGroupDeclaration <$> traverse f' ds) >>= f

154 f' (ValueDeclaration name nameKind bs val) = (ValueDeclaration name nameKind <$> traverse h' bs <*> eitherM (traverse (pairM g' g')) g' val) >>= f

176 f' (ValueDeclaration name nameKind bs val) = (ValueDeclaration name nameKind <$> traverse h' bs <*> eitherM (traverse (pairM g' g')) g' val) >>= f

155 f' (BindingGroupDeclaration ds) = (BindingGroupDeclaration <$> traverse (\(name, nameKind, val) -> (,,) name nameKind <$> g' val) ds) >>= f

177 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')

158 f' (PositionedDeclaration pos com d) = (PositionedDeclaration pos com <$> f' d) >>= f

180 f' (PositionedDeclaration pos com d) = (PositionedDeclaration pos com <$> f' d) >>= f

159 f' other = f other

181 f' other = f other

160

182

183+ g' :: Expr -> m Expr

184+ g' (Literal l) = (Literal <$> lit g' l) >>= g

161 g' (UnaryMinus v) = (UnaryMinus <$> g' v) >>= g

185 g' (UnaryMinus v) = (UnaryMinus <$> g' v) >>= g

162 g' (BinaryNoParens op v1 v2) = (BinaryNoParens <$> g' op <*> g' v1 <*> g' v2) >>= g

186 g' (BinaryNoParens op v1 v2) = (BinaryNoParens <$> g' op <*> g' v1 <*> g' v2) >>= g

163 g' (Parens v) = (Parens <$> g' v) >>= g

187 g' (Parens v) = (Parens <$> g' v) >>= g

164 g' (OperatorSection op (Left v)) = (OperatorSection <$> g' op <*> (Left <$> g' v)) >>= g

188 g' (OperatorSection op (Left v)) = (OperatorSection <$> g' op <*> (Left <$> g' v)) >>= g

165 g' (OperatorSection op (Right v)) = (OperatorSection <$> g' op <*> (Right <$> g' v)) >>= g

189 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

169 g' (TypeClassDictionaryConstructorApp name v) = (TypeClassDictionaryConstructorApp name <$> g' v) >>= g

190 g' (TypeClassDictionaryConstructorApp name v) = (TypeClassDictionaryConstructorApp name <$> g' v) >>= g

170 g' (Accessor prop v) = (Accessor prop <$> g' v) >>= g

191 g' (Accessor prop v) = (Accessor prop <$> g' v) >>= g

171 g' (ObjectUpdate obj vs) = (ObjectUpdate <$> g' obj <*> traverse (sndM g') vs) >>= g

192 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

173 g' (Abs name v) = (Abs name <$> g' v) >>= g

193 g' (Abs name v) = (Abs name <$> g' v) >>= g

174 g' (App v1 v2) = (App <$> g' v1 <*> g' v2) >>= g

194 g' (App v1 v2) = (App <$> g' v1 <*> g' v2) >>= g

175 g' (IfThenElse v1 v2 v3) = (IfThenElse <$> g' v1 <*> g' v2 <*> g' v3) >>= g

195 g' (IfThenElse v1 v2 v3) = (IfThenElse <$> g' v1 <*> g' v2 <*> g' v3) >>= g

@@ -180,31 +200,51 @@ everywhereOnValuesM f g h = (f', g', h')

180 g' (PositionedValue pos com v) = (PositionedValue pos com <$> g' v) >>= g

200 g' (PositionedValue pos com v) = (PositionedValue pos com <$> g' v) >>= g

181 g' other = g other

201 g' other = g other

182

202

203+ h' :: Binder -> m Binder

204+ h' (LiteralBinder l) = (LiteralBinder <$> lit h' l) >>= h

183 h' (ConstructorBinder ctor bs) = (ConstructorBinder ctor <$> traverse h' bs) >>= h

205 h' (ConstructorBinder ctor bs) = (ConstructorBinder ctor <$> traverse h' bs) >>= h

184− h' (ObjectBinder bs) = (ObjectBinder <$> traverse (sndM h') bs) >>= h

206+ h' (BinaryNoParensBinder b1 b2 b3) = (BinaryNoParensBinder <$> h' b1 <*> h' b2 <*> h' b3) >>= h

185− h' (ArrayBinder bs) = (ArrayBinder <$> traverse h' bs) >>= h

207+ h' (ParensInBinder b) = (ParensInBinder <$> h' b) >>= h

186 h' (NamedBinder name b) = (NamedBinder name <$> h' b) >>= h

208 h' (NamedBinder name b) = (NamedBinder name <$> h' b) >>= h

187 h' (PositionedBinder pos com b) = (PositionedBinder pos com <$> h' b) >>= h

209 h' (PositionedBinder pos com b) = (PositionedBinder pos com <$> h' b) >>= h

188 h' (TypedBinder t b) = (TypedBinder t <$> h' b) >>= h

210 h' (TypedBinder t b) = (TypedBinder t <$> h' b) >>= h

189 h' other = h other

211 h' other = h other

190

212

191− handleCaseAlternative (CaseAlternative bs val) = CaseAlternative <$> traverse h' bs

213+ lit :: (a -> m a) -> Literal a -> m (Literal a)

192− <*> eitherM (traverse (pairM g' g')) g' val

214+ lit go (ObjectLiteral as) = ObjectLiteral <$> traverse (sndM go) as

215+ lit go (ArrayLiteral as) = ArrayLiteral <$> traverse go as

216+ lit _ other = pure other

193

217

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

194 handleDoNotationElement (DoNotationValue v) = DoNotationValue <$> g' v

225 handleDoNotationElement (DoNotationValue v) = DoNotationValue <$> g' v

195 handleDoNotationElement (DoNotationBind b v) = DoNotationBind <$> h' b <*> g' v

226 handleDoNotationElement (DoNotationBind b v) = DoNotationBind <$> h' b <*> g' v

196 handleDoNotationElement (DoNotationLet ds) = DoNotationLet <$> traverse f' ds

227 handleDoNotationElement (DoNotationLet ds) = DoNotationLet <$> traverse f' ds

197 handleDoNotationElement (PositionedDoNotationElement pos com e) = PositionedDoNotationElement pos com <$> handleDoNotationElement e

228 handleDoNotationElement (PositionedDoNotationElement pos com e) = PositionedDoNotationElement pos com <$> handleDoNotationElement e

198

229

199−everythingOnValues :: (r -> r -> r) ->

230+everythingOnValues

231+ :: forall r

232+ . (r -> r -> r)

200− (Declaration -> r) ->

233+ -> (Declaration -> r)

201− (Expr -> r) ->

234+ -> (Expr -> r)

202− (Binder -> r) ->

235+ -> (Binder -> r)

203− (CaseAlternative -> r) ->

236+ -> (CaseAlternative -> r)

204− (DoNotationElement -> r) ->

237+ -> (DoNotationElement -> r)

238+ -> ( Declaration -> r

239+ , Expr -> r

240+ , Binder -> r

241+ , CaseAlternative -> r

205− (Declaration -> r, Expr -> r, Binder -> r, CaseAlternative -> r, DoNotationElement -> r)

242+ , DoNotationElement -> r

243+ )

206everythingOnValues (<>) f g h i j = (f', g', h', i', j')

244everythingOnValues (<>) f g h i j = (f', g', h', i', j')

207 where

245 where

246+

247+ f' :: Declaration -> r

208 f' d@(DataBindingGroupDeclaration ds) = foldl (<>) (f d) (map f' ds)

248 f' d@(DataBindingGroupDeclaration ds) = foldl (<>) (f d) (map f' ds)

209 f' d@(ValueDeclaration _ _ bs (Right val)) = foldl (<>) (f d) (map h' bs) <> g' val

249 f' d@(ValueDeclaration _ _ bs (Right val)) = foldl (<>) (f d) (map h' bs) <> g' val

210 f' d@(ValueDeclaration _ _ bs (Left gs)) = foldl (<>) (f d) (map h' bs ++ concatMap (\(grd, val) -> [g' grd, g' val]) gs)

250 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')

214 f' d@(PositionedDeclaration _ _ d1) = f d <> f' d1

254 f' d@(PositionedDeclaration _ _ d1) = f d <> f' d1

215 f' d = f d

255 f' d = f d

216

256

257+ g' :: Expr -> r

258+ g' v@(Literal l) = lit (g v) g' l

217 g' v@(UnaryMinus v1) = g v <> g' v1

259 g' v@(UnaryMinus v1) = g v <> g' v1

218 g' v@(BinaryNoParens op v1 v2) = g v <> g' op <> g' v1 <> g' v2

260 g' v@(BinaryNoParens op v1 v2) = g v <> g' op <> g' v1 <> g' v2

219 g' v@(Parens v1) = g v <> g' v1

261 g' v@(Parens v1) = g v <> g' v1

220 g' v@(OperatorSection op (Left v1)) = g v <> g' op <> g' v1

262 g' v@(OperatorSection op (Left v1)) = g v <> g' op <> g' v1

221 g' v@(OperatorSection op (Right v1)) = g v <> g' op <> g' v1

263 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))

225 g' v@(TypeClassDictionaryConstructorApp _ v1) = g v <> g' v1

264 g' v@(TypeClassDictionaryConstructorApp _ v1) = g v <> g' v1

226 g' v@(Accessor _ v1) = g v <> g' v1

265 g' v@(Accessor _ v1) = g v <> g' v1

227 g' v@(ObjectUpdate obj vs) = foldl (<>) (g v <> g' obj) (map (g' . snd) vs)

266 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))

229 g' v@(Abs _ v1) = g v <> g' v1

267 g' v@(Abs _ v1) = g v <> g' v1

230 g' v@(App v1 v2) = g v <> g' v1 <> g' v2

268 g' v@(App v1 v2) = g v <> g' v1 <> g' v2

231 g' v@(IfThenElse v1 v2 v3) = g v <> g' v1 <> g' v2 <> g' v3

269 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')

236 g' v@(PositionedValue _ _ v1) = g v <> g' v1

274 g' v@(PositionedValue _ _ v1) = g v <> g' v1

237 g' v = g v

275 g' v = g v

238

276

277+ h' :: Binder -> r

278+ h' b@(LiteralBinder l) = lit (h b) h' l

239 h' b@(ConstructorBinder _ bs) = foldl (<>) (h b) (map h' bs)

279 h' b@(ConstructorBinder _ bs) = foldl (<>) (h b) (map h' bs)

240− h' b@(ObjectBinder bs) = foldl (<>) (h b) (map (h' . snd) bs)

280+ h' b@(BinaryNoParensBinder b1 b2 b3) = h b <> h' b1 <> h' b2 <> h' b3

241− h' b@(ArrayBinder bs) = foldl (<>) (h b) (map h' bs)

281+ h' b@(ParensInBinder b1) = h b <> h' b1

242 h' b@(NamedBinder _ b1) = h b <> h' b1

282 h' b@(NamedBinder _ b1) = h b <> h' b1

243 h' b@(PositionedBinder _ _ b1) = h b <> h' b1

283 h' b@(PositionedBinder _ _ b1) = h b <> h' b1

244 h' b@(TypedBinder _ b1) = h b <> h' b1

284 h' b@(TypedBinder _ b1) = h b <> h' b1

245 h' b = h b

285 h' b = h b

246

286

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

247 i' ca@(CaseAlternative bs (Right val)) = foldl (<>) (i ca) (map h' bs) <> g' val

293 i' ca@(CaseAlternative bs (Right val)) = foldl (<>) (i ca) (map h' bs) <> g' val

248 i' ca@(CaseAlternative bs (Left gs)) = foldl (<>) (i ca) (map h' bs ++ concatMap (\(grd, val) -> [g' grd, g' val]) gs)

294 i' ca@(CaseAlternative bs (Left gs)) = foldl (<>) (i ca) (map h' bs ++ concatMap (\(grd, val) -> [g' grd, g' val]) gs)

249

295

296+ j' :: DoNotationElement -> r

250 j' e@(DoNotationValue v) = j e <> g' v

297 j' e@(DoNotationValue v) = j e <> g' v

251 j' e@(DoNotationBind b v) = j e <> h' b <> g' v

298 j' e@(DoNotationBind b v) = j e <> h' b <> g' v

252 j' e@(DoNotationLet ds) = foldl (<>) (j e) (map f' ds)

299 j' e@(DoNotationLet ds) = foldl (<>) (j e) (map f' ds)

253 j' e@(PositionedDoNotationElement _ _ e1) = j e <> j' e1

300 j' e@(PositionedDoNotationElement _ _ e1) = j e <> j' e1

254

301

255−everythingWithContextOnValues ::

302+everythingWithContextOnValues

256− s ->

303+ :: forall s r

257− r ->

304+ . s

305+ -> r

258− (r -> r -> r) ->

306+ -> (r -> r -> r)

259− (s -> Declaration -> (s, r)) ->

307+ -> (s -> Declaration -> (s, r))

260− (s -> Expr -> (s, r)) ->

308+ -> (s -> Expr -> (s, r))

261− (s -> Binder -> (s, r)) ->

309+ -> (s -> Binder -> (s, r))

262− (s -> CaseAlternative -> (s, r)) ->

310+ -> (s -> CaseAlternative -> (s, r))

263− (s -> DoNotationElement -> (s, r)) ->

311+ -> (s -> DoNotationElement -> (s, r))

264− ( Declaration -> r

312+ -> ( Declaration -> r

265− , Expr -> r

313+ , Expr -> r

266− , Binder -> r

314+ , Binder -> r

267− , CaseAlternative -> r

315+ , CaseAlternative -> r

268− , DoNotationElement -> r)

316+ , DoNotationElement -> r)

269everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j'' s0)

317everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j'' s0)

270 where

318 where

319+

320+ f'' :: s -> Declaration -> r

271 f'' s d = let (s', r) = f s d in r <> f' s' d

321 f'' s d = let (s', r) = f s d in r <> f' s' d

272

322

323+ f' :: s -> Declaration -> r

273 f' s (DataBindingGroupDeclaration ds) = foldl (<>) r0 (map (f'' s) ds)

324 f' s (DataBindingGroupDeclaration ds) = foldl (<>) r0 (map (f'' s) ds)

274 f' s (ValueDeclaration _ _ bs (Right val)) = foldl (<>) r0 (map (h'' s) bs) <> g'' s val

325 f' s (ValueDeclaration _ _ bs (Right val)) = foldl (<>) r0 (map (h'' s) bs) <> g'' s val

275 f' s (ValueDeclaration _ _ bs (Left gs)) = foldl (<>) r0 (map (h'' s) bs ++ concatMap (\(grd, val) -> [g'' s grd, g'' s val]) gs)

326 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'

279 f' s (PositionedDeclaration _ _ d1) = f'' s d1

330 f' s (PositionedDeclaration _ _ d1) = f'' s d1

280 f' _ _ = r0

331 f' _ _ = r0

281

332

333+ g'' :: s -> Expr -> r

282 g'' s v = let (s', r) = g s v in r <> g' s' v

334 g'' s v = let (s', r) = g s v in r <> g' s' v

283

335

336+ g' :: s -> Expr -> r

337+ g' s (Literal l) = lit g'' s l

284 g' s (UnaryMinus v1) = g'' s v1

338 g' s (UnaryMinus v1) = g'' s v1

285 g' s (BinaryNoParens op v1 v2) = g'' s op <> g'' s v1 <> g'' s v2

339 g' s (BinaryNoParens op v1 v2) = g'' s op <> g'' s v1 <> g'' s v2

286 g' s (Parens v1) = g'' s v1

340 g' s (Parens v1) = g'' s v1

287 g' s (OperatorSection op (Left v)) = g'' s op <> g'' s v

341 g' s (OperatorSection op (Left v)) = g'' s op <> g'' s v

288 g' s (OperatorSection op (Right v)) = g'' s op <> g'' s v

342 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))

292 g' s (TypeClassDictionaryConstructorApp _ v1) = g'' s v1

343 g' s (TypeClassDictionaryConstructorApp _ v1) = g'' s v1

293 g' s (Accessor _ v1) = g'' s v1

344 g' s (Accessor _ v1) = g'' s v1

294 g' s (ObjectUpdate obj vs) = foldl (<>) (g'' s obj) (map (g'' s . snd) vs)

345 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))

296 g' s (Abs _ v1) = g'' s v1

346 g' s (Abs _ v1) = g'' s v1

297 g' s (App v1 v2) = g'' s v1 <> g'' s v2

347 g' s (App v1 v2) = g'' s v1 <> g'' s v2

298 g' s (IfThenElse v1 v2 v3) = g'' s v1 <> g'' s v2 <> g'' s v3

348 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'

303 g' s (PositionedValue _ _ v1) = g'' s v1

353 g' s (PositionedValue _ _ v1) = g'' s v1

304 g' _ _ = r0

354 g' _ _ = r0

305

355

356+ h'' :: s -> Binder -> r

306 h'' s b = let (s', r) = h s b in r <> h' s' b

357 h'' s b = let (s', r) = h s b in r <> h' s' b

307

358

359+ h' :: s -> Binder -> r

360+ h' s (LiteralBinder l) = lit h'' s l

308 h' s (ConstructorBinder _ bs) = foldl (<>) r0 (map (h'' s) bs)

361 h' s (ConstructorBinder _ bs) = foldl (<>) r0 (map (h'' s) bs)

309− h' s (ObjectBinder bs) = foldl (<>) r0 (map (h'' s . snd) bs)

362+ h' s (BinaryNoParensBinder b1 b2 b3) = h'' s b1 <> h'' s b2 <> h'' s b3

310− h' s (ArrayBinder bs) = foldl (<>) r0 (map (h'' s) bs)

363+ h' s (ParensInBinder b) = h'' s b

311 h' s (NamedBinder _ b1) = h'' s b1

364 h' s (NamedBinder _ b1) = h'' s b1

312 h' s (PositionedBinder _ _ b1) = h'' s b1

365 h' s (PositionedBinder _ _ b1) = h'' s b1

313 h' s (TypedBinder _ b1) = h'' s b1

366 h' s (TypedBinder _ b1) = h'' s b1

314 h' _ _ = r0

367 h' _ _ = r0

315

368

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

316 i'' s ca = let (s', r) = i s ca in r <> i' s' ca

375 i'' s ca = let (s', r) = i s ca in r <> i' s' ca

317

376

377+ i' :: s -> CaseAlternative -> r

318 i' s (CaseAlternative bs (Right val)) = foldl (<>) r0 (map (h'' s) bs) <> g'' s val

378 i' s (CaseAlternative bs (Right val)) = foldl (<>) r0 (map (h'' s) bs) <> g'' s val

319 i' s (CaseAlternative bs (Left gs)) = foldl (<>) r0 (map (h'' s) bs ++ concatMap (\(grd, val) -> [g'' s grd, g'' s val]) gs)

379 i' s (CaseAlternative bs (Left gs)) = foldl (<>) r0 (map (h'' s) bs ++ concatMap (\(grd, val) -> [g'' s grd, g'' s val]) gs)

320

380

381+ j'' :: s -> DoNotationElement -> r

321 j'' s e = let (s', r) = j s e in r <> j' s' e

382 j'' s e = let (s', r) = j s e in r <> j' s' e

322

383

384+ j' :: s -> DoNotationElement -> r

323 j' s (DoNotationValue v) = g'' s v

385 j' s (DoNotationValue v) = g'' s v

324 j' s (DoNotationBind b v) = h'' s b <> g'' s v

386 j' s (DoNotationBind b v) = h'' s b <> g'' s v

325 j' s (DoNotationLet ds) = foldl (<>) r0 (map (f'' s) ds)

387 j' s (DoNotationLet ds) = foldl (<>) r0 (map (f'' s) ds)

326 j' s (PositionedDoNotationElement _ _ e1) = j'' s e1

388 j' s (PositionedDoNotationElement _ _ e1) = j'' s e1

327

389

328−everywhereWithContextOnValuesM :: (Functor m, Applicative m, Monad m) =>

390+everywhereWithContextOnValuesM

329− s ->

391+ :: forall m s

392+ . (Monad m)

393+ => s

330− (s -> Declaration -> m (s, Declaration)) ->

394+ -> (s -> Declaration -> m (s, Declaration))

331− (s -> Expr -> m (s, Expr)) ->

395+ -> (s -> Expr -> m (s, Expr))

332− (s -> Binder -> m (s, Binder)) ->

396+ -> (s -> Binder -> m (s, Binder))

333− (s -> CaseAlternative -> m (s, CaseAlternative)) ->

397+ -> (s -> CaseAlternative -> m (s, CaseAlternative))

334− (s -> DoNotationElement -> m (s, DoNotationElement)) ->

398+ -> (s -> DoNotationElement -> m (s, DoNotationElement))

335− ( Declaration -> m Declaration

399+ -> ( Declaration -> m Declaration

336− , Expr -> m Expr

400+ , Expr -> m Expr

337− , Binder -> m Binder

401+ , Binder -> m Binder

338− , CaseAlternative -> m CaseAlternative

402+ , CaseAlternative -> m CaseAlternative

339− , DoNotationElement -> m DoNotationElement)

403+ , DoNotationElement -> m DoNotationElement)

340everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j'' s0)

404everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j'' s0)

341 where

405 where

342 f'' s = uncurry f' <=< f s

406 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

351

415

352 g'' s = uncurry g' <=< g s

416 g'' s = uncurry g' <=< g s

353

417

418+ g' s (Literal l) = Literal <$> lit g'' s l

354 g' s (UnaryMinus v) = UnaryMinus <$> g'' s v

419 g' s (UnaryMinus v) = UnaryMinus <$> g'' s v

355 g' s (BinaryNoParens op v1 v2) = BinaryNoParens <$> g'' s op <*> g'' s v1 <*> g'' s v2

420 g' s (BinaryNoParens op v1 v2) = BinaryNoParens <$> g'' s op <*> g'' s v1 <*> g'' s v2

356 g' s (Parens v) = Parens <$> g'' s v

421 g' s (Parens v) = Parens <$> g'' s v

357 g' s (OperatorSection op (Left v)) = OperatorSection <$> g'' s op <*> (Left <$> g'' s v)

422 g' s (OperatorSection op (Left v)) = OperatorSection <$> g'' s op <*> (Left <$> g'' s v)

358 g' s (OperatorSection op (Right v)) = OperatorSection <$> g'' s op <*> (Right <$> g'' s v)

423 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

362 g' s (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> g'' s v

424 g' s (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> g'' s v

363 g' s (Accessor prop v) = Accessor prop <$> g'' s v

425 g' s (Accessor prop v) = Accessor prop <$> g'' s v

364 g' s (ObjectUpdate obj vs) = ObjectUpdate <$> g'' s obj <*> traverse (sndM (g'' s)) vs

426 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

366 g' s (Abs name v) = Abs name <$> g'' s v

427 g' s (Abs name v) = Abs name <$> g'' s v

367 g' s (App v1 v2) = App <$> g'' s v1 <*> g'' s v2

428 g' s (App v1 v2) = App <$> g'' s v1 <*> g'' s v2

368 g' s (IfThenElse v1 v2 v3) = IfThenElse <$> g'' s v1 <*> g'' s v2 <*> g'' s v3

429 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

375

436

376 h'' s = uncurry h' <=< h s

437 h'' s = uncurry h' <=< h s

377

438

439+ h' s (LiteralBinder l) = LiteralBinder <$> lit h'' s l

378 h' s (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> traverse (h'' s) bs

440 h' s (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> traverse (h'' s) bs

379− h' s (ObjectBinder bs) = ObjectBinder <$> traverse (sndM (h'' s)) bs

441+ h' s (BinaryNoParensBinder b1 b2 b3) = BinaryNoParensBinder <$> h'' s b1 <*> h'' s b2 <*> h'' s b3

380− h' s (ArrayBinder bs) = ArrayBinder <$> traverse (h'' s) bs

442+ h' s (ParensInBinder b) = ParensInBinder <$> h'' s b

381 h' s (NamedBinder name b) = NamedBinder name <$> h'' s b

443 h' s (NamedBinder name b) = NamedBinder name <$> h'' s b

382 h' s (PositionedBinder pos com b) = PositionedBinder pos com <$> h'' s b

444 h' s (PositionedBinder pos com b) = PositionedBinder pos com <$> h'' s b

383 h' s (TypedBinder t b) = TypedBinder t <$> h'' s b

445 h' s (TypedBinder t b) = TypedBinder t <$> h'' s b

384 h' _ other = return other

446 h' _ other = return other

385

447

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+

386 i'' s = uncurry i' <=< i s

453 i'' s = uncurry i' <=< i s

387

454

388 i' s (CaseAlternative bs val) = CaseAlternative <$> traverse (h'' s) bs <*> eitherM (traverse (pairM (g'' s) (g'' s))) (g'' s) val

455 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

394 j' s (DoNotationLet ds) = DoNotationLet <$> traverse (f'' s) ds

461 j' s (DoNotationLet ds) = DoNotationLet <$> traverse (f'' s) ds

395 j' s (PositionedDoNotationElement pos com e1) = PositionedDoNotationElement pos com <$> j'' s e1

462 j' s (PositionedDoNotationElement pos com e1) = PositionedDoNotationElement pos com <$> j'' s e1

396

463

397−everythingWithScope ::

464+everythingWithScope

465+ :: forall r

398− (Monoid r) =>

466+ . (Monoid r)

399− (S.Set Ident -> Declaration -> r) ->

467+ => (S.Set Ident -> Declaration -> r)

400− (S.Set Ident -> Expr -> r) ->

468+ -> (S.Set Ident -> Expr -> r)

401− (S.Set Ident -> Binder -> r) ->

469+ -> (S.Set Ident -> Binder -> r)

402− (S.Set Ident -> CaseAlternative -> r) ->

470+ -> (S.Set Ident -> CaseAlternative -> r)

403− (S.Set Ident -> DoNotationElement -> r) ->

471+ -> (S.Set Ident -> DoNotationElement -> r)

404− ( S.Set Ident -> Declaration -> r

472+ -> ( S.Set Ident -> Declaration -> r

405− , S.Set Ident -> Expr -> r

473+ , S.Set Ident -> Expr -> r

406− , S.Set Ident -> Binder -> r

474+ , S.Set Ident -> Binder -> r

407− , S.Set Ident -> CaseAlternative -> r

475+ , S.Set Ident -> CaseAlternative -> r

408− , S.Set Ident -> DoNotationElement -> r)

476+ , S.Set Ident -> DoNotationElement -> r

477+ )

409everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)

478everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)

410 where

479 where

411 -- Avoid importing Data.Monoid and getting shadowed names above

480 -- Avoid importing Data.Monoid and getting shadowed names above

412 (<>) = mappend

481 (<>) = mappend

413

482

483+ f'' :: S.Set Ident -> Declaration -> r

414 f'' s a = f s a <> f' s a

484 f'' s a = f s a <> f' s a

415

485

486+ f' :: S.Set Ident -> Declaration -> r

416 f' s (DataBindingGroupDeclaration ds) =

487 f' s (DataBindingGroupDeclaration ds) =

417 let s' = S.union s (S.fromList (mapMaybe getDeclIdent ds))

488 let s' = S.union s (S.fromList (mapMaybe getDeclIdent ds))

418 in foldMap (f'' s') ds

489 in foldMap (f'' s') ds

@@ -431,20 +502,19 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)

431 f' s (PositionedDeclaration _ _ d) = f'' s d

502 f' s (PositionedDeclaration _ _ d) = f'' s d

432 f' _ _ = mempty

503 f' _ _ = mempty

433

504

505+ g'' :: S.Set Ident -> Expr -> r

434 g'' s a = g s a <> g' s a

506 g'' s a = g s a <> g' s a

435

507

508+ g' :: S.Set Ident -> Expr -> r

509+ g' s (Literal l) = lit g'' s l

436 g' s (UnaryMinus v1) = g'' s v1

510 g' s (UnaryMinus v1) = g'' s v1

437 g' s (BinaryNoParens op v1 v2) = g' s op <> g' s v1 <> g' s v2

511 g' s (BinaryNoParens op v1 v2) = g' s op <> g' s v1 <> g' s v2

438 g' s (Parens v1) = g'' s v1

512 g' s (Parens v1) = g'' s v1

439 g' s (OperatorSection op (Left v)) = g'' s op <> g'' s v

513 g' s (OperatorSection op (Left v)) = g'' s op <> g'' s v

440 g' s (OperatorSection op (Right v)) = g'' s op <> g'' s v

514 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)

444 g' s (TypeClassDictionaryConstructorApp _ v1) = g'' s v1

515 g' s (TypeClassDictionaryConstructorApp _ v1) = g'' s v1

445 g' s (Accessor _ v1) = g'' s v1

516 g' s (Accessor _ v1) = g'' s v1

446 g' s (ObjectUpdate obj vs) = g'' s obj <> foldMap (g'' s . snd) vs

517 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)

448 g' s (Abs (Left name) v1) =

518 g' s (Abs (Left name) v1) =

449 let s' = S.insert name s

519 let s' = S.insert name s

450 in g'' s' v1

520 in g'' s' v1

@@ -462,20 +532,28 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)

462 g' s (PositionedValue _ _ v1) = g'' s v1

532 g' s (PositionedValue _ _ v1) = g'' s v1

463 g' _ _ = mempty

533 g' _ _ = mempty

464

534

535+ h'' :: S.Set Ident -> Binder -> r

465 h'' s a = h s a <> h' s a

536 h'' s a = h s a <> h' s a

466

537

538+ h' :: S.Set Ident -> Binder -> r

539+ h' s (LiteralBinder l) = lit h'' s l

467 h' s (ConstructorBinder _ bs) = foldMap (h'' s) bs

540 h' s (ConstructorBinder _ bs) = foldMap (h'' s) bs

468− h' s (ObjectBinder bs) = foldMap (h'' s . snd) bs

541+ h' s (BinaryNoParensBinder b1 b2 b3) = foldMap (h'' s) [b1, b2, b3]

469− h' s (ArrayBinder bs) = foldMap (h'' s) bs

542+ h' s (ParensInBinder b) = h'' s b

470− h' s (NamedBinder name b1) =

543+ h' s (NamedBinder name b1) = h'' (S.insert name s) b1

471− let s' = S.insert name s

472− in h'' s' b1

473 h' s (PositionedBinder _ _ b1) = h'' s b1

544 h' s (PositionedBinder _ _ b1) = h'' s b1

474 h' s (TypedBinder _ b1) = h'' s b1

545 h' s (TypedBinder _ b1) = h'' s b1

475 h' _ _ = mempty

546 h' _ _ = mempty

476

547

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

477 i'' s a = i s a <> i' s a

554 i'' s a = i s a <> i' s a

478

555

556+ i' :: S.Set Ident -> CaseAlternative -> r

479 i' s (CaseAlternative bs (Right val)) =

557 i' s (CaseAlternative bs (Right val)) =

480 let s' = S.union s (S.fromList (concatMap binderNames bs))

558 let s' = S.union s (S.fromList (concatMap binderNames bs))

481 in foldMap (h'' s) bs <> g'' s' val

559 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)

483 let s' = S.union s (S.fromList (concatMap binderNames bs))

561 let s' = S.union s (S.fromList (concatMap binderNames bs))

484 in foldMap (h'' s) bs <> foldMap (\(grd, val) -> g'' s' grd <> g'' s' val) gs

562 in foldMap (h'' s) bs <> foldMap (\(grd, val) -> g'' s' grd <> g'' s' val) gs

485

563

564+ j'' :: S.Set Ident -> DoNotationElement -> (S.Set Ident, r)

486 j'' s a = let (s', r) = j' s a in (s', j s a <> r)

565 j'' s a = let (s', r) = j' s a in (s', j s a <> r)

487

566

567+ j' :: S.Set Ident -> DoNotationElement -> (S.Set Ident, r)

488 j' s (DoNotationValue v) = (s, g'' s v)

568 j' s (DoNotationValue v) = (s, g'' s v)

489 j' s (DoNotationBind b v) =

569 j' s (DoNotationBind b v) =

490 let s' = S.union (S.fromList (binderNames b)) s

570 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)

500 getDeclIdent (TypeDeclaration ident _) = Just ident

580 getDeclIdent (TypeDeclaration ident _) = Just ident

501 getDeclIdent _ = Nothing

581 getDeclIdent _ = Nothing

502

582

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+ )

504accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (const mempty) (const mempty)

592accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (const mempty) (const mempty)

505 where

593 where

506 forDecls (DataDeclaration _ _ _ dctors) = mconcat (concatMap (map f . snd) dctors)

594 forDecls (DataDeclaration _ _ _ dctors) = mconcat (concatMap (map f . snd) dctors)

src/Language/PureScript/Bundle.hs+16−13

@@ -95,7 +95,7 @@ data ExportType

95-- Each is labelled with the original AST node which generated it, so that we can dump it back

96-- into the output during codegen.

97data ModuleElement

98− = Require JSNode String ModuleIdentifier

98+ = Require JSNode String (Either String ModuleIdentifier)

99 | Member JSNode Bool String [JSNode] [Key]

100 | ExportsList [(ExportType, String, JSNode, [Key])]

101 | Other JSNode

@@ -137,13 +137,13 @@ node (NN n) = n

137node (NT n _ _) = n

138

139-- | 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

141checkImportPath _ "./foreign" m _ =

142− Just (ModuleIdentifier (moduleName m) Foreign)

142+ Right (ModuleIdentifier (moduleName m) Foreign)

143checkImportPath requirePath name _ names

144 | Just name' <- stripPrefix (fromMaybe "" requirePath) name

145− , name' `S.member` names = Just (ModuleIdentifier name' Regular)

145+ , name' `S.member` names = Right (ModuleIdentifier name' Regular)

146−checkImportPath _ _ _ _ = Nothing

146+checkImportPath _ name _ _ = Left name

147

148-- | Compute the dependencies of all elements in a module, and add them to the tree.

149--

@@ -166,7 +166,7 @@ withDeps (Module modulePath es) = Module modulePath (map expandDeps es)

166 imports = mapMaybe toImport es

167 where

168 toImport :: ModuleElement -> Maybe (String, ModuleIdentifier)

169− toImport (Require _ nm mid) = Just (nm, mid)

169+ toImport (Require _ nm (Right mid)) = Just (nm, mid)

170 toImport _ = Nothing

171

172 -- | 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)

209--

210-- Each type of module element is matched using pattern guards, and everything else is bundled into the

211-- 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

213toModule requirePath mids mid top

214 | JSSourceElementsTop ns <- node top = Module mid <$> traverse toModuleElement ns

215 | otherwise = err InvalidTopLevel

@@ -226,7 +226,7 @@ toModule requirePath mids mid top

226 , JSIdentifier "require" <- node req

227 , JSArguments _ [ impS ] _ <- node impP

228 , JSStringLiteral _ importPath <- node impS

229− , Just importPath' <- checkImportPath requirePath importPath mid mids

229+ , importPath' <- checkImportPath requirePath importPath mid mids

230 = pure (Require n importName importPath')

231 toModuleElement n

232 | JSVariables var [ varIntro ] _ <- node n

@@ -371,7 +371,7 @@ sortModules modules = map (\v -> case nodeFor v of (n, _, _) -> n) (reverse (top

371 return (m, mid, mapMaybe getKey els)

372

373 getKey :: ModuleElement -> Maybe ModuleIdentifier

374− getKey (Require _ _ mi) = Just mi

374+ getKey (Require _ _ (Right mi)) = Just mi

375 getKey _ = Nothing

376

377-- | A module is empty if it contains no exported members (in other words,

@@ -416,9 +416,7 @@ codeGen optionsMainModule optionsNamespace ms = renderToString (NN (JSSourceElem

416 declToJS (Require _ nm req) =

417 [ NN (JSVariables (NT (JSLiteral "var") tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n " ])

418 [ NN (JSVarDecl (sp (JSIdentifier nm))

419− [ sp (JSLiteral "=")

420− , moduleReference sp (moduleName req)

419+ (sp (JSLiteral "=") : either require (return . moduleReference sp . moduleName) req))

421− ])

422 ]

420 ]

423 (nt (JSLiteral ";"))) ]

421 (nt (JSLiteral ";"))) ]

424 declToJS (ExportsList exps) = map toExport exps

422 declToJS (ExportsList exps) = map toExport exps

@@ -467,6 +465,11 @@ codeGen optionsMainModule optionsNamespace ms = renderToString (NN (JSSourceElem

467 , lf

465 , lf

468 ]

466 ]

469

467

468+ require :: String -> [JSNode]

469+ require mn = [ sp (JSIdentifier "require")

470+ , NN (JSArguments (nt (JSLiteral "(")) [ nt (JSStringLiteral '"' mn) ] (nt (JSLiteral ")")))

471+ ]

472+

470 moduleReference :: (Node -> JSNode) -> String -> JSNode

473 moduleReference :: (Node -> JSNode) -> String -> JSNode

471 moduleReference f mn =

474 moduleReference f mn =

472 NN (JSMemberSquare [ f (JSIdentifier optionsNamespace) ]

475 NN (JSMemberSquare [ f (JSIdentifier optionsNamespace) ]

@@ -530,7 +533,7 @@ codeGen optionsMainModule optionsNamespace ms = renderToString (NN (JSSourceElem

530-- | The bundling function.

533-- | The bundling function.

531-- This function performs dead code elimination, filters empty modules

534-- This function performs dead code elimination, filters empty modules

532-- and generates and prints the final Javascript bundle.

535-- and generates and prints the final Javascript bundle.

533−bundle :: (Applicative m, MonadError ErrorMessage m)

536+bundle :: (MonadError ErrorMessage m)

534 => [(ModuleIdentifier, String)] -- ^ The input modules. Each module should be javascript rendered from 'Language.PureScript.Make' or @psc@.

537 => [(ModuleIdentifier, String)] -- ^ The input modules. Each module should be javascript rendered from 'Language.PureScript.Make' or @psc@.

535 -> [ModuleIdentifier] -- ^ Entry points. These module identifiers are used as the roots for dead-code elimination

538 -> [ModuleIdentifier] -- ^ Entry points. These module identifiers are used as the roots for dead-code elimination

536 -> Maybe String -- ^ An optional main module.

539 -> Maybe String -- ^ An optional main module.

src/Language/PureScript/CodeGen/JS.hs+167−133

@@ -10,7 +10,6 @@ module Language.PureScript.CodeGen.JS

10 ( module AST

11 , module Common

12 , moduleToJs

13− , mainCall

14 ) where

13 ) where

15

14

16import Prelude ()

15import Prelude ()

@@ -19,10 +18,11 @@ import Prelude.Compat

19import Data.List ((\\), delete, intersect)

18import Data.List ((\\), delete, intersect)

20import Data.Maybe (isNothing, fromMaybe)

19import Data.Maybe (isNothing, fromMaybe)

21import qualified Data.Map as M

20import 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

23

24import Control.Arrow ((&&&))

25−import Control.Monad (replicateM, forM)

25+import Control.Monad (replicateM, forM, void)

26import Control.Monad.Error.Class (MonadError(..))

27import Control.Monad.Reader (MonadReader, asks)

28import Control.Monad.Supply.Class

@@ -45,26 +45,31 @@ import System.FilePath.Posix ((</>))

45-- Generate code in the simplified Javascript intermediate representation for all declarations in a

46-- module.

47--

48+moduleToJs

49+ :: forall m

48−moduleToJs :: forall m. (Applicative m, Monad m, MonadReader Options m, MonadSupply m, MonadError MultipleErrors m)

50+ . (Monad m, MonadReader Options m, MonadSupply m, MonadError MultipleErrors m)

49− => Module Ann -> Maybe JS -> m [JS]

51+ => Module Ann

52+ -> Maybe JS

53+ -> m [JS]

50moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =

54moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =

51 rethrow (addHint (ErrorInModule mn)) $ do

55 rethrow (addHint (ErrorInModule mn)) $ do

52 let usedNames = concatMap getNames decls

56 let usedNames = concatMap getNames decls

53 let mnLookup = renameImports usedNames imps

57 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

55 let decls' = renameModules mnLookup decls

59 let decls' = renameModules mnLookup decls

56 jsDecls <- mapM bindToJs decls'

60 jsDecls <- mapM bindToJs decls'

57 optimized <- T.traverse (T.traverse optimize) jsDecls

61 optimized <- T.traverse (T.traverse optimize) jsDecls

62+ F.traverse_ (F.traverse_ checkIntegers) optimized

58 comments <- not <$> asks optionsNoComments

63 comments <- not <$> asks optionsNoComments

59− let strict = JSStringLiteral "use strict"

64+ let strict = JSStringLiteral Nothing "use strict"

60− let header = if comments && not (null coms) then JSComment coms strict else strict

65+ let header = if comments && not (null coms) then JSComment Nothing coms strict else strict

61− let foreign' = [JSVariableIntroduction "$foreign" foreign_ | not $ null foreigns || isNothing foreign_]

66+ let foreign' = [JSVariableIntroduction Nothing "$foreign" foreign_ | not $ null foreigns || isNothing foreign_]

62 let moduleBody = header : foreign' ++ jsImports ++ concat optimized

67 let moduleBody = header : foreign' ++ jsImports ++ concat optimized

63 let foreignExps = exps `intersect` (fst `map` foreigns)

68 let foreignExps = exps `intersect` (fst `map` foreigns)

64 let standardExps = exps \\ foreignExps

69 let standardExps = exps \\ foreignExps

65− let exps' = JSObjectLiteral $ map (runIdent &&& JSVar . identToJs) standardExps

70+ let exps' = JSObjectLiteral Nothing $ map (runIdent &&& (JSVar Nothing) . identToJs) standardExps

66 ++ map (runIdent &&& foreignIdent) foreignExps

71 ++ 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']

68

73

69 where

74 where

70

75

@@ -72,23 +77,23 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =

72 -- Extracts all declaration names from a binding group.

77 -- Extracts all declaration names from a binding group.

73 --

78 --

74 getNames :: Bind Ann -> [Ident]

79 getNames :: Bind Ann -> [Ident]

75− getNames (NonRec ident _) = [ident]

80+ getNames (NonRec _ ident _) = [ident]

76− getNames (Rec vals) = map fst vals

81+ getNames (Rec vals) = map (snd . fst) vals

77

82

78 -- |

83 -- |

79 -- Creates alternative names for each module to ensure they don't collide

84 -- Creates alternative names for each module to ensure they don't collide

80 -- with declaration names.

85 -- with declaration names.

81 --

86 --

82− renameImports :: [Ident] -> [ModuleName] -> M.Map ModuleName ModuleName

87+ renameImports :: [Ident] -> [(Ann, ModuleName)] -> M.Map ModuleName (Ann, ModuleName)

83 renameImports ids mns = go M.empty ids mns

88 renameImports ids mns = go M.empty ids mns

84 where

89 where

85− go :: M.Map ModuleName ModuleName -> [Ident] -> [ModuleName] -> M.Map ModuleName ModuleName

90+ go :: M.Map ModuleName (Ann, ModuleName) -> [Ident] -> [(Ann, ModuleName)] -> M.Map ModuleName (Ann, ModuleName)

86− go acc used (mn' : mns') =

91+ go acc used ((ann, mn') : mns') =

87 let mni = Ident $ runModuleName mn'

92 let mni = Ident $ runModuleName mn'

88− in if mni `elem` used

93+ in if mn' /= mn && mni `elem` used

89 then let newName = freshModuleName 1 mn' used

94 then let newName = freshModuleName 1 mn' used

90− in go (M.insert mn' newName acc) (Ident (runModuleName newName) : used) mns'

95+ in go (M.insert mn' (ann, newName) acc) (Ident (runModuleName newName) : used) mns'

91− else go (M.insert mn' mn' acc) (mni : used) mns'

96+ else go (M.insert mn' (ann, mn') acc) (mni : used) mns'

92 go acc _ [] = acc

97 go acc _ [] = acc

93

98

94 freshModuleName :: Integer -> ModuleName -> [Ident] -> ModuleName

99 freshModuleName :: Integer -> ModuleName -> [Ident] -> ModuleName

@@ -102,18 +107,18 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =

102 -- Generates Javascript code for a module import, binding the required module

107 -- Generates Javascript code for a module import, binding the required module

103 -- to the alternative

108 -- to the alternative

104 --

109 --

105− importToJs :: M.Map ModuleName ModuleName -> ModuleName -> m JS

110+ importToJs :: M.Map ModuleName (Ann, ModuleName) -> ModuleName -> m JS

106 importToJs mnLookup mn' = do

111 importToJs mnLookup mn' = do

107 path <- asks optionsRequirePath

112 path <- asks optionsRequirePath

108− let mnSafe = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup

113+ let ((ss, _, _, _), mnSafe) = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup

109− let moduleBody = JSApp (JSVar "require") [JSStringLiteral (maybe id (</>) path $ runModuleName mn')]

114+ let moduleBody = JSApp Nothing (JSVar Nothing "require") [JSStringLiteral Nothing (maybe id (</>) path $ runModuleName mn')]

110− return $ JSVariableIntroduction (moduleNameToJs mnSafe) (Just moduleBody)

115+ withPos ss $ JSVariableIntroduction Nothing (moduleNameToJs mnSafe) (Just moduleBody)

111

116

112 -- |

117 -- |

113 -- Replaces the `ModuleName`s in the AST so that the generated code refers to

118 -- Replaces the `ModuleName`s in the AST so that the generated code refers to

114 -- the collision-avoiding renamed module imports.

119 -- the collision-avoiding renamed module imports.

115 --

120 --

116− renameModules :: M.Map ModuleName ModuleName -> [Bind Ann] -> [Bind Ann]

121+ renameModules :: M.Map ModuleName (Ann, ModuleName) -> [Bind Ann] -> [Bind Ann]

117 renameModules mnLookup binds =

122 renameModules mnLookup binds =

118 let (f, _, _) = everywhereOnValues id goExpr goBinder

123 let (f, _, _) = everywhereOnValues id goExpr goBinder

119 in map f binds

124 in map f binds

@@ -126,7 +131,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =

126 goBinder b = b

131 goBinder b = b

127 renameQual :: Qualified a -> Qualified a

132 renameQual :: Qualified a -> Qualified a

128 renameQual (Qualified (Just mn') a) =

133 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

130 in Qualified (Just mnSafe) a

135 in Qualified (Just mnSafe) a

131 renameQual q = q

136 renameQual q = q

132

137

@@ -134,8 +139,8 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =

134 -- Generate code in the simplified Javascript intermediate representation for a declaration

139 -- Generate code in the simplified Javascript intermediate representation for a declaration

135 --

140 --

136 bindToJs :: Bind Ann -> m [JS]

141 bindToJs :: Bind Ann -> m [JS]

137− bindToJs (NonRec ident val) = return <$> nonRecToJS ident val

142+ bindToJs (NonRec ann ident val) = return <$> nonRecToJS ann ident val

138− bindToJs (Rec vals) = forM vals (uncurry nonRecToJS)

143+ bindToJs (Rec vals) = forM vals (uncurry . uncurry $ nonRecToJS)

139

144

140 -- |

145 -- |

141 -- Generate code in the simplified Javascript intermediate representation for a single non-recursive

146 -- 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_ =

143 --

148 --

144 -- The main purpose of this function is to handle code generation for comments.

149 -- The main purpose of this function is to handle code generation for comments.

145 --

150 --

146− nonRecToJS :: Ident -> Expr Ann -> m JS

151+ nonRecToJS :: Ann -> Ident -> Expr Ann -> m JS

147− nonRecToJS i e@(extractAnn -> (_, com, _, _)) | not (null com) = do

152+ nonRecToJS a i e@(extractAnn -> (_, com, _, _)) | not (null com) = do

148 withoutComment <- asks optionsNoComments

153 withoutComment <- asks optionsNoComments

149 if withoutComment

154 if withoutComment

150− then nonRecToJS i (modifyAnn removeComments e)

155+ then nonRecToJS a i (modifyAnn removeComments e)

151− else JSComment com <$> nonRecToJS i (modifyAnn removeComments e)

156+ else JSComment Nothing com <$> nonRecToJS a i (modifyAnn removeComments e)

152− nonRecToJS ident val = do

157+ nonRecToJS (ss, _, _, _) ident val = do

153 js <- valueToJs val

158 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

155

168

156 -- |

169 -- |

157 -- Generate code in the simplified Javascript intermediate representation for a variable based on a

170 -- Generate code in the simplified Javascript intermediate representation for a variable based on a

158 -- PureScript identifier.

171 -- PureScript identifier.

159 --

172 --

160 var :: Ident -> JS

173 var :: Ident -> JS

161− var = JSVar . identToJs

174+ var = JSVar Nothing . identToJs

162

175

163 -- |

176 -- |

164 -- Generate code in the simplified Javascript intermediate representation for an accessor based on

177 -- 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_ =

167 --

180 --

168 accessor :: Ident -> JS -> JS

181 accessor :: Ident -> JS -> JS

169 accessor (Ident prop) = accessorString prop

182 accessor (Ident prop) = accessorString prop

170− accessor (Op op) = JSIndexer (JSStringLiteral op)

183+ accessor (Op op) = JSIndexer Nothing (JSStringLiteral Nothing op)

171 accessor (GenIdent _ _) = internalError "GenIdent in accessor"

184 accessor (GenIdent _ _) = internalError "GenIdent in accessor"

172

185

173 accessorString :: String -> JS -> JS

186 accessorString :: String -> JS -> JS

174− accessorString prop | identNeedsEscaping prop = JSIndexer (JSStringLiteral prop)

187+ accessorString prop | identNeedsEscaping prop = JSIndexer Nothing (JSStringLiteral Nothing prop)

175− | otherwise = JSAccessor prop

188+ | otherwise = JSAccessor Nothing prop

176

189

177 -- |

190 -- |

178 -- Generate code in the simplified Javascript intermediate representation for a value or expression.

191 -- Generate code in the simplified Javascript intermediate representation for a value or expression.

179 --

192 --

180 valueToJs :: Expr Ann -> m JS

193 valueToJs :: Expr Ann -> m JS

194+ valueToJs e =

195+ let (ss, _, _, _) = extractAnn e in

196+ withPos ss =<< valueToJs' e

197+

198+ valueToJs' :: Expr Ann -> m JS

181− valueToJs (Literal (pos, _, _, _) l) =

199+ valueToJs' (Literal (pos, _, _, _) l) =

182 maybe id rethrowWithPosition pos $ literalToValueJS l

200 maybe id rethrowWithPosition pos $ literalToValueJS l

183− valueToJs (Var (_, _, _, Just (IsConstructor _ [])) name) =

201+ valueToJs' (Var (_, _, _, Just (IsConstructor _ [])) name) =

184− return $ JSAccessor "value" $ qualifiedToJS id name

202+ return $ JSAccessor Nothing "value" $ qualifiedToJS id name

185− valueToJs (Var (_, _, _, Just (IsConstructor _ _)) name) =

203+ valueToJs' (Var (_, _, _, Just (IsConstructor _ _)) name) =

186− return $ JSAccessor "create" $ qualifiedToJS id name

204+ return $ JSAccessor Nothing "create" $ qualifiedToJS id name

187− valueToJs (Accessor _ prop val) =

205+ valueToJs' (Accessor _ prop val) =

188 accessorString prop <$> valueToJs val

206 accessorString prop <$> valueToJs val

189− valueToJs (ObjectUpdate _ o ps) = do

207+ valueToJs' (ObjectUpdate _ o ps) = do

190 obj <- valueToJs o

208 obj <- valueToJs o

191 sts <- mapM (sndM valueToJs) ps

209 sts <- mapM (sndM valueToJs) ps

192 extendObj obj sts

210 extendObj obj sts

193− valueToJs e@(Abs (_, _, _, Just IsTypeClassConstructor) _ _) =

211+ valueToJs' e@(Abs (_, _, _, Just IsTypeClassConstructor) _ _) =

194 let args = unAbs e

212 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)

196 where

214 where

197 unAbs :: Expr Ann -> [Ident]

215 unAbs :: Expr Ann -> [Ident]

198 unAbs (Abs _ arg val) = arg : unAbs val

216 unAbs (Abs _ arg val) = arg : unAbs val

199 unAbs _ = []

217 unAbs _ = []

200 assign :: Ident -> JS

218 assign :: Ident -> JS

201− assign name = JSAssignment (accessorString (runIdent name) (JSVar "this"))

219+ assign name = JSAssignment Nothing (accessorString (runIdent name) (JSVar Nothing "this"))

202 (var name)

220 (var name)

203− valueToJs (Abs _ arg val) = do

221+ valueToJs' (Abs _ arg val) = do

204 ret <- valueToJs val

222 ret <- valueToJs val

205− return $ JSFunction Nothing [identToJs arg] (JSBlock [JSReturn ret])

223+ return $ JSFunction Nothing Nothing [identToJs arg] (JSBlock Nothing [JSReturn Nothing ret])

206− valueToJs e@App{} = do

224+ valueToJs' e@App{} = do

207 let (f, args) = unApp e []

225 let (f, args) = unApp e []

208 args' <- mapM valueToJs args

226 args' <- mapM valueToJs args

209 case f of

227 case f of

210 Var (_, _, _, Just IsNewtype) _ -> return (head args')

228 Var (_, _, _, Just IsNewtype) _ -> return (head args')

211 Var (_, _, _, Just (IsConstructor _ fields)) name | length args == length fields ->

229 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'

213 Var (_, _, _, Just IsTypeClassConstructor) name ->

231 Var (_, _, _, Just IsTypeClassConstructor) name ->

214− return $ JSUnary JSNew $ JSApp (qualifiedToJS id name) args'

232+ return $ JSUnary Nothing JSNew $ JSApp Nothing (qualifiedToJS id name) args'

215− _ -> flip (foldl (\fn a -> JSApp fn [a])) args' <$> valueToJs f

233+ _ -> flip (foldl (\fn a -> JSApp Nothing fn [a])) args' <$> valueToJs f

216 where

234 where

217 unApp :: Expr Ann -> [Expr Ann] -> (Expr Ann, [Expr Ann])

235 unApp :: Expr Ann -> [Expr Ann] -> (Expr Ann, [Expr Ann])

218 unApp (App _ val arg) args = unApp val (arg : args)

236 unApp (App _ val arg) args = unApp val (arg : args)

219 unApp other args = (other, args)

237 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)) =

221 return $ if mn' == mn

239 return $ if mn' == mn

222 then foreignIdent ident

240 then foreignIdent ident

223 else varToJs qi

241 else varToJs qi

224− valueToJs (Var (_, _, _, Just IsForeign) ident) =

242+ valueToJs' (Var (_, _, _, Just IsForeign) ident) =

225 error $ "Encountered an unqualified reference to a foreign ident " ++ showQualified showIdent ident

243 error $ "Encountered an unqualified reference to a foreign ident " ++ showQualified showIdent ident

226− valueToJs (Var _ ident) =

244+ valueToJs' (Var _ ident) = return $ varToJs ident

227− return $ varToJs ident

228− valueToJs (Case (maybeSpan, _, _, _) values binders) = do

245+ valueToJs' (Case (maybeSpan, _, _, _) values binders) = do

229 vals <- mapM valueToJs values

246 vals <- mapM valueToJs values

230 bindersToJs maybeSpan binders vals

247 bindersToJs maybeSpan binders vals

231− valueToJs (Let _ ds val) = do

248+ valueToJs' (Let _ ds val) = do

232 ds' <- concat <$> mapM bindToJs ds

249 ds' <- concat <$> mapM bindToJs ds

233 ret <- valueToJs val

250 ret <- valueToJs val

234− return $ JSApp (JSFunction Nothing [] (JSBlock (ds' ++ [JSReturn ret]))) []

251+ return $ JSApp Nothing (JSFunction Nothing Nothing [] (JSBlock Nothing (ds' ++ [JSReturn Nothing ret]))) []

235− valueToJs (Constructor (_, _, _, Just IsNewtype) _ (ProperName ctor) _) =

252+ valueToJs' (Constructor (_, _, _, Just IsNewtype) _ (ProperName ctor) _) =

236− return $ JSVariableIntroduction ctor (Just $

253+ return $ JSVariableIntroduction Nothing ctor (Just $

237− JSObjectLiteral [("create",

254+ JSObjectLiteral Nothing [("create",

238− JSFunction Nothing ["value"]

255+ JSFunction Nothing Nothing ["value"]

239− (JSBlock [JSReturn $ JSVar "value"]))])

256+ (JSBlock Nothing [JSReturn Nothing $ JSVar Nothing "value"]))])

240− valueToJs (Constructor _ _ (ProperName ctor) []) =

257+ valueToJs' (Constructor _ _ (ProperName ctor) []) =

241− return $ iife ctor [ JSFunction (Just ctor) [] (JSBlock [])

258+ return $ iife ctor [ JSFunction Nothing (Just ctor) [] (JSBlock Nothing [])

242− , JSAssignment (JSAccessor "value" (JSVar ctor))

259+ , JSAssignment Nothing (JSAccessor Nothing "value" (JSVar Nothing ctor))

243− (JSUnary JSNew $ JSApp (JSVar ctor) []) ]

260+ (JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing ctor) []) ]

244− valueToJs (Constructor _ _ (ProperName ctor) fields) =

261+ valueToJs' (Constructor _ _ (ProperName ctor) fields) =

245 let constructor =

262 let constructor =

246− let body = [ JSAssignment (JSAccessor (identToJs f) (JSVar "this")) (var f) | f <- fields ]

263+ let body = [ JSAssignment Nothing (JSAccessor Nothing (identToJs f) (JSVar Nothing "this")) (var f) | f <- fields ]

247− in JSFunction (Just ctor) (identToJs `map` fields) (JSBlock body)

264+ in JSFunction Nothing (Just ctor) (identToJs `map` fields) (JSBlock Nothing body)

248 createFn =

265 createFn =

249− let body = JSUnary JSNew $ JSApp (JSVar ctor) (var `map` fields)

266+ let body = JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing ctor) (var `map` fields)

250− in foldr (\f inner -> JSFunction Nothing [identToJs f] (JSBlock [JSReturn inner])) body fields

267+ in foldr (\f inner -> JSFunction Nothing Nothing [identToJs f] (JSBlock Nothing [JSReturn Nothing inner])) body fields

251 in return $ iife ctor [ constructor

268 in return $ iife ctor [ constructor

252− , JSAssignment (JSAccessor "create" (JSVar ctor)) createFn

269+ , JSAssignment Nothing (JSAccessor Nothing "create" (JSVar Nothing ctor)) createFn

253 ]

270 ]

254

271

255 iife :: String -> [JS] -> JS

272 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])) []

257

274

258 literalToValueJS :: Literal (Expr Ann) -> m JS

275 literalToValueJS :: Literal (Expr Ann) -> m JS

259− literalToValueJS (NumericLiteral (Left i)) =

276+ literalToValueJS (NumericLiteral (Left i)) = return $ JSNumericLiteral Nothing (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)

277+ literalToValueJS (NumericLiteral (Right n)) = return $ JSNumericLiteral Nothing (Right n)

266− literalToValueJS (StringLiteral s) = return $ JSStringLiteral s

278+ literalToValueJS (StringLiteral s) = return $ JSStringLiteral Nothing s

267− literalToValueJS (CharLiteral c) = return $ JSStringLiteral [c]

279+ literalToValueJS (CharLiteral c) = return $ JSStringLiteral Nothing [c]

268− literalToValueJS (BooleanLiteral b) = return $ JSBooleanLiteral b

280+ literalToValueJS (BooleanLiteral b) = return $ JSBooleanLiteral Nothing b

269− literalToValueJS (ArrayLiteral xs) = JSArrayLiteral <$> mapM valueToJs xs

281+ literalToValueJS (ArrayLiteral xs) = JSArrayLiteral Nothing <$> mapM valueToJs xs

270− literalToValueJS (ObjectLiteral ps) = JSObjectLiteral <$> mapM (sndM valueToJs) ps

282+ literalToValueJS (ObjectLiteral ps) = JSObjectLiteral Nothing <$> mapM (sndM valueToJs) ps

271

283

272 -- |

284 -- |

273 -- Shallow copy an object.

285 -- Shallow copy an object.

@@ -277,16 +289,16 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =

277 newObj <- freshName

289 newObj <- freshName

278 key <- freshName

290 key <- freshName

279 let

291 let

280− jsKey = JSVar key

292+ jsKey = JSVar Nothing key

281− jsNewObj = JSVar newObj

293+ jsNewObj = JSVar Nothing newObj

282− block = JSBlock (objAssign:copy:extend ++ [JSReturn jsNewObj])

294+ block = JSBlock Nothing (objAssign:copy:extend ++ [JSReturn Nothing jsNewObj])

283− objAssign = JSVariableIntroduction newObj (Just $ JSObjectLiteral [])

295+ objAssign = JSVariableIntroduction Nothing newObj (Just $ JSObjectLiteral Nothing [])

284− copy = JSForIn key obj $ JSBlock [JSIfElse cond assign Nothing]

296+ copy = JSForIn Nothing key obj $ JSBlock Nothing [JSIfElse Nothing cond assign Nothing]

285− cond = JSApp (JSAccessor "hasOwnProperty" obj) [jsKey]

297+ cond = JSApp Nothing (JSAccessor Nothing "hasOwnProperty" obj) [jsKey]

286− assign = JSBlock [JSAssignment (JSIndexer jsKey jsNewObj) (JSIndexer jsKey obj)]

298+ assign = JSBlock Nothing [JSAssignment Nothing (JSIndexer Nothing jsKey jsNewObj) (JSIndexer Nothing jsKey obj)]

287− stToAssign (s, js) = JSAssignment (JSAccessor s jsNewObj) js

299+ stToAssign (s, js) = JSAssignment Nothing (JSAccessor Nothing s jsNewObj) js

288 extend = map stToAssign sts

300 extend = map stToAssign sts

289− return $ JSApp (JSFunction Nothing [] block) []

301+ return $ JSApp Nothing (JSFunction Nothing Nothing [] block) []

290

302

291 -- |

303 -- |

292 -- Generate code in the simplified Javascript intermediate representation for a reference to a

304 -- 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_ =

301 -- variable that may have a qualified name.

313 -- variable that may have a qualified name.

302 --

314 --

303 qualifiedToJS :: (a -> Ident) -> Qualified a -> JS

315 qualifiedToJS :: (a -> Ident) -> Qualified a -> JS

304− qualifiedToJS f (Qualified (Just (ModuleName [ProperName mn'])) a) | mn' == C.prim = JSVar . runIdent $ f a

316+ qualifiedToJS f (Qualified (Just (ModuleName [ProperName mn'])) a) | mn' == C.prim = JSVar Nothing . runIdent $ f a

305− qualifiedToJS f (Qualified (Just mn') a) | mn /= mn' = accessor (f a) (JSVar (moduleNameToJs mn'))

317+ qualifiedToJS f (Qualified (Just mn') a) | mn /= mn' = accessor (f a) (JSVar Nothing (moduleNameToJs mn'))

306− qualifiedToJS f (Qualified _ a) = JSVar $ identToJs (f a)

318+ qualifiedToJS f (Qualified _ a) = JSVar Nothing $ identToJs (f a)

307

319

308 foreignIdent :: Ident -> JS

320 foreignIdent :: Ident -> JS

309− foreignIdent ident = accessorString (runIdent ident) (JSVar "$foreign")

321+ foreignIdent ident = accessorString (runIdent ident) (JSVar Nothing "$foreign")

310

322

311 -- |

323 -- |

312 -- Generate code in the simplified Javascript intermediate representation for pattern match binders

324 -- 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_ =

315 bindersToJs :: Maybe SourceSpan -> [CaseAlternative Ann] -> [JS] -> m JS

327 bindersToJs :: Maybe SourceSpan -> [CaseAlternative Ann] -> [JS] -> m JS

316 bindersToJs maybeSpan binders vals = do

328 bindersToJs maybeSpan binders vals = do

317 valNames <- replicateM (length vals) freshName

329 valNames <- replicateM (length vals) freshName

318− let assignments = zipWith JSVariableIntroduction valNames (map Just vals)

330+ let assignments = zipWith (JSVariableIntroduction Nothing) valNames (map Just vals)

319 jss <- forM binders $ \(CaseAlternative bs result) -> do

331 jss <- forM binders $ \(CaseAlternative bs result) -> do

320 ret <- guardsToJs result

332 ret <- guardsToJs result

321 go valNames ret bs

333 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])))

323 []

335 []

324 where

336 where

325 go :: [String] -> [JS] -> [Binder Ann] -> m [JS]

337 go :: [String] -> [JS] -> [Binder Ann] -> m [JS]

@@ -330,43 +342,48 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =

330 go _ _ _ = internalError "Invalid arguments to bindersToJs"

342 go _ _ _ = internalError "Invalid arguments to bindersToJs"

331

343

332 failedPatternError :: [String] -> JS

344 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)]

334

346

335 failedPatternMessage :: String

347 failedPatternMessage :: String

336 failedPatternMessage = "Failed pattern match" ++ maybe "" (((" at " ++ runModuleName mn ++ " ") ++) . displayStartEndPos) maybeSpan ++ ": "

348 failedPatternMessage = "Failed pattern match" ++ maybe "" (((" at " ++ runModuleName mn ++ " ") ++) . displayStartEndPos) maybeSpan ++ ": "

337

349

338 valueError :: String -> JS -> JS

350 valueError :: String -> JS -> JS

339− valueError _ l@(JSNumericLiteral _) = l

351+ valueError _ l@(JSNumericLiteral _ _) = l

340− valueError _ l@(JSStringLiteral _) = l

352+ valueError _ l@(JSStringLiteral _ _) = l

341− valueError _ l@(JSBooleanLiteral _) = l

353+ valueError _ l@(JSBooleanLiteral _ _) = l

342− valueError s _ = JSAccessor "name" . JSAccessor "constructor" $ JSVar s

354+ valueError s _ = JSAccessor Nothing "name" . JSAccessor Nothing "constructor" $ JSVar Nothing s

343

355

344 guardsToJs :: Either [(Guard Ann, Expr Ann)] (Expr Ann) -> m [JS]

356 guardsToJs :: Either [(Guard Ann, Expr Ann)] (Expr Ann) -> m [JS]

345 guardsToJs (Left gs) = forM gs $ \(cond, val) -> do

357 guardsToJs (Left gs) = forM gs $ \(cond, val) -> do

346 cond' <- valueToJs cond

358 cond' <- valueToJs cond

347 done <- valueToJs val

359 done <- valueToJs val

348− return $ JSIfElse cond' (JSBlock [JSReturn done]) Nothing

360+ return $ JSIfElse Nothing cond' (JSBlock Nothing [JSReturn Nothing done]) Nothing

349− guardsToJs (Right v) = return . JSReturn <$> valueToJs v

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

350

367

351 -- |

368 -- |

352 -- Generate code in the simplified Javascript intermediate representation for a pattern match

369 -- Generate code in the simplified Javascript intermediate representation for a pattern match

353 -- binder.

370 -- binder.

354 --

371 --

355− binderToJs :: String -> [JS] -> Binder Ann -> m [JS]

372+ binderToJs' :: String -> [JS] -> Binder Ann -> m [JS]

356− binderToJs _ done (NullBinder{}) = return done

373+ binderToJs' _ done (NullBinder{}) = return done

357− binderToJs varName done (LiteralBinder _ l) =

374+ binderToJs' varName done (LiteralBinder _ l) =

358 literalToBinderJS varName done l

375 literalToBinderJS varName done l

359− binderToJs varName done (VarBinder _ ident) =

376+ binderToJs' varName done (VarBinder _ ident) =

360− return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : done)

377+ return (JSVariableIntroduction Nothing (identToJs ident) (Just (JSVar Nothing varName)) : done)

361− binderToJs varName done (ConstructorBinder (_, _, _, Just IsNewtype) _ _ [b]) =

378+ binderToJs' varName done (ConstructorBinder (_, _, _, Just IsNewtype) _ _ [b]) =

362 binderToJs varName done b

379 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

364 js <- go (zip fields bs) done

381 js <- go (zip fields bs) done

365 return $ case ctorType of

382 return $ case ctorType of

366 ProductType -> js

383 ProductType -> js

367 SumType ->

384 SumType ->

368− [JSIfElse (JSInstanceOf (JSVar varName) (qualifiedToJS (Ident . runProperName) ctor))

385+ [JSIfElse Nothing (JSInstanceOf Nothing (JSVar Nothing varName) (qualifiedToJS (Ident . runProperName) ctor))

369− (JSBlock js)

386+ (JSBlock Nothing js)

370 Nothing]

387 Nothing]

371 where

388 where

372 go :: [(Ident, Binder Ann)] -> [JS] -> m [JS]

389 go :: [(Ident, Binder Ann)] -> [JS] -> m [JS]

@@ -375,24 +392,24 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =

375 argVar <- freshName

392 argVar <- freshName

376 done'' <- go remain done'

393 done'' <- go remain done'

377 js <- binderToJs argVar done'' binder

394 js <- binderToJs argVar done'' binder

378− return (JSVariableIntroduction argVar (Just (JSAccessor (identToJs field) (JSVar varName))) : js)

395+ return (JSVariableIntroduction Nothing argVar (Just (JSAccessor Nothing (identToJs field) (JSVar Nothing varName))) : js)

379− binderToJs _ _ ConstructorBinder{} =

396+ binderToJs' _ _ ConstructorBinder{} =

380 internalError "binderToJs: Invalid ConstructorBinder in binderToJs"

397 internalError "binderToJs: Invalid ConstructorBinder in binderToJs"

381− binderToJs varName done (NamedBinder _ ident binder) = do

398+ binderToJs' varName done (NamedBinder _ ident binder) = do

382 js <- binderToJs varName done binder

399 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)

384

401

385 literalToBinderJS :: String -> [JS] -> Literal (Binder Ann) -> m [JS]

402 literalToBinderJS :: String -> [JS] -> Literal (Binder Ann) -> m [JS]

386 literalToBinderJS varName done (NumericLiteral num) =

403 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]

388 literalToBinderJS varName done (CharLiteral c) =

405 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]

390 literalToBinderJS varName done (StringLiteral str) =

407 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]

392 literalToBinderJS varName done (BooleanLiteral True) =

409 literalToBinderJS varName done (BooleanLiteral True) =

393− return [JSIfElse (JSVar varName) (JSBlock done) Nothing]

410+ return [JSIfElse Nothing (JSVar Nothing varName) (JSBlock Nothing done) Nothing]

394 literalToBinderJS varName done (BooleanLiteral False) =

411 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]

396 literalToBinderJS varName done (ObjectLiteral bs) = go done bs

413 literalToBinderJS varName done (ObjectLiteral bs) = go done bs

397 where

414 where

398 go :: [JS] -> [(String, Binder Ann)] -> m [JS]

415 go :: [JS] -> [(String, Binder Ann)] -> m [JS]

@@ -401,10 +418,10 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =

401 propVar <- freshName

418 propVar <- freshName

402 done'' <- go done' bs'

419 done'' <- go done' bs'

403 js <- binderToJs propVar done'' binder

420 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)

405 literalToBinderJS varName done (ArrayLiteral bs) = do

422 literalToBinderJS varName done (ArrayLiteral bs) = do

406 js <- go done 0 bs

423 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]

408 where

425 where

409 go :: [JS] -> Integer -> [Binder Ann] -> m [JS]

426 go :: [JS] -> Integer -> [Binder Ann] -> m [JS]

410 go done' _ [] = return done'

427 go done' _ [] = return done'

@@ -412,7 +429,24 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =

412 elVar <- freshName

429 elVar <- freshName

413 done'' <- go done' (index + 1) bs'

430 done'' <- go done' (index + 1) bs'

414 js <- binderToJs elVar done'' binder

431 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)

416

433

417−mainCall :: ModuleName -> String -> JS

434+ -- Check that all integers fall within the valid int range for JavaScript.

418−mainCall mmi ns = JSApp (JSAccessor C.main (JSAccessor (moduleNameToJs mmi) (JSVar ns))) []

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−--

11-- |

1-- |

12-- Data types for the intermediate simplified-Javascript AST

2-- Data types for the intermediate simplified-Javascript AST

13--

3--

14−-----------------------------------------------------------------------------

15−

16−{-# LANGUAGE DeriveDataTypeable #-}

17−

18module Language.PureScript.CodeGen.JS.AST where

4module Language.PureScript.CodeGen.JS.AST where

19

5

20import Prelude ()

6import Prelude ()

21import Prelude.Compat

7import Prelude.Compat

22

8

23import Control.Monad.Identity

9import Control.Monad.Identity

24−import Data.Data

25

10

26import Language.PureScript.Comments

11import Language.PureScript.Comments

27import Language.PureScript.Traversals

12import Language.PureScript.Traversals

13+import Language.PureScript.AST (SourceSpan(..))

28

14

29-- |

15-- |

30-- Built-in unary operators

16-- Built-in unary operators

@@ -49,7 +35,8 @@ data UnaryOperator

49 -- |

35 -- |

50 -- Constructor

36 -- Constructor

51 --

37 --

38+ | JSNew

52− | JSNew deriving (Show, Read, Eq, Data, Typeable)

39+ deriving (Show, Read, Eq)

53

40

54-- |

41-- |

55-- Built-in binary operators

42-- Built-in binary operators

@@ -130,7 +117,8 @@ data BinaryOperator

130 -- |

117 -- |

131 -- Bitwise right shift with zero-fill

118 -- Bitwise right shift with zero-fill

132 --

119 --

133− | ZeroFillShiftRight deriving (Show, Read, Eq, Data, Typeable)

120+ | ZeroFillShiftRight

121+ deriving (Show, Read, Eq)

134

122

135-- |

123-- |

136-- Data type for simplified Javascript expressions

124-- Data type for simplified Javascript expressions

@@ -139,119 +127,190 @@ data JS

139 -- |

127 -- |

140 -- A numeric literal

128 -- A numeric literal

141 --

129 --

142− = JSNumericLiteral (Either Integer Double)

130+ = JSNumericLiteral (Maybe SourceSpan) (Either Integer Double)

143 -- |

131 -- |

144 -- A string literal

132 -- A string literal

145 --

133 --

146− | JSStringLiteral String

134+ | JSStringLiteral (Maybe SourceSpan) String

147 -- |

135 -- |

148 -- A boolean literal

136 -- A boolean literal

149 --

137 --

150− | JSBooleanLiteral Bool

138+ | JSBooleanLiteral (Maybe SourceSpan) Bool

151 -- |

139 -- |

152 -- A unary operator application

140 -- A unary operator application

153 --

141 --

154− | JSUnary UnaryOperator JS

142+ | JSUnary (Maybe SourceSpan) UnaryOperator JS

155 -- |

143 -- |

156 -- A binary operator application

144 -- A binary operator application

157 --

145 --

158− | JSBinary BinaryOperator JS JS

146+ | JSBinary (Maybe SourceSpan) BinaryOperator JS JS

159 -- |

147 -- |

160 -- An array literal

148 -- An array literal

161 --

149 --

162− | JSArrayLiteral [JS]

150+ | JSArrayLiteral (Maybe SourceSpan) [JS]

163 -- |

151 -- |

164 -- An array indexer expression

152 -- An array indexer expression

165 --

153 --

166− | JSIndexer JS JS

154+ | JSIndexer (Maybe SourceSpan) JS JS

167 -- |

155 -- |

168 -- An object literal

156 -- An object literal

169 --

157 --

170− | JSObjectLiteral [(String, JS)]

158+ | JSObjectLiteral (Maybe SourceSpan) [(String, JS)]

171 -- |

159 -- |

172 -- An object property accessor expression

160 -- An object property accessor expression

173 --

161 --

174− | JSAccessor String JS

162+ | JSAccessor (Maybe SourceSpan) String JS

175 -- |

163 -- |

176 -- A function introduction (optional name, arguments, body)

164 -- A function introduction (optional name, arguments, body)

177 --

165 --

178− | JSFunction (Maybe String) [String] JS

166+ | JSFunction (Maybe SourceSpan) (Maybe String) [String] JS

179 -- |

167 -- |

180 -- Function application

168 -- Function application

181 --

169 --

182− | JSApp JS [JS]

170+ | JSApp (Maybe SourceSpan) JS [JS]

183 -- |

171 -- |

184 -- Variable

172 -- Variable

185 --

173 --

186− | JSVar String

174+ | JSVar (Maybe SourceSpan) String

187 -- |

175 -- |

188 -- Conditional expression

176 -- Conditional expression

189 --

177 --

190− | JSConditional JS JS JS

178+ | JSConditional (Maybe SourceSpan) JS JS JS

191 -- |

179 -- |

192 -- A block of expressions in braces

180 -- A block of expressions in braces

193 --

181 --

194− | JSBlock [JS]

182+ | JSBlock (Maybe SourceSpan) [JS]

195 -- |

183 -- |

196 -- A variable introduction and optional initialization

184 -- A variable introduction and optional initialization

197 --

185 --

198− | JSVariableIntroduction String (Maybe JS)

186+ | JSVariableIntroduction (Maybe SourceSpan) String (Maybe JS)

199 -- |

187 -- |

200 -- A variable assignment

188 -- A variable assignment

201 --

189 --

202− | JSAssignment JS JS

190+ | JSAssignment (Maybe SourceSpan) JS JS

203 -- |

191 -- |

204 -- While loop

192 -- While loop

205 --

193 --

206− | JSWhile JS JS

194+ | JSWhile (Maybe SourceSpan) JS JS

207 -- |

195 -- |

208 -- For loop

196 -- For loop

209 --

197 --

210− | JSFor String JS JS JS

198+ | JSFor (Maybe SourceSpan) String JS JS JS

211 -- |

199 -- |

212 -- ForIn loop

200 -- ForIn loop

213 --

201 --

214− | JSForIn String JS JS

202+ | JSForIn (Maybe SourceSpan) String JS JS

215 -- |

203 -- |

216 -- If-then-else statement

204 -- If-then-else statement

217 --

205 --

218− | JSIfElse JS JS (Maybe JS)

206+ | JSIfElse (Maybe SourceSpan) JS JS (Maybe JS)

219 -- |

207 -- |

220 -- Return statement

208 -- Return statement

221 --

209 --

222− | JSReturn JS

210+ | JSReturn (Maybe SourceSpan) JS

223 -- |

211 -- |

224 -- Throw statement

212 -- Throw statement

225 --

213 --

226− | JSThrow JS

214+ | JSThrow (Maybe SourceSpan) JS

227 -- |

215 -- |

228 -- Type-Of operator

216 -- Type-Of operator

229 --

217 --

230− | JSTypeOf JS

218+ | JSTypeOf (Maybe SourceSpan) JS

231 -- |

219 -- |

232 -- InstanceOf test

220 -- InstanceOf test

233 --

221 --

234− | JSInstanceOf JS JS

222+ | JSInstanceOf (Maybe SourceSpan) JS JS

235 -- |

223 -- |

236 -- Labelled statement

224 -- Labelled statement

237 --

225 --

238− | JSLabel String JS

226+ | JSLabel (Maybe SourceSpan) String JS

239 -- |

227 -- |

240 -- Break statement

228 -- Break statement

241 --

229 --

242− | JSBreak String

230+ | JSBreak (Maybe SourceSpan) String

243 -- |

231 -- |

244 -- Continue statement

232 -- Continue statement

245 --

233 --

246− | JSContinue String

234+ | JSContinue (Maybe SourceSpan) String

247 -- |

235 -- |

248 -- Raw Javascript (generated when parsing fails for an inline foreign import declaration)

236 -- Raw Javascript (generated when parsing fails for an inline foreign import declaration)

249 --

237 --

250− | JSRaw String

238+ | JSRaw (Maybe SourceSpan) String

251 -- |

239 -- |

252 -- Commented Javascript

240 -- Commented Javascript

253 --

241 --

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

255

314

256--

315--

257-- Traversals

316-- Traversals

@@ -261,85 +320,85 @@ everywhereOnJS :: (JS -> JS) -> JS -> JS

261everywhereOnJS f = go

320everywhereOnJS f = go

262 where

321 where

263 go :: JS -> JS

322 go :: JS -> JS

264− go (JSUnary op j) = f (JSUnary op (go j))

323+ go (JSUnary ss op j) = f (JSUnary ss op (go j))

265− go (JSBinary op j1 j2) = f (JSBinary op (go j1) (go j2))

324+ go (JSBinary ss op j1 j2) = f (JSBinary ss op (go j1) (go j2))

266− go (JSArrayLiteral js) = f (JSArrayLiteral (map go js))

325+ go (JSArrayLiteral ss js) = f (JSArrayLiteral ss (map go js))

267− go (JSIndexer j1 j2) = f (JSIndexer (go j1) (go j2))

326+ go (JSIndexer ss j1 j2) = f (JSIndexer ss (go j1) (go j2))

268− go (JSObjectLiteral js) = f (JSObjectLiteral (map (fmap go) js))

327+ go (JSObjectLiteral ss js) = f (JSObjectLiteral ss (map (fmap go) js))

269− go (JSAccessor prop j) = f (JSAccessor prop (go j))

328+ go (JSAccessor ss prop j) = f (JSAccessor ss prop (go j))

270− go (JSFunction name args j) = f (JSFunction name args (go j))

329+ go (JSFunction ss name args j) = f (JSFunction ss name args (go j))

271− go (JSApp j js) = f (JSApp (go j) (map go js))

330+ go (JSApp ss j js) = f (JSApp ss (go j) (map go js))

272− go (JSConditional j1 j2 j3) = f (JSConditional (go j1) (go j2) (go j3))

331+ go (JSConditional ss j1 j2 j3) = f (JSConditional ss (go j1) (go j2) (go j3))

273− go (JSBlock js) = f (JSBlock (map go js))

332+ go (JSBlock ss js) = f (JSBlock ss (map go js))

274− go (JSVariableIntroduction name j) = f (JSVariableIntroduction name (fmap go j))

333+ go (JSVariableIntroduction ss name j) = f (JSVariableIntroduction ss name (fmap go j))

275− go (JSAssignment j1 j2) = f (JSAssignment (go j1) (go j2))

334+ go (JSAssignment ss j1 j2) = f (JSAssignment ss (go j1) (go j2))

276− go (JSWhile j1 j2) = f (JSWhile (go j1) (go j2))

335+ go (JSWhile ss j1 j2) = f (JSWhile ss (go j1) (go j2))

277− go (JSFor name j1 j2 j3) = f (JSFor name (go j1) (go j2) (go j3))

336+ go (JSFor ss name j1 j2 j3) = f (JSFor ss name (go j1) (go j2) (go j3))

278− go (JSForIn name j1 j2) = f (JSForIn name (go j1) (go j2))

337+ go (JSForIn ss name j1 j2) = f (JSForIn ss name (go j1) (go j2))

279− go (JSIfElse j1 j2 j3) = f (JSIfElse (go j1) (go j2) (fmap go j3))

338+ go (JSIfElse ss j1 j2 j3) = f (JSIfElse ss (go j1) (go j2) (fmap go j3))

280− go (JSReturn js) = f (JSReturn (go js))

339+ go (JSReturn ss js) = f (JSReturn ss (go js))

281− go (JSThrow js) = f (JSThrow (go js))

340+ go (JSThrow ss js) = f (JSThrow ss (go js))

282− go (JSTypeOf js) = f (JSTypeOf (go js))

341+ go (JSTypeOf ss js) = f (JSTypeOf ss (go js))

283− go (JSLabel name js) = f (JSLabel name (go js))

342+ go (JSLabel ss name js) = f (JSLabel ss name (go js))

284− go (JSInstanceOf j1 j2) = f (JSInstanceOf (go j1) (go j2))

343+ go (JSInstanceOf ss j1 j2) = f (JSInstanceOf ss (go j1) (go j2))

285− go (JSComment com j) = f (JSComment com (go j))

344+ go (JSComment ss com j) = f (JSComment ss com (go j))

286 go other = f other

345 go other = f other

287

346

288everywhereOnJSTopDown :: (JS -> JS) -> JS -> JS

347everywhereOnJSTopDown :: (JS -> JS) -> JS -> JS

289everywhereOnJSTopDown f = runIdentity . everywhereOnJSTopDownM (Identity . f)

348everywhereOnJSTopDown f = runIdentity . everywhereOnJSTopDownM (Identity . f)

290

349

291−everywhereOnJSTopDownM :: (Applicative m, Monad m) => (JS -> m JS) -> JS -> m JS

350+everywhereOnJSTopDownM :: (Monad m) => (JS -> m JS) -> JS -> m JS

292everywhereOnJSTopDownM f = f >=> go

351everywhereOnJSTopDownM f = f >=> go

293 where

352 where

294 f' = f >=> go

353 f' = f >=> go

295− go (JSUnary op j) = JSUnary op <$> f' j

354+ go (JSUnary ss op j) = JSUnary ss op <$> f' j

296− go (JSBinary op j1 j2) = JSBinary op <$> f' j1 <*> f' j2

355+ go (JSBinary ss op j1 j2) = JSBinary ss op <$> f' j1 <*> f' j2

297− go (JSArrayLiteral js) = JSArrayLiteral <$> traverse f' js

356+ go (JSArrayLiteral ss js) = JSArrayLiteral ss <$> traverse f' js

298− go (JSIndexer j1 j2) = JSIndexer <$> f' j1 <*> f' j2

357+ go (JSIndexer ss j1 j2) = JSIndexer ss <$> f' j1 <*> f' j2

299− go (JSObjectLiteral js) = JSObjectLiteral <$> traverse (sndM f') js

358+ go (JSObjectLiteral ss js) = JSObjectLiteral ss <$> traverse (sndM f') js

300− go (JSAccessor prop j) = JSAccessor prop <$> f' j

359+ go (JSAccessor ss prop j) = JSAccessor ss prop <$> f' j

301− go (JSFunction name args j) = JSFunction name args <$> f' j

360+ go (JSFunction ss name args j) = JSFunction ss name args <$> f' j

302− go (JSApp j js) = JSApp <$> f' j <*> traverse f' js

361+ go (JSApp ss j js) = JSApp ss <$> f' j <*> traverse f' js

303− go (JSConditional j1 j2 j3) = JSConditional <$> f' j1 <*> f' j2 <*> f' j3

362+ go (JSConditional ss j1 j2 j3) = JSConditional ss <$> f' j1 <*> f' j2 <*> f' j3

304− go (JSBlock js) = JSBlock <$> traverse f' js

363+ go (JSBlock ss js) = JSBlock ss <$> traverse f' js

305− go (JSVariableIntroduction name j) = JSVariableIntroduction name <$> traverse f' j

364+ go (JSVariableIntroduction ss name j) = JSVariableIntroduction ss name <$> traverse f' j

306− go (JSAssignment j1 j2) = JSAssignment <$> f' j1 <*> f' j2

365+ go (JSAssignment ss j1 j2) = JSAssignment ss <$> f' j1 <*> f' j2

307− go (JSWhile j1 j2) = JSWhile <$> f' j1 <*> f' j2

366+ go (JSWhile ss j1 j2) = JSWhile ss <$> f' j1 <*> f' j2

308− go (JSFor name j1 j2 j3) = JSFor name <$> f' j1 <*> f' j2 <*> f' j3

367+ go (JSFor ss name j1 j2 j3) = JSFor ss name <$> f' j1 <*> f' j2 <*> f' j3

309− go (JSForIn name j1 j2) = JSForIn name <$> f' j1 <*> f' j2

368+ go (JSForIn ss name j1 j2) = JSForIn ss name <$> f' j1 <*> f' j2

310− go (JSIfElse j1 j2 j3) = JSIfElse <$> f' j1 <*> f' j2 <*> traverse f' j3

369+ go (JSIfElse ss j1 j2 j3) = JSIfElse ss <$> f' j1 <*> f' j2 <*> traverse f' j3

311− go (JSReturn j) = JSReturn <$> f' j

370+ go (JSReturn ss j) = JSReturn ss <$> f' j

312− go (JSThrow j) = JSThrow <$> f' j

371+ go (JSThrow ss j) = JSThrow ss <$> f' j

313− go (JSTypeOf j) = JSTypeOf <$> f' j

372+ go (JSTypeOf ss j) = JSTypeOf ss <$> f' j

314− go (JSLabel name j) = JSLabel name <$> f' j

373+ go (JSLabel ss name j) = JSLabel ss name <$> f' j

315− go (JSInstanceOf j1 j2) = JSInstanceOf <$> f' j1 <*> f' j2

374+ go (JSInstanceOf ss j1 j2) = JSInstanceOf ss <$> f' j1 <*> f' j2

316− go (JSComment com j) = JSComment com <$> f' j

375+ go (JSComment ss com j) = JSComment ss com <$> f' j

317 go other = f other

376 go other = f other

318

377

319everythingOnJS :: (r -> r -> r) -> (JS -> r) -> JS -> r

378everythingOnJS :: (r -> r -> r) -> (JS -> r) -> JS -> r

320everythingOnJS (<>) f = go

379everythingOnJS (<>) f = go

321 where

380 where

322− go j@(JSUnary _ j1) = f j <> go j1

381+ go j@(JSUnary _ _ j1) = f j <> go j1

323− go j@(JSBinary _ j1 j2) = f j <> go j1 <> go j2

382+ go j@(JSBinary _ _ j1 j2) = f j <> go j1 <> go j2

324− go j@(JSArrayLiteral js) = foldl (<>) (f j) (map go js)

383+ go j@(JSArrayLiteral _ js) = foldl (<>) (f j) (map go js)

325− go j@(JSIndexer j1 j2) = f j <> go j1 <> go j2

384+ go j@(JSIndexer _ j1 j2) = f j <> go j1 <> go j2

326− go j@(JSObjectLiteral js) = foldl (<>) (f j) (map (go . snd) js)

385+ go j@(JSObjectLiteral _ js) = foldl (<>) (f j) (map (go . snd) js)

327− go j@(JSAccessor _ j1) = f j <> go j1

386+ go j@(JSAccessor _ _ j1) = f j <> go j1

328− go j@(JSFunction _ _ j1) = f j <> go j1

387+ go j@(JSFunction _ _ _ j1) = f j <> go j1

329− go j@(JSApp j1 js) = foldl (<>) (f j <> go j1) (map go js)

388+ 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

389+ 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)

390+ go j@(JSBlock _ js) = foldl (<>) (f j) (map go js)

332− go j@(JSVariableIntroduction _ (Just j1)) = f j <> go j1

391+ go j@(JSVariableIntroduction _ _ (Just j1)) = f j <> go j1

333− go j@(JSAssignment j1 j2) = f j <> go j1 <> go j2

392+ go j@(JSAssignment _ j1 j2) = f j <> go j1 <> go j2

334− go j@(JSWhile j1 j2) = f j <> go j1 <> go j2

393+ 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

394+ 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

395+ go j@(JSForIn _ _ j1 j2) = f j <> go j1 <> go j2

337− go j@(JSIfElse j1 j2 Nothing) = f j <> go j1 <> go j2

396+ 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

397+ go j@(JSIfElse _ j1 j2 (Just j3)) = f j <> go j1 <> go j2 <> go j3

339− go j@(JSReturn j1) = f j <> go j1

398+ go j@(JSReturn _ j1) = f j <> go j1

340− go j@(JSThrow j1) = f j <> go j1

399+ go j@(JSThrow _ j1) = f j <> go j1

341− go j@(JSTypeOf j1) = f j <> go j1

400+ go j@(JSTypeOf _ j1) = f j <> go j1

342− go j@(JSLabel _ j1) = f j <> go j1

401+ go j@(JSLabel _ _ j1) = f j <> go j1

343− go j@(JSInstanceOf j1 j2) = f j <> go j1 <> go j2

402+ go j@(JSInstanceOf _ j1 j2) = f j <> go j1 <> go j2

344− go j@(JSComment _ j1) = f j <> go j1

403+ go j@(JSComment _ _ j1) = f j <> go j1

345 go other = f other

404 go other = f other

src/Language/PureScript/CodeGen/JS/Optimizer.hs+19−27

@@ -1,13 +1,5 @@

1−-----------------------------------------------------------------------------

1+{-# LANGUAGE FlexibleContexts #-}

2−--

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−--

11-- |

3-- |

12-- This module optimizes code in the simplified-Javascript intermediate representation.

4-- This module optimizes code in the simplified-Javascript intermediate representation.

13--

5--

@@ -29,13 +21,7 @@

29--

21--

30-- * Inlining primitive Javascript operators

22-- * Inlining primitive Javascript operators

31--

23--

32−-----------------------------------------------------------------------------

33−

34−{-# LANGUAGE FlexibleContexts #-}

35−

36−module Language.PureScript.CodeGen.JS.Optimizer (

24+module Language.PureScript.CodeGen.JS.Optimizer (optimize) where

37− optimize

38−) where

39

25

40import Prelude ()

26import Prelude ()

41import Prelude.Compat

27import Prelude.Compat

@@ -57,19 +43,29 @@ import Language.PureScript.CodeGen.JS.Optimizer.Blocks

57-- |

43-- |

58-- Apply a series of optimizer passes to simplified Javascript code

44-- Apply a series of optimizer passes to simplified Javascript code

59--

45--

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

61optimize js = do

47optimize js = do

62 noOpt <- asks optionsNoOptimizations

48 noOpt <- asks optionsNoOptimizations

63 if noOpt then return js else optimize' js

49 if noOpt then return js else optimize' js

64

50

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

66optimize' js = do

52optimize' js = do

67 opts <- ask

53 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

69 [ collapseNestedBlocks

67 [ collapseNestedBlocks

70 , collapseNestedIfs

68 , collapseNestedIfs

71− , tco opts

72− , magicDo opts

73 , removeCodeAfterReturnStatements

69 , removeCodeAfterReturnStatements

74 , removeUnusedArg

70 , removeUnusedArg

75 , removeUndefinedApp

71 , removeUndefinedApp

@@ -77,11 +73,7 @@ optimize' js = do

77 , etaConvert

73 , etaConvert

78 , evaluateIifes

74 , evaluateIifes

79 , inlineVariables

75 , inlineVariables

80− , inlineValues

76+ ]

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

85

77

86untilFixedPoint :: (Monad m, Eq a) => (a -> m a) -> a -> m a

78untilFixedPoint :: (Monad m, Eq a) => (a -> m a) -> a -> m a

87untilFixedPoint f = go

79untilFixedPoint f = go

src/Language/PureScript/CodeGen/JS/Optimizer/Blocks.hs+4−4

@@ -27,16 +27,16 @@ collapseNestedBlocks :: JS -> JS

27collapseNestedBlocks = everywhereOnJS collapse

28 where

29 collapse :: JS -> JS

30− collapse (JSBlock sts) = JSBlock (concatMap go sts)

30+ collapse (JSBlock ss sts) = JSBlock ss (concatMap go sts)

31 collapse js = js

32 go :: JS -> [JS]

33− go (JSBlock sts) = sts

33+ go (JSBlock _ sts) = sts

34 go s = [s]

35

36collapseNestedIfs :: JS -> JS

37collapseNestedIfs = everywhereOnJS collapse

38 where

39 collapse :: JS -> JS

40− collapse (JSIfElse cond1 (JSBlock [JSIfElse cond2 body Nothing]) Nothing) =

40+ collapse (JSIfElse s1 cond1 (JSBlock _ [JSIfElse s2 cond2 body Nothing]) Nothing) =

41− JSIfElse (JSBinary And cond1 cond2) body Nothing

41+ JSIfElse s1 (JSBinary s2 And cond1 cond2) body Nothing

42 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−--

11-- |

1-- |

12-- Common functions used by the various optimizer phases

2-- Common functions used by the various optimizer phases

13--

3--

14−-----------------------------------------------------------------------------

15−

16module Language.PureScript.CodeGen.JS.Optimizer.Common where

4module Language.PureScript.CodeGen.JS.Optimizer.Common where

17

5

18import Data.Maybe (fromMaybe)

6import Data.Maybe (fromMaybe)

@@ -26,53 +14,68 @@ applyAll = foldl1 (.)

26replaceIdent :: String -> JS -> JS -> JS

14replaceIdent :: String -> JS -> JS -> JS

27replaceIdent var1 js = everywhereOnJS replace

15replaceIdent var1 js = everywhereOnJS replace

28 where

16 where

29− replace (JSVar var2) | var1 == var2 = js

17+ replace (JSVar _ var2) | var1 == var2 = js

30 replace other = other

18 replace other = other

31

19

32replaceIdents :: [(String, JS)] -> JS -> JS

20replaceIdents :: [(String, JS)] -> JS -> JS

33replaceIdents vars = everywhereOnJS replace

21replaceIdents vars = everywhereOnJS replace

34 where

22 where

35− replace v@(JSVar var) = fromMaybe v $ lookup var vars

23+ replace v@(JSVar _ var) = fromMaybe v $ lookup var vars

36 replace other = other

24 replace other = other

37

25

38isReassigned :: String -> JS -> Bool

26isReassigned :: String -> JS -> Bool

39isReassigned var1 = everythingOnJS (||) check

27isReassigned var1 = everythingOnJS (||) check

40 where

28 where

41 check :: JS -> Bool

29 check :: JS -> Bool

42− check (JSFunction _ args _) | var1 `elem` args = True

30+ check (JSFunction _ _ args _) | var1 `elem` args = True

43− check (JSVariableIntroduction arg _) | var1 == arg = True

31+ check (JSVariableIntroduction _ arg _) | var1 == arg = True

44− check (JSAssignment (JSVar arg) _) | var1 == arg = True

32+ check (JSAssignment _ (JSVar _ arg) _) | var1 == arg = True

45− check (JSFor arg _ _ _) | var1 == arg = True

33+ check (JSFor _ arg _ _ _) | var1 == arg = True

46− check (JSForIn arg _ _) | var1 == arg = True

34+ check (JSForIn _ arg _ _) | var1 == arg = True

47 check _ = False

35 check _ = False

48

36

49isRebound :: JS -> JS -> Bool

37isRebound :: JS -> JS -> Bool

50isRebound js d = any (\v -> isReassigned v d || isUpdated v d) (everythingOnJS (++) variablesOf js)

38isRebound js d = any (\v -> isReassigned v d || isUpdated v d) (everythingOnJS (++) variablesOf js)

51 where

39 where

52− variablesOf (JSVar var) = [var]

40+ variablesOf (JSVar _ var) = [var]

53 variablesOf _ = []

41 variablesOf _ = []

54

42

55isUsed :: String -> JS -> Bool

43isUsed :: String -> JS -> Bool

56isUsed var1 = everythingOnJS (||) check

44isUsed var1 = everythingOnJS (||) check

57 where

45 where

58 check :: JS -> Bool

46 check :: JS -> Bool

59− check (JSVar var2) | var1 == var2 = True

47+ check (JSVar _ var2) | var1 == var2 = True

60− check (JSAssignment target _) | var1 == targetVariable target = True

48+ check (JSAssignment _ target _) | var1 == targetVariable target = True

61 check _ = False

49 check _ = False

62

50

63targetVariable :: JS -> String

51targetVariable :: JS -> String

64−targetVariable (JSVar var) = var

52+targetVariable (JSVar _ var) = var

65−targetVariable (JSAccessor _ tgt) = targetVariable tgt

53+targetVariable (JSAccessor _ _ tgt) = targetVariable tgt

66−targetVariable (JSIndexer _ tgt) = targetVariable tgt

54+targetVariable (JSIndexer _ _ tgt) = targetVariable tgt

67targetVariable _ = internalError "Invalid argument to targetVariable"

55targetVariable _ = internalError "Invalid argument to targetVariable"

68

56

69isUpdated :: String -> JS -> Bool

57isUpdated :: String -> JS -> Bool

70isUpdated var1 = everythingOnJS (||) check

58isUpdated var1 = everythingOnJS (||) check

71 where

59 where

72 check :: JS -> Bool

60 check :: JS -> Bool

73− check (JSAssignment target _) | var1 == targetVariable target = True

61+ check (JSAssignment _ target _) | var1 == targetVariable target = True

74 check _ = False

62 check _ = False

75

63

76removeFromBlock :: ([JS] -> [JS]) -> JS -> JS

64removeFromBlock :: ([JS] -> [JS]) -> JS -> JS

77−removeFromBlock go (JSBlock sts) = JSBlock (go sts)

65+removeFromBlock go (JSBlock ss sts) = JSBlock ss (go sts)

78removeFromBlock _ js = js

66removeFromBlock _ 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−--

11-- |

1-- |

12-- This module provides basic inlining capabilities

2-- This module provides basic inlining capabilities

13--

3--

14−-----------------------------------------------------------------------------

15−

16−module Language.PureScript.CodeGen.JS.Optimizer.Inliner (

4+module Language.PureScript.CodeGen.JS.Optimizer.Inliner

17− inlineVariables,

5+ ( inlineVariables

18− inlineValues,

6+ , inlineCommonValues

19− inlineOperator,

7+ , inlineOperator

20− inlineCommonOperators,

8+ , inlineCommonOperators

21− inlineFnComposition,

9+ , inlineFnComposition

22− etaConvert,

10+ , etaConvert

23− unThunk,

11+ , unThunk

24− evaluateIifes

12+ , evaluateIifes

25−) where

13+ ) where

26

14

27import Prelude ()

15import Prelude ()

28import Prelude.Compat

16import Prelude.Compat

@@ -41,42 +29,42 @@ import qualified Language.PureScript.Constants as C

41-- Needs to be: { 0..toFixed(10); }

29-- Needs to be: { 0..toFixed(10); }

42-- Probably needs to be fixed in pretty-printer instead.

30-- Probably needs to be fixed in pretty-printer instead.

43shouldInline :: JS -> Bool

31shouldInline :: JS -> Bool

44−shouldInline (JSVar _) = True

32+shouldInline (JSVar _ _) = True

45−shouldInline (JSNumericLiteral _) = True

33+shouldInline (JSNumericLiteral _ _) = True

46−shouldInline (JSStringLiteral _) = True

34+shouldInline (JSStringLiteral _ _) = True

47−shouldInline (JSBooleanLiteral _) = True

35+shouldInline (JSBooleanLiteral _ _) = True

48−shouldInline (JSAccessor _ val) = shouldInline val

36+shouldInline (JSAccessor _ _ val) = shouldInline val

49−shouldInline (JSIndexer index val) = shouldInline index && shouldInline val

37+shouldInline (JSIndexer _ index val) = shouldInline index && shouldInline val

50shouldInline _ = False

38shouldInline _ = False

51

39

52etaConvert :: JS -> JS

40etaConvert :: JS -> JS

53etaConvert = everywhereOnJS convert

41etaConvert = everywhereOnJS convert

54 where

42 where

55 convert :: JS -> JS

43 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)])

57 | all shouldInline args &&

45 | all shouldInline args &&

58− not (any (`isRebound` block) (map JSVar idents)) &&

46+ not (any (`isRebound` block) (map (JSVar Nothing) idents)) &&

59 not (any (`isRebound` block) args)

47 not (any (`isRebound` block) args)

60− = JSBlock (map (replaceIdents (zip idents args)) body)

48+ = JSBlock ss (map (replaceIdents (zip idents args)) body)

61− convert (JSFunction Nothing [] (JSBlock [JSReturn (JSApp fn [])])) = fn

49+ convert (JSFunction _ Nothing [] (JSBlock _ [JSReturn _ (JSApp _ fn [])])) = fn

62 convert js = js

50 convert js = js

63

51

64unThunk :: JS -> JS

52unThunk :: JS -> JS

65unThunk = everywhereOnJS convert

53unThunk = everywhereOnJS convert

66 where

54 where

67 convert :: JS -> JS

55 convert :: JS -> JS

68− convert (JSBlock []) = JSBlock []

56+ convert (JSBlock ss []) = JSBlock ss []

69− convert (JSBlock jss) =

57+ convert (JSBlock ss jss) =

70 case last jss of

58 case last jss of

71− JSReturn (JSApp (JSFunction Nothing [] (JSBlock body)) []) -> JSBlock $ init jss ++ body

59+ JSReturn _ (JSApp _ (JSFunction _ Nothing [] (JSBlock _ body)) []) -> JSBlock ss $ init jss ++ body

72− _ -> JSBlock jss

60+ _ -> JSBlock ss jss

73 convert js = js

61 convert js = js

74

62

75evaluateIifes :: JS -> JS

63evaluateIifes :: JS -> JS

76evaluateIifes = everywhereOnJS convert

64evaluateIifes = everywhereOnJS convert

77 where

65 where

78 convert :: JS -> JS

66 convert :: JS -> JS

79− convert (JSApp (JSFunction Nothing [] (JSBlock [JSReturn ret])) []) = ret

67+ convert (JSApp _ (JSFunction _ Nothing [] (JSBlock _ [JSReturn _ ret])) []) = ret

80 convert js = js

68 convert js = js

81

69

82inlineVariables :: JS -> JS

70inlineVariables :: JS -> JS

@@ -84,85 +72,96 @@ inlineVariables = everywhereOnJS $ removeFromBlock go

84 where

72 where

85 go :: [JS] -> [JS]

73 go :: [JS] -> [JS]

86 go [] = []

74 go [] = []

87− go (JSVariableIntroduction var (Just js) : sts)

75+ go (JSVariableIntroduction _ var (Just js) : sts)

88 | shouldInline js && not (any (isReassigned var) sts) && not (any (isRebound js) sts) && not (any (isUpdated var) sts) =

76 | shouldInline js && not (any (isReassigned var) sts) && not (any (isRebound js) sts) && not (any (isUpdated var) sts) =

89 go (map (replaceIdent var js) sts)

77 go (map (replaceIdent var js) sts)

90 go (s:sts) = s : go sts

78 go (s:sts) = s : go sts

91

79

92−inlineValues :: JS -> JS

80+inlineCommonValues :: JS -> JS

93−inlineValues = everywhereOnJS convert

81+inlineCommonValues = everywhereOnJS convert

94 where

82 where

95 convert :: JS -> JS

83 convert :: JS -> JS

96− convert (JSApp fn [dict]) | isDict semiringNumber dict && isFn fnZero fn = JSNumericLiteral (Left 0)

84+ convert (JSApp ss fn [dict])

97− | isDict semiringNumber dict && isFn fnOne fn = JSNumericLiteral (Left 1)

98− | isDict semiringInt dict && isFn fnZero fn = JSNumericLiteral (Left 0)

85+ | isDict' (semiringNumber ++ semiringInt) dict && isFn' fnZero fn = JSNumericLiteral ss (Left 0)

99− | isDict semiringInt dict && isFn fnOne fn = JSNumericLiteral (Left 1)

86+ | isDict' (semiringNumber ++ semiringInt) dict && isFn' fnOne fn = JSNumericLiteral ss (Left 1)

100− | isDict boundedBoolean dict && isFn fnBottom fn = JSBooleanLiteral False

87+ | isDict' boundedBoolean dict && isFn' fnBottom fn = JSBooleanLiteral ss False

101− | isDict boundedBoolean dict && isFn fnTop fn = JSBooleanLiteral True

88+ | isDict' boundedBoolean dict && isFn' fnTop fn = JSBooleanLiteral ss True

102− convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y])

89+ convert (JSApp ss (JSApp _ (JSApp _ fn [dict]) [x]) [y])

103− | isDict semiringInt dict && isFn fnAdd fn = JSBinary BitwiseOr (JSBinary Add x y) (JSNumericLiteral (Left 0))

90+ | isDict' semiringInt dict && isFn' fnAdd fn = intOp ss Add x y

104− | isDict semiringInt dict && isFn fnMultiply fn = JSBinary BitwiseOr (JSBinary Multiply x y) (JSNumericLiteral (Left 0))

91+ | isDict' semiringInt dict && isFn' fnMultiply fn = intOp ss Multiply x y

105− | isDict moduloSemiringInt dict && isFn fnDivide fn = JSBinary BitwiseOr (JSBinary Divide x y) (JSNumericLiteral (Left 0))

92+ | isDict' moduloSemiringInt dict && isFn' fnDivide fn = intOp ss Divide x y

106− | isDict ringInt dict && isFn fnSubtract fn = JSBinary BitwiseOr (JSBinary Subtract x y) (JSNumericLiteral (Left 0))

93+ | isDict' ringInt dict && isFn' fnSubtract fn = intOp ss Subtract x y

107 convert other = other

94 convert other = other

108− fnZero = (C.prelude, C.zero)

95+ fnZero = [(C.prelude, C.zero), (C.dataSemiring, C.zero)]

109− fnOne = (C.prelude, C.one)

96+ fnOne = [(C.prelude, C.one), (C.dataSemiring, C.one)]

110− fnBottom = (C.prelude, C.bottom)

97+ fnBottom = [(C.prelude, C.bottom), (C.dataBounded, C.bottom)]

111− fnTop = (C.prelude, C.top)

98+ fnTop = [(C.prelude, C.top), (C.dataBounded, C.top)]

112− fnAdd = (C.prelude, (C.+))

99+ fnAdd = [(C.prelude, (C.+)), (C.prelude, (C.add)), (C.dataSemiring, (C.+)), (C.dataSemiring, (C.add))]

113− fnDivide = (C.prelude, (C./))

100+ fnDivide = [(C.prelude, (C./)), (C.prelude, (C.div)), (C.dataModuloSemiring, C.div)]

114− fnMultiply = (C.prelude, (C.*))

101+ fnMultiply = [(C.prelude, (C.*)), (C.prelude, (C.mul)), (C.dataSemiring, (C.*)), (C.dataSemiring, (C.mul))]

115− fnSubtract = (C.prelude, (C.-))

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))

116

104

117inlineOperator :: (String, String) -> (JS -> JS -> JS) -> JS -> JS

105inlineOperator :: (String, String) -> (JS -> JS -> JS) -> JS -> JS

118inlineOperator (m, op) f = everywhereOnJS convert

106inlineOperator (m, op) f = everywhereOnJS convert

119 where

107 where

120 convert :: JS -> JS

108 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

122 convert other = other

110 convert other = other

123− isOp (JSAccessor longForm (JSVar m')) = m == m' && longForm == identToJs (Op op)

111+ isOp (JSAccessor _ longForm (JSVar _ m')) = m == m' && longForm == identToJs (Op op)

124− isOp (JSIndexer (JSStringLiteral op') (JSVar m')) = m == m' && op == op'

112+ isOp (JSIndexer _ (JSStringLiteral _ op') (JSVar _ m')) = m == m' && op == op'

125 isOp _ = False

113 isOp _ = False

126

114

127inlineCommonOperators :: JS -> JS

115inlineCommonOperators :: JS -> JS

128inlineCommonOperators = applyAll $

116inlineCommonOperators = applyAll $

129− [ binary semiringNumber (C.+) Add

117+ [ binary semiringNumber opAdd Add

130− , binary semiringNumber (C.*) Multiply

118+ , binary semiringNumber opMul Multiply

131−

119+

132− , binary ringNumber (C.-) Subtract

120+ , binary ringNumber opSub Subtract

133− , unary ringNumber C.negate Negate

121+ , unary ringNumber opNegate Negate

134− , binary ringInt (C.-) Subtract

122+ , binary ringInt opSub Subtract

135− , unary ringInt C.negate Negate

123+ , unary ringInt opNegate Negate

136−

124+

137− , binary moduloSemiringNumber (C./) Divide

125+ , binary moduloSemiringNumber opDiv Divide

138− , binary moduloSemiringInt C.mod Modulus

126+ , binary moduloSemiringInt opMod Modulus

139−

127+

140− , binary eqNumber (C.==) EqualTo

128+ , binary eqNumber opEq EqualTo

141− , binary eqNumber (C./=) NotEqualTo

129+ , binary eqNumber opNotEq NotEqualTo

142− , binary eqInt (C.==) EqualTo

130+ , binary eqInt opEq EqualTo

143− , binary eqInt (C./=) NotEqualTo

131+ , binary eqInt opNotEq NotEqualTo

144− , binary eqString (C.==) EqualTo

132+ , binary eqString opEq EqualTo

145− , binary eqString (C./=) NotEqualTo

133+ , binary eqString opNotEq NotEqualTo

134+ , binary eqChar opEq EqualTo

135+ , binary eqChar opNotEq NotEqualTo

146− , binary eqBoolean (C.==) EqualTo

136+ , binary eqBoolean opEq EqualTo

147− , binary eqBoolean (C./=) NotEqualTo

137+ , binary eqBoolean opNotEq NotEqualTo

148−

138+

149− , binary ordNumber (C.<) LessThan

139+ , binary ordBoolean opLessThan LessThan

150− , binary ordNumber (C.>) GreaterThan

140+ , binary ordBoolean opLessThanOrEq LessThanOrEqualTo

141+ , binary ordBoolean opGreaterThan GreaterThan

142+ , binary ordBoolean opGreaterThanOrEq GreaterThanOrEqualTo

143+ , binary ordChar opLessThan LessThan

151− , binary ordNumber (C.<=) LessThanOrEqualTo

144+ , binary ordChar opLessThanOrEq LessThanOrEqualTo

145+ , binary ordChar opGreaterThan GreaterThan

152− , binary ordNumber (C.>=) GreaterThanOrEqualTo

146+ , binary ordChar opGreaterThanOrEq GreaterThanOrEqualTo

153− , binary ordInt (C.<) LessThan

147+ , binary ordInt opLessThan LessThan

154− , binary ordInt (C.>) GreaterThan

148+ , binary ordInt opLessThanOrEq LessThanOrEqualTo

155− , binary ordInt (C.<=) LessThanOrEqualTo

149+ , binary ordInt opGreaterThan GreaterThan

156− , binary ordInt (C.>=) GreaterThanOrEqualTo

150+ , binary ordInt opGreaterThanOrEq GreaterThanOrEqualTo

157−

151+ , binary ordNumber opLessThan LessThan

158− , binary semigroupString (C.<>) Add

152+ , binary ordNumber opLessThanOrEq LessThanOrEqualTo

159− , binary semigroupString (C.++) Add

153+ , binary ordNumber opGreaterThan GreaterThan

160−

154+ , binary ordNumber opGreaterThanOrEq GreaterThanOrEqualTo

161− , binary booleanAlgebraBoolean (C.&&) And

155+ , binary ordString opLessThan LessThan

162− , binary booleanAlgebraBoolean (C.||) Or

156+ , binary ordString opLessThanOrEq LessThanOrEqualTo

157+ , binary ordString opGreaterThan GreaterThan

158+ , binary ordString opGreaterThanOrEq GreaterThanOrEqualTo

159+

160+ , binary semigroupString opAppend Add

161+

163− , binaryFunction booleanAlgebraBoolean C.conj And

162+ , binary booleanAlgebraBoolean opConj And

164− , binaryFunction booleanAlgebraBoolean C.disj Or

163+ , binary booleanAlgebraBoolean opDisj Or

165− , unary booleanAlgebraBoolean C.not Not

164+ , unary booleanAlgebraBoolean opNot Not

166

165

167 , binary' C.dataIntBits (C..|.) BitwiseOr

166 , binary' C.dataIntBits (C..|.) BitwiseOr

168 , binary' C.dataIntBits (C..&.) BitwiseAnd

167 , binary' C.dataIntBits (C..&.) BitwiseAnd

@@ -174,59 +173,53 @@ inlineCommonOperators = applyAll $

174 ] ++

173 ] ++

175 [ fn | i <- [0..10], fn <- [ mkFn i, runFn i ] ]

174 [ fn | i <- [0..10], fn <- [ mkFn i, runFn i ] ]

176 where

175 where

177− binary :: (String, String) -> String -> BinaryOperator -> JS -> JS

176+ binary :: [(String, String)] -> [(String, String)] -> BinaryOperator -> JS -> JS

178− binary dict opString op = everywhereOnJS convert

177+ binary dict fns op = everywhereOnJS convert

179 where

178 where

180 convert :: JS -> JS

179 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

182 convert other = other

181 convert other = other

183 binary' :: String -> String -> BinaryOperator -> JS -> JS

182 binary' :: String -> String -> BinaryOperator -> JS -> JS

184 binary' moduleName opString op = everywhereOnJS convert

183 binary' moduleName opString op = everywhereOnJS convert

185 where

184 where

186 convert :: JS -> JS

185 convert :: JS -> JS

187− convert (JSApp (JSApp fn [x]) [y]) | isFn (moduleName, opString) fn = JSBinary op x y

186+ convert (JSApp ss (JSApp _ fn [x]) [y]) | isFn (moduleName, opString) fn = JSBinary ss 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

194 convert other = other

187 convert other = other

195− unary :: (String, String) -> String -> UnaryOperator -> JS -> JS

188+ unary :: [(String, String)] -> [(String, String)] -> UnaryOperator -> JS -> JS

196− unary dict fnName op = everywhereOnJS convert

189+ unary dicts fns op = everywhereOnJS convert

197 where

190 where

198 convert :: JS -> JS

191 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

200 convert other = other

193 convert other = other

201 unary' :: String -> String -> UnaryOperator -> JS -> JS

194 unary' :: String -> String -> UnaryOperator -> JS -> JS

202 unary' moduleName fnName op = everywhereOnJS convert

195 unary' moduleName fnName op = everywhereOnJS convert

203 where

196 where

204 convert :: JS -> JS

197 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

206 convert other = other

199 convert other = other

207 mkFn :: Int -> JS -> JS

200 mkFn :: Int -> JS -> JS

208 mkFn 0 = everywhereOnJS convert

201 mkFn 0 = everywhereOnJS convert

209 where

202 where

210 convert :: JS -> JS

203 convert :: JS -> JS

211− convert (JSApp mkFnN [JSFunction Nothing [_] (JSBlock js)]) | isNFn C.mkFn 0 mkFnN =

204+ convert (JSApp _ mkFnN [JSFunction s1 Nothing [_] (JSBlock s2 js)]) | isNFn C.mkFn 0 mkFnN =

212− JSFunction Nothing [] (JSBlock js)

205+ JSFunction s1 Nothing [] (JSBlock s2 js)

213 convert other = other

206 convert other = other

214 mkFn n = everywhereOnJS convert

207 mkFn n = everywhereOnJS convert

215 where

208 where

216 convert :: JS -> JS

209 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 =

218 case collectArgs n [] fn of

211 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)

220 Nothing -> orig

213 Nothing -> orig

221 convert other = other

214 convert other = other

222 collectArgs :: Int -> [String] -> JS -> Maybe ([String], [JS])

215 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)

216+ 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

217+ collectArgs m acc (JSFunction _ Nothing [oneArg] (JSBlock _ [JSReturn _ ret])) = collectArgs (m - 1) (oneArg : acc) ret

225 collectArgs _ _ _ = Nothing

218 collectArgs _ _ _ = Nothing

226

219

227 isNFn :: String -> Int -> JS -> Bool

220 isNFn :: String -> Int -> JS -> Bool

228− isNFn prefix n (JSVar name) = name == (prefix ++ show n)

221+ isNFn prefix n (JSVar _ name) = name == (prefix ++ show n)

229− isNFn prefix n (JSAccessor name (JSVar dataFunction)) | dataFunction == C.dataFunction = name == (prefix ++ show n)

222+ isNFn prefix n (JSAccessor _ name (JSVar _ dataFunction)) | dataFunction == C.dataFunction = name == (prefix ++ show n)

230 isNFn _ _ _ = False

223 isNFn _ _ _ = False

231

224

232 runFn :: Int -> JS -> JS

225 runFn :: Int -> JS -> JS

@@ -236,81 +229,140 @@ inlineCommonOperators = applyAll $

236 convert js = fromMaybe js $ go n [] js

229 convert js = fromMaybe js $ go n [] js

237

230

238 go :: Int -> [JS] -> JS -> Maybe JS

231 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)

232+ go 0 acc (JSApp ss runFnN [fn]) | isNFn C.runFn n runFnN && length acc == n = Just (JSApp ss fn acc)

240− go m acc (JSApp lhs [arg]) = go (m - 1) (arg : acc) lhs

233+ go m acc (JSApp _ lhs [arg]) = go (m - 1) (arg : acc) lhs

241 go _ _ _ = Nothing

234 go _ _ _ = Nothing

242

235

243-- (f <<< g $ x) = f (g x)

236-- (f <<< g $ x) = f (g x)

244-- (f <<< g) = \x -> f (g x)

237-- (f <<< g) = \x -> f (g x)

245−inlineFnComposition :: (Applicative m, MonadSupply m) => JS -> m JS

238+inlineFnComposition :: (MonadSupply m) => JS -> m JS

246inlineFnComposition = everywhereOnJSTopDownM convert

239inlineFnComposition = everywhereOnJSTopDownM convert

247 where

240 where

248 convert :: (MonadSupply m) => JS -> m JS

241 convert :: (MonadSupply m) => JS -> m JS

249− convert (JSApp (JSApp (JSApp (JSApp fn [dict']) [x]) [y]) [z]) | isFnCompose dict' fn =

242+ convert (JSApp s1 (JSApp s2 (JSApp _ (JSApp _ fn [dict']) [x]) [y]) [z])

250− return $ JSApp x [JSApp 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]]

251− convert (JSApp (JSApp (JSApp fn [dict']) [x]) [y]) | isFnCompose dict' fn = do

245+ convert (JSApp ss (JSApp _ (JSApp _ fn [dict']) [x]) [y])

246+ | isFnCompose dict' fn = do

252− arg <- freshName

247+ arg <- freshName

253− return $ JSFunction Nothing [arg] (JSBlock [JSReturn $ JSApp x [JSApp y [JSVar arg]]])

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]]])

254 convert other = return other

252 convert other = return other

255 isFnCompose :: JS -> JS -> Bool

253 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)]

257

312

258−isDict :: (String, String) -> JS -> Bool

313+boundedBoolean :: [(String, String)]

259−isDict (moduleName, dictName) (JSAccessor x (JSVar y)) = x == dictName && y == moduleName

314+boundedBoolean = [(C.prelude, C.boundedBoolean), (C.dataBounded, C.boundedBoolean)]

260−isDict _ _ = False

261

315

262−isFn :: (String, String) -> JS -> Bool

316+booleanAlgebraBoolean :: [(String, String)]

263−isFn (moduleName, fnName) (JSAccessor x (JSVar y)) = x == fnName && y == moduleName

317+booleanAlgebraBoolean = [(C.prelude, C.booleanAlgebraBoolean), (C.dataBooleanAlgebra, C.booleanAlgebraBoolean)]

264−isFn (moduleName, fnName) (JSIndexer (JSStringLiteral x) (JSVar y)) = x == fnName && y == moduleName

265−isFn _ _ = False

266

318

267−isPreludeFn :: String -> JS -> Bool

319+semigroupoidFn :: [(String, String)]

268−isPreludeFn fnName = isFn (C.prelude, fnName)

320+semigroupoidFn = [(C.prelude, C.semigroupoidFn), (C.controlSemigroupoid, C.semigroupoidFn)]

269

321

270−semiringNumber :: (String, String)

322+opAdd :: [(String, String)]

271−semiringNumber = (C.prelude, C.semiringNumber)

323+opAdd = [(C.prelude, (C.+)), (C.prelude, C.add), (C.dataSemiring, C.add)]

272

324

273−semiringInt :: (String, String)

325+opMul :: [(String, String)]

274−semiringInt = (C.prelude, C.semiringInt)

326+opMul = [(C.prelude, (C.*)), (C.prelude, C.mul), (C.dataSemiring, C.mul)]

275

327

276−ringNumber :: (String, String)

328+opEq :: [(String, String)]

277−ringNumber = (C.prelude, C.ringNumber)

329+opEq = [(C.prelude, (C.==)), (C.prelude, C.eq), (C.dataEq, C.eq)]

278

330

279−ringInt :: (String, String)

331+opNotEq :: [(String, String)]

280−ringInt = (C.prelude, C.ringInt)

332+opNotEq = [(C.prelude, (C./=)), (C.dataEq, C.notEq)]

281

333

282−moduloSemiringNumber :: (String, String)

334+opLessThan :: [(String, String)]

283−moduloSemiringNumber = (C.prelude, C.moduloSemiringNumber)

335+opLessThan = [(C.prelude, (C.<)), (C.dataOrd, C.lessThan)]

284

336

285−moduloSemiringInt :: (String, String)

337+opLessThanOrEq :: [(String, String)]

286−moduloSemiringInt = (C.prelude, C.moduloSemiringInt)

338+opLessThanOrEq = [(C.prelude, (C.<=)), (C.dataOrd, C.lessThanOrEq)]

287

339

288−eqNumber :: (String, String)

340+opGreaterThan :: [(String, String)]

289−eqNumber = (C.prelude, C.eqNumber)

341+opGreaterThan = [(C.prelude, (C.>)), (C.dataOrd, C.greaterThan)]

290

342

291−eqInt :: (String, String)

343+opGreaterThanOrEq :: [(String, String)]

292−eqInt = (C.prelude, C.eqInt)

344+opGreaterThanOrEq = [(C.prelude, (C.>=)), (C.dataOrd, C.greaterThanOrEq)]

293

345

294−eqString :: (String, String)

346+opAppend :: [(String, String)]

295−eqString = (C.prelude, C.eqNumber)

347+opAppend = [(C.prelude, (C.<>)), (C.prelude, (C.++)), (C.prelude, C.append), (C.dataSemigroup, C.append)]

296

348

297−eqBoolean :: (String, String)

349+opSub :: [(String, String)]

298−eqBoolean = (C.prelude, C.eqNumber)

350+opSub = [(C.prelude, (C.-)), (C.prelude, C.sub), (C.dataRing, C.sub)]

299

351

300−ordNumber :: (String, String)

352+opNegate :: [(String, String)]

301−ordNumber = (C.prelude, C.ordNumber)

353+opNegate = [(C.prelude, C.negate), (C.dataRing, C.negate)]

302

354

303−ordInt :: (String, String)

355+opDiv :: [(String, String)]

304−ordInt = (C.prelude, C.ordInt)

356+opDiv = [(C.prelude, (C./)), (C.prelude, C.div), (C.dataModuloSemiring, C.div)]

305

357

306−semigroupString :: (String, String)

358+opMod :: [(String, String)]

307−semigroupString = (C.prelude, C.semigroupString)

359+opMod = [(C.prelude, C.mod), (C.dataModuloSemiring, C.mod)]

308

360

309−boundedBoolean :: (String, String)

361+opConj :: [(String, String)]

310−boundedBoolean = (C.prelude, C.boundedBoolean)

362+opConj = [(C.prelude, (C.&&)), (C.prelude, C.conj), (C.dataBooleanAlgebra, C.conj)]

311

363

312−booleanAlgebraBoolean :: (String, String)

364+opDisj :: [(String, String)]

313−booleanAlgebraBoolean = (C.prelude, C.booleanAlgebraBoolean)

365+opDisj = [(C.prelude, (C.||)), (C.prelude, C.disj), (C.dataBooleanAlgebra, C.disj)]

314

366

315−semigroupoidFn :: (String, String)

367+opNot :: [(String, String)]

316−semigroupoidFn = (C.prelude, C.semigroupoidFn)

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−--

11-- |

1-- |

12-- This module implements the "Magic Do" optimization, which inlines calls to return

2-- This module implements the "Magic Do" optimization, which inlines calls to return

13-- and bind for the Eff monad, as well as some of its actions.

3-- and bind for the Eff monad, as well as some of its actions.

14--

4--

15−-----------------------------------------------------------------------------

16−

17−module Language.PureScript.CodeGen.JS.Optimizer.MagicDo (

5+module Language.PureScript.CodeGen.JS.Optimizer.MagicDo (magicDo) where

18− magicDo

19−) where

20

6

21import Data.List (nub)

7import Data.List (nub)

22import Data.Maybe (fromJust, isJust)

8import Data.Maybe (fromJust, isJust)

23

9

24import Language.PureScript.CodeGen.JS.AST

10import Language.PureScript.CodeGen.JS.AST

25−import Language.PureScript.CodeGen.JS.Common

11+import Language.PureScript.CodeGen.JS.Optimizer.Common

26−import Language.PureScript.Names

27import Language.PureScript.Options

12import Language.PureScript.Options

28import qualified Language.PureScript.Constants as C

13import qualified Language.PureScript.Constants as C

29

14

@@ -54,63 +39,47 @@ magicDo' = everywhereOnJS undo . everywhereOnJSTopDown convert

54 fnName = "__do"

39 fnName = "__do"

55 -- Desugar monomorphic calls to >>= and return for the Eff monad

40 -- Desugar monomorphic calls to >>= and return for the Eff monad

56 convert :: JS -> JS

41 convert :: JS -> JS

57− -- Desugar return

42+ -- Desugar pure & return

58− convert (JSApp (JSApp ret [val]) []) | isReturn ret = val

59− -- Desugar pure

60− convert (JSApp (JSApp pure' [val]) []) | isPure pure' = val

43+ convert (JSApp _ (JSApp _ pure' [val]) []) | isPure pure' = val

61 -- Desugar >>

44 -- Desugar >>

62− convert (JSApp (JSApp bind [m]) [JSFunction Nothing [] (JSBlock js)]) | isBind bind =

45+ convert (JSApp _ (JSApp _ bind [m]) [JSFunction s1 Nothing [] (JSBlock s2 js)]) | isBind bind =

63− JSFunction (Just fnName) [] $ JSBlock (JSApp m [] : map applyReturns js )

46+ JSFunction s1 (Just fnName) [] $ JSBlock s2 (JSApp s2 m [] : map applyReturns js )

64 -- Desugar >>=

47 -- Desugar >>=

65− convert (JSApp (JSApp bind [m]) [JSFunction Nothing [arg] (JSBlock js)]) | isBind bind =

48+ convert (JSApp _ (JSApp _ bind [m]) [JSFunction s1 Nothing [arg] (JSBlock s2 js)]) | isBind bind =

66− JSFunction (Just fnName) [] $ JSBlock (JSVariableIntroduction arg (Just (JSApp m [])) : map applyReturns js)

49+ JSFunction s1 (Just fnName) [] $ JSBlock s2 (JSVariableIntroduction s2 arg (Just (JSApp s2 m [])) : map applyReturns js)

67 -- Desugar untilE

50 -- Desugar untilE

68− convert (JSApp (JSApp f [arg]) []) | isEffFunc C.untilE f =

51+ convert (JSApp s1 (JSApp _ f [arg]) []) | isEffFunc C.untilE f =

69− JSApp (JSFunction Nothing [] (JSBlock [ JSWhile (JSUnary Not (JSApp arg [])) (JSBlock []), JSReturn $ JSObjectLiteral []])) []

52+ JSApp s1 (JSFunction s1 Nothing [] (JSBlock s1 [ JSWhile s1 (JSUnary s1 Not (JSApp s1 arg [])) (JSBlock s1 []), JSReturn s1 $ JSObjectLiteral s1 []])) []

70 -- Desugar whileE

53 -- Desugar whileE

71− convert (JSApp (JSApp (JSApp f [arg1]) [arg2]) []) | isEffFunc C.whileE f =

54+ convert (JSApp _ (JSApp _ (JSApp s1 f [arg1]) [arg2]) []) | isEffFunc C.whileE f =

72− JSApp (JSFunction Nothing [] (JSBlock [ JSWhile (JSApp arg1 []) (JSBlock [ JSApp arg2 [] ]), JSReturn $ JSObjectLiteral []])) []

55+ JSApp s1 (JSFunction s1 Nothing [] (JSBlock s1 [ JSWhile s1 (JSApp s1 arg1 []) (JSBlock s1 [ JSApp s1 arg2 [] ]), JSReturn s1 $ JSObjectLiteral s1 []])) []

73 convert other = other

56 convert other = other

74 -- Check if an expression represents a monomorphic call to >>= for the Eff monad

57 -- 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

76 isBind _ = False

59 isBind _ = False

77− -- Check if an expression represents a monomorphic call to return for the Eff monad

60+ -- Check if an expression represents a monomorphic call to pure or return for the Eff applicative

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

61+ isPure (JSApp _ fn [dict]) | isDict (C.eff, C.applicativeEffDictionary) dict && isPurePoly fn = True

82 isPure _ = False

62 isPure _ = False

83 -- Check if an expression represents the polymorphic >>= function

63 -- 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.>>=)])

64+ isBindPoly = isFn' [(C.prelude, C.bind), (C.prelude, (C.>>=)), (C.controlBind, C.bind)]

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

65+ -- Check if an expression represents the polymorphic pure or return function

88− isRetPoly (JSAccessor returnEscaped (JSVar prelude)) = prelude == C.prelude && returnEscaped == C.returnEscaped

66+ isPurePoly = isFn' [(C.prelude, C.pure'), (C.prelude, C.return), (C.controlApplicative, C.pure')]

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

67+ -- Check if an expression represents a function in the Eff module

96− isEffFunc name (JSAccessor name' (JSVar eff)) = eff == C.eff && name == name'

68+ isEffFunc name (JSAccessor _ name' (JSVar _ eff)) = eff == C.eff && name == name'

97 isEffFunc _ _ = False

69 isEffFunc _ _ = False

98− -- Check if an expression represents the Monad Eff dictionary

70+

99− isEffDict name (JSVar ident) | ident == name = True

100− isEffDict name (JSAccessor prop (JSVar eff)) = eff == C.eff && prop == name

101− isEffDict _ _ = False

102 -- Remove __do function applications which remain after desugaring

71 -- Remove __do function applications which remain after desugaring

103 undo :: JS -> JS

72 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

105 undo other = other

74 undo other = other

106

75

107 applyReturns :: JS -> JS

76 applyReturns :: JS -> JS

108− applyReturns (JSReturn ret) = JSReturn (JSApp ret [])

77+ applyReturns (JSReturn ss ret) = JSReturn ss (JSApp ss ret [])

109− applyReturns (JSBlock jss) = JSBlock (map applyReturns jss)

78+ applyReturns (JSBlock ss jss) = JSBlock ss (map applyReturns jss)

110− applyReturns (JSWhile cond js) = JSWhile cond (applyReturns js)

79+ applyReturns (JSWhile ss cond js) = JSWhile ss cond (applyReturns js)

111− applyReturns (JSFor v lo hi js) = JSFor v lo hi (applyReturns js)

80+ applyReturns (JSFor ss v lo hi js) = JSFor ss v lo hi (applyReturns js)

112− applyReturns (JSForIn v xs js) = JSForIn v xs (applyReturns js)

81+ applyReturns (JSForIn ss v xs js) = JSForIn ss v xs (applyReturns js)

113− applyReturns (JSIfElse cond t f) = JSIfElse cond (applyReturns t) (applyReturns `fmap` f)

82+ applyReturns (JSIfElse ss cond t f) = JSIfElse ss cond (applyReturns t) (applyReturns `fmap` f)

114 applyReturns other = other

83 applyReturns other = other

115

84

116-- |

85-- |

@@ -122,7 +91,7 @@ inlineST = everywhereOnJS convertBlock

122 -- Look for runST blocks and inline the STRefs there.

91 -- Look for runST blocks and inline the STRefs there.

123 -- If all STRefs are used in the scope of the same runST, only using { read, write, modify }STRef then

92 -- If all STRefs are used in the scope of the same runST, only using { read, write, modify }STRef then

124 -- we can be more aggressive about inlining, and actually turn STRefs into local variables.

93 -- 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 =

126 let refs = nub . findSTRefsIn $ arg

95 let refs = nub . findSTRefsIn $ arg

127 usages = findAllSTUsagesIn arg

96 usages = findAllSTUsagesIn arg

128 allUsagesAreLocalVars = all (\u -> let v = toVar u in isJust v && fromJust v `elem` refs) usages

97 allUsagesAreLocalVars = all (\u -> let v = toVar u in isJust v && fromJust v `elem` refs) usages

@@ -132,34 +101,34 @@ inlineST = everywhereOnJS convertBlock

132 -- Convert a block in a safe way, preserving object wrappers of references,

101 -- Convert a block in a safe way, preserving object wrappers of references,

133 -- or in a more aggressive way, turning wrappers into local variables depending on the

102 -- or in a more aggressive way, turning wrappers into local variables depending on the

134 -- agg(ressive) parameter.

103 -- agg(ressive) parameter.

135− convert agg (JSApp f [arg]) | isSTFunc C.newSTRef f =

104+ convert agg (JSApp s1 f [arg]) | isSTFunc C.newSTRef f =

136− JSFunction Nothing [] (JSBlock [JSReturn $ if agg then arg else JSObjectLiteral [(C.stRefValue, arg)]])

105+ JSFunction s1 Nothing [] (JSBlock s1 [JSReturn s1 $ if agg then arg else JSObjectLiteral s1 [(C.stRefValue, arg)]])

137− convert agg (JSApp (JSApp f [ref]) []) | isSTFunc C.readSTRef f =

106+ convert agg (JSApp _ (JSApp s1 f [ref]) []) | isSTFunc C.readSTRef f =

138− if agg then ref else JSAccessor C.stRefValue ref

107+ if agg then ref else JSAccessor s1 C.stRefValue ref

139− convert agg (JSApp (JSApp (JSApp f [ref]) [arg]) []) | isSTFunc C.writeSTRef f =

108+ convert agg (JSApp _ (JSApp _ (JSApp s1 f [ref]) [arg]) []) | isSTFunc C.writeSTRef f =

140− if agg then JSAssignment ref arg else JSAssignment (JSAccessor C.stRefValue ref) arg

109+ if agg then JSAssignment s1 ref arg else JSAssignment s1 (JSAccessor s1 C.stRefValue ref) arg

141− convert agg (JSApp (JSApp (JSApp f [ref]) [func]) []) | isSTFunc C.modifySTRef f =

110+ convert agg (JSApp _ (JSApp _ (JSApp s1 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])

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])

143 convert _ other = other

112 convert _ other = other

144 -- Check if an expression represents a function in the ST module

113 -- 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'

146 isSTFunc _ _ = False

115 isSTFunc _ _ = False

147 -- Find all ST Refs initialized in this block

116 -- Find all ST Refs initialized in this block

148 findSTRefsIn = everythingOnJS (++) isSTRef

117 findSTRefsIn = everythingOnJS (++) isSTRef

149 where

118 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]

151 isSTRef _ = []

120 isSTRef _ = []

152 -- Find all STRefs used as arguments to readSTRef, writeSTRef, modifySTRef

121 -- Find all STRefs used as arguments to readSTRef, writeSTRef, modifySTRef

153 findAllSTUsagesIn = everythingOnJS (++) isSTUsage

122 findAllSTUsagesIn = everythingOnJS (++) isSTUsage

154 where

123 where

155− isSTUsage (JSApp (JSApp f [ref]) []) | isSTFunc C.readSTRef f = [ref]

124+ 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]

125+ isSTUsage (JSApp _ (JSApp _ (JSApp _ f [ref]) [_]) []) | isSTFunc C.writeSTRef f || isSTFunc C.modifySTRef f = [ref]

157 isSTUsage _ = []

126 isSTUsage _ = []

158 -- Find all uses of a variable

127 -- Find all uses of a variable

159 appearingIn ref = everythingOnJS (++) isVar

128 appearingIn ref = everythingOnJS (++) isVar

160 where

129 where

161− isVar e@(JSVar v) | v == ref = [e]

130+ isVar e@(JSVar _ v) | v == ref = [e]

162 isVar _ = []

131 isVar _ = []

163 -- Convert a JS value to a String if it is a JSVar

132 -- Convert a JS value to a String if it is a JSVar

164− toVar (JSVar v) = Just v

133+ toVar (JSVar _ v) = Just v

165 toVar _ = Nothing

134 toVar _ = Nothing

src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs+33−31

@@ -40,7 +40,7 @@ tco' = everywhereOnJS convert

40 copyVar arg = "__copy_" ++ arg

41

42 convert :: JS -> JS

43− convert js@(JSVariableIntroduction name (Just fn@JSFunction {})) =

43+ convert js@(JSVariableIntroduction ss name (Just fn@JSFunction {})) =

44 let

45 (argss, body', replace) = collectAllFunctionArgs [] id fn

46 in case () of

@@ -48,19 +48,19 @@ tco' = everywhereOnJS convert

48 let

49 allArgs = concat $ reverse argss

50 in

51− JSVariableIntroduction name (Just (replace (toLoop name allArgs body')))

51+ JSVariableIntroduction ss name (Just (replace (toLoop name allArgs body')))

52 | otherwise -> js

53 convert js = js

54

55 collectAllFunctionArgs :: [[String]] -> (JS -> JS) -> JS -> ([[String]], JS, JS -> JS)

56− collectAllFunctionArgs allArgs f (JSFunction ident args (JSBlock (body@(JSReturn _):_))) =

56+ collectAllFunctionArgs allArgs f (JSFunction s1 ident args (JSBlock s2 (body@(JSReturn _ _):_))) =

57− collectAllFunctionArgs (args : allArgs) (\b -> f (JSFunction ident (map copyVar args) (JSBlock [b]))) body

57+ collectAllFunctionArgs (args : allArgs) (\b -> f (JSFunction s1 ident (map copyVar args) (JSBlock s2 [b]))) body

58− collectAllFunctionArgs allArgs f (JSFunction ident args body@(JSBlock _)) =

58+ collectAllFunctionArgs allArgs f (JSFunction ss ident args body@(JSBlock _ _)) =

59− (args : allArgs, body, f . JSFunction ident (map copyVar args))

59+ (args : allArgs, body, f . JSFunction ss ident (map copyVar args))

60− collectAllFunctionArgs allArgs f (JSReturn (JSFunction ident args (JSBlock [body]))) =

60+ collectAllFunctionArgs allArgs f (JSReturn s1 (JSFunction s2 ident args (JSBlock s3 [body]))) =

61− collectAllFunctionArgs (args : allArgs) (\b -> f (JSReturn (JSFunction ident (map copyVar args) (JSBlock [b])))) body

61+ collectAllFunctionArgs (args : allArgs) (\b -> f (JSReturn s1 (JSFunction s2 ident (map copyVar args) (JSBlock s3 [b])))) body

62− collectAllFunctionArgs allArgs f (JSReturn (JSFunction ident args body@(JSBlock _))) =

62+ collectAllFunctionArgs allArgs f (JSReturn s1 (JSFunction s2 ident args body@(JSBlock _ _))) =

63− (args : allArgs, body, f . JSReturn . JSFunction ident (map copyVar args))

63+ (args : allArgs, body, f . JSReturn s1 . JSFunction s2 ident (map copyVar args))

64 collectAllFunctionArgs allArgs f body = (allArgs, body, f)

65

66 isTailCall :: String -> JS -> Bool

@@ -77,51 +77,53 @@ tco' = everywhereOnJS convert

77 && numSelfCallWithFnArgs == 0

78 where

79 countSelfCalls :: JS -> Int

80− countSelfCalls (JSApp (JSVar ident') _) | ident == ident' = 1

80+ countSelfCalls (JSApp _ (JSVar _ ident') _) | ident == ident' = 1

81 countSelfCalls _ = 0

82−

82+

83 countSelfCallsInTailPosition :: JS -> Int

84− countSelfCallsInTailPosition (JSReturn ret) | isSelfCall ident ret = 1

84+ countSelfCallsInTailPosition (JSReturn _ ret) | isSelfCall ident ret = 1

85 countSelfCallsInTailPosition _ = 0

86−

86+

87 countSelfCallsUnderFunctions :: JS -> Int

88− countSelfCallsUnderFunctions (JSFunction _ _ js') = everythingOnJS (+) countSelfCalls js'

88+ countSelfCallsUnderFunctions (JSFunction _ _ _ js') = everythingOnJS (+) countSelfCalls js'

89 countSelfCallsUnderFunctions _ = 0

90−

90+

91 countSelfCallsWithFnArgs :: JS -> Int

92 countSelfCallsWithFnArgs ret = if isSelfCallWithFnArgs ident ret [] then 1 else 0

93

94 toLoop :: String -> [String] -> JS -> JS

95− toLoop ident allArgs js = JSBlock $

95+ toLoop ident allArgs js = JSBlock rootSS $

96− map (\arg -> JSVariableIntroduction arg (Just (JSVar (copyVar arg)))) allArgs ++

96+ map (\arg -> JSVariableIntroduction rootSS arg (Just (JSVar rootSS (copyVar arg)))) allArgs ++

97− [ JSLabel tcoLabel $ JSWhile (JSBooleanLiteral True) (JSBlock [ everywhereOnJS loopify js ]) ]

97+ [ JSLabel rootSS tcoLabel $ JSWhile rootSS (JSBooleanLiteral rootSS True) (JSBlock rootSS [ everywhereOnJS loopify js ]) ]

98 where

99+ rootSS = Nothing

100+

99 loopify :: JS -> JS

101 loopify :: JS -> JS

100− loopify (JSReturn ret) | isSelfCall ident ret =

102+ loopify (JSReturn ss ret) | isSelfCall ident ret =

101 let

103 let

102 allArgumentValues = concat $ collectSelfCallArgs [] ret

104 allArgumentValues = concat $ collectSelfCallArgs [] ret

103 in

105 in

104− JSBlock $ zipWith (\val arg ->

106+ JSBlock ss $ zipWith (\val arg ->

105− JSVariableIntroduction (tcoVar arg) (Just val)) allArgumentValues allArgs

107+ JSVariableIntroduction ss (tcoVar arg) (Just val)) allArgumentValues allArgs

106 ++ map (\arg ->

108 ++ map (\arg ->

107− JSAssignment (JSVar arg) (JSVar (tcoVar arg))) allArgs

109+ JSAssignment ss (JSVar ss arg) (JSVar ss (tcoVar arg))) allArgs

108− ++ [ JSContinue tcoLabel ]

110+ ++ [ JSContinue ss tcoLabel ]

109 loopify other = other

111 loopify other = other

110 collectSelfCallArgs :: [[JS]] -> JS -> [[JS]]

112 collectSelfCallArgs :: [[JS]] -> JS -> [[JS]]

111− collectSelfCallArgs allArgumentValues (JSApp fn args') = collectSelfCallArgs (args' : allArgumentValues) fn

113+ collectSelfCallArgs allArgumentValues (JSApp _ fn args') = collectSelfCallArgs (args' : allArgumentValues) fn

112 collectSelfCallArgs allArgumentValues _ = allArgumentValues

114 collectSelfCallArgs allArgumentValues _ = allArgumentValues

113

115

114 isSelfCall :: String -> JS -> Bool

116 isSelfCall :: String -> JS -> Bool

115− isSelfCall ident (JSApp (JSVar ident') _) = ident == ident'

117+ isSelfCall ident (JSApp _ (JSVar _ ident') _) = ident == ident'

116− isSelfCall ident (JSApp fn _) = isSelfCall ident fn

118+ isSelfCall ident (JSApp _ fn _) = isSelfCall ident fn

117 isSelfCall _ _ = False

119 isSelfCall _ _ = False

118

120

119 isSelfCallWithFnArgs :: String -> JS -> [JS] -> Bool

121 isSelfCallWithFnArgs :: String -> JS -> [JS] -> Bool

120− isSelfCallWithFnArgs ident (JSVar ident') args | ident == ident' && any hasFunction args = True

122+ isSelfCallWithFnArgs ident (JSVar _ ident') args | ident == ident' && any hasFunction args = True

121− isSelfCallWithFnArgs ident (JSApp fn args) acc = isSelfCallWithFnArgs ident fn (args ++ acc)

123+ isSelfCallWithFnArgs ident (JSApp _ fn args) acc = isSelfCallWithFnArgs ident fn (args ++ acc)

122 isSelfCallWithFnArgs _ _ _ = False

124 isSelfCallWithFnArgs _ _ _ = False

123−

125+

124− hasFunction :: JS -> Bool

126+ hasFunction :: JS -> Bool

125 hasFunction = getAny . everythingOnJS mappend (Any . isFunction)

127 hasFunction = getAny . everythingOnJS mappend (Any . isFunction)

126 where

128 where

127 isFunction JSFunction{} = True

129 isFunction JSFunction{} = True

src/Language/PureScript/CodeGen/JS/Optimizer/Unused.hs+3−3

@@ -30,17 +30,17 @@ removeCodeAfterReturnStatements = everywhereOnJS (removeFromBlock go)

30 go :: [JS] -> [JS]

31 go jss | not (any isJSReturn jss) = jss

32 | otherwise = let (body, ret : _) = break isJSReturn jss in body ++ [ret]

33− isJSReturn (JSReturn _) = True

33+ isJSReturn (JSReturn _ _) = True

34 isJSReturn _ = False

35

36removeUnusedArg :: JS -> JS

37removeUnusedArg = everywhereOnJS convert

38 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

40 convert js = js

41

42removeUndefinedApp :: JS -> JS

43removeUndefinedApp = everywhereOnJS convert

44 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 []

46 convert js = js

src/Language/PureScript/Comments.hs+3−17

@@ -1,29 +1,15 @@

1−-----------------------------------------------------------------------------

1+{-# LANGUAGE TemplateHaskell #-}

2−--

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−--

11-- |

3-- |

12-- Defines the types of source code comments

4-- Defines the types of source code comments

13--

5--

14−-----------------------------------------------------------------------------

15−

16−{-# LANGUAGE DeriveDataTypeable #-}

17−{-# LANGUAGE TemplateHaskell #-}

18−

19module Language.PureScript.Comments where

6module Language.PureScript.Comments where

20

7

21import Data.Aeson.TH

8import Data.Aeson.TH

22−import qualified Data.Data as D

23

9

24data Comment

10data Comment

25 = LineComment String

11 = LineComment String

26 | BlockComment String

12 | BlockComment String

27− deriving (Show, Read, Eq, Ord, D.Data, D.Typeable)

13+ deriving (Show, Read, Eq, Ord)

28

14

29$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Comment)

15$(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−--

11-- |

1-- |

12-- Various constants which refer to things in the Prelude

2-- Various constants which refer to things in the Prelude

13--

3--

14−-----------------------------------------------------------------------------

15−

16module Language.PureScript.Constants where

4module Language.PureScript.Constants where

17

5

18-- Operators

6-- Operators

@@ -20,59 +8,110 @@ module Language.PureScript.Constants where

20($) :: String

8($) :: String

21($) = "$"

9($) = "$"

22

10

11+apply :: String

12+apply = "apply"

13+

23(#) :: String

14(#) :: String

24(#) = "#"

15(#) = "#"

25

16

17+applyFlipped :: String

18+applyFlipped = "applyFlipped"

19+

26(<>) :: String

20(<>) :: String

27(<>) = "<>"

21(<>) = "<>"

28

22

29(++) :: String

23(++) :: String

30(++) = "++"

24(++) = "++"

31

25

26+append :: String

27+append = "append"

28+

32(>>=) :: String

29(>>=) :: String

33(>>=) = ">>="

30(>>=) = ">>="

34

31

32+bind :: String

33+bind = "bind"

34+

35(+) :: String

36(+) = "+"

37

38+add :: String

39+add = "add"

40+

38(-) :: String

41(-) :: String

39(-) = "-"

42(-) = "-"

40

43

44+sub :: String

45+sub = "sub"

46+

41(*) :: String

47(*) :: String

42(*) = "*"

48(*) = "*"

43

49

50+mul :: String

51+mul = "mul"

52+

44(/) :: String

53(/) :: String

45(/) = "/"

54(/) = "/"

46

55

56+div :: String

57+div = "div"

58+

47(%) :: String

59(%) :: String

48(%) = "%"

60(%) = "%"

49

61

62+mod :: String

63+mod = "mod"

64+

50(<) :: String

65(<) :: String

51(<) = "<"

66(<) = "<"

52

67

68+lessThan :: String

69+lessThan = "lessThan"

70+

53(>) :: String

71(>) :: String

54(>) = ">"

72(>) = ">"

55

73

74+greaterThan :: String

75+greaterThan = "greaterThan"

76+

56(<=) :: String

77(<=) :: String

57(<=) = "<="

78(<=) = "<="

58

79

80+lessThanOrEq :: String

81+lessThanOrEq = "lessThanOrEq"

82+

59(>=) :: String

83(>=) :: String

60(>=) = ">="

84(>=) = ">="

61

85

86+greaterThanOrEq :: String

87+greaterThanOrEq = "greaterThanOrEq"

88+

62(==) :: String

89(==) :: String

63(==) = "=="

90(==) = "=="

64

91

92+eq :: String

93+eq = "eq"

94+

65(/=) :: String

95(/=) :: String

66(/=) = "/="

96(/=) = "/="

67

97

98+notEq :: String

99+notEq = "notEq"

100+

101+compare :: String

102+compare = "compare"

103+

68(&&) :: String

104(&&) :: String

69(&&) = "&&"

105(&&) = "&&"

70

106

107+conj :: String

108+conj = "conj"

109+

71(||) :: String

110(||) :: String

72(||) = "||"

111(||) = "||"

73

112

74−bind :: String

113+disj :: String

75−bind = "bind"

114+disj = "disj"

76

115

77unsafeIndex :: String

116unsafeIndex :: String

78unsafeIndex = "unsafeIndex"

117unsafeIndex = "unsafeIndex"

@@ -92,6 +131,12 @@ unsafeIndex = "unsafeIndex"

92compose :: String

131compose :: String

93compose = "compose"

132compose = "compose"

94

133

134+(>>>) :: String

135+(>>>) = ">>>"

136+

137+composeFlipped :: String

138+composeFlipped = "composeFlipped"

139+

95-- Functions

140-- Functions

96

141

97negate :: String

142negate :: String

@@ -100,15 +145,6 @@ negate = "negate"

100not :: String

145not :: String

101not = "not"

146not = "not"

102

147

103−conj :: String

104−conj = "conj"

105−

106−disj :: String

107−disj = "disj"

108−

109−mod :: String

110−mod = "mod"

111−

112shl :: String

148shl :: String

113shl = "shl"

149shl = "shl"

114

150

@@ -211,12 +247,21 @@ moduloSemiringNumber = "moduloSemiringNumber"

211moduloSemiringInt :: String

247moduloSemiringInt :: String

212moduloSemiringInt = "moduloSemiringInt"

248moduloSemiringInt = "moduloSemiringInt"

213

249

250+ordBoolean :: String

251+ordBoolean = "ordBoolean"

252+

214ordNumber :: String

253ordNumber :: String

215ordNumber = "ordNumber"

254ordNumber = "ordNumber"

216

255

217ordInt :: String

256ordInt :: String

218ordInt = "ordInt"

257ordInt = "ordInt"

219

258

259+ordString :: String

260+ordString = "ordString"

261+

262+ordChar :: String

263+ordChar = "ordChar"

264+

220eqNumber :: String

265eqNumber :: String

221eqNumber = "eqNumber"

266eqNumber = "eqNumber"

222

267

@@ -226,6 +271,9 @@ eqInt = "eqInt"

226eqString :: String

271eqString :: String

227eqString = "eqString"

272eqString = "eqString"

228

273

274+eqChar :: String

275+eqChar = "eqChar"

276+

229eqBoolean :: String

277eqBoolean :: String

230eqBoolean = "eqBoolean"

278eqBoolean = "eqBoolean"

231

279

@@ -285,6 +333,39 @@ eff = "Control_Monad_Eff"

285st :: String

333st :: String

286st = "Control_Monad_ST"

334st = "Control_Monad_ST"

287

335

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+

288dataFunction :: String

369dataFunction :: String

289dataFunction = "Data_Function"

370dataFunction = "Data_Function"

290

371

src/Language/PureScript/CoreFn.hs+3−14

@@ -1,17 +1,6 @@

1−-----------------------------------------------------------------------------

1+-- |

2+-- The core functional representation

2--

3--

3−-- Module : Language.PureScript.CoreFn

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−

15module Language.PureScript.CoreFn (

4module Language.PureScript.CoreFn (

16 module C

5 module C

17) where

6) where

@@ -20,7 +9,7 @@ import Language.PureScript.CoreFn.Ann as C

20import Language.PureScript.CoreFn.Binders as C

9import Language.PureScript.CoreFn.Binders as C

21import Language.PureScript.CoreFn.Desugar as C

10import Language.PureScript.CoreFn.Desugar as C

22import Language.PureScript.CoreFn.Expr as C

11import Language.PureScript.CoreFn.Expr as C

23−import Language.PureScript.CoreFn.Literals as C

12+import Language.PureScript.AST.Literals as C

24import Language.PureScript.CoreFn.Meta as C

13import Language.PureScript.CoreFn.Meta as C

25import Language.PureScript.CoreFn.Module as C

14import Language.PureScript.CoreFn.Module as C

26import Language.PureScript.CoreFn.Traversals as C

15import 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

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 #-}

16{-# LANGUAGE DeriveFunctor #-}

1{-# LANGUAGE DeriveFunctor #-}

17

2

3+-- |

4+-- The core functional representation for binders

5+--

18module Language.PureScript.CoreFn.Binders where

6module Language.PureScript.CoreFn.Binders where

19

7

20−import qualified Data.Data as D

21−

22−import Language.PureScript.CoreFn.Literals

8+import Language.PureScript.AST.Literals

23import Language.PureScript.Names

9import Language.PureScript.Names

24

10

25-- |

11-- |

@@ -39,10 +25,18 @@ data Binder a

39 --

25 --

40 | VarBinder a Ident

26 | VarBinder a Ident

41 -- |

27 -- |

42− -- A binder which matches a data constructor (type name, constructor name, binders)

28+ -- A binder which matches a data constructor

43 --

29 --

44− | ConstructorBinder a (Qualified ProperName) (Qualified ProperName) [Binder a]

30+ | ConstructorBinder a (Qualified (ProperName 'TypeName)) (Qualified (ProperName 'ConstructorName)) [Binder a]

45 -- |

31 -- |

46 -- A binder which binds its input to an identifier

32 -- A binder which binds its input to an identifier

47 --

33 --

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 @@

1module Language.PureScript.CoreFn.Desugar (moduleToCoreFn) where

2

3+import Prelude ()

4+import Prelude.Compat

5+

6+

3import Data.Function (on)

7import Data.Function (on)

4import Data.List (sort, sortBy, nub)

8import Data.List (sort, sortBy, nub)

5import Data.Maybe (mapMaybe)

9import Data.Maybe (mapMaybe)

@@ -13,7 +17,7 @@ import Language.PureScript.AST.Traversals

13import Language.PureScript.CoreFn.Ann

17import Language.PureScript.CoreFn.Ann

14import Language.PureScript.CoreFn.Binders

18import Language.PureScript.CoreFn.Binders

15import Language.PureScript.CoreFn.Expr

19import Language.PureScript.CoreFn.Expr

16−import Language.PureScript.CoreFn.Literals

20+import Language.PureScript.AST.Literals

17import Language.PureScript.CoreFn.Meta

21import Language.PureScript.CoreFn.Meta

18import Language.PureScript.CoreFn.Module

22import Language.PureScript.CoreFn.Module

19import Language.PureScript.Environment

23import Language.PureScript.Environment

@@ -30,37 +34,52 @@ moduleToCoreFn :: Environment -> A.Module -> Module Ann

30moduleToCoreFn _ (A.Module _ _ _ _ Nothing) =

34moduleToCoreFn _ (A.Module _ _ _ _ Nothing) =

31 internalError "Module exports were not elaborated before moduleToCoreFn"

35 internalError "Module exports were not elaborated before moduleToCoreFn"

32moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =

36moduleToCoreFn 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

34 exps' = nub $ concatMap exportToCoreFn exps

39 exps' = nub $ concatMap exportToCoreFn exps

35 externs = nub $ mapMaybe externToCoreFn decls

40 externs = nub $ mapMaybe externToCoreFn decls

36 decls' = concatMap (declToCoreFn Nothing []) decls

41 decls' = concatMap (declToCoreFn Nothing []) decls

37− in Module coms mn imports exps' externs decls'

42+ in Module coms mn imports' exps' externs decls'

38

43

39 where

44 where

40

45

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+

41 -- |

59 -- |

42 -- Desugars member declarations from AST to CoreFn representation.

60 -- Desugars member declarations from AST to CoreFn representation.

43 --

61 --

44 declToCoreFn :: Maybe SourceSpan -> [Comment] -> A.Declaration -> [Bind Ann]

62 declToCoreFn :: Maybe SourceSpan -> [Comment] -> A.Declaration -> [Bind Ann]

45 declToCoreFn ss com (A.DataDeclaration Newtype _ _ [(ctor, _)]) =

63 declToCoreFn ss com (A.DataDeclaration Newtype _ _ [(ctor, _)]) =

46− [NonRec (properToIdent ctor) $

64+ [NonRec (ssA ss) (properToIdent ctor) $

47 Abs (ss, com, Nothing, Just IsNewtype) (Ident "x") (Var nullAnn $ Qualified Nothing (Ident "x"))]

65 Abs (ss, com, Nothing, Just IsNewtype) (Ident "x") (Var nullAnn $ Qualified Nothing (Ident "x"))]

48 declToCoreFn _ _ d@(A.DataDeclaration Newtype _ _ _) =

66 declToCoreFn _ _ d@(A.DataDeclaration Newtype _ _ _) =

49 error $ "Found newtype with multiple constructors: " ++ show d

67 error $ "Found newtype with multiple constructors: " ++ show d

50 declToCoreFn ss com (A.DataDeclaration Data tyName _ ctors) =

68 declToCoreFn ss com (A.DataDeclaration Data tyName _ ctors) =

51 flip map ctors $ \(ctor, _) ->

69 flip map ctors $ \(ctor, _) ->

52 let (_, _, _, fields) = lookupConstructor env (Qualified (Just mn) ctor)

70 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

54 declToCoreFn ss _ (A.DataBindingGroupDeclaration ds) = concatMap (declToCoreFn ss []) ds

72 declToCoreFn ss _ (A.DataBindingGroupDeclaration ds) = concatMap (declToCoreFn ss []) ds

55 declToCoreFn ss com (A.ValueDeclaration name _ _ (Right e)) =

73 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)]

57 declToCoreFn ss com (A.FixityDeclaration _ name (Just alias)) =

75 declToCoreFn ss com (A.FixityDeclaration _ name (Just alias)) =

58− let qname = Qualified (Just mn) alias

76+ let meta = either getValueMeta (Just . getConstructorMeta) alias

77+ alias' = either id (fmap properToIdent) alias

59− in [NonRec (Op name) (Var (ss, com, Nothing, getValueMeta qname) (Qualified Nothing alias))]

78+ in [NonRec (ssA ss) (Op name) (Var (ss, com, Nothing, meta) alias')]

60 declToCoreFn ss _ (A.BindingGroupDeclaration ds) =

79 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]

62 declToCoreFn ss com (A.TypeClassDeclaration name _ supers members) =

81 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]

64 declToCoreFn _ com (A.PositionedDeclaration ss com1 d) =

83 declToCoreFn _ com (A.PositionedDeclaration ss com1 d) =

65 declToCoreFn (Just ss) (com ++ com1) d

84 declToCoreFn (Just ss) (com ++ com1) d

66 declToCoreFn _ _ _ = []

85 declToCoreFn _ _ _ = []

@@ -69,18 +88,8 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =

69 -- Desugars expressions from AST to CoreFn representation.

88 -- Desugars expressions from AST to CoreFn representation.

70 --

89 --

71 exprToCoreFn :: Maybe SourceSpan -> [Comment] -> Maybe Type -> A.Expr -> Expr Ann

90 exprToCoreFn :: Maybe SourceSpan -> [Comment] -> Maybe Type -> A.Expr -> Expr Ann

72− exprToCoreFn ss com ty (A.NumericLiteral v) =

91+ exprToCoreFn ss com ty (A.Literal lit) =

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)

92+ Literal (ss, com, ty, Nothing) (fmap (exprToCoreFn ss com Nothing) lit)

82− exprToCoreFn ss com ty (A.ObjectLiteral vs) =

83− Literal (ss, com, ty, Nothing) (ObjectLiteral $ map (second (exprToCoreFn ss [] Nothing)) vs)

84 exprToCoreFn ss com ty (A.Accessor name v) =

93 exprToCoreFn ss com ty (A.Accessor name v) =

85 Accessor (ss, com, ty, Nothing) name (exprToCoreFn ss [] Nothing v)

94 Accessor (ss, com, ty, Nothing) name (exprToCoreFn ss [] Nothing v)

86 exprToCoreFn ss com ty (A.ObjectUpdate obj vs) =

95 exprToCoreFn ss com ty (A.ObjectUpdate obj vs) =

@@ -107,7 +116,7 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =

107 exprToCoreFn ss com (Just ty) v

116 exprToCoreFn ss com (Just ty) v

108 exprToCoreFn ss com ty (A.Let ds v) =

117 exprToCoreFn ss com ty (A.Let ds v) =

109 Let (ss, com, ty, Nothing) (concatMap (declToCoreFn ss []) ds) (exprToCoreFn ss [] Nothing v)

118 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)) _)) =

111 let args = map (exprToCoreFn ss [] Nothing . snd) $ sortBy (compare `on` fst) vs

120 let args = map (exprToCoreFn ss [] Nothing . snd) $ sortBy (compare `on` fst) vs

112 ctor = Var (ss, [], Nothing, Just IsTypeClassConstructor) (fmap properToIdent name)

121 ctor = Var (ss, [], Nothing, Just IsTypeClassConstructor) (fmap properToIdent name)

113 in foldl (App (ss, com, Nothing, Nothing)) ctor args

122 in foldl (App (ss, com, Nothing, Nothing)) ctor args

@@ -133,31 +142,27 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =

133 -- Desugars case binders from AST to CoreFn representation.

142 -- Desugars case binders from AST to CoreFn representation.

134 --

143 --

135 binderToCoreFn :: Maybe SourceSpan -> [Comment] -> A.Binder -> Binder Ann

144 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)

136 binderToCoreFn ss com (A.NullBinder) =

147 binderToCoreFn ss com (A.NullBinder) =

137 NullBinder (ss, com, Nothing, Nothing)

148 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)

146 binderToCoreFn ss com (A.VarBinder name) =

149 binderToCoreFn ss com (A.VarBinder name) =

147 VarBinder (ss, com, Nothing, Nothing) name

150 VarBinder (ss, com, Nothing, Nothing) name

148 binderToCoreFn ss com (A.ConstructorBinder dctor@(Qualified mn' _) bs) =

151 binderToCoreFn ss com (A.ConstructorBinder dctor@(Qualified mn' _) bs) =

149 let (_, tctor, _, _) = lookupConstructor env dctor

152 let (_, tctor, _, _) = lookupConstructor env dctor

150 in ConstructorBinder (ss, com, Nothing, Just $ getConstructorMeta dctor) (Qualified mn' tctor) dctor (map (binderToCoreFn ss []) bs)

153 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)

155 binderToCoreFn ss com (A.NamedBinder name b) =

154 binderToCoreFn ss com (A.NamedBinder name b) =

156 NamedBinder (ss, com, Nothing, Nothing) name (binderToCoreFn ss [] b)

155 NamedBinder (ss, com, Nothing, Nothing) name (binderToCoreFn ss [] b)

157 binderToCoreFn _ com (A.PositionedBinder ss com1 b) =

156 binderToCoreFn _ com (A.PositionedBinder ss com1 b) =

158 binderToCoreFn (Just ss) (com ++ com1) b

157 binderToCoreFn (Just ss) (com ++ com1) b

159 binderToCoreFn ss com (A.TypedBinder _ b) =

158 binderToCoreFn ss com (A.TypedBinder _ b) =

160 binderToCoreFn ss com b

159 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"

161

166

162 -- |

167 -- |

163 -- Gets metadata for values.

168 -- Gets metadata for values.

@@ -171,7 +176,7 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =

171 -- |

176 -- |

172 -- Gets metadata for data constructors.

177 -- Gets metadata for data constructors.

173 --

178 --

174− getConstructorMeta :: Qualified ProperName -> Meta

179+ getConstructorMeta :: Qualified (ProperName 'ConstructorName) -> Meta

175 getConstructorMeta ctor =

180 getConstructorMeta ctor =

176 case lookupConstructor env ctor of

181 case lookupConstructor env ctor of

177 (Newtype, _, _, _) -> IsNewtype

182 (Newtype, _, _, _) -> IsNewtype

@@ -179,9 +184,15 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =

179 let constructorType = if numConstructors (ctor, dc) == 1 then ProductType else SumType

184 let constructorType = if numConstructors (ctor, dc) == 1 then ProductType else SumType

180 in IsConstructor constructorType fields

185 in IsConstructor constructorType fields

181 where

186 where

187+

188+ numConstructors

182− numConstructors :: (Qualified ProperName, (DataDeclType, ProperName, Type, [Ident])) -> Int

189+ :: (Qualified (ProperName 'ConstructorName), (DataDeclType, ProperName 'TypeName, Type, [Ident]))

190+ -> Int

183 numConstructors ty = length $ filter (((==) `on` typeConstructor) ty) $ M.toList $ dataConstructors env

191 numConstructors ty = length $ filter (((==) `on` typeConstructor) ty) $ M.toList $ dataConstructors env

192+

193+ typeConstructor

184− typeConstructor :: (Qualified ProperName, (DataDeclType, ProperName, Type, [Ident])) -> (ModuleName, ProperName)

194+ :: (Qualified (ProperName 'ConstructorName), (DataDeclType, ProperName 'TypeName, Type, [Ident]))

195+ -> (ModuleName, ProperName 'TypeName)

185 typeConstructor (Qualified (Just mn') _, (_, tyCtor, _, _)) = (mn', tyCtor)

196 typeConstructor (Qualified (Just mn') _, (_, tyCtor, _, _)) = (mn', tyCtor)

186 typeConstructor _ = internalError "Invalid argument to typeConstructor"

197 typeConstructor _ = internalError "Invalid argument to typeConstructor"

187

198

@@ -190,30 +201,36 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =

190-- ensure instances are imported from any module that is referenced by the

201-- ensure instances are imported from any module that is referenced by the

191-- current module, not just from those that are imported explicitly (#667).

202-- current module, not just from those that are imported explicitly (#667).

192--

203--

193−findQualModules :: [A.Declaration] -> [ModuleName]

204+findQualModules :: [A.Declaration] -> [(Ann, ModuleName)]

194findQualModules decls =

205findQualModules decls =

195 let (f, _, _, _, _) = everythingOnValues (++) fqDecls fqValues fqBinders (const []) (const [])

206 let (f, _, _, _, _) = everythingOnValues (++) fqDecls fqValues fqBinders (const []) (const [])

196 in f `concatMap` decls

207 in f `concatMap` decls

197 where

208 where

198− fqDecls :: A.Declaration -> [ModuleName]

209+ fqDecls :: A.Declaration -> [(Ann, ModuleName)]

199− fqDecls (A.TypeInstanceDeclaration _ _ (Qualified (Just mn) _) _ _) = [mn]

210+ fqDecls (A.TypeInstanceDeclaration _ _ q _ _) = getQual q

211+ fqDecls (A.FixityDeclaration _ _ (Just eq)) = either getQual getQual eq

200 fqDecls _ = []

212 fqDecls _ = []

201

213

202− fqValues :: A.Expr -> [ModuleName]

214+ fqValues :: A.Expr -> [(Ann, ModuleName)]

203− fqValues (A.Var (Qualified (Just mn) _)) = [mn]

215+ fqValues (A.Var q) = getQual q

204− fqValues (A.Constructor (Qualified (Just mn) _)) = [mn]

216+ fqValues (A.Constructor q) = getQual q

205 fqValues _ = []

217 fqValues _ = []

206

218

207− fqBinders :: A.Binder -> [ModuleName]

219+ fqBinders :: A.Binder -> [(Ann, ModuleName)]

208− fqBinders (A.ConstructorBinder (Qualified (Just mn) _) _) = [mn]

220+ fqBinders (A.ConstructorBinder q _) = getQual q

209 fqBinders _ = []

221 fqBinders _ = []

210

222

223+ getQual :: Qualified a -> [(Ann, ModuleName)]

224+ getQual (Qualified (Just mn) _) = [(nullAnn, mn)]

225+ getQual _ = []

226+

211-- |

227-- |

212-- Desugars import declarations from AST to CoreFn representation.

228-- Desugars import declarations from AST to CoreFn representation.

213--

229--

214−importToCoreFn :: A.Declaration -> Maybe ModuleName

230+importToCoreFn :: A.Declaration -> Maybe (Ann, ModuleName)

215−importToCoreFn (A.ImportDeclaration name _ _ _) = Just name

231+importToCoreFn (A.ImportDeclaration name _ _ _) = Just (nullAnn, name)

216−importToCoreFn (A.PositionedDeclaration _ _ d) = importToCoreFn d

232+importToCoreFn (A.PositionedDeclaration ss _ d) =

233+ ((,) (Just ss, [], Nothing, Nothing) . snd) <$> importToCoreFn d

217importToCoreFn _ = Nothing

234importToCoreFn _ = Nothing

218

235

219-- |

236-- |

@@ -255,5 +272,5 @@ mkTypeClassConstructor ss com supers members =

255-- |

272-- |

256-- Converts a ProperName to an Ident.

273-- Converts a ProperName to an Ident.

257--

274--

258−properToIdent :: ProperName -> Ident

275+properToIdent :: ProperName a -> Ident

259properToIdent = Ident . runProperName

276properToIdent = Ident . runProperName

src/Language/PureScript/CoreFn/Expr.hs+10−23

@@ -1,28 +1,14 @@

1−-----------------------------------------------------------------------------

2−--

3−-- Module : Language.PureScript.CoreFn.Expr

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 #-}

16{-# LANGUAGE DeriveFunctor #-}

1{-# LANGUAGE DeriveFunctor #-}

17

2

3+-- |

4+-- The core functional representation

5+--

18module Language.PureScript.CoreFn.Expr where

6module Language.PureScript.CoreFn.Expr where

19

7

20import Control.Arrow ((***))

8import Control.Arrow ((***))

21

9

22−import qualified Data.Data as D

23−

24import Language.PureScript.CoreFn.Binders

10import Language.PureScript.CoreFn.Binders

25−import Language.PureScript.CoreFn.Literals

11+import Language.PureScript.AST.Literals

26import Language.PureScript.Names

12import Language.PureScript.Names

27

13

28-- |

14-- |

@@ -36,7 +22,7 @@ data Expr a

36 -- |

22 -- |

37 -- A data constructor (type name, constructor name, field names)

23 -- A data constructor (type name, constructor name, field names)

38 --

24 --

39− | Constructor a ProperName ProperName [Ident]

25+ | Constructor a (ProperName 'TypeName) (ProperName 'ConstructorName) [Ident]

40 -- |

26 -- |

41 -- A record property accessor

27 -- A record property accessor

42 --

28 --

@@ -64,7 +50,8 @@ data Expr a

64 -- |

50 -- |

65 -- A let binding

51 -- A let binding

66 --

52 --

53+ | Let a [Bind a] (Expr a)

67− | Let a [Bind a] (Expr a) deriving (Show, Read, D.Data, D.Typeable, Functor)

54+ deriving (Show, Read, Functor)

68

55

69-- |

56-- |

70-- A let or module binding.

57-- A let or module binding.

@@ -73,11 +60,11 @@ data Bind a

73 -- |

60 -- |

74 -- Non-recursive binding for a single value

61 -- Non-recursive binding for a single value

75 --

62 --

76− = NonRec Ident (Expr a)

63+ = NonRec a Ident (Expr a)

77 -- |

64 -- |

78 -- Mutually recursive binding group for several values

65 -- Mutually recursive binding group for several values

79 --

66 --

80− | Rec [(Ident, Expr a)] deriving (Show, Read, D.Data, D.Typeable, Functor)

67+ | Rec [((a, Ident), Expr a)] deriving (Show, Read, Functor)

81

68

82-- |

69-- |

83-- A guard is just a boolean-valued expression that appears alongside a set of binders

70-- A guard is just a boolean-valued expression that appears alongside a set of binders

@@ -96,7 +83,7 @@ data CaseAlternative a = CaseAlternative

96 -- The result expression or a collect of guarded expressions

83 -- The result expression or a collect of guarded expressions

97 --

84 --

98 , caseAlternativeResult :: Either [(Guard a, Expr a)] (Expr a)

85 , caseAlternativeResult :: Either [(Guard a, Expr a)] (Expr a)

99− } deriving (Show, Read, D.Data, D.Typeable)

86+ } deriving (Show, Read)

100

87

101instance Functor CaseAlternative where

88instance Functor CaseAlternative where

102

89

src/Language/PureScript/CoreFn/Literals.hsdeleted−50

@@ -1,50 +0,0 @@

1−-----------------------------------------------------------------------------

2−--

3−-- Module : Language.PureScript.CoreFn.Literals

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−-----------------------------------------------------------------------------

1+-- |

2−--

3−-- Module : Language.PureScript.CoreFn.Meta

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

2+-- Metadata annotations for core functional representation

12--

3--

13−-----------------------------------------------------------------------------

14−

15−{-# LANGUAGE DeriveDataTypeable #-}

16−

17module Language.PureScript.CoreFn.Meta where

4module Language.PureScript.CoreFn.Meta where

18

5

19−import qualified Data.Data as D

20−

21import Language.PureScript.Names

6import Language.PureScript.Names

22

7

23-- |

8-- |

@@ -39,7 +24,7 @@ data Meta

39 -- |

24 -- |

40 -- The contained reference is for a foreign member

25 -- The contained reference is for a foreign member

41 --

26 --

42− | IsForeign deriving (Show, Read, D.Data, D.Typeable)

27+ | IsForeign deriving (Show, Read, Eq)

43

28

44-- |

29-- |

45-- Data constructor metadata

30-- Data constructor metadata

@@ -52,4 +37,4 @@ data ConstructorType

52 -- |

37 -- |

53 -- The constructor is for a type with multiple construcors

38 -- The constructor is for a type with multiple construcors

54 --

39 --

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

22data Module a = Module

23 { moduleComments :: [Comment]

24 , moduleName :: ModuleName

25− , moduleImports :: [ModuleName]

25+ , moduleImports :: [(a, ModuleName)]

26 , moduleExports :: [Ident]

27 , moduleForeign :: [ForeignDecl]

28 , moduleDecls :: [Bind a]

src/Language/PureScript/CoreFn/Traversals.hs+6−16

@@ -1,24 +1,13 @@

1−-----------------------------------------------------------------------------

1+-- |

2+-- CoreFn traversal helpers

2--

3--

3−-- Module : Language.PureScript.CoreFn.Traversals

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−

15module Language.PureScript.CoreFn.Traversals where

4module Language.PureScript.CoreFn.Traversals where

16

5

17import Control.Arrow (second, (***), (+++))

6import Control.Arrow (second, (***), (+++))

18

7

19import Language.PureScript.CoreFn.Binders

8import Language.PureScript.CoreFn.Binders

20import Language.PureScript.CoreFn.Expr

9import Language.PureScript.CoreFn.Expr

21−import Language.PureScript.CoreFn.Literals

10+import Language.PureScript.AST.Literals

22

11

23everywhereOnValues :: (Bind a -> Bind a) ->

12everywhereOnValues :: (Bind a -> Bind a) ->

24 (Expr a -> Expr a) ->

13 (Expr a -> Expr a) ->

@@ -26,7 +15,7 @@ everywhereOnValues :: (Bind a -> Bind a) ->

26 (Bind a -> Bind a, Expr a -> Expr a, Binder a -> Binder a)

15 (Bind a -> Bind a, Expr a -> Expr a, Binder a -> Binder a)

27everywhereOnValues f g h = (f', g', h')

16everywhereOnValues f g h = (f', g', h')

28 where

17 where

29− f' (NonRec name e) = f (NonRec name (g' e))

18+ f' (NonRec a name e) = f (NonRec a name (g' e))

30 f' (Rec es) = f (Rec (map (second g') es))

19 f' (Rec es) = f (Rec (map (second g') es))

31

20

32 g' (Literal ann e) = g (Literal ann (handleLiteral g' e))

21 g' (Literal ann e) = g (Literal ann (handleLiteral g' e))

@@ -40,6 +29,7 @@ everywhereOnValues f g h = (f', g', h')

40

29

41 h' (LiteralBinder a b) = h (LiteralBinder a (handleLiteral h' b))

30 h' (LiteralBinder a b) = h (LiteralBinder a (handleLiteral h' b))

42 h' (NamedBinder a name b) = h (NamedBinder a name (h' b))

31 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))

43 h' b = h b

33 h' b = h b

44

34

45 handleCaseAlternative ca =

35 handleCaseAlternative ca =

@@ -60,7 +50,7 @@ everythingOnValues :: (r -> r -> r) ->

60 (Bind a -> r, Expr a -> r, Binder a -> r, CaseAlternative a -> r)

50 (Bind a -> r, Expr a -> r, Binder a -> r, CaseAlternative a -> r)

61everythingOnValues (<>) f g h i = (f', g', h', i')

51everythingOnValues (<>) f g h i = (f', g', h', i')

62 where

52 where

63− f' b@(NonRec _ e) = f b <> g' e

53+ f' b@(NonRec _ _ e) = f b <> g' e

64 f' b@(Rec es) = foldl (<>) (f b) (map (g' . snd) es)

54 f' b@(Rec es) = foldl (<>) (f b) (map (g' . snd) es)

65

55

66 g' v@(Literal _ l) = foldl (<>) (g v) (map g' (extractLiteral l))

56 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

11import Language.PureScript.Docs.RenderedCode.Render as Docs

12import Language.PureScript.Docs.Convert as Docs

13import 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 @@

1{-# LANGUAGE RecordWildCards #-}

2+{-# LANGUAGE FlexibleContexts #-}

2

3

3−module Language.PureScript.Docs.AsMarkdown (

4+module Language.PureScript.Docs.AsMarkdown

4− renderModulesAsMarkdown

5+ ( renderModulesAsMarkdown

6+ , Docs

7+ , runDocs

8+ , modulesAsMarkdown

5−) where

9+ ) where

6

10

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)

8import Data.Foldable (for_)

17import Data.Foldable (for_)

9import Data.List (partition)

18import Data.List (partition)

10

19

@@ -19,33 +28,41 @@ import qualified Language.PureScript.Docs.Render as Render

19-- Take a list of modules and render them all in order, returning a single

28-- Take a list of modules and render them all in order, returning a single

20-- Markdown-formatted String.

29-- Markdown-formatted String.

21--

30--

22−renderModulesAsMarkdown :: [P.Module] -> String

31+renderModulesAsMarkdown ::

32+ (MonadError P.MultipleErrors m) =>

33+ [P.Module] ->

34+ m String

23renderModulesAsMarkdown =

35renderModulesAsMarkdown =

24− runDocs . modulesAsMarkdown . map Convert.convertModule

36+ fmap (runDocs . modulesAsMarkdown) . Convert.convertModules

25

37

26modulesAsMarkdown :: [Module] -> Docs

38modulesAsMarkdown :: [Module] -> Docs

27modulesAsMarkdown = mapM_ moduleAsMarkdown

39modulesAsMarkdown = mapM_ moduleAsMarkdown

28

40

29moduleAsMarkdown :: Module -> Docs

41moduleAsMarkdown :: Module -> Docs

30moduleAsMarkdown Module{..} = do

42moduleAsMarkdown Module{..} = do

31− headerLevel 2 $ "Module " ++ modName

43+ headerLevel 2 $ "Module " ++ P.runModuleName modName

32 spacer

44 spacer

33 for_ modComments tell'

45 for_ modComments tell'

34− mapM_ declAsMarkdown modDeclarations

46+ mapM_ (declAsMarkdown modName) modDeclarations

35 spacer

47 spacer

48+ for_ modReExports $ \(mn, decls) -> do

49+ headerLevel 3 $ "Re-exported from " ++ P.runModuleName mn ++ ":"

50+ spacer

51+ mapM_ (declAsMarkdown mn) decls

36

52

37−declAsMarkdown :: Declaration -> Docs

53+declAsMarkdown :: P.ModuleName -> Declaration -> Docs

38−declAsMarkdown decl@Declaration{..} = do

54+declAsMarkdown mn decl@Declaration{..} = do

55+ let options = defaultRenderTypeOptions { currentModule = Just mn }

39 headerLevel 4 (ticks declTitle)

56 headerLevel 4 (ticks declTitle)

40 spacer

57 spacer

41

58

42 let (instances, children) = partition (isChildInstance . cdeclInfo) declChildren

59 let (instances, children) = partition (isChildInstance . cdeclInfo) declChildren

43 fencedBlock $ do

60 fencedBlock $ do

44− tell' (codeToString $ Render.renderDeclaration decl)

61+ tell' (codeToString $ Render.renderDeclarationWithOptions options decl)

45 zipWithM_ (\f c -> tell' (childToString f c)) (First : repeat NotFirst) children

62 zipWithM_ (\f c -> tell' (childToString f c)) (First : repeat NotFirst) children

46 spacer

63 spacer

47

64

48− for_ declFixity (\(fixity, alias) -> fixityAsMarkdown fixity alias >> spacer)

65+ for_ declFixity (\fixity -> fixityAsMarkdown fixity >> spacer)

49

66

50 for_ declComments tell'

67 for_ declComments tell'

51

68

@@ -68,11 +85,9 @@ codeToString = outputWith elemAsMarkdown

68 elemAsMarkdown (Keyword x) = x

85 elemAsMarkdown (Keyword x) = x

69 elemAsMarkdown Space = " "

86 elemAsMarkdown Space = " "

70

87

71−fixityAsMarkdown :: P.Fixity -> Maybe String -> Docs

88+fixityAsMarkdown :: P.Fixity -> Docs

72−fixityAsMarkdown (P.Fixity associativity precedence) alias =

89+fixityAsMarkdown (P.Fixity associativity precedence) =

73− -- TODO: link alias name to member

74 tell' $ concat [ "_"

90 tell' $ concat [ "_"

75− , maybe "" (\i -> "alias for " ++ i ++ " - ") alias

76 , associativityStr

91 , associativityStr

77 , " / precedence "

92 , " / precedence "

78 , show precedence

93 , show precedence

src/Language/PureScript/Docs/Convert.hs+160−193

@@ -2,228 +2,195 @@

2{-# LANGUAGE OverloadedStrings #-}

3{-# LANGUAGE RecordWildCards #-}

4{-# LANGUAGE ViewPatterns #-}

5+{-# LANGUAGE FlexibleContexts #-}

5

6

6-- | Functions for converting PureScript ASTs into values of the data types

7-- | Functions for converting PureScript ASTs into values of the data types

7-- from Language.PureScript.Docs.

8-- from Language.PureScript.Docs.

8

9

9module Language.PureScript.Docs.Convert

10module Language.PureScript.Docs.Convert

10− ( convertModule

11+ ( convertModules

12+ , convertModulesInPackage

11 , collectBookmarks

13 , collectBookmarks

12 ) where

14 ) where

13

15

14import Prelude ()

16import Prelude ()

15import Prelude.Compat

17import Prelude.Compat

16

18

17−import Control.Monad

19+import Control.Arrow ((&&&), second)

18import Control.Category ((>>>))

20import Control.Category ((>>>))

19−import Data.Either

21+import Control.Monad

20−import Data.Maybe (mapMaybe, isNothing)

22+import Control.Monad.State (runStateT)

21−import Data.List (nub, isPrefixOf, isSuffixOf)

23+import Control.Monad.Writer.Strict (runWriterT)

24+import Control.Monad.Error.Class (MonadError)

25+import qualified Data.Map as Map

22

26

27+import Text.Parsec (eof)

23import qualified Language.PureScript as P

28import qualified Language.PureScript as P

29+import qualified Language.PureScript.Constants as C

24

30

25import Language.PureScript.Docs.Types

31import Language.PureScript.Docs.Types

32+import Language.PureScript.Docs.Convert.Single (convertSingleModule, collectBookmarks)

33+import Language.PureScript.Docs.Convert.ReExports (updateReExports)

26

34

27-- |

35-- |

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.

29--

39--

30−convertModule :: P.Module -> Module

40+convertModulesInPackage ::

31−convertModule m@(P.Module _ coms moduleName _ _) =

41+ (MonadError P.MultipleErrors m) =>

32− Module (P.runModuleName moduleName) comments (declarations m)

42+ [InPackage P.Module] ->

43+ m [Module]

44+convertModulesInPackage modules =

45+ go modules

33 where

46 where

34− comments = convertComments coms

47+ localNames =

35− declarations =

48+ map P.getModuleName (takeLocals modules)

36− P.exportedDeclarations

49+ go =

37− >>> mapMaybe (\d -> getDeclarationTitle d >>= convertDeclaration d)

50+ map ignorePackage

38− >>> augmentDeclarations

51+ >>> convertModules

39− >>> map addDefaultFixity

52+ >>> fmap (filter ((`elem` localNames) . modName))

40−

53+

41−-- | The data type for an intermediate stage which we go through during

54+-- |

42−-- converting.

55+-- Convert a group of modules to the intermediate format, designed for

43−--

56+-- producing documentation from. It is also necessary to pass an Env containing

44−-- In the first pass, we take all top level declarations in the module, and

57+-- imports/exports information about the list of modules, which is needed for

45−-- collect other information which will later be used to augment the top level

58+-- documenting re-exports.

46−-- declarations. These two situation correspond to the Right and Left

47−-- constructors, respectively.

48--

59--

49−-- In the second pass, we go over all of the Left values and augment the

60+-- Note that the whole module dependency graph must be included in the list; if

50−-- relevant declarations, leaving only the augmented Right values.

61+-- some modules import things from other modules, then those modules must also

62+-- be included.

51--

63--

52−-- Note that in the Left case, we provide a [String] as well as augment

64+-- For value declarations, if explicit type signatures are omitted, or a

53−-- information. The [String] value should be a list of titles of declarations

65+-- wildcard type is used, then we typecheck the modules and use the inferred

54−-- that the augmentation should apply to. For example, for a type instance

66+-- types.

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--

67--

64−-- The AugmentChild constructor allows us to move all children under their

68+convertModules ::

65−-- respective parents. It is only necessary for type instance declarations,

69+ (MonadError P.MultipleErrors m) =>

66−-- since they appear at the top level in the AST, and since they might need to

70+ [P.Module] ->

67−-- appear as children in two places (for example, if a data type defined in a

71+ m [Module]

68−-- module is an instance of a type class also defined in that 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.

69--

82--

70−-- The AugmentFixity constructor allows us to augment operator definitions

83+convertSorted ::

71−-- with their associativity and precedence.

84+ (MonadError P.MultipleErrors m) =>

72−data DeclarationAugment

85+ [P.Module] ->

73− = AugmentChild ChildDeclaration

86+ m [Module]

74− | AugmentFixity P.Fixity (Maybe P.Ident)

87+convertSorted modules = do

75−

88+ (env, convertedModules) <- second (map convertSingleModule) <$> partiallyDesugar modules

76−-- | Augment top-level declarations; the second pass. See the comments under

89+

77−-- the type synonym IntermediateDeclaration for more information.

90+ modulesWithTypes <- typeCheckIfNecessary modules convertedModules

78−augmentDeclarations :: [IntermediateDeclaration] -> [Declaration]

91+ let moduleMap = Map.fromList (map (modName &&& id) modulesWithTypes)

79−augmentDeclarations (partitionEithers -> (augments, toplevels)) =

92+

80− foldl go toplevels augments

93+ let traversalOrder = map P.getModuleName modules

81− where

94+ pure (Map.elems (updateReExports env traversalOrder moduleMap))

82− go ds (parentTitles, a) =

95+

83− map (\d ->

96+-- |

84− if declTitle d `elem` parentTitles

97+-- If any exported value declarations have either wildcard type signatures, or

85− then augmentWith a d

98+-- none at all, then typecheck in order to fill them in with the inferred

86− else d) ds

99+-- types.

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.

97--

100--

98−-- TODO: This may no longer be necessary after issue 806 is resolved, hopefully

101+typeCheckIfNecessary ::

99−-- in 0.9.

102+ (MonadError P.MultipleErrors m) =>

100−addDefaultFixity :: Declaration -> Declaration

103+ [P.Module] ->

101−addDefaultFixity decl@Declaration{..}

104+ [Module] ->

102− | isOp declTitle && isNothing declFixity =

105+ m [Module]

103− decl { declFixity = Just (defaultFixity, Nothing) }

106+typeCheckIfNecessary modules convertedModules =

104− | otherwise =

107+ if any hasWildcards convertedModules

105− decl

108+ then go

106− where

109+ else pure convertedModules

107− isOp :: String -> Bool

110+

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)

204 where

111 where

205− go = unlines . map stripPipes

112+ hasWildcards =

113+ any ((==) (ValueDeclaration P.TypeWildcard) . declInfo) . modDeclarations

206

114

207− toLines (P.LineComment s) = [s]

115+ go = do

208− toLines (P.BlockComment s) = lines s

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

209

133

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)

211

139

212− stripPipes = dropPipe . dropWhile (== ' ')

140+ ignoreWarnings =

141+ fmap fst . runWriterT

213

142

214− dropPipe ('|':' ':s) = s

143+-- |

215− dropPipe ('|':s) = s

144+-- Updates all the types of the ValueDeclarations inside the module based on

216− dropPipe s = s

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

217

179

218−-- | Go through a PureScript module and extract a list of Bookmarks; references

180+-- |

219−-- to data types or values, to be used as a kind of index. These are used for

181+-- Partially desugar modules so that they are suitable for extracting

220−-- generating links in the HTML documentation, for example.

182+-- documentation information from.

221−collectBookmarks :: InPackage P.Module -> [Bookmark]

183+--

222−collectBookmarks (Local m) = map Local (collectBookmarks' m)

184+partiallyDesugar ::

223−collectBookmarks (FromDep pkg m) = map (FromDep pkg) (collectBookmarks' m)

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 []

224

195

225−collectBookmarks' :: P.Module -> [(P.ModuleName, String)]

196+ ignoreWarnings = fmap fst . runWriterT

226−collectBookmarks' m =

227− map (P.getModuleName m, )

228− (mapMaybe getDeclarationTitle

229− (P.exportedDeclarations m))

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{..} =

49 [ keywordClass ]

50 ++ maybeToList superclasses

51 ++ [renderType' (typeApp declTitle args)]

52− ++ [keywordWhere | any (isTypeClassMember . cdeclInfo) declChildren]

52+ ++ [keywordWhere | any isTypeClassMember declChildren]

53

54 where

55 superclasses

@@ -58,11 +58,23 @@ renderDeclarationWithOptions opts Declaration{..} =

58 syntax "("

59 <> mintersperse (syntax "," <> sp) (map renderConstraint implies)

60 <> 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+ ]

61

72

62− isTypeClassMember (ChildTypeClassMember _) = True

63− isTypeClassMember _ = False

64 where

73 where

65 renderType' = renderTypeWithOptions opts

74 renderType' = renderTypeWithOptions opts

75+ dequalifyCurrentModule (P.Qualified mn a)

76+ | mn == currentModule opts = P.Qualified Nothing a

77+ | otherwise = P.Qualified mn a

66

78

67renderChildDeclaration :: ChildDeclaration -> RenderedCode

79renderChildDeclaration :: ChildDeclaration -> RenderedCode

68renderChildDeclaration = renderChildDeclarationWithOptions defaultRenderTypeOptions

80renderChildDeclaration = renderChildDeclarationWithOptions defaultRenderTypeOptions

@@ -86,12 +98,12 @@ renderChildDeclarationWithOptions opts ChildDeclaration{..} =

86 where

98 where

87 renderType' = renderTypeWithOptions opts

99 renderType' = renderTypeWithOptions opts

88

100

89−renderConstraint :: (P.Qualified P.ProperName, [P.Type]) -> RenderedCode

101+renderConstraint :: P.Constraint -> RenderedCode

90renderConstraint = renderConstraintWithOptions defaultRenderTypeOptions

102renderConstraint = renderConstraintWithOptions defaultRenderTypeOptions

91

103

92−renderConstraintWithOptions :: RenderTypeOptions -> (P.Qualified P.ProperName, [P.Type]) -> RenderedCode

104+renderConstraintWithOptions :: RenderTypeOptions -> P.Constraint -> RenderedCode

93renderConstraintWithOptions opts (pn, tys) =

105renderConstraintWithOptions 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

95

107

96renderConstraints :: [P.Constraint] -> Maybe RenderedCode

108renderConstraints :: [P.Constraint] -> Maybe RenderedCode

97renderConstraints = renderConstraintsWithOptions defaultRenderTypeOptions

109renderConstraints = renderConstraintsWithOptions defaultRenderTypeOptions

@@ -108,7 +120,7 @@ renderConstraintsWithOptions opts constraints

108 mintersperse (syntax "," <> sp)

120 mintersperse (syntax "," <> sp)

109 (map (renderConstraintWithOptions opts) constraints)

121 (map (renderConstraintWithOptions opts) constraints)

110

122

111−notQualified :: String -> P.Qualified P.ProperName

123+notQualified :: String -> P.Qualified (P.ProperName a)

112notQualified = P.Qualified Nothing . P.ProperName

124notQualified = P.Qualified Nothing . P.ProperName

113

125

114typeApp :: String -> [(String, Maybe P.Kind)] -> P.Type

126typeApp :: 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 (

9 defaultRenderTypeOptions,

10 renderTypeWithOptions

11) where

12−

12+

13import Prelude ()

14import Prelude.Compat

15

@@ -52,9 +52,10 @@ typeLiterals = mkPattern match

52 ]

53 where

54 constraints = mintersperse (syntax "," <> sp) (map renderDep deps)

55+ renderDep :: Constraint -> RenderedCode

55 renderDep (pn, tys) =

56 renderDep (pn, tys) =

56− let instApp = foldl TypeApp (TypeConstructor pn) tys

57+ let instApp = foldl TypeApp (TypeConstructor (fmap coerceProperName pn)) tys

57− in renderType instApp

58+ in renderType instApp

58 match REmpty =

59 match REmpty =

59 Just (syntax "()")

60 Just (syntax "()")

60 match row@RCons{} =

61 match row@RCons{} =

@@ -172,10 +173,15 @@ renderType = renderTypeWithOptions defaultRenderTypeOptions

172

173

173data RenderTypeOptions = RenderTypeOptions

174data RenderTypeOptions = RenderTypeOptions

174 { prettyPrintObjects :: Bool

175 { prettyPrintObjects :: Bool

176+ , currentModule :: Maybe ModuleName

175 }

177 }

176

178

177defaultRenderTypeOptions :: RenderTypeOptions

179defaultRenderTypeOptions :: RenderTypeOptions

178−defaultRenderTypeOptions = RenderTypeOptions { prettyPrintObjects = True }

180+defaultRenderTypeOptions =

181+ RenderTypeOptions

182+ { prettyPrintObjects = True

183+ , currentModule = Nothing

184+ }

179

185

180renderTypeWithOptions :: RenderTypeOptions -> Type -> RenderedCode

186renderTypeWithOptions :: RenderTypeOptions -> Type -> RenderedCode

181renderTypeWithOptions opts =

187renderTypeWithOptions opts =

src/Language/PureScript/Docs/RenderedCode/Types.hs+6

@@ -28,6 +28,7 @@ module Language.PureScript.Docs.RenderedCode.Types

28 , keywordClass

29 , keywordInstance

30 , keywordWhere

31+ , keywordFixity

31 ) where

32 ) where

32

33

33import Prelude ()

34import Prelude ()

@@ -189,3 +190,8 @@ keywordInstance = keyword "instance"

189

190

190keywordWhere :: RenderedCode

191keywordWhere :: RenderedCode

191keywordWhere = keyword "where"

192keywordWhere = 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

73packageName = bowerName . pkgMeta

74

75data Module = Module

76− { modName :: String

76+ { modName :: P.ModuleName

77 , modComments :: Maybe String

78 , modDeclarations :: [Declaration]

79+ -- Re-exported values from other modules

80+ , modReExports :: [(P.ModuleName, [Declaration])]

79 }

81 }

80 deriving (Show, Eq, Ord)

82 deriving (Show, Eq, Ord)

81

83

@@ -84,7 +86,7 @@ data Declaration = Declaration

84 , declComments :: Maybe String

86 , declComments :: Maybe String

85 , declSourceSpan :: Maybe P.SourceSpan

87 , declSourceSpan :: Maybe P.SourceSpan

86 , declChildren :: [ChildDeclaration]

88 , declChildren :: [ChildDeclaration]

87− , declFixity :: Maybe (P.Fixity, Maybe String)

89+ , declFixity :: Maybe P.Fixity -- TODO: remove in 0.9

88 , declInfo :: DeclarationInfo

90 , declInfo :: DeclarationInfo

89 }

91 }

90 deriving (Show, Eq, Ord)

92 deriving (Show, Eq, Ord)

@@ -126,6 +128,12 @@ data DeclarationInfo

126 -- members are represented as child declarations.

128 -- members are represented as child declarations.

127 --

129 --

128 | TypeClassDeclaration [(String, Maybe P.Kind)] [P.Constraint]

130 | 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

129 deriving (Show, Eq, Ord)

137 deriving (Show, Eq, Ord)

130

138

131declInfoToString :: DeclarationInfo -> String

139declInfoToString :: DeclarationInfo -> String

@@ -134,6 +142,38 @@ declInfoToString (DataDeclaration _ _) = "data"

134declInfoToString (ExternDataDeclaration _) = "externData"

142declInfoToString (ExternDataDeclaration _) = "externData"

135declInfoToString (TypeSynonymDeclaration _ _) = "typeSynonym"

143declInfoToString (TypeSynonymDeclaration _ _) = "typeSynonym"

136declInfoToString (TypeClassDeclaration _ _) = "typeClass"

144declInfoToString (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) }

137

177

138data ChildDeclaration = ChildDeclaration

178data ChildDeclaration = ChildDeclaration

139 { cdeclTitle :: String

179 { cdeclTitle :: String

@@ -167,6 +207,18 @@ childDeclInfoToString (ChildInstance _ _) = "instance"

167childDeclInfoToString (ChildDataConstructor _) = "dataConstructor"

207childDeclInfoToString (ChildDataConstructor _) = "dataConstructor"

168childDeclInfoToString (ChildTypeClassMember _) = "typeClassMember"

208childDeclInfoToString (ChildTypeClassMember _) = "typeClassMember"

169

209

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+

170newtype GithubUser

222newtype GithubUser

171 = GithubUser { runGithubUser :: String }

223 = GithubUser { runGithubUser :: String }

172 deriving (Show, Eq, Ord)

224 deriving (Show, Eq, Ord)

@@ -294,9 +346,10 @@ parseVersion' str =

294

346

295asModule :: Parse PackageError Module

347asModule :: Parse PackageError Module

296asModule =

348asModule =

297− Module <$> key "name" asString

349+ Module <$> key "name" (P.moduleNameFromString <$> asString)

298 <*> key "comments" (perhaps asString)

350 <*> key "comments" (perhaps asString)

299 <*> key "declarations" (eachInArray asDeclaration)

351 <*> key "declarations" (eachInArray asDeclaration)

352+ <*> key "reExports" (eachInArray asReExport)

300

353

301asDeclaration :: Parse PackageError Declaration

354asDeclaration :: Parse PackageError Declaration

302asDeclaration =

355asDeclaration =

@@ -307,12 +360,23 @@ asDeclaration =

307 <*> key "fixity" (perhaps asFixity)

360 <*> key "fixity" (perhaps asFixity)

308 <*> key "info" asDeclarationInfo

361 <*> key "info" asDeclarationInfo

309

362

310−asFixity :: Parse PackageError (P.Fixity, Maybe String)

363+asReExport :: Parse PackageError (P.ModuleName, [Declaration])

311−asFixity = do

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 =

312− fixity <- P.Fixity <$> key "associativity" asAssociativity

378+ P.Fixity <$> key "associativity" asAssociativity

313− <*> key "precedence" asIntegral

379+ <*> key "precedence" asIntegral

314− alias <- keyMay "alias" asString

315− return (fixity, alias)

316

380

317parseAssociativity :: String -> Maybe P.Associativity

381parseAssociativity :: String -> Maybe P.Associativity

318parseAssociativity str = case str of

382parseAssociativity str = case str of

@@ -341,9 +405,15 @@ asDeclarationInfo = do

341 "typeClass" ->

405 "typeClass" ->

342 TypeClassDeclaration <$> key "arguments" asTypeArguments

406 TypeClassDeclaration <$> key "arguments" asTypeArguments

343 <*> key "superclasses" (eachInArray asConstraint)

407 <*> key "superclasses" (eachInArray asConstraint)

408+ "alias" ->

409+ AliasDeclaration <$> key "for" asAliasFor

410+ <*> key "fixity" asFixity

344 other ->

411 other ->

345 throwCustomError (InvalidDeclarationType other)

412 throwCustomError (InvalidDeclarationType other)

346

413

414+asAliasFor :: Parse e (Either (P.Qualified P.Ident) (P.Qualified (P.ProperName 'P.ConstructorName)))

415+asAliasFor = fromAesonParser

416+

347asTypeArguments :: Parse PackageError [(String, Maybe P.Kind)]

417asTypeArguments :: Parse PackageError [(String, Maybe P.Kind)]

348asTypeArguments = eachInArray asTypeArgument

418asTypeArguments = eachInArray asTypeArgument

349 where

419 where

@@ -391,20 +461,19 @@ asConstraint :: Parse PackageError P.Constraint

391asConstraint = (,) <$> nth 0 asQualifiedProperName

461asConstraint = (,) <$> nth 0 asQualifiedProperName

392 <*> nth 1 (eachInArray asType)

462 <*> nth 1 (eachInArray asType)

393

463

394−asQualifiedProperName :: Parse e (P.Qualified P.ProperName)

464+asQualifiedProperName :: Parse e (P.Qualified (P.ProperName a))

395asQualifiedProperName = fromAesonParser

465asQualifiedProperName = fromAesonParser

396

466

467+asQualifiedIdent :: Parse e (P.Qualified P.Ident)

468+asQualifiedIdent = fromAesonParser

469+

397asBookmarks :: Parse BowerError [Bookmark]

470asBookmarks :: Parse BowerError [Bookmark]

398asBookmarks = eachInArray asBookmark

471asBookmarks = eachInArray asBookmark

399

472

400asBookmark :: Parse BowerError Bookmark

473asBookmark :: Parse BowerError Bookmark

401asBookmark =

474asBookmark =

402− build <$> key "package" (perhaps (withString parsePackageName))

403− <*> key "item" ((,) <$> nth 0 (P.moduleNameFromString <$> asString)

475+ asInPackage ((,) <$> nth 0 (P.moduleNameFromString <$> asString)

404− <*> nth 1 asString)

476+ <*> nth 1 asString)

405− where

406− build Nothing = Local

407− build (Just pn) = FromDep pn

408

477

409asResolvedDependencies :: Parse PackageError [(PackageName, Version)]

478asResolvedDependencies :: Parse PackageError [(PackageName, Version)]

410asResolvedDependencies =

479asResolvedDependencies =

@@ -446,10 +515,15 @@ instance A.ToJSON NotYetKnown where

446

515

447instance A.ToJSON Module where

516instance A.ToJSON Module where

448 toJSON Module{..} =

517 toJSON Module{..} =

449− A.object [ "name" .= modName

518+ A.object [ "name" .= P.runModuleName modName

450 , "comments" .= modComments

519 , "comments" .= modComments

451 , "declarations" .= modDeclarations

520 , "declarations" .= modDeclarations

521+ , "reExports" .= map toObj modReExports

452 ]

522 ]

523+ where

524+ toObj (mn, decls) = A.object [ "moduleName" .= mn

525+ , "declarations" .= decls

526+ ]

453

527

454instance A.ToJSON Declaration where

528instance A.ToJSON Declaration where

455 toJSON Declaration{..} =

529 toJSON Declaration{..} =

@@ -478,6 +552,7 @@ instance A.ToJSON DeclarationInfo where

478 ExternDataDeclaration kind -> ["kind" .= kind]

552 ExternDataDeclaration kind -> ["kind" .= kind]

479 TypeSynonymDeclaration args ty -> ["arguments" .= args, "type" .= ty]

553 TypeSynonymDeclaration args ty -> ["arguments" .= args, "type" .= ty]

480 TypeClassDeclaration args super -> ["arguments" .= args, "superclasses" .= super]

554 TypeClassDeclaration args super -> ["arguments" .= args, "superclasses" .= super]

555+ AliasDeclaration for fixity -> ["for" .= for, "fixity" .= fixity]

481

556

482instance A.ToJSON ChildDeclarationInfo where

557instance A.ToJSON ChildDeclarationInfo where

483 toJSON info = A.object $ "declType" .= childDeclInfoToString info : props

558 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

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{-# LANGUAGE OverloadedStrings #-}

1{-# LANGUAGE OverloadedStrings #-}

17{-# LANGUAGE TemplateHaskell #-}

2{-# LANGUAGE TemplateHaskell #-}

18

3

19module Language.PureScript.Environment where

4module Language.PureScript.Environment where

20

5

21−import Data.Data

22import Data.Maybe (fromMaybe)

6import Data.Maybe (fromMaybe)

23import Data.Aeson.TH

7import Data.Aeson.TH

24import qualified Data.Map as M

8import qualified Data.Map as M

@@ -43,23 +27,23 @@ data Environment = Environment {

43 -- |

27 -- |

44 -- Type names currently in scope

28 -- Type names currently in scope

45 --

29 --

46− , types :: M.Map (Qualified ProperName) (Kind, TypeKind)

30+ , types :: M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind)

47 -- |

31 -- |

48 -- Data constructors currently in scope, along with their associated type

32 -- Data constructors currently in scope, along with their associated type

49 -- constructor name, argument types and return type.

33 -- 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])

51 -- |

35 -- |

52 -- Type synonyms currently in scope

36 -- Type synonyms currently in scope

53 --

37 --

54− , typeSynonyms :: M.Map (Qualified ProperName) ([(String, Maybe Kind)], Type)

38+ , typeSynonyms :: M.Map (Qualified (ProperName 'TypeName)) ([(String, Maybe Kind)], Type)

55 -- |

39 -- |

56 -- Available type class dictionaries

40 -- Available type class dictionaries

57 --

41 --

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))

59 -- |

43 -- |

60 -- Type classes

44 -- Type classes

61 --

45 --

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])

63 } deriving (Show, Read)

47 } deriving (Show, Read)

64

48

65-- |

49-- |

@@ -98,7 +82,8 @@ data NameKind

98 -- |

82 -- |

99 -- A name for member introduced by foreign import

83 -- A name for member introduced by foreign import

100 --

84 --

85+ | External

101− | External deriving (Show, Read, Eq, Data, Typeable)

86+ deriving (Show, Read, Eq)

102

87

103-- |

88-- |

104-- The kinds of a type

89-- The kinds of a type

@@ -107,7 +92,7 @@ data TypeKind

107 -- |

92 -- |

108 -- Data type

93 -- Data type

109 --

94 --

110− = DataType [(String, Maybe Kind)] [(ProperName, [Type])]

95+ = DataType [(String, Maybe Kind)] [(ProperName 'ConstructorName, [Type])]

111 -- |

96 -- |

112 -- Type synonym

97 -- Type synonym

113 --

98 --

@@ -124,7 +109,7 @@ data TypeKind

124 -- A scoped type variable

109 -- A scoped type variable

125 --

110 --

126 | ScopedTypeVar

111 | ScopedTypeVar

127− deriving (Show, Read, Eq, Data, Typeable)

112+ deriving (Show, Read, Eq)

128

113

129-- |

114-- |

130-- The type ('data' or 'newtype') of a data type declaration

115-- The type ('data' or 'newtype') of a data type declaration

@@ -137,7 +122,8 @@ data DataDeclType

137 -- |

122 -- |

138 -- A newtype constructor

123 -- A newtype constructor

139 --

124 --

125+ | Newtype

140− | Newtype deriving (Show, Read, Eq, Ord, Data, Typeable)

126+ deriving (Show, Read, Eq, Ord)

141

127

142showDataDeclType :: DataDeclType -> String

128showDataDeclType :: DataDeclType -> String

143showDataDeclType Data = "data"

129showDataDeclType Data = "data"

@@ -156,7 +142,7 @@ instance A.FromJSON DataDeclType where

156-- |

142-- |

157-- Construct a ProperName in the Prim module

143-- Construct a ProperName in the Prim module

158--

144--

159−primName :: String -> Qualified ProperName

145+primName :: String -> Qualified (ProperName a)

160primName = Qualified (Just $ ModuleName [ProperName C.prim]) . ProperName

146primName = Qualified (Just $ ModuleName [ProperName C.prim]) . ProperName

161

147

162-- |

148-- |

@@ -240,7 +226,7 @@ function t1 = TypeApp (TypeApp tyFunction t1)

240-- associated kinds. There is also a pseudo `Partial` type that corresponds to

226-- associated kinds. There is also a pseudo `Partial` type that corresponds to

241-- the class with the same name.

227-- the class with the same name.

242--

228--

243−primTypes :: M.Map (Qualified ProperName) (Kind, TypeKind)

229+primTypes :: M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind)

244primTypes =

230primTypes =

245 M.fromList

231 M.fromList

246 [ (primName "Function", (FunKind Star (FunKind Star Star), ExternData))

232 [ (primName "Function", (FunKind Star (FunKind Star Star), ExternData))

@@ -258,7 +244,7 @@ primTypes =

258-- The primitive class map. This just contains to `Partial` class, used as a

244-- The primitive class map. This just contains to `Partial` class, used as a

259-- kind of magic constraint for partial functions.

245-- kind of magic constraint for partial functions.

260--

246--

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])

262primClasses =

248primClasses =

263 M.fromList

249 M.fromList

264 [ (primName "Partial", ([], [], [])) ]

250 [ (primName "Partial", ([], [], [])) ]

@@ -266,14 +252,14 @@ primClasses =

266-- |

252-- |

267-- Finds information about data constructors from the current environment.

253-- Finds information about data constructors from the current environment.

268--

254--

269−lookupConstructor :: Environment -> Qualified ProperName -> (DataDeclType, ProperName, Type, [Ident])

255+lookupConstructor :: Environment -> Qualified (ProperName 'ConstructorName) -> (DataDeclType, ProperName 'TypeName, Type, [Ident])

270lookupConstructor env ctor =

256lookupConstructor env ctor =

271 fromMaybe (internalError "Data constructor not found") $ ctor `M.lookup` dataConstructors env

257 fromMaybe (internalError "Data constructor not found") $ ctor `M.lookup` dataConstructors env

272

258

273-- |

259-- |

274-- Checks whether a data constructor is for a newtype.

260-- Checks whether a data constructor is for a newtype.

275--

261--

276−isNewtypeConstructor :: Environment -> Qualified ProperName -> Bool

262+isNewtypeConstructor :: Environment -> Qualified (ProperName 'ConstructorName) -> Bool

277isNewtypeConstructor e ctor = case lookupConstructor e ctor of

263isNewtypeConstructor e ctor = case lookupConstructor e ctor of

278 (Newtype, _, _, _) -> True

264 (Newtype, _, _, _) -> True

279 (Data, _, _, _) -> False

265 (Data, _, _, _) -> False

src/Language/PureScript/Errors.hs+264−128

@@ -1,6 +1,5 @@

1{-# LANGUAGE GeneralizedNewtypeDeriving #-}

2{-# LANGUAGE FlexibleContexts #-}

3−{-# LANGUAGE RecordWildCards #-}

4{-# LANGUAGE MultiParamTypeClasses #-}

3{-# LANGUAGE MultiParamTypeClasses #-}

5

4

6module Language.PureScript.Errors where

5module Language.PureScript.Errors where

@@ -9,6 +8,7 @@ import Prelude ()

9import Prelude.Compat

8import Prelude.Compat

10

9

11import Data.Ord (comparing)

10import Data.Ord (comparing)

11+import Data.Char (isSpace)

12import Data.Either (lefts, rights)

13import Data.List (intercalate, transpose, nub, nubBy, sortBy)

14import Data.Foldable (fold)

@@ -24,6 +24,7 @@ import Control.Arrow ((&&&))

24import Language.PureScript.Crash

25import Language.PureScript.AST

26import Language.PureScript.Pretty

27+import Language.PureScript.Pretty.Common (before)

27import Language.PureScript.Types

28import Language.PureScript.Types

28import Language.PureScript.Names

29import Language.PureScript.Names

29import Language.PureScript.Kinds

30import Language.PureScript.Kinds

@@ -53,65 +54,67 @@ data SimpleErrorMessage

53 | RedefinedIdent Ident

54 | RedefinedIdent Ident

54 | OverlappingNamesInLet

55 | OverlappingNamesInLet

55 | UnknownModule ModuleName

56 | UnknownModule ModuleName

56− | UnknownType (Qualified ProperName)

57+ | UnknownType (Qualified (ProperName 'TypeName))

57− | UnknownTypeClass (Qualified ProperName)

58+ | UnknownTypeClass (Qualified (ProperName 'ClassName))

58 | UnknownValue (Qualified Ident)

59 | UnknownValue (Qualified Ident)

59− | UnknownDataConstructor (Qualified ProperName) (Maybe (Qualified ProperName))

60+ | UnknownDataConstructor (Qualified (ProperName 'ConstructorName)) (Maybe (Qualified (ProperName 'ConstructorName)))

60− | UnknownTypeConstructor (Qualified ProperName)

61+ | UnknownTypeConstructor (Qualified (ProperName 'TypeName))

61− | UnknownImportType ModuleName ProperName

62+ | UnknownImportType ModuleName (ProperName 'TypeName)

62− | UnknownExportType ProperName

63+ | UnknownExportType (ProperName 'TypeName)

63− | UnknownImportTypeClass ModuleName ProperName

64+ | UnknownImportTypeClass ModuleName (ProperName 'ClassName)

64− | UnknownExportTypeClass ProperName

65+ | UnknownExportTypeClass (ProperName 'ClassName)

65 | UnknownImportValue ModuleName Ident

66 | UnknownImportValue ModuleName Ident

66 | UnknownExportValue Ident

67 | UnknownExportValue Ident

67 | UnknownExportModule ModuleName

68 | UnknownExportModule ModuleName

68− | UnknownImportDataConstructor ModuleName ProperName ProperName

69+ | UnknownImportDataConstructor ModuleName (ProperName 'TypeName) (ProperName 'ConstructorName)

69− | UnknownExportDataConstructor ProperName ProperName

70+ | UnknownExportDataConstructor (ProperName 'TypeName) (ProperName 'ConstructorName)

70 | ScopeConflict String [ModuleName]

71 | ScopeConflict String [ModuleName]

72+ | ScopeShadowing String (Maybe ModuleName) [ModuleName]

71− | ConflictingTypeDecls ProperName

73+ | ConflictingTypeDecls (ProperName 'TypeName)

72− | ConflictingCtorDecls ProperName

74+ | ConflictingCtorDecls (ProperName 'ConstructorName)

73− | TypeConflictsWithClass ProperName

75+ | TypeConflictsWithClass (ProperName 'TypeName)

74− | CtorConflictsWithClass ProperName

76+ | CtorConflictsWithClass (ProperName 'ConstructorName)

75− | ClassConflictsWithType ProperName

77+ | ClassConflictsWithType (ProperName 'ClassName)

76− | ClassConflictsWithCtor ProperName

78+ | ClassConflictsWithCtor (ProperName 'ClassName)

77 | DuplicateModuleName ModuleName

79 | DuplicateModuleName ModuleName

78− | DuplicateClassExport ProperName

80+ | DuplicateClassExport (ProperName 'ClassName)

79 | DuplicateValueExport Ident

81 | DuplicateValueExport Ident

80 | DuplicateTypeArgument String

82 | DuplicateTypeArgument String

81 | InvalidDoBind

83 | InvalidDoBind

82 | InvalidDoLet

84 | InvalidDoLet

83 | CycleInDeclaration Ident

85 | CycleInDeclaration Ident

84− | CycleInTypeSynonym (Maybe ProperName)

86+ | CycleInTypeSynonym (Maybe (ProperName 'TypeName))

85 | CycleInModules [ModuleName]

87 | CycleInModules [ModuleName]

86 | NameIsUndefined Ident

88 | NameIsUndefined Ident

87− | UndefinedTypeVariable ProperName

89+ | UndefinedTypeVariable (ProperName 'TypeName)

88− | PartiallyAppliedSynonym (Qualified ProperName)

90+ | PartiallyAppliedSynonym (Qualified (ProperName 'TypeName))

89 | EscapedSkolem (Maybe Expr)

91 | EscapedSkolem (Maybe Expr)

90 | TypesDoNotUnify Type Type

92 | TypesDoNotUnify Type Type

91 | KindsDoNotUnify Kind Kind

93 | KindsDoNotUnify Kind Kind

92 | ConstrainedTypeUnified Type Type

94 | ConstrainedTypeUnified Type Type

93− | OverlappingInstances (Qualified ProperName) [Type] [Qualified Ident]

95+ | OverlappingInstances (Qualified (ProperName 'ClassName)) [Type] [Qualified Ident]

94− | NoInstanceFound (Qualified ProperName) [Type]

96+ | NoInstanceFound (Qualified (ProperName 'ClassName)) [Type]

95− | PossiblyInfiniteInstance (Qualified ProperName) [Type]

97+ | PossiblyInfiniteInstance (Qualified (ProperName 'ClassName)) [Type]

96− | CannotDerive (Qualified ProperName) [Type]

98+ | CannotDerive (Qualified (ProperName 'ClassName)) [Type]

97− | CannotFindDerivingType ProperName

99+ | CannotFindDerivingType (ProperName 'TypeName)

98 | DuplicateLabel String (Maybe Expr)

100 | DuplicateLabel String (Maybe Expr)

99 | DuplicateValueDeclaration Ident

101 | DuplicateValueDeclaration Ident

100 | ArgListLengthsDiffer Ident

102 | ArgListLengthsDiffer Ident

101 | OverlappingArgNames (Maybe Ident)

103 | OverlappingArgNames (Maybe Ident)

102 | MissingClassMember Ident

104 | MissingClassMember Ident

103− | ExtraneousClassMember Ident (Qualified ProperName)

105+ | ExtraneousClassMember Ident (Qualified (ProperName 'ClassName))

104 | ExpectedType Type Kind

106 | ExpectedType Type Kind

105− | IncorrectConstructorArity (Qualified ProperName)

107+ | IncorrectConstructorArity (Qualified (ProperName 'ConstructorName))

106 | ExprDoesNotHaveType Expr Type

108 | ExprDoesNotHaveType Expr Type

107 | PropertyIsMissing String

109 | PropertyIsMissing String

108 | AdditionalProperty String

110 | AdditionalProperty String

109 | CannotApplyFunction Type Expr

111 | CannotApplyFunction Type Expr

110 | TypeSynonymInstance

112 | TypeSynonymInstance

111− | OrphanInstance Ident (Qualified ProperName) [Type]

113+ | OrphanInstance Ident (Qualified (ProperName 'ClassName)) [Type]

112− | InvalidNewtype ProperName

114+ | InvalidNewtype (ProperName 'TypeName)

113 | InvalidInstanceHead Type

115 | InvalidInstanceHead Type

114 | TransitiveExportError DeclarationRef [DeclarationRef]

116 | TransitiveExportError DeclarationRef [DeclarationRef]

117+ | TransitiveDctorExportError DeclarationRef (ProperName 'ConstructorName)

115 | ShadowedName Ident

118 | ShadowedName Ident

116 | ShadowedTypeVar String

119 | ShadowedTypeVar String

117 | UnusedTypeVar String

120 | UnusedTypeVar String

@@ -120,17 +123,18 @@ data SimpleErrorMessage

120 | NotExhaustivePattern [[Binder]] Bool

123 | NotExhaustivePattern [[Binder]] Bool

121 | OverlappingPattern [[Binder]] Bool

124 | OverlappingPattern [[Binder]] Bool

122 | IncompleteExhaustivityCheck

125 | IncompleteExhaustivityCheck

123− | ClassOperator ProperName Ident

126+ | ClassOperator (ProperName 'ClassName) Ident

124− | MisleadingEmptyTypeImport ModuleName ProperName

127+ | MisleadingEmptyTypeImport ModuleName (ProperName 'TypeName)

125 | ImportHidingModule ModuleName

128 | ImportHidingModule ModuleName

126 | UnusedImport ModuleName

129 | UnusedImport ModuleName

127− | UnusedExplicitImport ModuleName [String]

130+ | UnusedExplicitImport ModuleName [String] (Maybe ModuleName) [DeclarationRef]

128− | UnusedDctorImport ProperName

131+ | UnusedDctorImport (ProperName 'TypeName)

129− | UnusedDctorExplicitImport ProperName [ProperName]

132+ | UnusedDctorExplicitImport (ProperName 'TypeName) [ProperName 'ConstructorName]

130 | DeprecatedOperatorDecl String

133 | DeprecatedOperatorDecl String

134+ | DeprecatedOperatorSection Expr (Either Expr Expr)

131 | DeprecatedQualifiedSyntax ModuleName ModuleName

135 | DeprecatedQualifiedSyntax ModuleName ModuleName

132− | DeprecatedClassImport ModuleName ProperName

136+ | DeprecatedClassImport ModuleName (ProperName 'ClassName)

133− | DeprecatedClassExport ProperName

137+ | DeprecatedClassExport (ProperName 'ClassName)

134 | RedundantUnqualifiedImport ModuleName ImportDeclarationType

138 | RedundantUnqualifiedImport ModuleName ImportDeclarationType

135 | DuplicateSelectiveImport ModuleName

139 | DuplicateSelectiveImport ModuleName

136 | DuplicateImport ModuleName ImportDeclarationType (Maybe ModuleName)

140 | DuplicateImport ModuleName ImportDeclarationType (Maybe ModuleName)

@@ -138,8 +142,12 @@ data SimpleErrorMessage

138 | DuplicateExportRef String

142 | DuplicateExportRef String

139 | IntOutOfRange Integer String Integer Integer

143 | IntOutOfRange Integer String Integer Integer

140 | RedundantEmptyHidingImport ModuleName

144 | RedundantEmptyHidingImport ModuleName

145+ | ImplicitQualifiedImport ModuleName ModuleName [DeclarationRef]

141 | ImplicitImport ModuleName [DeclarationRef]

146 | ImplicitImport ModuleName [DeclarationRef]

147+ | HidingImport ModuleName [DeclarationRef]

142 | CaseBinderLengthDiffers Int [Binder]

148 | CaseBinderLengthDiffers Int [Binder]

149+ | IncorrectAnonymousArgument

150+ | InvalidOperatorInBinder Ident Ident

143 deriving (Show)

151 deriving (Show)

144

152

145-- | Error message hints, providing more detailed information about failure.

153-- | Error message hints, providing more detailed information about failure.

@@ -147,7 +155,7 @@ data ErrorMessageHint

147 = ErrorUnifyingTypes Type Type

155 = ErrorUnifyingTypes Type Type

148 | ErrorInExpression Expr

156 | ErrorInExpression Expr

149 | ErrorInModule ModuleName

157 | ErrorInModule ModuleName

150− | ErrorInInstance (Qualified ProperName) [Type]

158+ | ErrorInInstance (Qualified (ProperName 'ClassName)) [Type]

151 | ErrorInSubsumption Type Type

159 | ErrorInSubsumption Type Type

152 | ErrorCheckingAccessor Expr String

160 | ErrorCheckingAccessor Expr String

153 | ErrorCheckingType Expr Type

161 | ErrorCheckingType Expr Type

@@ -155,11 +163,11 @@ data ErrorMessageHint

155 | ErrorCheckingGuard

163 | ErrorCheckingGuard

156 | ErrorInferringType Expr

164 | ErrorInferringType Expr

157 | ErrorInApplication Expr Type Expr

165 | ErrorInApplication Expr Type Expr

158− | ErrorInDataConstructor ProperName

166+ | ErrorInDataConstructor (ProperName 'ConstructorName)

159− | ErrorInTypeConstructor ProperName

167+ | ErrorInTypeConstructor (ProperName 'TypeName)

160 | ErrorInBindingGroup [Ident]

168 | ErrorInBindingGroup [Ident]

161 | ErrorInDataBindingGroup

169 | ErrorInDataBindingGroup

162− | ErrorInTypeSynonym ProperName

170+ | ErrorInTypeSynonym (ProperName 'TypeName)

163 | ErrorInValueDeclaration Ident

171 | ErrorInValueDeclaration Ident

164 | ErrorInTypeDeclaration Ident

172 | ErrorInTypeDeclaration Ident

165 | ErrorInForeignImport Ident

173 | ErrorInForeignImport Ident

@@ -177,6 +185,8 @@ data HintCategory

177

185

178data ErrorMessage = ErrorMessage [ErrorMessageHint] SimpleErrorMessage deriving (Show)

186data ErrorMessage = ErrorMessage [ErrorMessageHint] SimpleErrorMessage deriving (Show)

179

187

188+newtype ErrorSuggestion = ErrorSuggestion String

189+

180-- | Get the source span for an error

190-- | Get the source span for an error

181errorSpan :: ErrorMessage -> Maybe SourceSpan

191errorSpan :: ErrorMessage -> Maybe SourceSpan

182errorSpan = findHint matchSpan

192errorSpan = findHint matchSpan

@@ -239,6 +249,7 @@ errorCode em = case unwrapErrorMessage em of

239 UnknownImportDataConstructor{} -> "UnknownImportDataConstructor"

249 UnknownImportDataConstructor{} -> "UnknownImportDataConstructor"

240 UnknownExportDataConstructor{} -> "UnknownExportDataConstructor"

250 UnknownExportDataConstructor{} -> "UnknownExportDataConstructor"

241 ScopeConflict{} -> "ScopeConflict"

251 ScopeConflict{} -> "ScopeConflict"

252+ ScopeShadowing{} -> "ScopeShadowing"

242 ConflictingTypeDecls{} -> "ConflictingTypeDecls"

253 ConflictingTypeDecls{} -> "ConflictingTypeDecls"

243 ConflictingCtorDecls{} -> "ConflictingCtorDecls"

254 ConflictingCtorDecls{} -> "ConflictingCtorDecls"

244 TypeConflictsWithClass{} -> "TypeConflictsWithClass"

255 TypeConflictsWithClass{} -> "TypeConflictsWithClass"

@@ -283,6 +294,7 @@ errorCode em = case unwrapErrorMessage em of

283 InvalidNewtype{} -> "InvalidNewtype"

294 InvalidNewtype{} -> "InvalidNewtype"

284 InvalidInstanceHead{} -> "InvalidInstanceHead"

295 InvalidInstanceHead{} -> "InvalidInstanceHead"

285 TransitiveExportError{} -> "TransitiveExportError"

296 TransitiveExportError{} -> "TransitiveExportError"

297+ TransitiveDctorExportError{} -> "TransitiveDctorExportError"

286 ShadowedName{} -> "ShadowedName"

298 ShadowedName{} -> "ShadowedName"

287 ShadowedTypeVar{} -> "ShadowedTypeVar"

299 ShadowedTypeVar{} -> "ShadowedTypeVar"

288 UnusedTypeVar{} -> "UnusedTypeVar"

300 UnusedTypeVar{} -> "UnusedTypeVar"

@@ -299,6 +311,7 @@ errorCode em = case unwrapErrorMessage em of

299 UnusedDctorImport{} -> "UnusedDctorImport"

311 UnusedDctorImport{} -> "UnusedDctorImport"

300 UnusedDctorExplicitImport{} -> "UnusedDctorExplicitImport"

312 UnusedDctorExplicitImport{} -> "UnusedDctorExplicitImport"

301 DeprecatedOperatorDecl{} -> "DeprecatedOperatorDecl"

313 DeprecatedOperatorDecl{} -> "DeprecatedOperatorDecl"

314+ DeprecatedOperatorSection{} -> "DeprecatedOperatorSection"

302 DeprecatedQualifiedSyntax{} -> "DeprecatedQualifiedSyntax"

315 DeprecatedQualifiedSyntax{} -> "DeprecatedQualifiedSyntax"

303 DeprecatedClassImport{} -> "DeprecatedClassImport"

316 DeprecatedClassImport{} -> "DeprecatedClassImport"

304 DeprecatedClassExport{} -> "DeprecatedClassExport"

317 DeprecatedClassExport{} -> "DeprecatedClassExport"

@@ -309,8 +322,12 @@ errorCode em = case unwrapErrorMessage em of

309 DuplicateExportRef{} -> "DuplicateExportRef"

322 DuplicateExportRef{} -> "DuplicateExportRef"

310 IntOutOfRange{} -> "IntOutOfRange"

323 IntOutOfRange{} -> "IntOutOfRange"

311 RedundantEmptyHidingImport{} -> "RedundantEmptyHidingImport"

324 RedundantEmptyHidingImport{} -> "RedundantEmptyHidingImport"

325+ ImplicitQualifiedImport{} -> "ImplicitQualifiedImport"

312 ImplicitImport{} -> "ImplicitImport"

326 ImplicitImport{} -> "ImplicitImport"

327+ HidingImport{} -> "HidingImport"

313 CaseBinderLengthDiffers{} -> "CaseBinderLengthDiffers"

328 CaseBinderLengthDiffers{} -> "CaseBinderLengthDiffers"

329+ IncorrectAnonymousArgument -> "IncorrectAnonymousArgument"

330+ InvalidOperatorInBinder{} -> "InvalidOperatorInBinder"

314

331

315-- |

332-- |

316-- A stack trace for an error

333-- A stack trace for an error

@@ -412,14 +429,48 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse

412 gHint (ErrorInInstance cl ts) = ErrorInInstance cl <$> traverse f ts

429 gHint (ErrorInInstance cl ts) = ErrorInInstance cl <$> traverse f ts

413 gHint other = pure other

430 gHint other = pure other

414

431

415−prettyPrintSingleError' :: Bool -> Level -> ErrorMessage ->Box.Box

432+wikiUri :: ErrorMessage -> String

416−prettyPrintSingleError' full level = flip evalState defaultUnknownMap . prettyPrintSingleError full level

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+ _ -> ""

417

468

418-- |

469-- |

419-- Pretty print a single error, simplifying if necessary

470-- Pretty print a single error, simplifying if necessary

420--

471--

421−prettyPrintSingleError :: Bool -> Level -> ErrorMessage -> State TypeMap Box.Box

472+prettyPrintSingleError :: Bool -> Level -> Bool -> ErrorMessage -> Box.Box

422−prettyPrintSingleError full level e = do

473+prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap $ do

423 em <- onTypesInErrorMessageM replaceUnknowns (if full then e else simplifyErrorMessage e)

474 em <- onTypesInErrorMessageM replaceUnknowns (if full then e else simplifyErrorMessage e)

424 um <- get

475 um <- get

425 return (prettyPrintErrorMessage um em)

476 return (prettyPrintErrorMessage um em)

@@ -428,20 +479,19 @@ prettyPrintSingleError full level e = do

428 -- Pretty print an ErrorMessage

479 -- Pretty print an ErrorMessage

429 prettyPrintErrorMessage :: TypeMap -> ErrorMessage -> Box.Box

480 prettyPrintErrorMessage :: TypeMap -> ErrorMessage -> Box.Box

430 prettyPrintErrorMessage typeMap (ErrorMessage hints simple) =

481 prettyPrintErrorMessage typeMap (ErrorMessage hints simple) =

431− paras

482+ paras $

432 [ foldr renderHint (indent (renderSimpleErrorMessage simple)) hints

483 [ foldr renderHint (indent (renderSimpleErrorMessage simple)) hints

484+ ] ++

433− , Box.moveDown 1 typeInformation

485+ maybe [] (return . Box.moveDown 1) typeInformation ++

434− , Box.moveDown 1 $ paras [ line $ "See " ++ wikiUri ++ " for more information, "

486+ [ Box.moveDown 1 $ paras [ line $ "See " ++ wikiUri e ++ " for more information, "

435− , line $ "or to contribute content related to this " ++ levelText ++ "."

487+ , line $ "or to contribute content related to this " ++ levelText ++ "."

436− ]

488+ ]

489+ | showWiki

437 ]

490 ]

438 where

491 where

439− wikiUri :: String

492+ typeInformation :: Maybe Box.Box

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]

493+ typeInformation | not (null types) = Just $ Box.hsep 1 Box.left [ line "where", paras types ]

444− | otherwise = Box.emptyBox 0 0

494+ | otherwise = Nothing

445 where

495 where

446 types :: [Box.Box]

496 types :: [Box.Box]

447 types = map skolemInfo (M.elems (umSkolemMap typeMap)) ++

497 types = map skolemInfo (M.elems (umSkolemMap typeMap)) ++

@@ -556,6 +606,13 @@ prettyPrintSingleError full level e = do

556 paras [ line $ "Conflicting definitions are in scope for " ++ nm ++ " from the following modules:"

606 paras [ line $ "Conflicting definitions are in scope for " ++ nm ++ " from the following modules:"

557 , indent $ paras $ map (line . runModuleName) ms

607 , indent $ paras $ map (line . runModuleName) ms

558 ]

608 ]

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+ ]

559 renderSimpleErrorMessage (ConflictingTypeDecls nm) =

616 renderSimpleErrorMessage (ConflictingTypeDecls nm) =

560 line $ "Conflicting type declarations for " ++ runProperName nm

617 line $ "Conflicting type declarations for " ++ runProperName nm

561 renderSimpleErrorMessage (ConflictingCtorDecls nm) =

618 renderSimpleErrorMessage (ConflictingCtorDecls nm) =

@@ -745,6 +802,10 @@ prettyPrintSingleError full level e = do

745 paras [ line $ "An export for " ++ prettyPrintExport x ++ " requires the following to also be exported: "

802 paras [ line $ "An export for " ++ prettyPrintExport x ++ " requires the following to also be exported: "

746 , indent $ paras $ map (line . prettyPrintExport) ys

803 , indent $ paras $ map (line . prettyPrintExport) ys

747 ]

804 ]

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+ ]

748 renderSimpleErrorMessage (ShadowedName nm) =

809 renderSimpleErrorMessage (ShadowedName nm) =

749 line $ "Name '" ++ showIdent nm ++ "' was shadowed."

810 line $ "Name '" ++ showIdent nm ++ "' was shadowed."

750 renderSimpleErrorMessage (ShadowedTypeVar tv) =

811 renderSimpleErrorMessage (ShadowedTypeVar tv) =

@@ -759,7 +820,7 @@ prettyPrintSingleError full level e = do

759 renderSimpleErrorMessage (MisleadingEmptyTypeImport mn name) =

820 renderSimpleErrorMessage (MisleadingEmptyTypeImport mn name) =

760 line $ "Importing type " ++ runProperName name ++ "(..) from " ++ runModuleName mn ++ " is misleading as it has no exported data constructors."

821 line $ "Importing type " ++ runProperName name ++ "(..) from " ++ runModuleName mn ++ " is misleading as it has no exported data constructors."

761 renderSimpleErrorMessage (ImportHidingModule name) =

822 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."

763 , line $ "An attempt was made to hide the import of " ++ runModuleName name

824 , line $ "An attempt was made to hide the import of " ++ runModuleName name

764 ]

825 ]

765 renderSimpleErrorMessage (WildcardInferredType ty) =

826 renderSimpleErrorMessage (WildcardInferredType ty) =

@@ -773,14 +834,14 @@ prettyPrintSingleError full level e = do

773 , indent $ typeAsBox ty

834 , indent $ typeAsBox ty

774 ]

835 ]

775 renderSimpleErrorMessage (NotExhaustivePattern bs b) =

836 renderSimpleErrorMessage (NotExhaustivePattern bs b) =

776− paras $ [ line "A case expression could not be determined to cover all inputs."

837+ 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"

838+ , line "The following additional cases are required to cover all inputs:\n"

778− , indent $ paras $

839+ , indent $ paras $

779− [ Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs)) ]

840+ [ Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs)) ]

780− ++ [ line "..." | not b ]

841+ ++ [ line "..." | not b ]

781− , line "Or alternatively, add a Partial constraint to the type of the enclosing value."

842+ , 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."

843+ , line "Non-exhaustive patterns for values without a `Partial` constraint will be disallowed in PureScript 0.9."

783− ]

844+ ]

784 renderSimpleErrorMessage (OverlappingPattern bs b) =

845 renderSimpleErrorMessage (OverlappingPattern bs b) =

785 paras $ [ line "A case expression contains unreachable cases:\n"

846 paras $ [ line "A case expression contains unreachable cases:\n"

786 , Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs))

847 , Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs))

@@ -793,9 +854,11 @@ prettyPrintSingleError full level e = do

793 renderSimpleErrorMessage (UnusedImport name) =

854 renderSimpleErrorMessage (UnusedImport name) =

794 line $ "The import of module " ++ runModuleName name ++ " is redundant"

855 line $ "The import of module " ++ runModuleName name ++ " is redundant"

795

856

796− renderSimpleErrorMessage (UnusedExplicitImport name names) =

857+ renderSimpleErrorMessage msg@(UnusedExplicitImport mn names _ _) =

797− paras [ line $ "The import of module " ++ runModuleName name ++ " contains the following unused references:"

858+ paras [ line $ "The import of module " ++ runModuleName mn ++ " contains the following unused references:"

798− , indent $ paras $ map line names ]

859+ , indent $ paras $ map line names

860+ , line "It could be replaced with:"

861+ , indent $ line $ showSuggestion msg ]

799

862

800 renderSimpleErrorMessage (UnusedDctorImport name) =

863 renderSimpleErrorMessage (UnusedDctorImport name) =

801 line $ "The import of type " ++ runProperName name ++ " includes data constructors but only the type is used"

864 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

808 paras [ line $ "The operator (" ++ name ++ ") was declared as a value rather than an alias for a named function."

871 paras [ line $ "The operator (" ++ name ++ ") was declared as a value rather than an alias for a named function."

809 , line "Operator aliases are declared by using a fixity declaration, for example:"

872 , line "Operator aliases are declared by using a fixity declaration, for example:"

810 , indent $ line $ "infixl 9 someFunction as " ++ name

873 , 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."

812 ]

875 ]

813

876

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 "`" ]

814 renderSimpleErrorMessage (DeprecatedQualifiedSyntax name qualName) =

901 renderSimpleErrorMessage (DeprecatedQualifiedSyntax name qualName) =

815− paras [ line $ "Import uses the deprecated 'qualified' syntax:"

902+ paras [ line "Import uses the deprecated 'qualified' syntax:"

816 , indent $ line $ "import qualified " ++ runModuleName name ++ " as " ++ runModuleName qualName

903 , indent $ line $ "import qualified " ++ runModuleName name ++ " as " ++ runModuleName qualName

817 , line "Should instead use the form:"

904 , line "Should instead use the form:"

818 , indent $ line $ "import " ++ runModuleName name ++ " as " ++ runModuleName qualName

905 , 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."

820 ]

907 ]

821

908

822 renderSimpleErrorMessage (DeprecatedClassImport mn name) =

909 renderSimpleErrorMessage (DeprecatedClassImport mn name) =

@@ -824,15 +911,15 @@ prettyPrintSingleError full level e = do

824 , indent $ line $ runProperName name

911 , indent $ line $ runProperName name

825 , line "Should instead use the form:"

912 , line "Should instead use the form:"

826 , indent $ line $ "class " ++ runProperName name

913 , 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."

828 ]

915 ]

829

916

830 renderSimpleErrorMessage (DeprecatedClassExport name) =

917 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:"

832 , indent $ line $ runProperName name

919 , indent $ line $ runProperName name

833 , line "Should instead use the form:"

920 , line "Should instead use the form:"

834 , indent $ line $ "class " ++ runProperName name

921 , 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."

836 ]

923 ]

837

924

838 renderSimpleErrorMessage (RedundantUnqualifiedImport name imp) =

925 renderSimpleErrorMessage (RedundantUnqualifiedImport name imp) =

@@ -857,15 +944,35 @@ prettyPrintSingleError full level e = do

857 renderSimpleErrorMessage (RedundantEmptyHidingImport mn) =

944 renderSimpleErrorMessage (RedundantEmptyHidingImport mn) =

858 line $ "The import for module " ++ runModuleName mn ++ " is redundant as all members have been explicitly hidden."

945 line $ "The import for module " ++ runModuleName mn ++ " is redundant as all members have been explicitly hidden."

859

946

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 _) =

861 paras [ line $ "Module " ++ runModuleName mn ++ " has unspecified imports, consider using the explicit form: "

954 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: "

862 , indent $ line $ "import " ++ runModuleName mn ++ " (" ++ intercalate ", " (map prettyPrintRef refs) ++ ")"

960 , indent $ line $ "import " ++ runModuleName mn ++ " (" ++ intercalate ", " (map prettyPrintRef refs) ++ ")"

863 ]

961 ]

864

962

865 renderSimpleErrorMessage (CaseBinderLengthDiffers l bs) =

963 renderSimpleErrorMessage (CaseBinderLengthDiffers l bs) =

866− paras $ [ line $ "Binder list length differs in case alternative:"

964+ paras [ line "Binder list length differs in case alternative:"

867− , indent $ line $ intercalate ", " $ fmap prettyPrintBinderAtom bs

965+ , indent $ line $ intercalate ", " $ fmap prettyPrintBinderAtom bs

868− , line $ "Expecting " ++ show l ++ " binder" ++ (if l == 1 then "" else "s") ++ "." ]

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+ ]

869

976

870 renderHint :: ErrorMessageHint -> Box.Box -> Box.Box

977 renderHint :: ErrorMessageHint -> Box.Box -> Box.Box

871 renderHint (ErrorUnifyingTypes t1 t2) detail =

978 renderHint (ErrorUnifyingTypes t1 t2) detail =

@@ -995,38 +1102,13 @@ prettyPrintSingleError full level e = do

995 paras :: [Box.Box] -> Box.Box

1102 paras :: [Box.Box] -> Box.Box

996 paras = Box.vcat Box.left

1103 paras = Box.vcat Box.left

997

1104

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−

1023 -- | Simplify an error message

1105 -- | Simplify an error message

1024 simplifyErrorMessage :: ErrorMessage -> ErrorMessage

1106 simplifyErrorMessage :: ErrorMessage -> ErrorMessage

1025 simplifyErrorMessage (ErrorMessage hints simple) = ErrorMessage (simplifyHints hints) simple

1107 simplifyErrorMessage (ErrorMessage hints simple) = ErrorMessage (simplifyHints hints) simple

1026 where

1108 where

1027 -- Take the last instance of each "hint category"

1109 -- Take the last instance of each "hint category"

1028 simplifyHints :: [ErrorMessageHint] -> [ErrorMessageHint]

1110 simplifyHints :: [ErrorMessageHint] -> [ErrorMessageHint]

1029− simplifyHints = reverse . nubBy categoriesEqual . reverse

1111+ simplifyHints = reverse . nubBy categoriesEqual . stripRedudantHints simple . reverse

1030

1112

1031 -- Don't remove hints in the "other" category

1113 -- Don't remove hints in the "other" category

1032 categoriesEqual :: ErrorMessageHint -> ErrorMessageHint -> Bool

1114 categoriesEqual :: ErrorMessageHint -> ErrorMessageHint -> Bool

@@ -1036,6 +1118,30 @@ prettyPrintSingleError full level e = do

1036 (_, OtherHint) -> False

1118 (_, OtherHint) -> False

1037 (c1, c2) -> c1 == c2

1119 (c1, c2) -> c1 == c2

1038

1120

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+

1039 hintCategory :: ErrorMessageHint -> HintCategory

1145 hintCategory :: ErrorMessageHint -> HintCategory

1040 hintCategory ErrorCheckingType{} = ExprHint

1146 hintCategory ErrorCheckingType{} = ExprHint

1041 hintCategory ErrorInferringType{} = ExprHint

1147 hintCategory ErrorInferringType{} = ExprHint

@@ -1047,36 +1153,60 @@ prettyPrintSingleError full level e = do

1047 hintCategory PositionedError{} = PositionHint

1153 hintCategory PositionedError{} = PositionHint

1048 hintCategory _ = OtherHint

1154 hintCategory _ = OtherHint

1049

1155

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+

1050-- |

1180-- |

1051-- Pretty print multiple errors

1181-- Pretty print multiple errors

1052--

1182--

1053prettyPrintMultipleErrors :: Bool -> MultipleErrors -> String

1183prettyPrintMultipleErrors :: Bool -> MultipleErrors -> String

1054−prettyPrintMultipleErrors full = renderBox . prettyPrintMultipleErrorsBox full

1184+prettyPrintMultipleErrors full = unlines . map renderBox . prettyPrintMultipleErrorsBox full

1055

1185

1056-- |

1186-- |

1057-- Pretty print multiple warnings

1187-- Pretty print multiple warnings

1058--

1188--

1059−prettyPrintMultipleWarnings :: Bool -> MultipleErrors -> String

1189+prettyPrintMultipleWarnings :: Bool -> MultipleErrors -> String

1060−prettyPrintMultipleWarnings full = renderBox . prettyPrintMultipleWarningsBox full

1190+prettyPrintMultipleWarnings full = unlines . map renderBox . prettyPrintMultipleWarningsBox full

1061

1191

1062-- | Pretty print warnings as a Box

1192-- | Pretty print warnings as a Box

1063−prettyPrintMultipleWarningsBox :: Bool -> MultipleErrors -> Box.Box

1193+prettyPrintMultipleWarningsBox :: Bool -> MultipleErrors -> [Box.Box]

1064−prettyPrintMultipleWarningsBox full = flip evalState defaultUnknownMap . prettyPrintMultipleErrorsWith Warning "Warning found:" "Warning" full

1194+prettyPrintMultipleWarningsBox full = prettyPrintMultipleErrorsWith Warning "Warning found:" "Warning" full

1065

1195

1066-- | Pretty print errors as a Box

1196-- | Pretty print errors as a Box

1067−prettyPrintMultipleErrorsBox :: Bool -> MultipleErrors -> Box.Box

1197+prettyPrintMultipleErrorsBox :: Bool -> MultipleErrors -> [Box.Box]

1068−prettyPrintMultipleErrorsBox full = flip evalState defaultUnknownMap . prettyPrintMultipleErrorsWith Error "Error found:" "Error" full

1198+prettyPrintMultipleErrorsBox full = prettyPrintMultipleErrorsWith Error "Error found:" "Error" full

1069−

1199+

1070−prettyPrintMultipleErrorsWith :: Level -> String -> String -> Bool -> MultipleErrors -> State TypeMap Box.Box

1200+prettyPrintMultipleErrorsWith :: Level -> String -> String -> Bool -> MultipleErrors -> [Box.Box]

1071−prettyPrintMultipleErrorsWith level intro _ full (MultipleErrors [e]) = do

1201+prettyPrintMultipleErrorsWith level intro _ full (MultipleErrors [e]) =

1072− result <- prettyPrintSingleError full level e

1202+ let result = prettyPrintSingleError full level True e

1073− return $

1074− Box.vcat Box.left [ Box.text intro

1203+ in [ Box.vcat Box.left [ Box.text intro

1075− , result

1204+ , result

1205+ ]

1076− ]

1206+ ]

1077−prettyPrintMultipleErrorsWith level _ intro full (MultipleErrors es) = do

1207+prettyPrintMultipleErrorsWith level _ intro full (MultipleErrors es) =

1078− result <- forM es $ prettyPrintSingleError full level

1208+ let result = map (prettyPrintSingleError full level True) es

1079− return $ Box.vsep 1 Box.left $ concat $ zipWith withIntro [1 :: Int ..] result

1209+ in concat $ zipWith withIntro [1 :: Int ..] result

1080 where

1210 where

1081 withIntro i err = [ Box.text (intro ++ " " ++ show i ++ " of " ++ show (length es) ++ ":")

1211 withIntro i err = [ Box.text (intro ++ " " ++ show i ++ " of " ++ show (length es) ++ ":")

1082 , Box.moveRight 2 err

1212 , Box.moveRight 2 err

@@ -1138,9 +1268,15 @@ line :: String -> Box.Box

1138line = Box.text

1268line = Box.text

1139

1269

1140renderBox :: Box.Box -> String

1270renderBox :: 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

1142 where

1277 where

1143− trimEnd = reverse . dropWhile (== ' ') . reverse

1278+ dropWhileEnd p = reverse . dropWhile p . reverse

1279+ whiteSpace = all isSpace

1144

1280

1145-- |

1281-- |

1146-- Rethrow an error with a more detailed error message in the case of failure

1282-- 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

1148rethrow :: (MonadError e m) => (e -> e) -> m a -> m a

1284rethrow :: (MonadError e m) => (e -> e) -> m a -> m a

1149rethrow f = flip catchError $ \e -> throwError (f e)

1285rethrow f = flip catchError $ \e -> throwError (f e)

1150

1286

1151−reifyErrors :: (Functor m, MonadError e m) => m a -> m (Either e a)

1287+reifyErrors :: (MonadError e m) => m a -> m (Either e a)

1152reifyErrors ma = catchError (fmap Right ma) (return . Left)

1288reifyErrors ma = catchError (fmap Right ma) (return . Left)

1153

1289

1154reflectErrors :: (MonadError e m) => m (Either e a) -> m a

1290reflectErrors :: (MonadError e m) => m (Either e a) -> m a

@@ -1175,13 +1311,13 @@ withPosition pos (ErrorMessage hints se) = ErrorMessage (PositionedError pos : h

1175-- |

1311-- |

1176-- Collect errors in in parallel

1312-- Collect errors in in parallel

1177--

1313--

1178−parU :: (MonadError MultipleErrors m, Functor m) => [a] -> (a -> m b) -> m [b]

1314+parU :: (MonadError MultipleErrors m) => [a] -> (a -> m b) -> m [b]

1179parU xs f = forM xs (withError . f) >>= collectErrors

1315parU xs f = forM xs (withError . f) >>= collectErrors

1180 where

1316 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)

1182 withError u = catchError (Right <$> u) (return . Left)

1318 withError u = catchError (Right <$> u) (return . Left)

1183

1319

1184− collectErrors :: (MonadError MultipleErrors m, Functor m) => [Either MultipleErrors a] -> m [a]

1320+ collectErrors :: (MonadError MultipleErrors m) => [Either MultipleErrors a] -> m [a]

1185 collectErrors es = case lefts es of

1321 collectErrors es = case lefts es of

1186 [] -> return $ rights es

1322 [] -> return $ rights es

1187 errs -> throwError $ fold errs

1323 errs -> throwError $ fold errs

src/Language/PureScript/Externs.hs+14−13

@@ -73,28 +73,28 @@ data ExternsFixity = ExternsFixity

73 -- | The operator symbol

74 , efOperator :: String

75 -- | The value the operator is an alias for

76− , efAlias :: Maybe Ident

76+ , efAlias :: Maybe (Either (Qualified Ident) (Qualified (ProperName 'ConstructorName)))

77 } deriving (Show, Read)

78

79-- | A type or value declaration appearing in an externs file

80data ExternsDeclaration =

81 -- | A type declaration

82 EDType

83− { edTypeName :: ProperName

83+ { edTypeName :: ProperName 'TypeName

84 , edTypeKind :: Kind

85 , edTypeDeclarationKind :: TypeKind

86 }

87 -- | A type synonym

88 | EDTypeSynonym

89− { edTypeSynonymName :: ProperName

89+ { edTypeSynonymName :: ProperName 'TypeName

90 , edTypeSynonymArguments :: [(String, Maybe Kind)]

91 , edTypeSynonymType :: Type

92 }

93 -- | A data construtor

94 | EDDataConstructor

95− { edDataCtorName :: ProperName

95+ { edDataCtorName :: ProperName 'ConstructorName

96 , edDataCtorOrigin :: DataDeclType

97− , edDataCtorTypeCtor :: ProperName

97+ , edDataCtorTypeCtor :: ProperName 'TypeName

98 , edDataCtorType :: Type

99 , edDataCtorFields :: [Ident]

100 }

@@ -105,14 +105,14 @@ data ExternsDeclaration =

105 }

106 -- | A type class declaration

107 | EDClass

108− { edClassName :: ProperName

108+ { edClassName :: ProperName 'ClassName

109 , edClassTypeArguments :: [(String, Maybe Kind)]

110 , edClassMembers :: [(Ident, Type)]

111 , edClassConstraints :: [Constraint]

112 }

113 -- | An instance declaration

114 | EDInstance

115− { edInstanceClassName :: Qualified ProperName

115+ { edInstanceClassName :: Qualified (ProperName 'ClassName)

116 , edInstanceName :: Ident

117 , edInstanceTypes :: [Type]

118 , edInstanceConstraints :: Maybe [Constraint]

@@ -153,7 +153,8 @@ moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..}

153 efDeclarations = concatMap toExternsDeclaration efExports

154

155 fixityDecl :: Declaration -> Maybe ExternsFixity

156+ fixityDecl (FixityDeclaration (Fixity assoc prec) op alias) =

156− fixityDecl (FixityDeclaration (Fixity assoc prec) op alias) = fmap (const (ExternsFixity assoc prec op alias)) (find exportsOp exps)

157+ fmap (const (ExternsFixity assoc prec op alias)) (find exportsOp exps)

157 where

158 where

158 exportsOp :: DeclarationRef -> Bool

159 exportsOp :: DeclarationRef -> Bool

159 exportsOp (PositionedDeclarationRef _ _ r) = exportsOp r

160 exportsOp (PositionedDeclarationRef _ _ r) = exportsOp r

@@ -178,7 +179,7 @@ moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..}

178 Just (kind, tk@(DataType _ tys)) ->

179 Just (kind, tk@(DataType _ tys)) ->

179 EDType pn kind tk : [ EDDataConstructor dctor dty pn ty args

180 EDType pn kind tk : [ EDDataConstructor dctor dty pn ty args

180 | dctor <- fromMaybe (map fst tys) dctors

181 | 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)

182 ]

183 ]

183 _ -> internalError "toExternsDeclaration: Invalid input"

184 _ -> internalError "toExternsDeclaration: Invalid input"

184 toExternsDeclaration (ValueRef ident)

185 toExternsDeclaration (ValueRef ident)

@@ -186,10 +187,10 @@ moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..}

186 = [ EDValue ident ty ]

187 = [ EDValue ident ty ]

187 toExternsDeclaration (TypeClassRef className)

188 toExternsDeclaration (TypeClassRef className)

188 | Just (args, members, implies) <- Qualified (Just mn) className `M.lookup` typeClasses env

189 | 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 (kind, TypeSynonym) <- Qualified (Just mn) (coerceProperName className) `M.lookup` types env

190− , Just (_, synTy) <- Qualified (Just mn) className `M.lookup` typeSynonyms env

191+ , Just (_, synTy) <- Qualified (Just mn) (coerceProperName className) `M.lookup` typeSynonyms env

191− = [ EDType className kind TypeSynonym

192+ = [ EDType (coerceProperName className) kind TypeSynonym

192− , EDTypeSynonym className args synTy

193+ , EDTypeSynonym (coerceProperName className) args synTy

193 , EDClass className args members implies

194 , EDClass className args members implies

194 ]

195 ]

195 toExternsDeclaration (TypeInstanceRef ident)

196 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 #-}

16{-# LANGUAGE TemplateHaskell #-}

1{-# LANGUAGE TemplateHaskell #-}

17

2

18module Language.PureScript.Kinds where

3module Language.PureScript.Kinds where

@@ -20,7 +5,6 @@ module Language.PureScript.Kinds where

20import Prelude ()

5import Prelude ()

21import Prelude.Compat

6import Prelude.Compat

22

7

23−import Data.Data

24import qualified Data.Aeson.TH as A

8import qualified Data.Aeson.TH as A

25

9

26-- |

10-- |

@@ -46,7 +30,8 @@ data Kind

46 -- |

30 -- |

47 -- Function kinds

31 -- Function kinds

48 --

32 --

33+ | FunKind Kind Kind

49− | FunKind Kind Kind deriving (Show, Read, Eq, Ord, Data, Typeable)

34+ deriving (Show, Read, Eq, Ord)

50

35

51$(A.deriveJSON A.defaultOptions ''Kind)

36$(A.deriveJSON A.defaultOptions ''Kind)

52

37

@@ -57,7 +42,7 @@ everywhereOnKinds f = go

57 go (FunKind k1 k2) = f (FunKind (go k1) (go k2))

42 go (FunKind k1 k2) = f (FunKind (go k1) (go k2))

58 go other = f other

43 go other = f other

59

44

60−everywhereOnKindsM :: (Functor m, Applicative m, Monad m) => (Kind -> m Kind) -> Kind -> m Kind

45+everywhereOnKindsM :: Monad m => (Kind -> m Kind) -> Kind -> m Kind

61everywhereOnKindsM f = go

46everywhereOnKindsM f = go

62 where

47 where

63 go (Row k1) = (Row <$> go k1) >>= f

48 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

29-- | Lint the PureScript AST.

30-- |

31-- | 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 ()

33lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDeclaration ds

34 where

35 moduleNames :: S.Set Ident

@@ -71,6 +71,7 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl

71 go d | Just i <- getDeclIdent d

72 , i `S.member` s = errorMessage (ShadowedName i)

73 | otherwise = mempty

74+ stepE _ (OperatorSection op val) = errorMessage $ DeprecatedOperatorSection op val

74 stepE _ _ = mempty

75 stepE _ _ = mempty

75

76

76 stepB :: S.Set Ident -> Binder -> MultipleErrors

77 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

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−

19{-# LANGUAGE FlexibleContexts #-}

1{-# LANGUAGE FlexibleContexts #-}

20{-# LANGUAGE ScopedTypeVariables #-}

2{-# LANGUAGE ScopedTypeVariables #-}

21

3

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+--

22module Language.PureScript.Linter.Exhaustive (checkExhaustiveModule) where

10module Language.PureScript.Linter.Exhaustive (checkExhaustiveModule) where

23

11

24import Prelude ()

12import Prelude ()

@@ -36,6 +24,7 @@ import Control.Monad.Writer.Class

36

24

37import Language.PureScript.Crash

25import Language.PureScript.Crash

38import Language.PureScript.AST.Binders

26import Language.PureScript.AST.Binders

27+import Language.PureScript.AST.Literals

39import Language.PureScript.AST.Declarations

28import Language.PureScript.AST.Declarations

40import Language.PureScript.Environment

29import Language.PureScript.Environment

41import Language.PureScript.Names as P

30import Language.PureScript.Names as P

@@ -43,18 +32,22 @@ import Language.PureScript.Kinds

43import Language.PureScript.Types as P

32import Language.PureScript.Types as P

44import Language.PureScript.Errors

33import Language.PureScript.Errors

45

34

46−-- | There are two modes of failure for the redudancy check:

35+-- | There are two modes of failure for the redundancy check:

47--

36--

48-- 1. Exhaustivity was incomplete due to too many cases, so we couldn't determine redundancy.

37-- 1. Exhaustivity was incomplete due to too many cases, so we couldn't determine redundancy.

49-- 2. We didn't attempt to determine redundancy for a binder, e.g. an integer binder.

38-- 2. We didn't attempt to determine redundancy for a binder, e.g. an integer binder.

50--

39--

51-- We want to warn the user in the first case.

40-- We want to warn the user in the first case.

52−data RedudancyError = Incomplete | Unknown

41+data RedundancyError = Incomplete | Unknown

53

42

54-- |

43-- |

55-- Qualifies a propername from a given qualified propername and a default module name

44-- Qualifies a propername from a given qualified propername and a default module name

56--

45--

57−qualifyName :: a -> ModuleName -> Qualified a -> Qualified a

46+qualifyName

47+ :: (ProperName a)

48+ -> ModuleName

49+ -> Qualified (ProperName b)

50+ -> Qualified (ProperName a)

58qualifyName n defmn qn = Qualified (Just mn) n

51qualifyName n defmn qn = Qualified (Just mn) n

59 where

52 where

60 (mn, _) = qualify defmn qn

53 (mn, _) = qualify defmn qn

@@ -65,31 +58,28 @@ qualifyName n defmn qn = Qualified (Just mn) n

65-- where: - ProperName is the name of the constructor (for example, "Nothing" in Maybe)

58-- where: - ProperName is the name of the constructor (for example, "Nothing" in Maybe)

66-- - [Type] is the list of arguments, if it has (for example, "Just" has [TypeVar "a"])

59-- - [Type] is the list of arguments, if it has (for example, "Just" has [TypeVar "a"])

67--

60--

68−getConstructors :: Environment -> ModuleName -> Qualified ProperName -> [(ProperName, [Type])]

61+getConstructors :: Environment -> ModuleName -> Qualified (ProperName 'ConstructorName) -> [(ProperName 'ConstructorName, [Type])]

69getConstructors env defmn n = extractConstructors lnte

62getConstructors env defmn n = extractConstructors lnte

70 where

63 where

71− qpn :: Qualified ProperName

72− qpn = getConsDataName n

73

64

74− getConsDataName :: Qualified ProperName -> Qualified ProperName

65+ extractConstructors :: Maybe (Kind, TypeKind) -> [(ProperName 'ConstructorName, [Type])]

75− getConsDataName con = qualifyName nm defmn con

66+ extractConstructors (Just (_, DataType _ pt)) = pt

76− where

67+ extractConstructors _ = internalError "Data name not in the scope of the current environment in extractConstructors"

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

86

68

87 lnte :: Maybe (Kind, TypeKind)

69 lnte :: Maybe (Kind, TypeKind)

88 lnte = M.lookup qpn (types env)

70 lnte = M.lookup qpn (types env)

89

71

90− extractConstructors :: Maybe (Kind, TypeKind) -> [(ProperName, [Type])]

72+ qpn :: Qualified (ProperName 'TypeName)

91− extractConstructors (Just (_, DataType _ pt)) = pt

73+ qpn = getConsDataName n

74+

75+ getConsDataName :: Qualified (ProperName 'ConstructorName) -> Qualified (ProperName 'TypeName)

76+ getConsDataName con =

77+ case getConsInfo con of

92− extractConstructors _ = internalError "Data name not in the scope of the current environment in extractConstructors"

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)

93

83

94-- |

84-- |

95-- Replicates a wildcard binder

85-- Replicates a wildcard binder

@@ -117,7 +107,7 @@ genericMerge f bsl@((s, b):bs) bsr@((s', b'):bs')

117-- Find the uncovered set between two binders:

107-- Find the uncovered set between two binders:

118-- the first binder is the case we are trying to cover, the second one is the matching binder

108-- the first binder is the case we are trying to cover, the second one is the matching binder

119--

109--

120−missingCasesSingle :: Environment -> ModuleName -> Binder -> Binder -> ([Binder], Either RedudancyError Bool)

110+missingCasesSingle :: Environment -> ModuleName -> Binder -> Binder -> ([Binder], Either RedundancyError Bool)

121missingCasesSingle _ _ _ NullBinder = ([], return True)

111missingCasesSingle _ _ _ NullBinder = ([], return True)

122missingCasesSingle _ _ _ (VarBinder _) = ([], return True)

112missingCasesSingle _ _ _ (VarBinder _) = ([], return True)

123missingCasesSingle env mn (VarBinder _) b = missingCasesSingle env mn NullBinder b

113missingCasesSingle env mn (VarBinder _) b = missingCasesSingle env mn NullBinder b

@@ -130,12 +120,12 @@ missingCasesSingle env mn NullBinder cb@(ConstructorBinder con _) =

130missingCasesSingle env mn cb@(ConstructorBinder con bs) (ConstructorBinder con' bs')

120missingCasesSingle env mn cb@(ConstructorBinder con bs) (ConstructorBinder con' bs')

131 | con == con' = let (bs'', pr) = missingCasesMultiple env mn bs bs' in (map (ConstructorBinder con) bs'', pr)

121 | con == con' = let (bs'', pr) = missingCasesMultiple env mn bs bs' in (map (ConstructorBinder con) bs'', pr)

132 | otherwise = ([cb], return False)

122 | otherwise = ([cb], return False)

133−missingCasesSingle env mn NullBinder (ObjectBinder bs) =

123+missingCasesSingle env mn NullBinder (LiteralBinder (ObjectLiteral bs)) =

134− (map (ObjectBinder . zip (map fst bs)) allMisses, pr)

124+ (map (LiteralBinder . ObjectLiteral . zip (map fst bs)) allMisses, pr)

135 where

125 where

136 (allMisses, pr) = missingCasesMultiple env mn (initialize $ length bs) (map snd bs)

126 (allMisses, pr) = missingCasesMultiple env mn (initialize $ length bs) (map snd bs)

137−missingCasesSingle env mn (ObjectBinder bs) (ObjectBinder bs') =

127+missingCasesSingle env mn (LiteralBinder (ObjectLiteral bs)) (LiteralBinder (ObjectLiteral bs')) =

138− (map (ObjectBinder . zip sortedNames) allMisses, pr)

128+ (map (LiteralBinder . ObjectLiteral . zip sortedNames) allMisses, pr)

139 where

129 where

140 (allMisses, pr) = uncurry (missingCasesMultiple env mn) (unzip binders)

130 (allMisses, pr) = uncurry (missingCasesMultiple env mn) (unzip binders)

141

131

@@ -152,10 +142,10 @@ missingCasesSingle env mn (ObjectBinder bs) (ObjectBinder bs') =

152 compBS e s b b' = (s, compB e b b')

142 compBS e s b b' = (s, compB e b b')

153

143

154 (sortedNames, binders) = unzip $ genericMerge (compBS NullBinder) sbs sbs'

144 (sortedNames, binders) = unzip $ genericMerge (compBS NullBinder) sbs sbs'

155−missingCasesSingle _ _ NullBinder (BooleanBinder b) = ([BooleanBinder $ not b], return True)

145+missingCasesSingle _ _ NullBinder (LiteralBinder (BooleanLiteral b)) = ([LiteralBinder . BooleanLiteral $ not b], return True)

156−missingCasesSingle _ _ (BooleanBinder bl) (BooleanBinder br)

146+missingCasesSingle _ _ (LiteralBinder (BooleanLiteral bl)) (LiteralBinder (BooleanLiteral br))

157 | bl == br = ([], return True)

147 | bl == br = ([], return True)

158− | otherwise = ([BooleanBinder bl], return False)

148+ | otherwise = ([LiteralBinder $ BooleanLiteral bl], return False)

159missingCasesSingle env mn b (PositionedBinder _ _ cb) = missingCasesSingle env mn b cb

149missingCasesSingle env mn b (PositionedBinder _ _ cb) = missingCasesSingle env mn b cb

160missingCasesSingle env mn b (TypedBinder _ cb) = missingCasesSingle env mn b cb

150missingCasesSingle env mn b (TypedBinder _ cb) = missingCasesSingle env mn b cb

161missingCasesSingle _ _ b _ = ([b], Left Unknown)

151missingCasesSingle _ _ b _ = ([b], Left Unknown)

@@ -186,7 +176,7 @@ missingCasesSingle _ _ b _ = ([b], Left Unknown)

186-- redundant or not, but uncovered at least. If we use `y` instead, we'll need to have a redundancy checker

176-- redundant or not, but uncovered at least. If we use `y` instead, we'll need to have a redundancy checker

187-- (which ought to be available soon), or increase the complexity of the algorithm.

177-- (which ought to be available soon), or increase the complexity of the algorithm.

188--

178--

189−missingCasesMultiple :: Environment -> ModuleName -> [Binder] -> [Binder] -> ([[Binder]], Either RedudancyError Bool)

179+missingCasesMultiple :: Environment -> ModuleName -> [Binder] -> [Binder] -> ([[Binder]], Either RedundancyError Bool)

190missingCasesMultiple env mn = go

180missingCasesMultiple env mn = go

191 where

181 where

192 go [] [] = ([], pure True)

182 go [] [] = ([], pure True)

@@ -212,18 +202,21 @@ isExhaustiveGuard :: Either [(Guard, Expr)] Expr -> Bool

212isExhaustiveGuard (Left gs) = not . null $ filter (\(g, _) -> isOtherwise g) gs

202isExhaustiveGuard (Left gs) = not . null $ filter (\(g, _) -> isOtherwise g) gs

213 where

203 where

214 isOtherwise :: Expr -> Bool

204 isOtherwise :: Expr -> Bool

215− isOtherwise (TypedValue _ (BooleanLiteral True) _) = True

205+ isOtherwise (Literal (BooleanLiteral True)) = True

216− isOtherwise (TypedValue _ (Var (Qualified (Just (ModuleName [ProperName "Prelude"])) (Ident "otherwise"))) _) = 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

217 isOtherwise _ = False

210 isOtherwise _ = False

218isExhaustiveGuard (Right _) = True

211isExhaustiveGuard (Right _) = True

219

212

220-- |

213-- |

221-- Returns the uncovered set of case alternatives

214-- Returns the uncovered set of case alternatives

222--

215--

223−missingCases :: Environment -> ModuleName -> [Binder] -> CaseAlternative -> ([[Binder]], Either RedudancyError Bool)

216+missingCases :: Environment -> ModuleName -> [Binder] -> CaseAlternative -> ([[Binder]], Either RedundancyError Bool)

224missingCases env mn uncovered ca = missingCasesMultiple env mn uncovered (caseAlternativeBinders ca)

217missingCases env mn uncovered ca = missingCasesMultiple env mn uncovered (caseAlternativeBinders ca)

225

218

226−missingAlternative :: Environment -> ModuleName -> CaseAlternative -> [Binder] -> ([[Binder]], Either RedudancyError Bool)

219+missingAlternative :: Environment -> ModuleName -> CaseAlternative -> [Binder] -> ([[Binder]], Either RedundancyError Bool)

227missingAlternative env mn ca uncovered

220missingAlternative env mn ca uncovered

228 | isExhaustiveGuard (caseAlternativeResult ca) = mcases

221 | isExhaustiveGuard (caseAlternativeResult ca) = mcases

229 | otherwise = ([uncovered], snd mcases)

222 | otherwise = ([uncovered], snd mcases)

@@ -239,13 +232,13 @@ missingAlternative env mn ca uncovered

239checkExhaustive :: forall m. (MonadWriter MultipleErrors m) => Bool -> Environment -> ModuleName -> Int -> [CaseAlternative] -> m ()

232checkExhaustive :: forall m. (MonadWriter MultipleErrors m) => Bool -> Environment -> ModuleName -> Int -> [CaseAlternative] -> m ()

240checkExhaustive hasConstraint env mn numArgs cas = makeResult . first nub $ foldl' step ([initialize numArgs], (pure True, [])) cas

233checkExhaustive hasConstraint env mn numArgs cas = makeResult . first nub $ foldl' step ([initialize numArgs], (pure True, [])) cas

241 where

234 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]]))

243 step (uncovered, (nec, redundant)) ca =

236 step (uncovered, (nec, redundant)) ca =

244 let (missed, pr) = unzip (map (missingAlternative env mn ca) uncovered)

237 let (missed, pr) = unzip (map (missingAlternative env mn ca) uncovered)

245 (missed', approx) = splitAt 10000 (nub (concat missed))

238 (missed', approx) = splitAt 10000 (nub (concat missed))

246− cond = liftA2 (&&) (or <$> sequenceA pr) nec

239+ cond = or <$> sequenceA pr

247 in (missed', ( if null approx

240 in (missed', ( if null approx

248− then cond

241+ then liftA2 (&&) cond nec

249 else Left Incomplete

242 else Left Incomplete

250 , if either (const True) id cond

243 , if either (const True) id cond

251 then redundant

244 then redundant

@@ -253,7 +246,7 @@ checkExhaustive hasConstraint env mn numArgs cas = makeResult . first nub $ fold

253 )

246 )

254 )

247 )

255

248

256− makeResult :: ([[Binder]], (Either RedudancyError Bool, [[Binder]])) -> m ()

249+ makeResult :: ([[Binder]], (Either RedundancyError Bool, [[Binder]])) -> m ()

257 makeResult (bss, (rr, bss')) =

250 makeResult (bss, (rr, bss')) =

258 do unless (hasConstraint || null bss) tellNonExhaustive

251 do unless (hasConstraint || null bss) tellNonExhaustive

259 unless (null bss') tellRedundant

252 unless (null bss') tellRedundant

@@ -268,7 +261,7 @@ checkExhaustive hasConstraint env mn numArgs cas = makeResult . first nub $ fold

268-- |

261-- |

269-- Exhaustivity checking over a list of declarations

262-- Exhaustivity checking over a list of declarations

270--

263--

271−checkExhaustiveDecls :: forall m. (Applicative m, MonadWriter MultipleErrors m) => Environment -> ModuleName -> [Declaration] -> m ()

264+checkExhaustiveDecls :: forall m. MonadWriter MultipleErrors m => Environment -> ModuleName -> [Declaration] -> m ()

272checkExhaustiveDecls env mn = mapM_ onDecl

265checkExhaustiveDecls env mn = mapM_ onDecl

273 where

266 where

274 onDecl :: Declaration -> m ()

267 onDecl :: Declaration -> m ()

@@ -282,8 +275,8 @@ checkExhaustiveDecls env mn = mapM_ onDecl

282

275

283 onExpr :: Bool -> Expr -> m ()

276 onExpr :: Bool -> Expr -> m ()

284 onExpr isP (UnaryMinus e) = onExpr isP e

277 onExpr isP (UnaryMinus e) = onExpr isP e

285− onExpr isP (ArrayLiteral es) = mapM_ (onExpr isP) es

278+ onExpr isP (Literal (ArrayLiteral es)) = mapM_ (onExpr isP) es

286− onExpr isP (ObjectLiteral es) = mapM_ (onExpr isP . snd) es

279+ onExpr isP (Literal (ObjectLiteral es)) = mapM_ (onExpr isP . snd) es

287 onExpr isP (TypeClassDictionaryConstructorApp _ e) = onExpr isP e

280 onExpr isP (TypeClassDictionaryConstructorApp _ e) = onExpr isP e

288 onExpr isP (Accessor _ e) = onExpr isP e

281 onExpr isP (Accessor _ e) = onExpr isP e

289 onExpr isP (ObjectUpdate o es) = onExpr isP o >> mapM_ (onExpr isP . snd) es

282 onExpr isP (ObjectUpdate o es) = onExpr isP o >> mapM_ (onExpr isP . snd) es

@@ -303,19 +296,19 @@ checkExhaustiveDecls env mn = mapM_ onDecl

303 hasPartialConstraint :: Type -> Bool

296 hasPartialConstraint :: Type -> Bool

304 hasPartialConstraint (ConstrainedType cs _) = any (go . fst) cs

297 hasPartialConstraint (ConstrainedType cs _) = any (go . fst) cs

305 where

298 where

306− go :: Qualified ProperName -> Bool

299+ go :: Qualified (ProperName 'ClassName) -> Bool

307 go qname

300 go qname

308 | qname == partialClass = True

301 | qname == partialClass = True

309 | otherwise =

302 | otherwise =

310 case qname `M.lookup` typeClasses env of

303 case qname `M.lookup` typeClasses env of

311 Just ([], _, cs') -> any (go . fst) cs'

304 Just ([], _, cs') -> any (go . fst) cs'

312 _ -> False

305 _ -> False

313− partialClass :: Qualified ProperName

306+ partialClass :: Qualified (ProperName 'ClassName)

314 partialClass = primName "Partial"

307 partialClass = primName "Partial"

315 hasPartialConstraint _ = False

308 hasPartialConstraint _ = False

316

309

317-- |

310-- |

318-- Exhaustivity checking over a single module

311-- Exhaustivity checking over a single module

319--

312--

320−checkExhaustiveModule :: forall m. (Applicative m, MonadWriter MultipleErrors m) => Environment -> Module -> m ()

313+checkExhaustiveModule :: forall m. MonadWriter MultipleErrors m => Environment -> Module -> m ()

321checkExhaustiveModule env (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ checkExhaustiveDecls env mn ds

314checkExhaustiveModule env (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ checkExhaustiveDecls env mn ds

src/Language/PureScript/Linter/Imports.hs+251−93

@@ -1,18 +1,24 @@

1{-# LANGUAGE ScopedTypeVariables #-}

2{-# LANGUAGE FlexibleContexts #-}

3

4−module Language.PureScript.Linter.Imports (findUnusedImports, Name(..), UsedImports()) where

4+module Language.PureScript.Linter.Imports

5+ ( lintImports

6+ , Name(..)

7+ , UsedImports()

8+ ) where

5

9

6import Prelude ()

10import Prelude ()

7import Prelude.Compat

11import Prelude.Compat

8

12

9−import qualified Data.Map as M

13+import Control.Monad (unless, when)

10−import Data.Maybe (mapMaybe)

11−import Data.List ((\\), find, intersect, nub)

12import Control.Monad.Error.Class (MonadError(..))

14import Control.Monad.Error.Class (MonadError(..))

13import Control.Monad.Writer.Class

15import Control.Monad.Writer.Class

14−import Control.Monad (unless,when)

16+

15import Data.Foldable (forM_)

17import 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

16

22

17import Language.PureScript.AST.Declarations

23import Language.PureScript.AST.Declarations

18import Language.PureScript.AST.SourcePos

24import Language.PureScript.AST.SourcePos

@@ -28,130 +34,280 @@ import qualified Language.PureScript.Constants as C

28-- | Imported name used in some type or expression.

34-- | Imported name used in some type or expression.

29data Name

35data Name

30 = IdentName (Qualified Ident)

36 = IdentName (Qualified Ident)

31− | TypeName (Qualified ProperName)

37+ | TyName (Qualified (ProperName 'TypeName))

32− | DctorName (Qualified ProperName)

38+ | DctorName (Qualified (ProperName 'ConstructorName))

33− | ClassName (Qualified ProperName)

39+ | TyClassName (Qualified (ProperName 'ClassName))

34− deriving (Eq)

40+ deriving (Eq, Show)

35

41

36−getIdentName :: Name -> Maybe Ident

42+getIdentName :: Maybe ModuleName -> Name -> Maybe Ident

37−getIdentName (IdentName (Qualified _ name)) = Just name

43+getIdentName q (IdentName (Qualified q' name)) | q == q' = Just name

38−getIdentName _ = Nothing

44+getIdentName _ _ = Nothing

39

45

40−getTypeName :: Name -> Maybe ProperName

46+getTypeName :: Maybe ModuleName -> Name -> Maybe (ProperName 'TypeName)

41−getTypeName (TypeName (Qualified _ name)) = Just name

47+getTypeName q (TyName (Qualified q' name)) | q == q' = Just name

42−getTypeName _ = Nothing

48+getTypeName _ _ = Nothing

43

49

44−getClassName :: Name -> Maybe ProperName

50+getClassName :: Maybe ModuleName -> Name -> Maybe (ProperName 'ClassName)

45−getClassName (ClassName (Qualified _ name)) = Just name

51+getClassName q (TyClassName (Qualified q' name)) | q == q' = Just name

46−getClassName _ = Nothing

52+getClassName _ _ = Nothing

47

53

48-- | Map of module name to list of imported names from that module which have been used.

54-- | Map of module name to list of imported names from that module which have been used.

49type UsedImports = M.Map ModuleName [Name]

55type UsedImports = M.Map ModuleName [Name]

50

56

51-- |

57-- |

52−-- Find and warn on any unused import statements (qualified or unqualified)

58+-- Find and warn on:

53−-- or references in an explicit import list.

54--

59--

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

55−findUnusedImports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Module -> Env -> UsedImports -> m ()

73+ . (MonadError MultipleErrors m, MonadWriter MultipleErrors m)

74+ => Module

75+ -> Env

76+ -> UsedImports

77+ -> m ()

56−findUnusedImports (Module _ _ _ mdecls mexports) env usedImps = do

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+

57− imps <- findImports mdecls

85+ imps <- M.toAscList <$> findImports mdecls

86+

58− forM_ (M.toAscList imps) $ \(mni, decls) -> unless (mni `elem` alwaysUsedModules) $

87+ forM_ imps $ \(mni, decls) ->

88+ unless (isPrim mni) $ do

59− forM_ decls $ \(ss, declType, qualifierName) ->

89+ forM_ decls $ \(ss, declType, qualifierName) ->

60− censor (onErrorMessages $ addModuleLocError ss) $ unless (qnameUsed qualifierName) $

90+ censor (onErrorMessages $ addModuleLocError ss) $ do

61− let names = nub $ sugarNames mni ++ M.findWithDefault [] mni usedImps

91+ let names = nub $ M.findWithDefault [] mni usedImps'

62− usedNames = mapMaybe (matchName (typeForDCtor mni) qualifierName) names

92+ lintImportDecl env mni qualifierName names declType allowImplicit

63− usedDctors = mapMaybe (matchDctor qualifierName) names

93+

64− in case declType of

94+ forM_ (M.toAscList (byQual imps)) $ \(mnq, entries) -> do

65− Implicit _ | null usedNames -> tell $ errorMessage $ UnusedImport mni

95+ let mnis = nub $ map (\(_, _, mni) -> mni) entries

66− Implicit False ->

96+ unless (length mnis == 1) $ do

67− let classRefs = TypeClassRef <$> mapMaybe getClassName names

97+ let implicits = filter (\(_, declType, _) -> not $ isExplicit declType) entries

68− valueRefs = ValueRef <$> mapMaybe getIdentName names

98+ forM_ implicits $ \(ss, _, mni) ->

69− types = mapMaybe getTypeName names

99+ censor (onErrorMessages $ addModuleLocError ss) $ do

70− typesWithDctors = reconstructTypeRefs mni usedDctors

100+ let names = nub $ M.findWithDefault [] mni usedImps'

71− typesWithoutDctors = filter (`M.notMember` typesWithDctors) types

101+ usedRefs = findUsedRefs env mni (Just mnq) names

72− typesRefs

102+ unless (null usedRefs) $

73− = map (flip TypeRef (Just [])) typesWithoutDctors

103+ tell $ errorMessage $ ImplicitQualifiedImport mni mnq usedRefs

74− ++ map (\(ty, ds) -> TypeRef ty (Just ds)) (M.toList typesWithDctors)

104+

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 ()

105+ return ()

96−

106+

97− _ -> return ()

98 where

107 where

99− sugarNames :: ModuleName -> [ Name ]

100− sugarNames (ModuleName [ProperName n]) | n == C.prelude = [ IdentName $ Qualified Nothing (Ident C.bind) ]

101− sugarNames _ = []

102

108

103− reconstructTypeRefs :: ModuleName -> [ProperName] -> M.Map ProperName [ProperName]

109+ countOpenImports :: Declaration -> Int

104− reconstructTypeRefs mni = foldr accumDctors M.empty

110+ countOpenImports (ImportDeclaration mn' Implicit Nothing _) | not (isPrim mn') = 1

105− where

111+ countOpenImports (ImportDeclaration mn' (Hiding _) Nothing _) | not (isPrim mn') = 1

106− accumDctors dctor = M.alter (Just . maybe [dctor] (dctor :)) (findTypeForDctor mni dctor)

112+ countOpenImports (PositionedDeclaration _ _ d) = countOpenImports d

113+ countOpenImports _ = 0

107

114

108− findTypeForDctor :: ModuleName -> ProperName -> ProperName

115+ -- Checks whether a module is the Prim module - used to suppress any checks

109− findTypeForDctor mn dctor =

116+ -- made, as Prim is always implicitly imported.

110− case mn `M.lookup` env of

117+ isPrim :: ModuleName -> Bool

111− Just (_, _, exps) ->

118+ isPrim = (== ModuleName [ProperName C.prim])

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"

116

119

117− -- rely on exports being elaborated by this point

120+ -- Creates a map of virtual modules mapped to all the declarations that

118− alwaysUsedModules :: [ ModuleName ]

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]

119− alwaysUsedModules = ModuleName [ProperName C.prim] : maybe [] (mapMaybe extractModule) mexports

137+ exportedModules = nub $ maybe [] (mapMaybe extractModule) mexports

120 where

138 where

121 extractModule (PositionedDeclarationRef _ _ r) = extractModule r

139 extractModule (PositionedDeclarationRef _ _ r) = extractModule r

122− extractModule (ModuleRef mn) = Just mn

140+ extractModule (ModuleRef mne) = Just mne

123 extractModule _ = Nothing

141 extractModule _ = Nothing

124

142

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

125− qnameUsed :: Maybe ModuleName -> Bool

176+ -> Maybe ModuleName

126− qnameUsed (Just qn) = qn `elem` alwaysUsedModules

177+ -> [Name]

127− qnameUsed Nothing = False

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 ()

128

226

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

129− dtys :: ModuleName -> [((ProperName, [ProperName]), ModuleName)]

235+ -> [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]

130 dtys mn = maybe [] exportedTypes $ envModuleExports <$> mn `M.lookup` env

236 dtys mn = maybe [] exportedTypes $ envModuleExports <$> mn `M.lookup` env

131

237

132− dctorsForType :: ModuleName -> ProperName -> [ProperName]

238+ dctorsForType

239+ :: ModuleName

240+ -> ProperName 'TypeName

241+ -> [ProperName 'ConstructorName]

133 dctorsForType mn tn =

242 dctorsForType mn tn =

134 maybe [] getDctors (find matches $ dtys mn)

243 maybe [] getDctors (find matches $ dtys mn)

135 where

244 where

136 matches ((ty, _),_) = ty == tn

245 matches ((ty, _),_) = ty == tn

137 getDctors ((_,ctors),_) = ctors

246 getDctors ((_,ctors),_) = ctors

138

247

248+ typeForDCtor

249+ :: ModuleName

250+ -> ProperName 'ConstructorName

139− typeForDCtor :: ModuleName -> ProperName -> Maybe ProperName

251+ -> Maybe (ProperName 'TypeName)

140 typeForDCtor mn pn =

252 typeForDCtor mn pn =

141 getTy <$> find matches (dtys mn)

253 getTy <$> find matches (dtys mn)

142 where

254 where

143 matches ((_, ctors), _) = pn `elem` ctors

255 matches ((_, ctors), _) = pn `elem` ctors

144 getTy ((ty, _), _) = ty

256 getTy ((ty, _), _) = ty

145

257

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

146

271

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

147−matchName :: (ProperName -> Maybe ProperName) -> Maybe ModuleName -> Name -> Maybe String

294+ :: (ProperName 'ConstructorName -> Maybe (ProperName 'TypeName))

295+ -> Maybe ModuleName

296+ -> Name

297+ -> Maybe String

148matchName _ qual (IdentName (Qualified q x)) | q == qual = Just $ showIdent x

298matchName _ qual (IdentName (Qualified q x)) | q == qual = Just $ showIdent x

149−matchName _ qual (TypeName (Qualified q x)) | q == qual = Just $ runProperName x

299+matchName _ qual (TyName (Qualified q x)) | q == qual = Just $ runProperName x

150−matchName _ qual (ClassName (Qualified q x)) | q == qual = Just $ runProperName x

300+matchName _ qual (TyClassName (Qualified q x)) | q == qual = Just $ runProperName x

151matchName lookupDc qual (DctorName (Qualified q x)) | q == qual = runProperName <$> lookupDc x

301matchName lookupDc qual (DctorName (Qualified q x)) | q == qual = runProperName <$> lookupDc x

152matchName _ _ _ = Nothing

302matchName _ _ _ = Nothing

153

303

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+

154−matchDctor :: Maybe ModuleName -> Name -> Maybe ProperName

310+matchDctor :: Maybe ModuleName -> Name -> Maybe (ProperName 'ConstructorName)

155matchDctor qual (DctorName (Qualified q x)) | q == qual = Just x

311matchDctor qual (DctorName (Qualified q x)) | q == qual = Just x

156matchDctor _ _ = Nothing

312matchDctor _ _ = Nothing

157

313

@@ -162,7 +318,9 @@ runDeclRef (TypeRef pn _) = Just $ runProperName pn

162runDeclRef (TypeClassRef pn) = Just $ runProperName pn

318runDeclRef (TypeClassRef pn) = Just $ runProperName pn

163runDeclRef _ = Nothing

319runDeclRef _ = Nothing

164

320

321+getTypeRef

322+ :: DeclarationRef

165−getTypeRef :: DeclarationRef -> Maybe (ProperName, Maybe [ProperName])

323+ -> Maybe (ProperName 'TypeName, Maybe [ProperName 'ConstructorName])

166getTypeRef (PositionedDeclarationRef _ _ ref) = getTypeRef ref

324getTypeRef (PositionedDeclarationRef _ _ ref) = getTypeRef ref

167getTypeRef (TypeRef pn x) = Just (pn, x)

325getTypeRef (TypeRef pn x) = Just (pn, x)

168getTypeRef _ = Nothing

326getTypeRef _ = Nothing

src/Language/PureScript/Make.hs+42−8

@@ -1,4 +1,3 @@

1−{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE FlexibleContexts #-}

1{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE GeneralizedNewtypeDeriving #-}

2{-# LANGUAGE GeneralizedNewtypeDeriving #-}

4{-# LANGUAGE TupleSections #-}

3{-# LANGUAGE TupleSections #-}

@@ -32,7 +31,7 @@ import Control.Monad.Writer.Class (MonadWriter(..))

32import Control.Monad.Trans.Class (MonadTrans(..))

31import Control.Monad.Trans.Class (MonadTrans(..))

33import Control.Monad.Trans.Except

32import Control.Monad.Trans.Except

34import Control.Monad.IO.Class

33import Control.Monad.IO.Class

35−import Control.Monad.Reader (MonadReader(..), ReaderT(..))

34+import Control.Monad.Reader (MonadReader(..), ReaderT(..), asks)

36import Control.Monad.Logger

35import Control.Monad.Logger

37import Control.Monad.Supply

36import Control.Monad.Supply

38import Control.Monad.Base (MonadBase(..))

37import Control.Monad.Base (MonadBase(..))

@@ -53,9 +52,12 @@ import qualified Data.ByteString.UTF8 as BU8

53import qualified Data.Set as S

52import qualified Data.Set as S

54import qualified Data.Map as M

53import qualified Data.Map as M

55

54

55+import SourceMap.Types

56+import SourceMap

57+

56import System.Directory

58import System.Directory

57− (doesFileExist, getModificationTime, createDirectoryIfMissing)

59+ (doesFileExist, getModificationTime, createDirectoryIfMissing, getCurrentDirectory)

58−import System.FilePath ((</>), takeDirectory)

60+import System.FilePath ((</>), takeDirectory, makeRelative, splitPath, normalise)

59import System.IO.Error (tryIOError)

61import System.IO.Error (tryIOError)

60import System.IO.UTF8 (readUTF8File, writeUTF8File)

62import System.IO.UTF8 (readUTF8File, writeUTF8File)

61

63

@@ -69,6 +71,7 @@ import Language.PureScript.ModuleDependencies

69import Language.PureScript.Names

71import Language.PureScript.Names

70import Language.PureScript.Options

72import Language.PureScript.Options

71import Language.PureScript.Pretty

73import Language.PureScript.Pretty

74+import Language.PureScript.Pretty.Common(SMap(..))

72import Language.PureScript.Renamer

75import Language.PureScript.Renamer

73import Language.PureScript.Sugar

76import Language.PureScript.Sugar

74import Language.PureScript.TypeChecker

77import Language.PureScript.TypeChecker

@@ -142,7 +145,7 @@ data RebuildPolicy

142-- If timestamps have not changed, the externs file can be used to provide the module's types without

145-- If timestamps have not changed, the externs file can be used to provide the module's types without

143-- having to typecheck the module again.

146-- having to typecheck the module again.

144--

147--

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)

146 => MakeActions m

149 => MakeActions m

147 -> [Module]

150 -> [Module]

148 -> m Environment

151 -> m Environment

@@ -325,20 +328,51 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =

325 | not $ requiresForeign m -> do

328 | not $ requiresForeign m -> do

326 tell $ errorMessage $ UnnecessaryFFIModule mn path

329 tell $ errorMessage $ UnnecessaryFFIModule mn path

327 return Nothing

330 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"]

329 Nothing | requiresForeign m -> throwError . errorMessage $ MissingFFIModule mn

332 Nothing | requiresForeign m -> throwError . errorMessage $ MissingFFIModule mn

330 | otherwise -> return Nothing

333 | 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, [])

332 let filePath = runModuleName mn

338 let filePath = runModuleName mn

333 jsFile = outputDir </> filePath </> "index.js"

339 jsFile = outputDir </> filePath </> "index.js"

340+ mapFile = outputDir </> filePath </> "index.js.map"

334 externsFile = outputDir </> filePath </> "externs.json"

341 externsFile = outputDir </> filePath </> "externs.json"

335 foreignFile = outputDir </> filePath </> "foreign.js"

342 foreignFile = outputDir </> filePath </> "foreign.js"

336 prefix = ["Generated by psc version " ++ showVersion Paths.version | usePrefix]

343 prefix = ["Generated by psc version " ++ showVersion Paths.version | usePrefix]

337 js = unlines $ map ("// " ++) prefix ++ [pjs]

344 js = unlines $ map ("// " ++) prefix ++ [pjs]

345+ mapRef = if sourceMaps then "//# sourceMappingURL=index.js.map\n" else ""

338 lift $ do

346 lift $ do

339− writeTextFile jsFile (fromString js)

347+ writeTextFile jsFile (fromString $ js ++ mapRef)

340 for_ (mn `M.lookup` foreigns) (readTextFile >=> writeTextFile foreignFile)

348 for_ (mn `M.lookup` foreigns) (readTextFile >=> writeTextFile foreignFile)

341 writeTextFile externsFile exts

349 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 }

342

376

343 requiresForeign :: CF.Module a -> Bool

377 requiresForeign :: CF.Module a -> Bool

344 requiresForeign = not . null . CF.moduleForeign

378 requiresForeign = not . null . CF.moduleForeign

src/Language/PureScript/ModuleDependencies.hs+8−4

@@ -23,7 +23,7 @@ import Control.Monad.Error.Class (MonadError(..))

23

24import Data.Graph

25import Data.List (nub)

26−import Data.Maybe (fromMaybe, mapMaybe)

26+import Data.Maybe (fromMaybe)

27

28import Language.PureScript.Crash

29import Language.PureScript.AST

@@ -54,21 +54,25 @@ sortModules ms = do

54-- Calculate a list of used modules based on explicit imports and qualified names

55--

56usedModules :: Declaration -> [ModuleName]

57+usedModules d =

57−usedModules = let (f, _, _, _, _) = everythingOnValues (++) forDecls forValues (const []) (const []) (const []) in nub . f

58+ let (f, _, _, _, _) = everythingOnValues (++) forDecls forValues (const []) (const []) (const [])

59+ (g, _, _, _, _) = accumTypes (everythingOnTypes (++) forTypes)

60+ in nub (f d ++ g d)

58 where

61 where

59 forDecls :: Declaration -> [ModuleName]

62 forDecls :: Declaration -> [ModuleName]

60 forDecls (ImportDeclaration mn _ _ _) = [mn]

63 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]

61 forDecls _ = []

67 forDecls _ = []

62

68

63 forValues :: Expr -> [ModuleName]

69 forValues :: Expr -> [ModuleName]

64 forValues (Var (Qualified (Just mn) _)) = [mn]

70 forValues (Var (Qualified (Just mn) _)) = [mn]

65 forValues (Constructor (Qualified (Just mn) _)) = [mn]

71 forValues (Constructor (Qualified (Just mn) _)) = [mn]

66− forValues (TypedValue _ _ ty) = forTypes ty

67 forValues _ = []

72 forValues _ = []

68

73

69 forTypes :: Type -> [ModuleName]

74 forTypes :: Type -> [ModuleName]

70 forTypes (TypeConstructor (Qualified (Just mn) _)) = [mn]

75 forTypes (TypeConstructor (Qualified (Just mn) _)) = [mn]

71− forTypes (ConstrainedType cs _) = mapMaybe (\(Qualified mn _, _) -> mn) cs

72 forTypes _ = []

76 forTypes _ = []

73

77

74-- |

78-- |

src/Language/PureScript/Names.hs+46−26

@@ -1,7 +1,7 @@

1−{-# LANGUAGE DeriveDataTypeable #-}

2{-# LANGUAGE DeriveFunctor #-}

1{-# LANGUAGE DeriveFunctor #-}

3{-# LANGUAGE TemplateHaskell #-}

2{-# LANGUAGE TemplateHaskell #-}

4−{-# LANGUAGE GADTs #-}

3+{-# LANGUAGE EmptyDataDecls #-}

4+{-# LANGUAGE KindSignatures #-}

5

6-- |

7-- Data types for names

@@ -12,11 +12,8 @@ import Control.Monad (liftM)

12import Control.Monad.Supply.Class

13

14import Data.List

15−import Data.Data

15+import Data.Aeson

16−import Data.List.Split (splitOn)

17import Data.Aeson.TH

16import Data.Aeson.TH

18−import qualified Data.Aeson as A

19−import qualified Data.Text as T

20

17

21-- |

18-- |

22-- Names for value identifiers

19-- Names for value identifiers

@@ -33,7 +30,8 @@ data Ident

33 -- |

30 -- |

34 -- A generated name for an identifier

31 -- A generated name for an identifier

35 --

32 --

36− | GenIdent (Maybe String) Integer deriving (Show, Read, Eq, Ord, Data, Typeable)

33+ | GenIdent (Maybe String) Integer

34+ deriving (Show, Read, Eq, Ord)

37

35

38runIdent :: Ident -> String

36runIdent :: Ident -> String

39runIdent (Ident i) = i

37runIdent (Ident i) = i

@@ -54,12 +52,33 @@ freshIdent' = liftM (GenIdent Nothing) fresh

54-- |

52-- |

55-- Proper names, i.e. capitalized names for e.g. module names, type//data constructors.

53-- Proper names, i.e. capitalized names for e.g. module names, type//data constructors.

56--

54--

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

58

76

59-- |

77-- |

60-- Module names

78-- Module names

61--

79--

62−newtype ModuleName = ModuleName [ProperName] deriving (Show, Read, Eq, Ord, Data, Typeable)

80+newtype ModuleName = ModuleName [ProperName 'Namespace]

81+ deriving (Show, Read, Eq, Ord)

63

82

64runModuleName :: ModuleName -> String

83runModuleName :: ModuleName -> String

65runModuleName (ModuleName pns) = intercalate "." (runProperName `map` pns)

84runModuleName (ModuleName pns) = intercalate "." (runProperName `map` pns)

@@ -75,25 +94,13 @@ moduleNameFromString = ModuleName . splitProperNames

75-- |

94-- |

76-- A qualified name, i.e. a name with an optional module name

95-- A qualified name, i.e. a name with an optional module name

77--

96--

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)

79

99

80showQualified :: (a -> String) -> Qualified a -> String

100showQualified :: (a -> String) -> Qualified a -> String

81showQualified f (Qualified Nothing a) = f a

101showQualified f (Qualified Nothing a) = f a

82showQualified f (Qualified (Just name) a) = runModuleName name ++ "." ++ f a

102showQualified f (Qualified (Just name) a) = runModuleName name ++ "." ++ f a

83

103

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−

97-- |

104-- |

98-- Provide a default module name, if a name is unqualified

105-- Provide a default module name, if a name is unqualified

99--

106--

@@ -114,10 +121,23 @@ disqualify (Qualified _ a) = a

114-- |

121-- |

115-- Checks whether a qualified value is actually qualified with a module reference

122-- Checks whether a qualified value is actually qualified with a module reference

116--

123--

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+--

117isUnqualified :: Qualified a -> Bool

131isUnqualified :: Qualified a -> Bool

118−isUnqualified (Qualified Nothing _) = True

132+isUnqualified = not . isQualified

119−isUnqualified _ = False

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

120

140

141+$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Qualified)

121$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Ident)

142$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Ident)

122−$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ProperName)

123$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ModuleName)

143$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ModuleName)

src/Language/PureScript/Options.hs+4−1

@@ -41,9 +41,12 @@ data Options = Options {

41 -- |

42 -- The path to prepend to require statements

43 , optionsRequirePath :: Maybe FilePath

44+ -- |

45+ -- Generate soure maps

46+ , optionsSourceMaps :: Bool

44 } deriving Show

47 } deriving Show

45

48

46-- |

49-- |

47-- Default make options

50-- Default make options

48defaultOptions :: Options

51defaultOptions :: 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−-----------------------------------------------------------------------------

1+{-# LANGUAGE FlexibleContexts #-}

2−--

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−--

11-- |

3-- |

12-- Constants, and utility functions to be used when parsing

4-- Constants, and utility functions to be used when parsing

13--

5--

14−-----------------------------------------------------------------------------

15−

16−{-# LANGUAGE FlexibleContexts #-}

17−

18module Language.PureScript.Parser.Common where

6module Language.PureScript.Parser.Common where

19

7

20import Control.Applicative

8import Control.Applicative

@@ -27,7 +15,7 @@ import Language.PureScript.Names

27

15

28import qualified Text.Parsec as P

16import qualified Text.Parsec as P

29

17

30−properName :: TokenParser ProperName

18+properName :: TokenParser (ProperName a)

31properName = ProperName <$> uname

19properName = ProperName <$> uname

32

20

33-- |

21-- |

src/Language/PureScript/Parser/Declarations.hs+63−63

@@ -122,9 +122,12 @@ parseFixityDeclaration :: TokenParser Declaration

122parseFixityDeclaration = do

123 fixity <- parseFixity

124 indented

125− alias <- P.optionMaybe $ (Ident <$> identifier) <* reserved "as"

125+ alias <- P.optionMaybe $ aliased <* reserved "as"

126 name <- symbol

127 return $ FixityDeclaration fixity name alias

128+ where

129+ aliased = (Left <$> parseQualified (Ident <$> identifier))

130+ <|> (Right <$> parseQualified (ProperName <$> uname))

128

131

129parseImportDeclaration :: TokenParser Declaration

132parseImportDeclaration :: TokenParser Declaration

130parseImportDeclaration = do

133parseImportDeclaration = do

@@ -151,10 +154,8 @@ parseImportDeclaration' = do

151 qName <- qualifiedName

154 qName <- qualifiedName

152 return (moduleName', declType, Just qName, True)

155 return (moduleName', declType, Just qName, True)

153 qualifyingList expectedType = do

156 qualifyingList expectedType = do

154− declType <- P.optionMaybe

155− $ P.try (expectedType <$> (indented *> parens (commaSep parseDeclarationRef)))

157+ declType <- P.optionMaybe (expectedType <$> (indented *> parens (commaSep parseDeclarationRef)))

156− <|> (const (Implicit True) <$> (indented *> parens (symbol' "..")))

157− return $ fromMaybe (Implicit False) declType

158+ return $ fromMaybe Implicit declType

158

159

159parseDeclarationRef :: TokenParser DeclarationRef

160parseDeclarationRef :: TokenParser DeclarationRef

160parseDeclarationRef =

161parseDeclarationRef =

@@ -167,7 +168,7 @@ parseDeclarationRef =

167 parseProperRef = do

168 parseProperRef = do

168 name <- properName

169 name <- properName

169 dctors <- P.optionMaybe $ parens (symbol' ".." *> pure Nothing <|> Just <$> commaSep properName)

170 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

171

172

172parseTypeClassDeclaration :: TokenParser Declaration

173parseTypeClassDeclaration :: TokenParser Declaration

173parseTypeClassDeclaration = do

174parseTypeClassDeclaration = do

@@ -259,7 +260,7 @@ parseModule = do

259 return $ Module ss comments name decls exports

260 return $ Module ss comments name decls exports

260

261

261-- | Parse a collection of modules in parallel

262-- | 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) =>

263 (k -> FilePath) -> [(k, String)] -> m [(k, Module)]

264 (k -> FilePath) -> [(k, String)] -> m [(k, Module)]

264parseModulesFromFiles toFilePath input = do

265parseModulesFromFiles toFilePath input = do

265 modules <- flip parU id $ map wrapError $ inParallel $ flip map input $ \(k, content) -> do

266 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

298booleanLiteral :: TokenParser Bool

299booleanLiteral :: TokenParser Bool

299booleanLiteral = (reserved "true" >> return True) P.<|> (reserved "false" >> return False)

300booleanLiteral = (reserved "true" >> return True) P.<|> (reserved "false" >> return False)

300

301

301−parseNumericLiteral :: TokenParser Expr

302+parseNumericLiteral :: TokenParser (Literal a)

302parseNumericLiteral = NumericLiteral <$> number

303parseNumericLiteral = NumericLiteral <$> number

303

304

304−parseCharLiteral :: TokenParser Expr

305+parseCharLiteral :: TokenParser (Literal a)

305parseCharLiteral = CharLiteral <$> charLiteral

306parseCharLiteral = CharLiteral <$> charLiteral

306

307

307−parseStringLiteral :: TokenParser Expr

308+parseStringLiteral :: TokenParser (Literal a)

308parseStringLiteral = StringLiteral <$> stringLiteral

309parseStringLiteral = StringLiteral <$> stringLiteral

309

310

310−parseBooleanLiteral :: TokenParser Expr

311+parseBooleanLiteral :: TokenParser (Literal a)

311parseBooleanLiteral = BooleanLiteral <$> booleanLiteral

312parseBooleanLiteral = BooleanLiteral <$> booleanLiteral

312

313

313−parseArrayLiteral :: TokenParser Expr

314+parseArrayLiteral :: TokenParser a -> TokenParser (Literal a)

314−parseArrayLiteral = ArrayLiteral <$> squares (commaSep parseValue)

315+parseArrayLiteral p = ArrayLiteral <$> squares (commaSep p)

315

316

316−parseObjectLiteral :: TokenParser Expr

317+parseObjectLiteral :: TokenParser (String, a) -> TokenParser (Literal a)

317−parseObjectLiteral = ObjectConstructor <$> braces (commaSep parseIdentifierAndValue)

318+parseObjectLiteral p = ObjectLiteral <$> braces (commaSep p)

318

319

319−parseIdentifierAndValue :: TokenParser (String, Maybe Expr)

320+parseIdentifierAndValue :: TokenParser (String, Expr)

320parseIdentifierAndValue =

321parseIdentifierAndValue =

321 do

322 do

322 name <- C.indented *> lname

323 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

324 return (name, b)

325 return (name, b)

325 <|> (,) <$> (C.indented *> stringLiteral) <*> rest

326 <|> (,) <$> (C.indented *> stringLiteral) <*> rest

326 where

327 where

327− rest = C.indented *> colon *> C.indented *> val

328+ rest = C.indented *> colon *> C.indented *> parseValue

328− val = (underscore *> pure Nothing) <|> (Just <$> parseValue)

329

330parseAbs :: TokenParser Expr

331parseAbs = do

@@ -375,13 +375,13 @@ parseLet = do

375

376parseValueAtom :: TokenParser Expr

377parseValueAtom = P.choice

378+ [ parseAnonymousArgument

378− [ parseNumericLiteral

379+ , Literal <$> parseNumericLiteral

379− , parseCharLiteral

380+ , Literal <$> parseCharLiteral

380− , parseStringLiteral

381+ , Literal <$> parseStringLiteral

381− , parseBooleanLiteral

382+ , Literal <$> parseBooleanLiteral

382− , parseArrayLiteral

383+ , Literal <$> parseArrayLiteral parseValue

383− , P.try parseObjectLiteral

384+ , Literal <$> P.try (parseObjectLiteral parseIdentifierAndValue)

384− , P.try parseObjectGetter

385 , parseAbs

386 , P.try parseConstructor

387 , P.try parseVar

@@ -391,8 +391,6 @@ parseValueAtom = P.choice

391 , parseLet

392 , P.try $ Parens <$> parens parseValue

393 , parseOperatorSection

394− -- TODO: combine this with parseObjectGetter

395− , parseObjectUpdaterWildcard

396 ]

394 ]

397

395

398-- |

396-- |

@@ -408,11 +406,11 @@ parseOperatorSection = parens $ left <|> right

408 right = OperatorSection <$> parseInfixExpr <* indented <*> (Right <$> indexersAndAccessors)

406 right = OperatorSection <$> parseInfixExpr <* indented <*> (Right <$> indexersAndAccessors)

409 left = flip OperatorSection <$> (Left <$> indexersAndAccessors) <* indented <*> parseInfixExpr

407 left = flip OperatorSection <$> (Left <$> indexersAndAccessors) <* indented <*> parseInfixExpr

410

408

411−parsePropertyUpdate :: TokenParser (String, Maybe Expr)

409+parsePropertyUpdate :: TokenParser (String, Expr)

412parsePropertyUpdate = do

410parsePropertyUpdate = do

413 name <- lname <|> stringLiteral

411 name <- lname <|> stringLiteral

414 _ <- C.indented *> equals

412 _ <- C.indented *> equals

415− value <- C.indented *> (underscore *> pure Nothing) <|> (Just <$> parseValue)

413+ value <- C.indented *> parseValue

416 return (name, value)

414 return (name, value)

417

415

418parseAccessor :: Expr -> TokenParser Expr

416parseAccessor :: Expr -> TokenParser Expr

@@ -438,15 +436,12 @@ parseDoNotationElement = P.choice

438 , DoNotationValue <$> parseValue

436 , DoNotationValue <$> parseValue

439 ]

437 ]

440

438

441−parseObjectGetter :: TokenParser Expr

442−parseObjectGetter = ObjectGetter <$> (underscore *> C.indented *> dot *> C.indented *> (lname <|> stringLiteral))

443−

444-- | Expressions including indexers and record updates

439-- | Expressions including indexers and record updates

445indexersAndAccessors :: TokenParser Expr

440indexersAndAccessors :: TokenParser Expr

446indexersAndAccessors = C.buildPostfixParser postfixTable parseValueAtom

441indexersAndAccessors = C.buildPostfixParser postfixTable parseValueAtom

447 where

442 where

448 postfixTable = [ parseAccessor

443 postfixTable = [ parseAccessor

449− , P.try . parseUpdaterBody . Just

444+ , P.try . parseUpdaterBody

450 ]

445 ]

451

446

452-- |

447-- |

@@ -468,23 +463,14 @@ parseValue = withSourceSpan PositionedValue

468 ]

463 ]

469 ]

464 ]

470

465

471−parseUpdaterBody :: Maybe Expr -> TokenParser Expr

466+parseUpdaterBody :: Expr -> TokenParser Expr

472−parseUpdaterBody v = ObjectUpdater v <$> (C.indented *> braces (commaSep1 (C.indented *> parsePropertyUpdate)))

467+parseUpdaterBody v = ObjectUpdate v <$> (C.indented *> braces (commaSep1 (C.indented *> parsePropertyUpdate)))

473−

474−parseObjectUpdaterWildcard :: TokenParser Expr

475−parseObjectUpdaterWildcard = underscore *> C.indented *> parseUpdaterBody Nothing

476

468

477−parseStringBinder :: TokenParser Binder

469+parseAnonymousArgument :: TokenParser Expr

478−parseStringBinder = StringBinder <$> stringLiteral

470+parseAnonymousArgument = underscore *> pure AnonymousArgument

479

471

480−parseCharBinder :: TokenParser Binder

472+parseNumberLiteral :: TokenParser Binder

481−parseCharBinder = CharBinder <$> charLiteral

473+parseNumberLiteral = LiteralBinder . NumericLiteral <$> (sign <*> number)

482−

483−parseBooleanBinder :: TokenParser Binder

484−parseBooleanBinder = BooleanBinder <$> booleanLiteral

485−

486−parseNumberBinder :: TokenParser Binder

487−parseNumberBinder = NumberBinder <$> (sign <*> number)

488 where

474 where

489 sign :: TokenParser (Either Integer Double -> Either Integer Double)

475 sign :: TokenParser (Either Integer Double -> Either Integer Double)

490 sign = (symbol' "-" >> return (negate +++ negate))

476 sign = (symbol' "-" >> return (negate +++ negate))

@@ -497,11 +483,11 @@ parseNullaryConstructorBinder = ConstructorBinder <$> C.parseQualified C.properN

497parseConstructorBinder :: TokenParser Binder

483parseConstructorBinder :: TokenParser Binder

498parseConstructorBinder = ConstructorBinder <$> C.parseQualified C.properName <*> many (C.indented *> parseBinderNoParens)

484parseConstructorBinder = ConstructorBinder <$> C.parseQualified C.properName <*> many (C.indented *> parseBinderNoParens)

499

485

500−parseObjectBinder :: TokenParser Binder

486+parseObjectBinder:: TokenParser Binder

501−parseObjectBinder = ObjectBinder <$> braces (commaSep (C.indented *> parseIdentifierAndBinder))

487+parseObjectBinder= LiteralBinder <$> parseObjectLiteral (C.indented *> parseIdentifierAndBinder)

502

488

503parseArrayBinder :: TokenParser Binder

489parseArrayBinder :: TokenParser Binder

504−parseArrayBinder = squares $ ArrayBinder <$> commaSep (C.indented *> parseBinder)

490+parseArrayBinder = LiteralBinder <$> parseArrayLiteral (C.indented *> parseBinder)

505

491

506parseVarOrNamedBinder :: TokenParser Binder

492parseVarOrNamedBinder :: TokenParser Binder

507parseVarOrNamedBinder = do

493parseVarOrNamedBinder = do

@@ -527,40 +513,54 @@ parseIdentifierAndBinder =

527-- Parse a binder

513-- Parse a binder

528--

514--

529parseBinder :: TokenParser Binder

515parseBinder :: TokenParser Binder

516+parseBinder =

517+ withSourceSpan

518+ PositionedBinder

519+ ( P.buildExpressionParser operators

530−parseBinder = withSourceSpan PositionedBinder (buildPostfixParser postfixTable parseBinderAtom)

520+ . buildPostfixParser postfixTable

521+ $ parseBinderAtom

522+ )

531 where

523 where

524+ operators =

525+ [ [ P.Infix (P.try (C.indented *> parseOpBinder P.<?> "binder operator") >>= \op ->

526+ return (BinaryNoParensBinder op)) P.AssocRight

527+ ]

528+ ]

532 -- TODO: parsePolyType when adding support for polymorphic types

529 -- TODO: parsePolyType when adding support for polymorphic types

533 postfixTable = [ \b -> flip TypedBinder b <$> (indented *> doubleColon *> parseType)

530 postfixTable = [ \b -> flip TypedBinder b <$> (indented *> doubleColon *> parseType)

534 ]

531 ]

535 parseBinderAtom :: TokenParser Binder

532 parseBinderAtom :: TokenParser Binder

536 parseBinderAtom = P.choice

533 parseBinderAtom = P.choice

537 [ parseNullBinder

534 [ parseNullBinder

538− , parseCharBinder

535+ , LiteralBinder <$> parseCharLiteral

539− , parseStringBinder

536+ , LiteralBinder <$> parseStringLiteral

540− , parseBooleanBinder

537+ , LiteralBinder <$> parseBooleanLiteral

541− , parseNumberBinder

538+ , parseNumberLiteral

542 , parseVarOrNamedBinder

539 , parseVarOrNamedBinder

543 , parseConstructorBinder

540 , parseConstructorBinder

544 , parseObjectBinder

541 , parseObjectBinder

545 , parseArrayBinder

542 , parseArrayBinder

546− , parens parseBinder

543+ , ParensInBinder <$> parens parseBinder

547 ] P.<?> "binder"

544 ] P.<?> "binder"

548

545

546+ parseOpBinder :: TokenParser Binder

547+ parseOpBinder = OpBinder <$> parseQualified (Op <$> symbol)

548+

549-- |

550-- Parse a binder as it would appear in a top level declaration

551--

552parseBinderNoParens :: TokenParser Binder

553parseBinderNoParens = P.choice

554 [ parseNullBinder

555− , parseCharBinder

555+ , LiteralBinder <$> parseCharLiteral

556− , parseStringBinder

556+ , LiteralBinder <$> parseStringLiteral

557− , parseBooleanBinder

557+ , LiteralBinder <$> parseBooleanLiteral

558− , parseNumberBinder

558+ , parseNumberLiteral

559 , parseVarOrNamedBinder

560 , parseNullaryConstructorBinder

561 , parseObjectBinder

562 , parseArrayBinder

563− , parens parseBinder

563+ , ParensInBinder <$> parens parseBinder

564 ] P.<?> "binder"

565

566-- |

src/Language/PureScript/Parser/JS.hs+1−1

@@ -36,7 +36,7 @@ import qualified Text.Parsec as PS

36

37type ForeignJS = String

38

39−parseForeignModulesFromFiles :: (Functor m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

39+parseForeignModulesFromFiles :: (MonadError MultipleErrors m, MonadWriter MultipleErrors m)

40 => [(FilePath, ForeignJS)]

41 -> m (M.Map ModuleName FilePath)

42parseForeignModulesFromFiles files = do

src/Language/PureScript/Parser/Lexer.hs+6

@@ -185,10 +185,15 @@ parsePositionedToken = P.try $ do

185parseToken :: P.Parsec String u Token

186parseToken = P.choice

187 [ P.try $ P.string "<-" *> P.notFollowedBy symbolChar *> pure LArrow

188+ , P.try $ P.string "←" *> P.notFollowedBy symbolChar *> pure LArrow

188 , P.try $ P.string "<=" *> P.notFollowedBy symbolChar *> pure LFatArrow

189 , P.try $ P.string "<=" *> P.notFollowedBy symbolChar *> pure LFatArrow

190+ , P.try $ P.string "⇐" *> P.notFollowedBy symbolChar *> pure LFatArrow

189 , P.try $ P.string "->" *> P.notFollowedBy symbolChar *> pure RArrow

191 , P.try $ P.string "->" *> P.notFollowedBy symbolChar *> pure RArrow

192+ , P.try $ P.string "→" *> P.notFollowedBy symbolChar *> pure RArrow

190 , P.try $ P.string "=>" *> P.notFollowedBy symbolChar *> pure RFatArrow

193 , P.try $ P.string "=>" *> P.notFollowedBy symbolChar *> pure RFatArrow

194+ , P.try $ P.string "⇒" *> P.notFollowedBy symbolChar *> pure RFatArrow

191 , P.try $ P.string "::" *> P.notFollowedBy symbolChar *> pure DoubleColon

195 , P.try $ P.string "::" *> P.notFollowedBy symbolChar *> pure DoubleColon

196+ , P.try $ P.string "∷" *> P.notFollowedBy symbolChar *> pure DoubleColon

192 , P.try $ P.char '(' *> pure LParen

197 , P.try $ P.char '(' *> pure LParen

193 , P.try $ P.char ')' *> pure RParen

198 , P.try $ P.char ')' *> pure RParen

194 , P.try $ P.char '{' *> pure LBrace

199 , P.try $ P.char '{' *> pure LBrace

@@ -411,6 +416,7 @@ reserved :: String -> TokenParser ()

411reserved s = token go P.<?> show s

416reserved s = token go P.<?> show s

412 where

417 where

413 go (LName s') | s == s' = Just ()

418 go (LName s') | s == s' = Just ()

419+ go (Symbol s') | s == s' = Just ()

414 go _ = Nothing

420 go _ = Nothing

415

421

416uname :: TokenParser String

422uname :: TokenParser String

src/Language/PureScript/Parser/Types.hs+1−1

@@ -36,7 +36,7 @@ parseTypeConstructor :: TokenParser Type

36parseTypeConstructor = TypeConstructor <$> parseQualified properName

37

38parseForAll :: 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)

40 <*> parseType

41

42-- |

src/Language/PureScript/Pretty.hs−3

@@ -27,6 +27,3 @@ import Language.PureScript.Pretty.Kinds as P

27import Language.PureScript.Pretty.Values as P

28import Language.PureScript.Pretty.Types as P

29import Language.PureScript.Pretty.JS as P

30−

31−

32−

src/Language/PureScript/Pretty/Common.hs+96−9

@@ -13,12 +13,18 @@

13--

14-----------------------------------------------------------------------------

15

16+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

17+

16module Language.PureScript.Pretty.Common where

18module Language.PureScript.Pretty.Common where

17

19

20+import Prelude ()

21+import Prelude.Compat

22+

18−import Control.Monad.State

23+import Control.Monad.State (StateT, modify, get)

19−import Data.List (intercalate)

24+import Data.List (elemIndices, intersperse)

20

25

21import Language.PureScript.Parser.Lexer (reservedPsNames, isSymbolChar)

26import Language.PureScript.Parser.Lexer (reservedPsNames, isSymbolChar)

27+import Language.PureScript.AST (SourcePos(..), SourceSpan(..))

22

28

23import Text.PrettyPrint.Boxes

29import Text.PrettyPrint.Boxes

24

30

@@ -26,9 +32,90 @@ import Text.PrettyPrint.Boxes

26-- Wrap a string in parentheses

32-- Wrap a string in parentheses

27--

33--

28parens :: String -> String

34parens :: 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 }

30

116

31−newtype PrinterState = PrinterState { indent :: Int } deriving (Show, Read, Eq, Ord)

117+emptyPrinterState :: PrinterState

118+emptyPrinterState = PrinterState { indent = 0 }

32

119

33-- |

120-- |

34-- Number of characters per identation level

121-- Number of characters per identation level

@@ -39,7 +126,7 @@ blockIndent = 4

39-- |

126-- |

40-- Pretty print with a new indentation level

127-- Pretty print with a new indentation level

41--

128--

42−withIndent :: StateT PrinterState Maybe String -> StateT PrinterState Maybe String

129+withIndent :: (Emit gen) => StateT PrinterState Maybe gen -> StateT PrinterState Maybe gen

43withIndent action = do

130withIndent action = do

44 modify $ \st -> st { indent = indent st + blockIndent }

131 modify $ \st -> st { indent = indent st + blockIndent }

45 result <- action

132 result <- action

@@ -49,19 +136,19 @@ withIndent action = do

49-- |

136-- |

50-- Get the current indentation level

137-- Get the current indentation level

51--

138--

52−currentIndent :: StateT PrinterState Maybe String

139+currentIndent :: (Emit gen) => StateT PrinterState Maybe gen

53currentIndent = do

140currentIndent = do

54 current <- get

141 current <- get

55− return $ replicate (indent current) ' '

142+ return $ emit $ replicate (indent current) ' '

56

143

57-- |

144-- |

58-- Print many lines

145-- Print many lines

59--

146--

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

61prettyPrintMany f xs = do

148prettyPrintMany f xs = do

62 ss <- mapM f xs

149 ss <- mapM f xs

63 indentString <- currentIndent

150 indentString <- currentIndent

64− return $ intercalate "\n" $ map (indentString ++) ss

151+ return $ intercalate (emit "\n") $ map (\s -> mappend indentString s) ss

65

152

66-- |

153-- |

67-- Prints an object key, escaping reserved names.

154-- Prints an object key, escaping reserved names.

src/Language/PureScript/Pretty/JS.hs+118−105

@@ -14,13 +14,12 @@

14-----------------------------------------------------------------------------

15

16module Language.PureScript.Pretty.JS (

17− prettyPrintJS

17+ prettyPrintJS, prettyPrintJSWithSourceMaps

18) where

19

20import Prelude ()

21import Prelude.Compat

22

23−import Data.List hiding (concat, concatMap)

24import Data.Maybe (fromMaybe)

23import Data.Maybe (fromMaybe)

25

24

26import Control.Arrow ((<+>))

25import Control.Arrow ((<+>))

@@ -34,103 +33,110 @@ import Language.PureScript.CodeGen.JS.Common

34import Language.PureScript.Pretty.Common

33import Language.PureScript.Pretty.Common

35import Language.PureScript.Comments

34import Language.PureScript.Comments

36

35

36+

37+import Language.PureScript.AST (SourceSpan(..))

38+

37import Numeric

39import Numeric

38

40

41+import Data.Monoid

42+

39−literals :: Pattern PrinterState JS String

43+literals :: (Emit gen) => Pattern PrinterState JS gen

40−literals = mkPattern' match

44+literals = mkPattern' match'

41 where

45 where

46+ match' :: (Emit gen) => JS -> StateT PrinterState Maybe gen

47+ match' js = (addMapping' (getSourceSpan js) <>) <$> match js

48+

42− match :: JS -> StateT PrinterState Maybe String

49+ match :: (Emit gen) => JS -> StateT PrinterState Maybe gen

43− match (JSNumericLiteral n) = return $ either show show n

50+ match (JSNumericLiteral _ n) = return $ emit $ either show show n

44− match (JSStringLiteral s) = return $ string s

51+ match (JSStringLiteral _ s) = return $ string s

45− match (JSBooleanLiteral True) = return "true"

52+ match (JSBooleanLiteral _ True) = return $ emit "true"

46− match (JSBooleanLiteral False) = return "false"

53+ match (JSBooleanLiteral _ False) = return $ emit "false"

47− match (JSArrayLiteral xs) = concat <$> sequence

54+ match (JSArrayLiteral _ xs) = mconcat <$> sequence

48− [ return "[ "

55+ [ return $ emit "[ "

49− , intercalate ", " <$> forM xs prettyPrintJS'

56+ , intercalate (emit ", ") <$> forM xs prettyPrintJS'

50− , return " ]"

57+ , return $ emit " ]"

51 ]

58 ]

52− match (JSObjectLiteral []) = return "{}"

59+ match (JSObjectLiteral _ []) = return $ emit "{}"

53− match (JSObjectLiteral ps) = concat <$> sequence

60+ match (JSObjectLiteral _ ps) = mconcat <$> sequence

54− [ return "{\n"

61+ [ return $ emit "{\n"

55 , withIndent $ do

62 , 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

57 indentString <- currentIndent

64 indentString <- currentIndent

58− return $ intercalate ", \n" $ map (indentString ++) jss

65+ return $ intercalate (emit ", \n") $ map (indentString <>) jss

59− , return "\n"

66+ , return $ emit "\n"

60 , currentIndent

67 , currentIndent

61− , return "}"

68+ , return $ emit "}"

62 ]

69 ]

63 where

70 where

64− objectPropertyToString :: String -> String

71+ objectPropertyToString :: (Emit gen) => String -> gen

65− objectPropertyToString s | identNeedsEscaping s = show s

72+ objectPropertyToString s | identNeedsEscaping s = emit $ show s

66− | otherwise = s

73+ | otherwise = emit s

67− match (JSBlock sts) = concat <$> sequence

74+ match (JSBlock _ sts) = mconcat <$> sequence

68− [ return "{\n"

75+ [ return $ emit "{\n"

69 , withIndent $ prettyStatements sts

76 , withIndent $ prettyStatements sts

70− , return "\n"

77+ , return $ emit "\n"

71 , currentIndent

78 , currentIndent

72− , return "}"

79+ , return $ emit "}"

73 ]

80 ]

74− match (JSVar ident) = return ident

81+ match (JSVar _ ident) = return $ emit ident

75− match (JSVariableIntroduction ident value) = concat <$> sequence

82+ match (JSVariableIntroduction _ ident value) = mconcat <$> sequence

76− [ return "var "

83+ [ return $ emit $ "var " ++ ident

77− , return ident

78− , maybe (return "") (fmap (" = " ++) . prettyPrintJS') value

84+ , maybe (return mempty) (fmap (emit " = " <>) . prettyPrintJS') value

79 ]

85 ]

80− match (JSAssignment target value) = concat <$> sequence

86+ match (JSAssignment _ target value) = mconcat <$> sequence

81 [ prettyPrintJS' target

87 [ prettyPrintJS' target

82− , return " = "

88+ , return $ emit " = "

83 , prettyPrintJS' value

89 , prettyPrintJS' value

84 ]

90 ]

85− match (JSWhile cond sts) = concat <$> sequence

91+ match (JSWhile _ cond sts) = mconcat <$> sequence

86− [ return "while ("

92+ [ return $ emit "while ("

87 , prettyPrintJS' cond

93 , prettyPrintJS' cond

88− , return ") "

94+ , return $ emit ") "

89 , prettyPrintJS' sts

95 , prettyPrintJS' sts

90 ]

96 ]

91− match (JSFor ident start end sts) = concat <$> sequence

97+ match (JSFor _ ident start end sts) = mconcat <$> sequence

92− [ return $ "for (var " ++ ident ++ " = "

98+ [ return $ emit $ "for (var " ++ ident ++ " = "

93 , prettyPrintJS' start

99 , prettyPrintJS' start

94− , return $ "; " ++ ident ++ " < "

100+ , return $ emit $ "; " ++ ident ++ " < "

95 , prettyPrintJS' end

101 , prettyPrintJS' end

96− , return $ "; " ++ ident ++ "++) "

102+ , return $ emit $ "; " ++ ident ++ "++) "

97 , prettyPrintJS' sts

103 , prettyPrintJS' sts

98 ]

104 ]

99− match (JSForIn ident obj sts) = concat <$> sequence

105+ match (JSForIn _ ident obj sts) = mconcat <$> sequence

100− [ return $ "for (var " ++ ident ++ " in "

106+ [ return $ emit $ "for (var " ++ ident ++ " in "

101 , prettyPrintJS' obj

107 , prettyPrintJS' obj

102− , return ") "

108+ , return $ emit ") "

103 , prettyPrintJS' sts

109 , prettyPrintJS' sts

104 ]

110 ]

105− match (JSIfElse cond thens elses) = concat <$> sequence

111+ match (JSIfElse _ cond thens elses) = mconcat <$> sequence

106− [ return "if ("

112+ [ return $ emit "if ("

107 , prettyPrintJS' cond

113 , prettyPrintJS' cond

108− , return ") "

114+ , return $ emit ") "

109 , prettyPrintJS' thens

115 , prettyPrintJS' thens

110− , maybe (return "") (fmap (" else " ++) . prettyPrintJS') elses

116+ , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintJS') elses

111 ]

117 ]

112− match (JSReturn value) = concat <$> sequence

118+ match (JSReturn _ value) = mconcat <$> sequence

113− [ return "return "

119+ [ return $ emit "return "

114 , prettyPrintJS' value

120 , prettyPrintJS' value

115 ]

121 ]

116− match (JSThrow value) = concat <$> sequence

122+ match (JSThrow _ value) = mconcat <$> sequence

117− [ return "throw "

123+ [ return $ emit "throw "

118 , prettyPrintJS' value

124 , prettyPrintJS' value

119 ]

125 ]

120− match (JSBreak lbl) = return $ "break " ++ lbl

126+ match (JSBreak _ lbl) = return $ emit $ "break " ++ lbl

121− match (JSContinue lbl) = return $ "continue " ++ lbl

127+ match (JSContinue _ lbl) = return $ emit $ "continue " ++ lbl

122− match (JSLabel lbl js) = concat <$> sequence

128+ match (JSLabel _ lbl js) = mconcat <$> sequence

123− [ return $ lbl ++ ": "

129+ [ return $ emit $ lbl ++ ": "

124 , prettyPrintJS' js

130 , prettyPrintJS' js

125 ]

131 ]

126− match (JSComment com js) = fmap concat $ sequence $

132+ match (JSComment _ com js) = fmap mconcat $ sequence $

127− [ return "\n"

133+ [ return $ emit "\n"

128 , currentIndent

134 , currentIndent

129− , return "/**\n"

135+ , return $ emit "/**\n"

130 ] ++

136 ] ++

131 map asLine (concatMap commentLines com) ++

137 map asLine (concatMap commentLines com) ++

132 [ currentIndent

138 [ currentIndent

133− , return " */\n"

139+ , return $ emit " */\n"

134 , currentIndent

140 , currentIndent

135 , prettyPrintJS' js

141 , prettyPrintJS' js

136 ]

142 ]

@@ -139,21 +145,21 @@ literals = mkPattern' match

139 commentLines (LineComment s) = [s]

145 commentLines (LineComment s) = [s]

140 commentLines (BlockComment s) = lines s

146 commentLines (BlockComment s) = lines s

141

147

142− asLine :: String -> StateT PrinterState Maybe String

148+ asLine :: (Emit gen) => String -> StateT PrinterState Maybe gen

143 asLine s = do

149 asLine s = do

144 i <- currentIndent

150 i <- currentIndent

145− return $ i ++ " * " ++ removeComments s ++ "\n"

151+ return $ i <> emit " * " <> (emit . removeComments) s <> emit "\n"

146

152

147 removeComments :: String -> String

153 removeComments :: String -> String

148 removeComments ('*' : '/' : s) = removeComments s

154 removeComments ('*' : '/' : s) = removeComments s

149 removeComments (c : s) = c : removeComments s

155 removeComments (c : s) = c : removeComments s

150

156

151 removeComments [] = []

157 removeComments [] = []

152− match (JSRaw js) = return js

158+ match (JSRaw _ js) = return $ emit js

153 match _ = mzero

159 match _ = mzero

154

160

155−string :: String -> String

161+string :: (Emit gen) => String -> gen

156−string s = '"' : concatMap encodeChar s ++ "\""

162+string s = emit $ '"' : concatMap encodeChar s ++ "\""

157 where

163 where

158 encodeChar :: Char -> String

164 encodeChar :: Char -> String

159 encodeChar '\b' = "\\b"

165 encodeChar '\b' = "\\b"

@@ -175,114 +181,121 @@ string s = '"' : concatMap encodeChar s ++ "\""

175 encodeChar c | fromEnum c > 0x7E || fromEnum c < 0x20 = "\\x" ++ showHex (fromEnum c) ""

181 encodeChar c | fromEnum c > 0x7E || fromEnum c < 0x20 = "\\x" ++ showHex (fromEnum c) ""

176 encodeChar c = [c]

182 encodeChar c = [c]

177

183

178−conditional :: Pattern PrinterState JS ((JS, JS), JS)

184+conditional :: Pattern PrinterState JS ((Maybe SourceSpan, JS, JS), JS)

179conditional = mkPattern match

185conditional = mkPattern match

180 where

186 where

181− match (JSConditional cond th el) = Just ((th, el), cond)

187+ match (JSConditional ss cond th el) = Just ((ss, th, el), cond)

182 match _ = Nothing

188 match _ = Nothing

183

189

184−accessor :: Pattern PrinterState JS (String, JS)

190+accessor :: (Emit gen) => Pattern PrinterState JS (gen, JS)

185accessor = mkPattern match

191accessor = mkPattern match

186 where

192 where

187− match (JSAccessor prop val) = Just (prop, val)

193+ match (JSAccessor _ prop val) = Just (emit prop, val)

188 match _ = Nothing

194 match _ = Nothing

189

195

190−indexer :: Pattern PrinterState JS (String, JS)

196+indexer :: (Emit gen) => Pattern PrinterState JS (gen, JS)

191indexer = mkPattern' match

197indexer = mkPattern' match

192 where

198 where

193− match (JSIndexer index val) = (,) <$> prettyPrintJS' index <*> pure val

199+ match (JSIndexer _ index val) = (,) <$> prettyPrintJS' index <*> pure val

200+

194 match _ = mzero

201 match _ = mzero

195

202

196−lam :: Pattern PrinterState JS ((Maybe String, [String]), JS)

203+lam :: Pattern PrinterState JS ((Maybe String, [String], Maybe SourceSpan), JS)

197lam = mkPattern match

204lam = mkPattern match

198 where

205 where

199− match (JSFunction name args ret) = Just ((name, args), ret)

206+ match (JSFunction ss name args ret) = Just ((name, args, ss), ret)

200 match _ = Nothing

207 match _ = Nothing

201

208

202−app :: Pattern PrinterState JS (String, JS)

209+app :: (Emit gen) => Pattern PrinterState JS (gen, JS)

203app = mkPattern' match

210app = mkPattern' match

204 where

211 where

205− match (JSApp val args) = do

212+ match (JSApp _ val args) = do

206 jss <- traverse prettyPrintJS' args

213 jss <- traverse prettyPrintJS' args

207− return (intercalate ", " jss, val)

214+ return (intercalate (emit ", ") jss, val)

208 match _ = mzero

215 match _ = mzero

209

216

210typeOf :: Pattern PrinterState JS ((), JS)

217typeOf :: Pattern PrinterState JS ((), JS)

211typeOf = mkPattern match

218typeOf = mkPattern match

212 where

219 where

213− match (JSTypeOf val) = Just ((), val)

220+ match (JSTypeOf _ val) = Just ((), val)

214 match _ = Nothing

221 match _ = Nothing

215

222

216instanceOf :: Pattern PrinterState JS (JS, JS)

223instanceOf :: Pattern PrinterState JS (JS, JS)

217instanceOf = mkPattern match

224instanceOf = mkPattern match

218 where

225 where

219− match (JSInstanceOf val ty) = Just (val, ty)

226+ match (JSInstanceOf _ val ty) = Just (val, ty)

220 match _ = Nothing

227 match _ = Nothing

221

228

222−unary' :: UnaryOperator -> (JS -> String) -> Operator PrinterState JS String

229+unary' :: (Emit gen) => UnaryOperator -> (JS -> String) -> Operator PrinterState JS gen

223−unary' op mkStr = Wrap match (++)

230+unary' op mkStr = Wrap match (<>)

224 where

231 where

225− match :: Pattern PrinterState JS (String, JS)

232+ match :: (Emit gen) => Pattern PrinterState JS (gen, JS)

226 match = mkPattern match'

233 match = mkPattern match'

227 where

234 where

228− match' (JSUnary op' val) | op' == op = Just (mkStr val, val)

235+ match' (JSUnary _ op' val) | op' == op = Just (emit $ mkStr val, val)

229 match' _ = Nothing

236 match' _ = Nothing

230

237

231−unary :: UnaryOperator -> String -> Operator PrinterState JS String

238+unary :: (Emit gen) => UnaryOperator -> String -> Operator PrinterState JS gen

232unary op str = unary' op (const str)

239unary op str = unary' op (const str)

233

240

234−negateOperator :: Operator PrinterState JS String

241+negateOperator :: (Emit gen) => Operator PrinterState JS gen

235negateOperator = unary' Negate (\v -> if isNegate v then "- " else "-")

242negateOperator = unary' Negate (\v -> if isNegate v then "- " else "-")

236 where

243 where

237− isNegate (JSUnary Negate _) = True

244+ isNegate (JSUnary _ Negate _) = True

238 isNegate _ = False

245 isNegate _ = False

239

246

240−binary :: BinaryOperator -> String -> Operator PrinterState JS String

247+binary :: (Emit gen) => BinaryOperator -> String -> Operator PrinterState JS gen

241−binary op str = AssocL match (\v1 v2 -> v1 ++ " " ++ str ++ " " ++ v2)

248+binary op str = AssocL match (\v1 v2 -> v1 <> emit (" " ++ str ++ " ") <> v2)

242 where

249 where

243 match :: Pattern PrinterState JS (JS, JS)

250 match :: Pattern PrinterState JS (JS, JS)

244 match = mkPattern match'

251 match = mkPattern match'

245 where

252 where

246− match' (JSBinary op' v1 v2) | op' == op = Just (v1, v2)

253+ match' (JSBinary _ op' v1 v2) | op' == op = Just (v1, v2)

247 match' _ = Nothing

254 match' _ = Nothing

248

255

249−prettyStatements :: [JS] -> StateT PrinterState Maybe String

256+prettyStatements :: (Emit gen) => [JS] -> StateT PrinterState Maybe gen

250prettyStatements sts = do

257prettyStatements sts = do

251 jss <- forM sts prettyPrintJS'

258 jss <- forM sts prettyPrintJS'

252 indentString <- currentIndent

259 indentString <- currentIndent

253− return $ intercalate "\n" $ map ((++ ";") . (indentString ++)) jss

260+ return $ intercalate (emit "\n") $ map ((<> emit ";") . (indentString <>)) jss

254

261

255-- |

262-- |

256-- Generate a pretty-printed string representing a Javascript expression

263-- Generate a pretty-printed string representing a Javascript expression

257--

264--

258−prettyPrintJS1 :: JS -> String

265+prettyPrintJS1 :: (Emit gen) => JS -> gen

259prettyPrintJS1 = fromMaybe (internalError "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyPrintJS'

266prettyPrintJS1 = fromMaybe (internalError "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyPrintJS'

260

267

261-- |

268-- |

262-- Generate a pretty-printed string representing a collection of Javascript expressions at the same indentation level

269-- Generate a pretty-printed string representing a collection of Javascript expressions at the same indentation level

263--

270--

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+

264prettyPrintJS :: [JS] -> String

276prettyPrintJS :: [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

266

278

267-- |

279-- |

268-- Generate an indented, pretty-printed string representing a Javascript expression

280-- Generate an indented, pretty-printed string representing a Javascript expression

269--

281--

270−prettyPrintJS' :: JS -> StateT PrinterState Maybe String

282+prettyPrintJS' :: (Emit gen) => JS -> StateT PrinterState Maybe gen

271prettyPrintJS' = A.runKleisli $ runPattern matchValue

283prettyPrintJS' = A.runKleisli $ runPattern matchValue

272 where

284 where

273− matchValue :: Pattern PrinterState JS String

285+ matchValue :: (Emit gen) => Pattern PrinterState JS gen

274− matchValue = buildPrettyPrinter operators (literals <+> fmap parens matchValue)

286+ matchValue = buildPrettyPrinter operators (literals <+> fmap parensPos matchValue)

275− operators :: OperatorTable PrinterState JS String

287+ operators :: (Emit gen) => OperatorTable PrinterState JS gen

276 operators =

288 operators =

277− OperatorTable [ [ Wrap accessor $ \prop val -> val ++ "." ++ prop ]

289+ OperatorTable [ [ Wrap accessor $ \prop val -> val <> emit "." <> prop ]

278− , [ Wrap indexer $ \index val -> val ++ "[" ++ index ++ "]" ]

290+ , [ Wrap indexer $ \index val -> val <> emit "[" <> index <> emit "]" ]

279− , [ Wrap app $ \args val -> val ++ "(" ++ args ++ ")" ]

291+ , [ Wrap app $ \args val -> val <> emit "(" <> args <> emit ")" ]

280 , [ unary JSNew "new " ]

292 , [ unary JSNew "new " ]

281− , [ Wrap lam $ \(name, args) ret -> "function "

293+ , [ Wrap lam $ \(name, args, ss) ret -> addMapping' ss <>

294+ emit ("function "

282 ++ fromMaybe "" name

295 ++ fromMaybe "" name

283− ++ "(" ++ intercalate ", " args ++ ") "

296+ ++ "(" ++ intercalate ", " args ++ ") ")

284− ++ ret ]

297+ <> ret ]

285− , [ Wrap typeOf $ \_ s -> "typeof " ++ s ]

298+ , [ Wrap typeOf $ \_ s -> emit "typeof " <> s ]

286 , [ unary Not "!"

299 , [ unary Not "!"

287 , unary BitwiseNot "~"

300 , unary BitwiseNot "~"

288 , unary Positive "+"

301 , unary Positive "+"

@@ -299,7 +312,7 @@ prettyPrintJS' = A.runKleisli $ runPattern matchValue

299 , binary LessThanOrEqualTo "<="

312 , binary LessThanOrEqualTo "<="

300 , binary GreaterThan ">"

313 , binary GreaterThan ">"

301 , binary GreaterThanOrEqualTo ">="

314 , binary GreaterThanOrEqualTo ">="

302− , AssocR instanceOf $ \v1 v2 -> v1 ++ " instanceof " ++ v2 ]

315+ , AssocR instanceOf $ \v1 v2 -> v1 <> emit " instanceof " <> v2 ]

303 , [ binary EqualTo "==="

316 , [ binary EqualTo "==="

304 , binary NotEqualTo "!==" ]

317 , binary NotEqualTo "!==" ]

305 , [ binary BitwiseAnd "&" ]

318 , [ binary BitwiseAnd "&" ]

@@ -307,5 +320,5 @@ prettyPrintJS' = A.runKleisli $ runPattern matchValue

307 , [ binary BitwiseOr "|" ]

320 , [ binary BitwiseOr "|" ]

308 , [ binary And "&&" ]

321 , [ binary And "&&" ]

309 , [ binary Or "||" ]

322 , [ 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 ]

311 ]

324 ]

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−--

11-- |

1-- |

12-- Pretty printer for Types

2-- Pretty printer for Types

13--

3--

14−-----------------------------------------------------------------------------

15−

16−module Language.PureScript.Pretty.Types (

4+module Language.PureScript.Pretty.Types

17− typeAsBox,

5+ ( typeAsBox

18− prettyPrintType,

6+ , prettyPrintType

19− typeAtomAsBox,

7+ , typeAtomAsBox

20− prettyPrintTypeAtom,

8+ , prettyPrintTypeAtom

21− prettyPrintRowWith,

9+ , prettyPrintRowWith

22− prettyPrintRow

10+ , prettyPrintRow

23−) where

11+ ) where

24

12

25import Data.Maybe (fromMaybe)

13import Data.Maybe (fromMaybe)

26

14

@@ -50,11 +38,11 @@ typeLiterals = mkPattern match

50 match row@RCons{} = Just $ prettyPrintRowWith '(' ')' row

38 match row@RCons{} = Just $ prettyPrintRowWith '(' ')' row

51 match _ = Nothing

39 match _ = Nothing

52

40

53−constraintsAsBox :: [(Qualified ProperName, [Type])] -> Box -> Box

41+constraintsAsBox :: [Constraint] -> Box -> Box

54constraintsAsBox [(pn, tys)] ty = text "(" <> constraintAsBox pn tys <> text ") => " <> ty

42constraintsAsBox [(pn, tys)] ty = text "(" <> constraintAsBox pn tys <> text ") => " <> ty

55constraintsAsBox xs ty = vcat left (zipWith (\i (pn, tys) -> text (if i == 0 then "( " else ", ") <> constraintAsBox pn tys) [0 :: Int ..] xs) `before` (text ") => " <> ty)

43constraintsAsBox xs ty = vcat left (zipWith (\i (pn, tys) -> text (if i == 0 then "( " else ", ") <> constraintAsBox pn tys) [0 :: Int ..] xs) `before` (text ") => " <> ty)

56

44

57−constraintAsBox :: Qualified ProperName -> [Type] -> Box

45+constraintAsBox :: Qualified (ProperName a) -> [Type] -> Box

58constraintAsBox pn tys = hsep 1 left (text (runProperName (disqualify pn)) : map typeAtomAsBox tys)

46constraintAsBox pn tys = hsep 1 left (text (runProperName (disqualify pn)) : map typeAtomAsBox tys)

59

47

60-- |

48-- |

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−--

11-- |

1-- |

12-- Pretty printer for values

2-- Pretty printer for values

13--

3--

14−-----------------------------------------------------------------------------

15−

16module Language.PureScript.Pretty.Values (

4module Language.PureScript.Pretty.Values (

17 prettyPrintValue,

5 prettyPrintValue,

18 prettyPrintBinder,

6 prettyPrintBinder,

19 prettyPrintBinderAtom

7 prettyPrintBinderAtom

20) where

8) where

21

9

22−import Data.List (intercalate)

23−

24import Control.Arrow (second)

10import Control.Arrow (second)

25

11

26import Language.PureScript.Crash

12import Language.PureScript.Crash

@@ -57,9 +43,9 @@ prettyPrintValue d (IfThenElse cond th el) =

57 ])

43 ])

58prettyPrintValue d (Accessor prop val) = prettyPrintValueAtom (d - 1) val <> text ("." ++ show prop)

44prettyPrintValue d (Accessor prop val) = prettyPrintValueAtom (d - 1) val <> text ("." ++ show prop)

59prettyPrintValue d (ObjectUpdate o ps) = prettyPrintValueAtom (d - 1) o <> text " " <> list '{' '}' (\(key, val) -> text (key ++ " = ") <> prettyPrintValue (d - 1) val) ps

45prettyPrintValue 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

61prettyPrintValue d (App val arg) = prettyPrintValueAtom (d - 1) val `beforeWithSpace` prettyPrintValueAtom (d - 1) arg

46prettyPrintValue d (App val arg) = prettyPrintValueAtom (d - 1) val `beforeWithSpace` prettyPrintValueAtom (d - 1) arg

62prettyPrintValue d (Abs (Left arg) val) = text ('\\' : showIdent arg ++ " -> ") // moveRight 2 (prettyPrintValue (d - 1) val)

47prettyPrintValue 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)

63prettyPrintValue d (TypeClassDictionaryConstructorApp className ps) =

49prettyPrintValue d (TypeClassDictionaryConstructorApp className ps) =

64 text (runProperName (disqualify className) ++ " ") <> prettyPrintValueAtom (d - 1) ps

50 text (runProperName (disqualify className) ++ " ") <> prettyPrintValueAtom (d - 1) ps

65prettyPrintValue d (Case values binders) =

51prettyPrintValue d (Case values binders) =

@@ -73,29 +59,49 @@ prettyPrintValue d (Do els) =

73 text "do " <> vcat left (map (prettyPrintDoNotationElement (d - 1)) els)

59 text "do " <> vcat left (map (prettyPrintDoNotationElement (d - 1)) els)

74prettyPrintValue _ (TypeClassDictionary (name, tys) _) = foldl1 beforeWithSpace $ text ("#dict " ++ runProperName (disqualify name)) : map typeAtomAsBox tys

60prettyPrintValue _ (TypeClassDictionary (name, tys) _) = foldl1 beforeWithSpace $ text ("#dict " ++ runProperName (disqualify name)) : map typeAtomAsBox tys

75prettyPrintValue _ (SuperClassDictionary name _) = text $ "#dict " ++ runProperName (disqualify name)

61prettyPrintValue _ (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 ">"

76prettyPrintValue d (TypedValue _ val _) = prettyPrintValue d val

64prettyPrintValue d (TypedValue _ val _) = prettyPrintValue d val

77prettyPrintValue d (PositionedValue _ _ val) = prettyPrintValue d val

65prettyPrintValue d (PositionedValue _ _ val) = prettyPrintValue d val

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

78−prettyPrintValue d expr = prettyPrintValueAtom d expr

74+prettyPrintValue d expr@ObjectGetter{} = prettyPrintValueAtom d expr

79

75

80-- | Pretty-print an atomic expression, adding parentheses if necessary.

76-- | Pretty-print an atomic expression, adding parentheses if necessary.

81prettyPrintValueAtom :: Int -> Expr -> Box

77prettyPrintValueAtom :: Int -> Expr -> Box

82−prettyPrintValueAtom _ (NumericLiteral n) = text $ either show show n

78+prettyPrintValueAtom d (Literal l) = prettyPrintLiteralValue d l

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

79+prettyPrintValueAtom _ AnonymousArgument = text "_"

91prettyPrintValueAtom _ (Constructor name) = text $ runProperName (disqualify name)

80prettyPrintValueAtom _ (Constructor name) = text $ runProperName (disqualify name)

92prettyPrintValueAtom _ (Var ident) = text $ showIdent (disqualify ident)

81prettyPrintValueAtom _ (Var ident) = text $ showIdent (disqualify ident)

93prettyPrintValueAtom d (OperatorSection op (Right val)) = ((text "(" <> prettyPrintValue (d - 1) op) `beforeWithSpace` prettyPrintValue (d - 1) val) `before` text ")"

82prettyPrintValueAtom d (OperatorSection op (Right val)) = ((text "(" <> prettyPrintValue (d - 1) op) `beforeWithSpace` prettyPrintValue (d - 1) val) `before` text ")"

94prettyPrintValueAtom d (OperatorSection op (Left val)) = ((text "(" <> prettyPrintValue (d - 1) val) `beforeWithSpace` prettyPrintValue (d - 1) op) `before` text ")"

83prettyPrintValueAtom 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 "`"

95prettyPrintValueAtom d (TypedValue _ val _) = prettyPrintValueAtom d val

89prettyPrintValueAtom d (TypedValue _ val _) = prettyPrintValueAtom d val

96prettyPrintValueAtom d (PositionedValue _ _ val) = prettyPrintValueAtom d val

90prettyPrintValueAtom 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

97prettyPrintValueAtom d expr = (text "(" <> prettyPrintValue d expr) `before` text ")"

94prettyPrintValueAtom d expr = (text "(" <> prettyPrintValue d expr) `before` text ")"

98

95

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+

99prettyPrintDeclaration :: Int -> Declaration -> Box

105prettyPrintDeclaration :: Int -> Declaration -> Box

100prettyPrintDeclaration d _ | d < 0 = ellipsis

106prettyPrintDeclaration d _ | d < 0 = ellipsis

101prettyPrintDeclaration _ (TypeDeclaration ident ty) =

107prettyPrintDeclaration _ (TypeDeclaration ident ty) =

@@ -140,28 +146,35 @@ prettyPrintDoNotationElement d (PositionedDoNotationElement _ _ el) = prettyPrin

140

146

141prettyPrintBinderAtom :: Binder -> String

147prettyPrintBinderAtom :: Binder -> String

142prettyPrintBinderAtom NullBinder = "_"

148prettyPrintBinderAtom NullBinder = "_"

143−prettyPrintBinderAtom (StringBinder str) = show str

149+prettyPrintBinderAtom (LiteralBinder l) = prettyPrintLiteralBinder l

144−prettyPrintBinderAtom (CharBinder c) = show c

145−prettyPrintBinderAtom (NumberBinder num) = either show show num

146−prettyPrintBinderAtom (BooleanBinder True) = "true"

147−prettyPrintBinderAtom (BooleanBinder False) = "false"

148prettyPrintBinderAtom (VarBinder ident) = showIdent ident

150prettyPrintBinderAtom (VarBinder ident) = showIdent ident

149prettyPrintBinderAtom (ConstructorBinder ctor []) = runProperName (disqualify ctor)

151prettyPrintBinderAtom (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) =

151 "{ "

168 "{ "

152 ++ intercalate ", " (map prettyPrintObjectPropertyBinder bs)

169 ++ intercalate ", " (map prettyPrintObjectPropertyBinder bs)

153 ++ " }"

170 ++ " }"

154 where

171 where

155 prettyPrintObjectPropertyBinder :: (String, Binder) -> String

172 prettyPrintObjectPropertyBinder :: (String, Binder) -> String

156 prettyPrintObjectPropertyBinder (key, binder) = prettyPrintObjectKey key ++ ": " ++ prettyPrintBinder binder

173 prettyPrintObjectPropertyBinder (key, binder) = prettyPrintObjectKey key ++ ": " ++ prettyPrintBinder binder

157−prettyPrintBinderAtom (ArrayBinder bs) =

174+prettyPrintLiteralBinder (ArrayLiteral bs) =

158 "[ "

175 "[ "

159 ++ intercalate ", " (map prettyPrintBinder bs)

176 ++ intercalate ", " (map prettyPrintBinder bs)

160 ++ " ]"

177 ++ " ]"

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)

165

178

166-- |

179-- |

167-- Generate a pretty-printed string representing a Binder

180-- Generate a pretty-printed string representing a Binder

src/Language/PureScript/Publish.hs+23−6

@@ -146,11 +146,20 @@ preparePackage' opts = do

146getModulesAndBookmarks :: PrepareM ([D.Bookmark], [D.Module])

147getModulesAndBookmarks = do

148 (inputFiles, depsFiles) <- liftIO getInputAndDepsFiles

149− liftIO (D.parseAndDesugar inputFiles depsFiles renderModules)

149+ (modules', bookmarks) <- parseAndBookmark inputFiles depsFiles

150− >>= either (userError . ParseAndDesugarError) return

150+

151+ case runExcept (D.convertModulesInPackage modules') of

152+ Right modules -> return (bookmarks, modules)

153+ Left err -> userError (CompileError err)

154+

151 where

155 where

152− renderModules bookmarks modules =

156+ parseAndBookmark inputFiles depsFiles = do

153− return (bookmarks, map D.convertModule modules)

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)

154

163

155data TreeStatus = Clean | Dirty deriving (Show, Read, Eq, Ord, Enum)

164data TreeStatus = Clean | Dirty deriving (Show, Read, Eq, Ord, Enum)

156

165

@@ -196,8 +205,7 @@ getBowerInfo = either (userError . BadRepositoryField) return . tryExtract

196 maybe (Left NotOnGithub) Right (extractGithub repositoryUrl)

205 maybe (Left NotOnGithub) Right (extractGithub repositoryUrl)

197

206

198extractGithub :: String -> Maybe (D.GithubUser, D.GithubRepo)

207extractGithub :: String -> Maybe (D.GithubUser, D.GithubRepo)

199−extractGithub =

208+extractGithub = stripGitHubPrefixes

200− stripPrefix "git://github.com/"

201 >>> fmap (splitOn "/")

209 >>> fmap (splitOn "/")

202 >=> takeTwo

210 >=> takeTwo

203 >>> fmap (D.GithubUser *** (D.GithubRepo . dropDotGit))

211 >>> fmap (D.GithubUser *** (D.GithubRepo . dropDotGit))

@@ -207,6 +215,15 @@ extractGithub =

207 takeTwo [x, y] = Just (x, y)

215 takeTwo [x, y] = Just (x, y)

208 takeTwo _ = Nothing

216 takeTwo _ = Nothing

209

217

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+

210 dropDotGit :: String -> String

227 dropDotGit :: String -> String

211 dropDotGit str

228 dropDotGit str

212 | ".git" `isSuffixOf` str = take (length str - 4) str

229 | ".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

33import qualified Web.Bower.PackageMeta as Bower

34

35import qualified Language.PureScript as P

36−import qualified Language.PureScript.Docs as D

37

36

38import Language.PureScript.Publish.BoxesHelpers

37import Language.PureScript.Publish.BoxesHelpers

39

38

@@ -61,7 +60,7 @@ data UserError

61 | AmbiguousVersions [Version] -- Invariant: should contain at least two elements

60 | AmbiguousVersions [Version] -- Invariant: should contain at least two elements

62 | BadRepositoryField RepositoryFieldError

61 | BadRepositoryField RepositoryFieldError

63 | MissingDependencies (NonEmpty PackageName)

62 | MissingDependencies (NonEmpty PackageName)

64− | ParseAndDesugarError D.ParseDesugarError

63+ | CompileError P.MultipleErrors

65 | DirtyWorkingTree

64 | DirtyWorkingTree

66 deriving (Show)

65 deriving (Show)

67

66

@@ -188,20 +187,10 @@ displayUserError e = case e of

188 [ "Please install ", them, " first, by running `bower install`."

187 [ "Please install ", them, " first, by running `bower install`."

189 ])

188 ])

190 ]

189 ]

191− ParseAndDesugarError (D.ParseError err) ->

190+ CompileError err ->

192 vcat

191 vcat

193− [ para "Parse error:"

192+ [ para "Compile 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)

193+ , indented (vcat (P.prettyPrintMultipleErrorsBox False err))

200− ]

201− ParseAndDesugarError (D.DesugarError err) ->

202− vcat

203− [ para "Error while desugaring:"

204− , indented (P.prettyPrintMultipleErrorsBox False err)

205 ]

194 ]

206 DirtyWorkingTree ->

195 DirtyWorkingTree ->

207 para (

196 para (

src/Language/PureScript/Renamer.hs+9−9

@@ -105,8 +105,8 @@ lookupIdent name = do

105findDeclIdents :: [Bind Ann] -> [Ident]

106findDeclIdents = concatMap go

107 where

108− go (NonRec ident _) = [ident]

108+ go (NonRec _ ident _) = [ident]

109− go (Rec ds) = map fst ds

109+ go (Rec ds) = map (snd . fst) ds

110

111-- |

112-- Renames within each declaration in a module.

@@ -128,19 +128,19 @@ renameInModules = map go

128-- another in the current scope.

129--

130renameInDecl :: Bool -> Bind Ann -> Rename (Bind Ann)

131−renameInDecl isTopLevel (NonRec name val) = do

131+renameInDecl isTopLevel (NonRec a name val) = do

132 name' <- if isTopLevel then return name else updateScope name

133− NonRec name' <$> renameInValue val

133+ NonRec a name' <$> renameInValue val

134renameInDecl isTopLevel (Rec ds) = do

135 ds' <- traverse updateNames ds

136 Rec <$> traverse updateValues ds'

137 where

138− updateNames :: (Ident, Expr Ann) -> Rename (Ident, Expr Ann)

138+ updateNames :: ((Ann, Ident), Expr Ann) -> Rename ((Ann, Ident), Expr Ann)

139− updateNames (name, val) = do

139+ updateNames ((a, name), val) = do

140 name' <- if isTopLevel then return name else updateScope name

141− return (name', val)

141+ return ((a, name'), val)

142− updateValues :: (Ident, Expr Ann) -> Rename (Ident, Expr Ann)

142+ updateValues :: ((Ann, Ident), Expr Ann) -> Rename ((Ann, Ident), Expr Ann)

143− updateValues (name, val) = (,) name <$> renameInValue val

143+ updateValues (aname, val) = (,) aname <$> renameInValue val

144

145-- |

146-- Renames within a value.

src/Language/PureScript/Sugar.hs+1−1

@@ -63,7 +63,7 @@ import Language.PureScript.Sugar.TypeDeclarations as S

63--

64-- * Group mutually recursive value and data declarations into binding groups.

65--

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]

67desugar externs =

68 map removeSignedLiterals

69 >>> traverse desugarObjectConstructors

src/Language/PureScript/Sugar/BindingGroups.hs+73−55

@@ -1,60 +1,61 @@

1−-----------------------------------------------------------------------------

1+{-# LANGUAGE FlexibleContexts #-}

2−--

2+{-# LANGUAGE ScopedTypeVariables #-}

3−-- Module : Language.PureScript.BindingGroups

3+{-# LANGUAGE LambdaCase #-}

4+

5−-- License : MIT (http://opensource.org/licenses/MIT)

6−--

7−-- Maintainer : Phil Freeman <paf31@cantab.net>

8−-- Stability : experimental

9−-- Portability :

10−--

11-- |

5-- |

12-- This module implements the desugaring pass which creates binding groups from sets of

6-- This module implements the desugaring pass which creates binding groups from sets of

13-- mutually-recursive value declarations and mutually-recursive type declarations.

7-- mutually-recursive value declarations and mutually-recursive type declarations.

14--

8--

15−-----------------------------------------------------------------------------

16−

17−{-# LANGUAGE FlexibleContexts #-}

18−{-# LANGUAGE ScopedTypeVariables #-}

19−

20−module Language.PureScript.Sugar.BindingGroups (

9+module Language.PureScript.Sugar.BindingGroups

21− createBindingGroups,

10+ ( createBindingGroups

22− createBindingGroupsModule,

11+ , createBindingGroupsModule

23− collapseBindingGroups,

12+ , collapseBindingGroups

24− collapseBindingGroupsModule

13+ , collapseBindingGroupsModule

25−) where

14+ ) where

26

15

27import Prelude ()

16import Prelude ()

28import Prelude.Compat

17import Prelude.Compat

29

18

30−import Data.Graph

31−import Data.List (nub, intersect)

32−import Data.Maybe (isJust, mapMaybe)

33import Control.Monad ((<=<))

19import Control.Monad ((<=<))

34import Control.Monad.Error.Class (MonadError(..))

20import Control.Monad.Error.Class (MonadError(..))

35

21

22+import Data.Graph

23+import Data.List (nub, intersect)

24+import Data.Maybe (isJust, mapMaybe)

36import qualified Data.Set as S

25import qualified Data.Set as S

37

26

38−import Language.PureScript.Crash

39import Language.PureScript.AST

27import Language.PureScript.AST

40−import Language.PureScript.Names

28+import Language.PureScript.Crash

41−import Language.PureScript.Types

42import Language.PureScript.Environment

29import Language.PureScript.Environment

43import Language.PureScript.Errors

30import Language.PureScript.Errors

31+import Language.PureScript.Names

32+import Language.PureScript.Types

44

33

45-- |

34-- |

46-- Replace all sets of mutually-recursive declarations in a module with binding groups

35-- Replace all sets of mutually-recursive declarations in a module with binding groups

47--

36--

48−createBindingGroupsModule :: (Functor m, Applicative m, MonadError MultipleErrors m) => [Module] -> m [Module]

37+createBindingGroupsModule

38+ :: (MonadError MultipleErrors m)

39+ => [Module]

40+ -> m [Module]

41+createBindingGroupsModule =

42+ mapM $ \(Module ss coms name ds exps) ->

49−createBindingGroupsModule = mapM $ \(Module ss coms name ds exps) -> Module ss coms name <$> createBindingGroups name ds <*> pure exps

43+ Module ss coms name <$> createBindingGroups name ds <*> pure exps

50

44

51-- |

45-- |

52-- Collapse all binding groups in a module to individual declarations

46-- Collapse all binding groups in a module to individual declarations

53--

47--

54collapseBindingGroupsModule :: [Module] -> [Module]

48collapseBindingGroupsModule :: [Module] -> [Module]

49+collapseBindingGroupsModule =

50+ map $ \(Module ss coms name ds exps) ->

55−collapseBindingGroupsModule = map $ \(Module ss coms name ds exps) -> Module ss coms name (collapseBindingGroups ds) exps

51+ Module ss coms name (collapseBindingGroups ds) exps

56−

52+

57−createBindingGroups :: forall m. (Functor m, Applicative m, MonadError MultipleErrors m) => ModuleName -> [Declaration] -> m [Declaration]

53+createBindingGroups

54+ :: forall m

55+ . (MonadError MultipleErrors m)

56+ => ModuleName

57+ -> [Declaration]

58+ -> m [Declaration]

58createBindingGroups moduleName = mapM f <=< handleDecls

59createBindingGroups moduleName = mapM f <=< handleDecls

59

60

60 where

61 where

@@ -71,8 +72,8 @@ createBindingGroups moduleName = mapM f <=< handleDecls

71 handleDecls ds = do

72 handleDecls ds = do

72 let values = filter isValueDecl ds

73 let values = filter isValueDecl ds

73 dataDecls = filter isDataDecl ds

74 dataDecls = filter isDataDecl ds

74− allProperNames = map getProperName dataDecls

75+ allProperNames = map getTypeName dataDecls

75− dataVerts = map (\d -> (d, getProperName d, usedProperNames moduleName d `intersect` allProperNames)) dataDecls

76+ dataVerts = map (\d -> (d, getTypeName d, usedTypeNames moduleName d `intersect` allProperNames)) dataDecls

76 dataBindingGroupDecls <- parU (stronglyConnComp dataVerts) toDataBindingGroup

77 dataBindingGroupDecls <- parU (stronglyConnComp dataVerts) toDataBindingGroup

77 let allIdents = map getIdent values

78 let allIdents = map getIdent values

78 valueVerts = map (\d -> (d, getIdent d, usedIdents moduleName d `intersect` allIdents)) values

79 valueVerts = map (\d -> (d, getIdent d, usedIdents moduleName d `intersect` allIdents)) values

@@ -90,11 +91,15 @@ createBindingGroups moduleName = mapM f <=< handleDecls

90-- Collapse all binding groups to individual declarations

91-- Collapse all binding groups to individual declarations

91--

92--

92collapseBindingGroups :: [Declaration] -> [Declaration]

93collapseBindingGroups :: [Declaration] -> [Declaration]

94+collapseBindingGroups =

93−collapseBindingGroups = let (f, _, _) = everywhereOnValues id collapseBindingGroupsForValue id in map f . concatMap go

95+ let (f, _, _) = everywhereOnValues id collapseBindingGroupsForValue id

96+ in map f . concatMap go

94 where

97 where

95 go (DataBindingGroupDeclaration ds) = ds

98 go (DataBindingGroupDeclaration ds) = ds

99+ go (BindingGroupDeclaration ds) =

96− go (BindingGroupDeclaration ds) = map (\(ident, nameKind, val) -> ValueDeclaration ident nameKind [] (Right val)) ds

100+ map (\(ident, nameKind, val) -> ValueDeclaration ident nameKind [] (Right val)) ds

101+ go (PositionedDeclaration pos com d) =

97− go (PositionedDeclaration pos com d) = map (PositionedDeclaration pos com) $ go d

102+ map (PositionedDeclaration pos com) $ go d

98 go other = [other]

103 go other = [other]

99

104

100collapseBindingGroupsForValue :: Expr -> Expr

105collapseBindingGroupsForValue :: Expr -> Expr

@@ -114,8 +119,10 @@ usedIdents moduleName = nub . usedIdents' S.empty . getValue

114 (_, usedIdents', _, _, _) = everythingWithScope def usedNamesE def def def

119 (_, usedIdents', _, _, _) = everythingWithScope def usedNamesE def def def

115

120

116 usedNamesE :: S.Set Ident -> Expr -> [Ident]

121 usedNamesE :: S.Set Ident -> Expr -> [Ident]

117− usedNamesE scope (Var (Qualified Nothing name)) | name `S.notMember` scope = [name]

122+ usedNamesE scope (Var (Qualified Nothing name))

123+ | name `S.notMember` scope = [name]

118− usedNamesE scope (Var (Qualified (Just moduleName') name)) | moduleName == moduleName' && name `S.notMember` scope = [name]

124+ usedNamesE scope (Var (Qualified (Just moduleName') name))

125+ | moduleName == moduleName' && name `S.notMember` scope = [name]

119 usedNamesE _ _ = []

126 usedNamesE _ _ = []

120

127

121usedImmediateIdents :: ModuleName -> Declaration -> [Ident]

128usedImmediateIdents :: ModuleName -> Declaration -> [Ident]

@@ -127,21 +134,24 @@ usedImmediateIdents moduleName =

127

134

128 usedNamesE :: Bool -> Expr -> (Bool, [Ident])

135 usedNamesE :: Bool -> Expr -> (Bool, [Ident])

129 usedNamesE True (Var (Qualified Nothing name)) = (True, [name])

136 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])

131 usedNamesE True (Abs _ _) = (False, [])

139 usedNamesE True (Abs _ _) = (False, [])

132 usedNamesE scope _ = (scope, [])

140 usedNamesE scope _ = (scope, [])

133

141

134−usedProperNames :: ModuleName -> Declaration -> [ProperName]

142+usedTypeNames :: ModuleName -> Declaration -> [ProperName 'TypeName]

135−usedProperNames moduleName =

143+usedTypeNames moduleName =

136 let (f, _, _, _, _) = accumTypes (everythingOnTypes (++) usedNames)

144 let (f, _, _, _, _) = accumTypes (everythingOnTypes (++) usedNames)

137 in nub . f

145 in nub . f

138 where

146 where

139− usedNames :: Type -> [ProperName]

147+ usedNames :: Type -> [ProperName 'TypeName]

140− usedNames (ConstrainedType constraints _) = flip mapMaybe constraints $ \qual ->

148+ usedNames (ConstrainedType constraints _) =

141− case qual of

149+ flip mapMaybe constraints $ \case

142− (Qualified (Just moduleName') name, _) | moduleName == moduleName' -> Just name

150+ (Qualified (Just moduleName') name, _)

151+ | moduleName == moduleName' -> Just (coerceProperName name)

143 _ -> Nothing

152 _ -> Nothing

144− usedNames (TypeConstructor (Qualified (Just moduleName') name)) | moduleName == moduleName' = [name]

153+ usedNames (TypeConstructor (Qualified (Just moduleName') name))

154+ | moduleName == moduleName' = [name]

145 usedNames _ = []

155 usedNames _ = []

146

156

147getIdent :: Declaration -> Ident

157getIdent :: Declaration -> Ident

@@ -149,17 +159,22 @@ getIdent (ValueDeclaration ident _ _ _) = ident

149getIdent (PositionedDeclaration _ _ d) = getIdent d

159getIdent (PositionedDeclaration _ _ d) = getIdent d

150getIdent _ = internalError "Expected ValueDeclaration"

160getIdent _ = internalError "Expected ValueDeclaration"

151

161

152−getProperName :: Declaration -> ProperName

162+getTypeName :: Declaration -> ProperName 'TypeName

153−getProperName (DataDeclaration _ pn _ _) = pn

163+getTypeName (DataDeclaration _ pn _ _) = pn

154−getProperName (TypeSynonymDeclaration pn _ _) = pn

164+getTypeName (TypeSynonymDeclaration pn _ _) = pn

155−getProperName (PositionedDeclaration _ _ d) = getProperName d

165+getTypeName (PositionedDeclaration _ _ d) = getTypeName d

156−getProperName _ = internalError "Expected DataDeclaration"

166+getTypeName _ = internalError "Expected DataDeclaration"

157

167

158-- |

168-- |

159-- Convert a group of mutually-recursive dependencies into a BindingGroupDeclaration (or simple ValueDeclaration).

169-- Convert a group of mutually-recursive dependencies into a BindingGroupDeclaration (or simple ValueDeclaration).

160--

170--

161--

171--

172+toBindingGroup

173+ :: forall m

162−toBindingGroup :: forall m. (Functor m, MonadError MultipleErrors m) => ModuleName -> SCC Declaration -> m Declaration

174+ . (MonadError MultipleErrors m)

175+ => ModuleName

176+ -> SCC Declaration

177+ -> m Declaration

163toBindingGroup _ (AcyclicSCC d) = return d

178toBindingGroup _ (AcyclicSCC d) = return d

164toBindingGroup moduleName (CyclicSCC ds') =

179toBindingGroup moduleName (CyclicSCC ds') =

165 -- Once we have a mutually-recursive group of declarations, we need to sort

180 -- Once we have a mutually-recursive group of declarations, we need to sort

@@ -188,7 +203,10 @@ toBindingGroup moduleName (CyclicSCC ds') =

188 cycleError (ValueDeclaration n _ _ (Right _)) = errorMessage $ CycleInDeclaration n

203 cycleError (ValueDeclaration n _ _ (Right _)) = errorMessage $ CycleInDeclaration n

189 cycleError _ = internalError "cycleError: Expected ValueDeclaration"

204 cycleError _ = internalError "cycleError: Expected ValueDeclaration"

190

205

206+toDataBindingGroup

191−toDataBindingGroup :: (MonadError MultipleErrors m) => SCC Declaration -> m Declaration

207+ :: MonadError MultipleErrors m

208+ => SCC Declaration

209+ -> m Declaration

192toDataBindingGroup (AcyclicSCC d) = return d

210toDataBindingGroup (AcyclicSCC d) = return d

193toDataBindingGroup (CyclicSCC [d]) = case isTypeSynonym d of

211toDataBindingGroup (CyclicSCC [d]) = case isTypeSynonym d of

194 Just pn -> throwError . errorMessage $ CycleInTypeSynonym (Just pn)

212 Just pn -> throwError . errorMessage $ CycleInTypeSynonym (Just pn)

@@ -197,7 +215,7 @@ toDataBindingGroup (CyclicSCC ds')

197 | all (isJust . isTypeSynonym) ds' = throwError . errorMessage $ CycleInTypeSynonym Nothing

215 | all (isJust . isTypeSynonym) ds' = throwError . errorMessage $ CycleInTypeSynonym Nothing

198 | otherwise = return $ DataBindingGroupDeclaration ds'

216 | otherwise = return $ DataBindingGroupDeclaration ds'

199

217

200−isTypeSynonym :: Declaration -> Maybe ProperName

218+isTypeSynonym :: Declaration -> Maybe (ProperName 'TypeName)

201isTypeSynonym (TypeSynonymDeclaration pn _ _) = Just pn

219isTypeSynonym (TypeSynonymDeclaration pn _ _) = Just pn

202isTypeSynonym (PositionedDeclaration _ _ d) = isTypeSynonym d

220isTypeSynonym (PositionedDeclaration _ _ d) = isTypeSynonym d

203isTypeSynonym _ = Nothing

221isTypeSynonym _ = Nothing

src/Language/PureScript/Sugar/CaseDeclarations.hs+15−24

@@ -36,7 +36,7 @@ isLeft (Right _) = False

36-- |

37-- Replace all top-level binders in a module with case expressions.

38--

39−desugarCasesModule :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Module] -> m [Module]

39+desugarCasesModule :: (MonadSupply m, MonadError MultipleErrors m) => [Module] -> m [Module]

40desugarCasesModule ms = forM ms $ \(Module ss coms name ds exps) ->

41 rethrow (addHint (ErrorInModule name)) $

42 Module ss coms name <$> (desugarCases <=< desugarAbs <=< validateCases $ ds) <*> pure exps

@@ -44,7 +44,7 @@ desugarCasesModule ms = forM ms $ \(Module ss coms name ds exps) ->

44-- |

45-- Validates that case head and binder lengths match.

46--

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]

48validateCases = flip parU f

49 where

50 (f, _, _) = everywhereOnValuesM return validate return

@@ -69,7 +69,7 @@ validateCases = flip parU f

69 positionedBinder (PositionedBinder p _ _) = Just p

70 positionedBinder _ = Nothing

71

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]

73desugarAbs = flip parU f

74 where

75 (f, _, _) = everywhereOnValuesM return replace return

@@ -83,7 +83,7 @@ desugarAbs = flip parU f

83-- |

84-- Replace all top-level binders with case expressions.

85--

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]

87desugarCases = desugarRest <=< fmap join . flip parU toDecls . groupBy inSameGroup

88 where

89 desugarRest :: [Declaration] -> m [Declaration]

@@ -109,7 +109,7 @@ inSameGroup (PositionedDeclaration _ _ d1) d2 = inSameGroup d1 d2

109inSameGroup d1 (PositionedDeclaration _ _ d2) = inSameGroup d1 d2

110inSameGroup _ _ = False

111

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]

113toDecls [ValueDeclaration ident nameKind bs (Right val)] | all isVarBinder bs = do

114 args <- mapM fromVarBinder bs

115 let body = foldr (Abs . Left) val args

@@ -147,10 +147,10 @@ toTuple (ValueDeclaration _ _ bs result) = (bs, result)

147toTuple (PositionedDeclaration _ _ d) = toTuple d

148toTuple _ = internalError "Not a value declaration"

149

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

151makeCaseDeclaration ident alternatives = do

152 let namedArgs = map findName . fst <$> alternatives

153− argNames = map join $ foldl1 resolveNames namedArgs

153+ argNames = foldl1 resolveNames namedArgs

154 args <- if allUnique (catMaybes argNames)

155 then mapM argName argNames

156 else replicateM (length argNames) freshIdent'

@@ -160,14 +160,11 @@ makeCaseDeclaration ident alternatives = do

160 return $ ValueDeclaration ident Public [] (Right value)

161 where

162 -- We will construct a table of potential names.

163− -- VarBinders will become Just (Just _) which is a potential name.

163+ -- VarBinders will become Just _ which is a potential name.

164− -- NullBinder will become Just Nothing, which indicates that we may

164+ -- Everything else becomes Nothing, which indicates that we

165 -- 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)

166+ findName :: Binder -> Maybe Ident

169− findName NullBinder = Just Nothing

170− findName (VarBinder name) = Just (Just name)

167+ findName (VarBinder name) = Just name

171 findName (PositionedBinder _ _ binder) = findName binder

168 findName (PositionedBinder _ _ binder) = findName binder

172 findName _ = Nothing

169 findName _ = Nothing

173

170

@@ -182,19 +179,13 @@ makeCaseDeclaration ident alternatives = do

182

179

183 -- Combine two lists of potential names from two case alternatives

180 -- Combine two lists of potential names from two case alternatives

184 -- by zipping correspoding columns.

181 -- by zipping correspoding columns.

185− resolveNames :: [Maybe (Maybe Ident)] ->

182+ resolveNames :: [Maybe Ident] -> [Maybe Ident] -> [Maybe Ident]

186− [Maybe (Maybe Ident)] ->

187− [Maybe (Maybe Ident)]

188 resolveNames = zipWith resolveName

183 resolveNames = zipWith resolveName

189

184

190 -- Resolve a pair of names. VarBinder beats NullBinder, and everything

185 -- Resolve a pair of names. VarBinder beats NullBinder, and everything

191 -- else results in Nothing.

186 -- else results in Nothing.

192− resolveName :: Maybe (Maybe Ident) ->

187+ resolveName :: Maybe Ident -> Maybe Ident -> Maybe Ident

193− Maybe (Maybe Ident) ->

194− Maybe (Maybe Ident)

195− resolveName (Just (Just a)) (Just (Just b))

188+ resolveName (Just a) (Just b)

196− | a == b = Just (Just a)

189+ | a == b = Just a

197 | otherwise = Nothing

190 | otherwise = Nothing

198− resolveName (Just Nothing) a = a

199− resolveName a (Just Nothing) = a

200 resolveName _ _ = Nothing

191 resolveName _ _ = Nothing

src/Language/PureScript/Sugar/DoNotation.hs+2−2

@@ -26,10 +26,10 @@ import Control.Monad.Supply.Class

26-- Replace all @DoNotationBind@ and @DoNotationValue@ constructors with applications of the Prelude.bind function,

27-- and all @DoNotationLet@ constructors with let expressions.

28--

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

30desugarDoModule (Module ss coms mn ds exts) = Module ss coms mn <$> parU ds desugarDo <*> pure exts

31

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

33desugarDo (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> rethrowWithPosition pos (desugarDo d)

34desugarDo d =

35 let (f, _, _) = everywhereOnValuesM return replace return

src/Language/PureScript/Sugar/Names.hs+100−36

@@ -1,8 +1,17 @@

1{-# LANGUAGE FlexibleContexts #-}

2{-# LANGUAGE RecordWildCards #-}

3{-# LANGUAGE ScopedTypeVariables #-}

4−

4+{-# LANGUAGE TupleSections #-}

5+

5−module Language.PureScript.Sugar.Names (desugarImports) where

6+module Language.PureScript.Sugar.Names

7+ ( desugarImports

8+ , desugarImportsWithEnv

9+ , Env

10+ , ImportRecord(..)

11+ , ImportProvenance(..)

12+ , Imports(..)

13+ , Exports(..)

14+ ) where

6

15

7import Prelude ()

16import Prelude ()

8import Prelude.Compat

17import Prelude.Compat

@@ -10,12 +19,14 @@ import Prelude.Compat

10import Data.List (find, nub)

19import Data.List (find, nub)

11import Data.Maybe (fromMaybe, mapMaybe)

20import Data.Maybe (fromMaybe, mapMaybe)

12

21

22+import Control.Arrow (first)

13import Control.Monad

23import Control.Monad

14import Control.Monad.Error.Class (MonadError(..))

24import Control.Monad.Error.Class (MonadError(..))

15import Control.Monad.Writer (MonadWriter(..), censor)

25import Control.Monad.Writer (MonadWriter(..), censor)

16import Control.Monad.State.Lazy

26import Control.Monad.State.Lazy

17

27

18import qualified Data.Map as M

28import qualified Data.Map as M

29+import qualified Data.Set as S

19

30

20import Language.PureScript.Crash

31import Language.PureScript.Crash

21import Language.PureScript.AST

32import Language.PureScript.AST

@@ -33,12 +44,21 @@ import Language.PureScript.Linter.Imports

33-- Replaces all local names with qualified names within a list of modules. The

44-- Replaces all local names with qualified names within a list of modules. The

34-- modules should be topologically sorted beforehand.

45-- modules should be topologically sorted beforehand.

35--

46--

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

36−desugarImports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module]

53+ . (MonadError MultipleErrors m, MonadWriter MultipleErrors m)

54+ => [ExternsFile]

55+ -> [Module]

56+ -> m (Env, [Module])

37−desugarImports externs modules = do

57+desugarImportsWithEnv externs modules = do

38 env <- silence $ foldM externsEnv primEnv externs

58 env <- silence $ foldM externsEnv primEnv externs

39 modules' <- traverse updateExportRefs modules

59 modules' <- traverse updateExportRefs modules

40− (modules'', env') <- foldM updateEnv ([], env) modules'

60+ (modules'', env') <- first reverse <$> foldM updateEnv ([], env) modules'

41− traverse (renameInModule' env') modules''

61+ (env',) <$> traverse (renameInModule' env') modules''

42 where

62 where

43 silence :: m a -> m a

63 silence :: m a -> m a

44 silence = censor (const mempty)

64 silence = censor (const mempty)

@@ -49,23 +69,23 @@ desugarImports externs modules = do

49 let members = Exports{..}

69 let members = Exports{..}

50 ss = internalModuleSourceSpan "<Externs>"

70 ss = internalModuleSourceSpan "<Externs>"

51 env' = M.insert efModuleName (ss, nullImports, members) env

71 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)])

53 imps <- foldM (resolveModuleImport env') nullImports (map fromEFImport efImports)

73 imps <- foldM (resolveModuleImport env') nullImports (map fromEFImport efImports)

54 exps <- resolveExports env' efModuleName imps members efExports

74 exps <- resolveExports env' efModuleName imps members efExports

55 return $ M.insert efModuleName (ss, imps, exps) env

75 return $ M.insert efModuleName (ss, imps, exps) env

56 where

76 where

57

77

58− exportedTypes :: [((ProperName, [ProperName]), ModuleName)]

78+ exportedTypes :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]

59 exportedTypes = mapMaybe toExportedType efExports

79 exportedTypes = mapMaybe toExportedType efExports

60 where

80 where

61 toExportedType (TypeRef tyCon dctors) = Just ((tyCon, fromMaybe (mapMaybe forTyCon efDeclarations) dctors), efModuleName)

81 toExportedType (TypeRef tyCon dctors) = Just ((tyCon, fromMaybe (mapMaybe forTyCon efDeclarations) dctors), efModuleName)

62 where

82 where

63− forTyCon :: ExternsDeclaration -> Maybe ProperName

83+ forTyCon :: ExternsDeclaration -> Maybe (ProperName 'ConstructorName)

64 forTyCon (EDDataConstructor pn _ tNm _ _) | tNm == tyCon = Just pn

84 forTyCon (EDDataConstructor pn _ tNm _ _) | tNm == tyCon = Just pn

65 forTyCon _ = Nothing

85 forTyCon _ = Nothing

66 toExportedType (PositionedDeclarationRef _ _ r) = toExportedType r

86 toExportedType (PositionedDeclarationRef _ _ r) = toExportedType r

67 toExportedType _ = Nothing

87 toExportedType _ = Nothing

68− exportedTypeClasses :: [(ProperName, ModuleName)]

88+ exportedTypeClasses :: [(ProperName 'ClassName, ModuleName)]

69 exportedTypeClasses = mapMaybe toExportedTypeClass efExports

89 exportedTypeClasses = mapMaybe toExportedTypeClass efExports

70 where

90 where

71 toExportedTypeClass (TypeClassRef className) = Just (className, efModuleName)

91 toExportedTypeClass (TypeClassRef className) = Just (className, efModuleName)

@@ -94,7 +114,7 @@ desugarImports externs modules = do

94 warnAndRethrow (addHint (ErrorInModule mn)) $ do

114 warnAndRethrow (addHint (ErrorInModule mn)) $ do

95 let (_, imps, exps) = fromMaybe (internalError "Module is missing in renameInModule'") $ M.lookup mn env

115 let (_, imps, exps) = fromMaybe (internalError "Module is missing in renameInModule'") $ M.lookup mn env

96 (m', used) <- flip runStateT M.empty $ renameInModule env imps (elaborateExports exps m)

116 (m', used) <- flip runStateT M.empty $ renameInModule env imps (elaborateExports exps m)

97− findUnusedImports m env used

117+ lintImports m env used

98 return m'

118 return m'

99

119

100-- |

120-- |

@@ -119,14 +139,23 @@ elaborateExports exps (Module ss coms mn decls refs) =

119-- Replaces all local names with qualified names within a module and checks that all existing

139-- Replaces all local names with qualified names within a module and checks that all existing

120-- qualified names are valid.

140-- qualified names are valid.

121--

141--

142+renameInModule

143+ :: forall m

122−renameInModule :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadState UsedImports m) => Env -> Imports -> Module -> m Module

144+ . (MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadState UsedImports m)

145+ => Env

146+ -> Imports

147+ -> Module

148+ -> m Module

123renameInModule env imports (Module ss coms mn decls exps) =

149renameInModule env imports (Module ss coms mn decls exps) =

124 Module ss coms mn <$> parU decls go <*> pure exps

150 Module ss coms mn <$> parU decls go <*> pure exps

125 where

151 where

126

152

127 (go, _, _, _, _) = everywhereWithContextOnValuesM (Nothing, []) updateDecl updateValue updateBinder updateCase defS

153 (go, _, _, _, _) = everywhereWithContextOnValuesM (Nothing, []) updateDecl updateValue updateBinder updateCase defS

128

154

155+ updateDecl

156+ :: (Maybe SourceSpan, [Ident])

157+ -> Declaration

129− updateDecl :: (Maybe SourceSpan, [Ident]) -> Declaration -> m ((Maybe SourceSpan, [Ident]), Declaration)

158+ -> m ((Maybe SourceSpan, [Ident]), Declaration)

130 updateDecl (_, bound) d@(PositionedDeclaration pos _ _) =

159 updateDecl (_, bound) d@(PositionedDeclaration pos _ _) =

131 return ((Just pos, bound), d)

160 return ((Just pos, bound), d)

132 updateDecl (pos, bound) (DataDeclaration dtype name args dctors) =

161 updateDecl (pos, bound) (DataDeclaration dtype name args dctors) =

@@ -141,9 +170,14 @@ renameInModule env imports (Module ss coms mn decls exps) =

141 (,) (pos, bound) <$> (TypeDeclaration name <$> updateTypesEverywhere pos ty)

170 (,) (pos, bound) <$> (TypeDeclaration name <$> updateTypesEverywhere pos ty)

142 updateDecl (pos, bound) (ExternDeclaration name ty) =

171 updateDecl (pos, bound) (ExternDeclaration name ty) =

143 (,) (pos, name : bound) <$> (ExternDeclaration name <$> updateTypesEverywhere pos ty)

172 (,) (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)

144 updateDecl s d = return (s, d)

175 updateDecl s d = return (s, d)

145

176

177+ updateValue

178+ :: (Maybe SourceSpan, [Ident])

179+ -> Expr

146− updateValue :: (Maybe SourceSpan, [Ident]) -> Expr -> m ((Maybe SourceSpan, [Ident]), Expr)

180+ -> m ((Maybe SourceSpan, [Ident]), Expr)

147 updateValue (_, bound) v@(PositionedValue pos' _ _) =

181 updateValue (_, bound) v@(PositionedValue pos' _ _) =

148 return ((Just pos', bound), v)

182 return ((Just pos', bound), v)

149 updateValue (pos, bound) (Abs (Left arg) val') =

183 updateValue (pos, bound) (Abs (Left arg) val') =

@@ -164,11 +198,16 @@ renameInModule env imports (Module ss coms mn decls exps) =

164 (,) s <$> (TypedValue check val <$> updateTypesEverywhere pos ty)

198 (,) s <$> (TypedValue check val <$> updateTypesEverywhere pos ty)

165 updateValue s v = return (s, v)

199 updateValue s v = return (s, v)

166

200

201+ updateBinder

202+ :: (Maybe SourceSpan, [Ident])

203+ -> Binder

167− updateBinder :: (Maybe SourceSpan, [Ident]) -> Binder -> m ((Maybe SourceSpan, [Ident]), Binder)

204+ -> m ((Maybe SourceSpan, [Ident]), Binder)

168 updateBinder (_, bound) v@(PositionedBinder pos _ _) =

205 updateBinder (_, bound) v@(PositionedBinder pos _ _) =

169 return ((Just pos, bound), v)

206 return ((Just pos, bound), v)

170 updateBinder s@(pos, _) (ConstructorBinder name b) =

207 updateBinder s@(pos, _) (ConstructorBinder name b) =

171 (,) s <$> (ConstructorBinder <$> updateDataConstructorName name pos <*> pure b)

208 (,) s <$> (ConstructorBinder <$> updateDataConstructorName name pos <*> pure b)

209+ updateBinder s@(pos, _) (OpBinder name) =

210+ (,) s <$> (OpBinder <$> updateValueName name pos)

172 updateBinder s (TypedBinder t b) = do

211 updateBinder s (TypedBinder t b) = do

173 (s'@ (span', _), b') <- updateBinder s b

212 (s'@ (span', _), b') <- updateBinder s b

174 t' <- updateTypesEverywhere span' t

213 t' <- updateTypesEverywhere span' t

@@ -176,7 +215,10 @@ renameInModule env imports (Module ss coms mn decls exps) =

176 updateBinder s v =

215 updateBinder s v =

177 return (s, v)

216 return (s, v)

178

217

218+ updateCase

219+ :: (Maybe SourceSpan, [Ident])

220+ -> CaseAlternative

179− updateCase :: (Maybe SourceSpan, [Ident]) -> CaseAlternative -> m ((Maybe SourceSpan, [Ident]), CaseAlternative)

221+ -> m ((Maybe SourceSpan, [Ident]), CaseAlternative)

180 updateCase (pos, bound) c@(CaseAlternative bs _) =

222 updateCase (pos, bound) c@(CaseAlternative bs _) =

181 return ((pos, concatMap binderNames bs ++ bound), c)

223 return ((pos, concatMap binderNames bs ++ bound), c)

182

224

@@ -196,16 +238,25 @@ renameInModule env imports (Module ss coms mn decls exps) =

196 updateConstraints :: Maybe SourceSpan -> [Constraint] -> m [Constraint]

238 updateConstraints :: Maybe SourceSpan -> [Constraint] -> m [Constraint]

197 updateConstraints pos = traverse (\(name, ts) -> (,) <$> updateClassName name pos <*> traverse (updateTypesEverywhere pos) ts)

239 updateConstraints pos = traverse (\(name, ts) -> (,) <$> updateClassName name pos <*> traverse (updateTypesEverywhere pos) ts)

198

240

241+ updateTypeName

242+ :: Qualified (ProperName 'TypeName)

243+ -> Maybe SourceSpan

199− updateTypeName :: Qualified ProperName -> Maybe SourceSpan -> m (Qualified ProperName)

244+ -> m (Qualified (ProperName 'TypeName))

200− updateTypeName = update UnknownType (importedTypes imports) (resolveType . exportedTypes) TypeName (("type " ++) . runProperName)

245+ updateTypeName = update UnknownType (importedTypes imports) (resolveType . exportedTypes) TyName (("type " ++) . runProperName)

201

246

202− updateDataConstructorName :: Qualified ProperName -> Maybe SourceSpan -> m (Qualified ProperName)

247+ updateDataConstructorName

248+ :: Qualified (ProperName 'ConstructorName)

249+ -> Maybe SourceSpan

250+ -> m (Qualified (ProperName 'ConstructorName))

203 updateDataConstructorName = update (flip UnknownDataConstructor Nothing) (importedDataConstructors imports) (resolveDctor . exportedTypes) DctorName (("data constructor " ++) . runProperName)

251 updateDataConstructorName = update (flip UnknownDataConstructor Nothing) (importedDataConstructors imports) (resolveDctor . exportedTypes) DctorName (("data constructor " ++) . runProperName)

204

252

253+ updateClassName

254+ :: Qualified (ProperName 'ClassName)

255+ -> Maybe SourceSpan

205− updateClassName :: Qualified ProperName -> Maybe SourceSpan -> m (Qualified ProperName)

256+ -> m (Qualified (ProperName 'ClassName))

206− updateClassName = update UnknownTypeClass (importedTypeClasses imports) (resolve . exportedTypeClasses) ClassName (("class " ++) . runProperName)

257+ updateClassName = update UnknownTypeClass (importedTypeClasses imports) (resolve . exportedTypeClasses) TyClassName (("class " ++) . runProperName)

207

258

208− updateValueName :: Qualified Ident -> Maybe SourceSpan -> m (Qualified Ident)

259+ updateValueName :: Qualified Ident -> Maybe SourceSpan -> m (Qualified Ident)

209 updateValueName = update UnknownValue (importedValues imports) (resolve . exportedValues) IdentName (("value " ++) . runIdent)

260 updateValueName = update UnknownValue (importedValues imports) (resolve . exportedValues) IdentName (("value " ++) . runIdent)

210

261

211 -- Used when performing an update to qualify values and classes with their

262 -- 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) =

215

266

216 -- Used when performing an update to qualify types with their module of

267 -- Used when performing an update to qualify types with their module of

217 -- original definition.

268 -- original definition.

269+ resolveType

218− resolveType :: [((ProperName, [ProperName]), ModuleName)] -> ProperName -> Maybe (Qualified ProperName)

270+ :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]

271+ -> ProperName 'TypeName

272+ -> Maybe (Qualified (ProperName 'TypeName))

219 resolveType tys name = mkQualified name . snd <$> find ((== name) . fst . fst) tys

273 resolveType tys name = mkQualified name . snd <$> find ((== name) . fst . fst) tys

220

274

221 -- Used when performing an update to qualify data constructors with their

275 -- Used when performing an update to qualify data constructors with their

222 -- module of original definition.

276 -- module of original definition.

277+ resolveDctor

223− resolveDctor :: [((ProperName, [ProperName]), ModuleName)] -> ProperName -> Maybe (Qualified ProperName)

278+ :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]

279+ -> ProperName 'ConstructorName

280+ -> Maybe (Qualified (ProperName 'ConstructorName))

224 resolveDctor tys name = mkQualified name . snd <$> find (elem name . snd . fst) tys

281 resolveDctor tys name = mkQualified name . snd <$> find (elem name . snd . fst) tys

225

282

226 -- Update names so unqualified references become qualified, and locally

283 -- Update names so unqualified references become qualified, and locally

@@ -229,7 +286,7 @@ renameInModule env imports (Module ss coms mn decls exps) =

229 update

286 update

230 :: (Ord a, Show a)

287 :: (Ord a, Show a)

231 => (Qualified a -> SimpleErrorMessage)

288 => (Qualified a -> SimpleErrorMessage)

232− -> M.Map (Qualified a) [(Qualified a, ModuleName)]

289+ -> M.Map (Qualified a) [ImportRecord a]

233 -> (Exports -> a -> Maybe (Qualified a))

290 -> (Exports -> a -> Maybe (Qualified a))

234 -> (Qualified a -> Name)

291 -> (Qualified a -> Name)

235 -> (a -> String)

292 -> (a -> String)

@@ -245,8 +302,7 @@ renameInModule env imports (Module ss coms mn decls exps) =

245 -- re-exports. If there are multiple options for the name to resolve to

302 -- re-exports. If there are multiple options for the name to resolve to

246 -- in scope, we throw an error.

303 -- in scope, we throw an error.

247 (Just options, _) -> do

304 (Just options, _) -> do

248− checkImportConflicts render options

249− let (Qualified (Just mnNew) _, mnOrig) = head options

305+ (mnNew, mnOrig) <- checkImportConflicts mn render options

250 modify $ \result -> M.insert mnNew (maybe [toName qname] (toName qname :) (mnNew `M.lookup` result)) result

306 modify $ \result -> M.insert mnNew (maybe [toName qname] (toName qname :) (mnNew `M.lookup` result)) result

251 return $ Qualified (Just mnOrig) name

307 return $ Qualified (Just mnOrig) name

252

308

@@ -255,42 +311,50 @@ renameInModule env imports (Module ss coms mn decls exps) =

255 -- by qualified importing). If that's not the case, then we just need to

311 -- by qualified importing). If that's not the case, then we just need to

256 -- check it refers to a symbol in another module.

312 -- check it refers to a symbol in another module.

257 (Nothing, Just mn'') -> do

313 (Nothing, Just mn'') -> do

258− modExports <- getExports env mn''

314+ case M.lookup mn'' env of

315+ Nothing

316+ | mn'' `S.member` importedVirtualModules imports -> throwUnknown

259− maybe (throwError . errorMessage $ unknown qname) return (getE modExports name)

317+ | otherwise -> throwError . errorMessage $ UnknownModule mn''

318+ Just env' -> maybe throwUnknown return (getE (envModuleExports env') name)

260

319

261 -- If neither of the above cases are true then it's an undefined or

320 -- If neither of the above cases are true then it's an undefined or

262 -- unimported symbol.

321 -- unimported symbol.

263− _ -> throwError . errorMessage $ unknown qname

322+ _ -> throwUnknown

264

323

265 where

324 where

266 positioned err = case pos of

325 positioned err = case pos of

267 Nothing -> err

326 Nothing -> err

268 Just pos' -> rethrowWithPosition pos' err

327 Just pos' -> rethrowWithPosition pos' err

328+ throwUnknown = throwError . errorMessage $ unknown qname

269

329

270-- |

330-- |

271-- Replaces `ProperRef` export values with a `TypeRef` or `TypeClassRef`

331-- Replaces `ProperRef` export values with a `TypeRef` or `TypeClassRef`

272-- depending on what is availble within the module. Warns when a `ProperRef`

332-- depending on what is availble within the module. Warns when a `ProperRef`

273-- desugars into a `TypeClassRef`.

333-- desugars into a `TypeClassRef`.

274--

334--

335+updateExportRefs

336+ :: forall m

275−updateExportRefs :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Module -> m Module

337+ . (MonadError MultipleErrors m, MonadWriter MultipleErrors m)

338+ => Module

339+ -> m Module

276updateExportRefs (Module ss coms mn decls exps) =

340updateExportRefs (Module ss coms mn decls exps) =

277 Module ss coms mn decls <$> traverse (traverse updateRef) exps

341 Module ss coms mn decls <$> traverse (traverse updateRef) exps

278 where

342 where

279

343

280 updateRef :: DeclarationRef -> m DeclarationRef

344 updateRef :: DeclarationRef -> m DeclarationRef

281 updateRef (ProperRef name)

345 updateRef (ProperRef name)

282− | name `elem` classNames = do

346+ | ProperName name `elem` classNames = do

283− tell . errorMessage $ DeprecatedClassExport name

347+ tell . errorMessage . DeprecatedClassExport $ ProperName name

284− return $ TypeClassRef name

348+ return . TypeClassRef $ ProperName name

285 -- Fall through case here - assume it's a type if it's not a class.

349 -- Fall through case here - assume it's a type if it's not a class.

286 -- If it's a reference to something that doesn't actually exist it will

350 -- If it's a reference to something that doesn't actually exist it will

287 -- be picked up elsewhere

351 -- be picked up elsewhere

288− | otherwise = return $ TypeRef name (Just [])

352+ | otherwise = return $ TypeRef (ProperName name) (Just [])

289 updateRef (PositionedDeclarationRef pos com ref) =

353 updateRef (PositionedDeclarationRef pos com ref) =

290 warnWithPosition pos $ PositionedDeclarationRef pos com <$> updateRef ref

354 warnWithPosition pos $ PositionedDeclarationRef pos com <$> updateRef ref

291 updateRef other = return other

355 updateRef other = return other

292

356

293− classNames :: [ProperName]

357+ classNames :: [ProperName 'ClassName]

294 classNames = mapMaybe go decls

358 classNames = mapMaybe go decls

295 where

359 where

296 go (PositionedDeclaration _ _ d) = go d

360 go (PositionedDeclaration _ _ d) = go d

src/Language/PureScript/Sugar/Names/Env.hs+72−27

@@ -2,7 +2,9 @@

2{-# LANGUAGE ScopedTypeVariables #-}

3

4module Language.PureScript.Sugar.Names.Env

5+ ( ImportRecord(..)

6+ , ImportProvenance(..)

5− ( Imports(..)

7+ , Imports(..)

6 , nullImports

8 , nullImports

7 , Exports(..)

9 , Exports(..)

8 , nullExports

10 , nullExports

@@ -19,12 +21,14 @@ module Language.PureScript.Sugar.Names.Env

19 ) where

21 ) where

20

22

21import Data.Function (on)

23import Data.Function (on)

22−import Data.List (groupBy, sortBy, nub)

24+import Data.List (groupBy, sortBy, nub, delete)

23import Data.Maybe (fromJust)

25import Data.Maybe (fromJust)

24import qualified Data.Map as M

26import qualified Data.Map as M

27+import qualified Data.Set as S

25

28

26import Control.Monad

29import Control.Monad

27import Control.Monad.Error.Class (MonadError(..))

30import Control.Monad.Error.Class (MonadError(..))

31+import Control.Monad.Writer.Class (MonadWriter(..))

28

32

29import Language.PureScript.AST

33import Language.PureScript.AST

30import Language.PureScript.Crash

34import Language.PureScript.Crash

@@ -32,6 +36,30 @@ import Language.PureScript.Names

32import Language.PureScript.Environment

36import Language.PureScript.Environment

33import Language.PureScript.Errors

37import Language.PureScript.Errors

34

38

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+

35-- |

63-- |

36-- The imported declarations for a module, including the module's own members.

64-- The imported declarations for a module, including the module's own members.

37--

65--

@@ -40,30 +68,35 @@ data Imports = Imports

40 -- |

68 -- |

41 -- Local names for types within a module mapped to to their qualified names

69 -- Local names for types within a module mapped to to their qualified names

42 --

70 --

43− importedTypes :: M.Map (Qualified ProperName) [(Qualified ProperName, ModuleName)]

71+ importedTypes :: M.Map (Qualified (ProperName 'TypeName)) [ImportRecord (ProperName 'TypeName)]

44 -- |

72 -- |

45 -- Local names for data constructors within a module mapped to to their qualified names

73 -- Local names for data constructors within a module mapped to to their qualified names

46 --

74 --

47− , importedDataConstructors :: M.Map (Qualified ProperName) [(Qualified ProperName, ModuleName)]

75+ , importedDataConstructors :: M.Map (Qualified (ProperName 'ConstructorName)) [ImportRecord (ProperName 'ConstructorName)]

48 -- |

76 -- |

49 -- Local names for classes within a module mapped to to their qualified names

77 -- Local names for classes within a module mapped to to their qualified names

50 --

78 --

51− , importedTypeClasses :: M.Map (Qualified ProperName) [(Qualified ProperName, ModuleName)]

79+ , importedTypeClasses :: M.Map (Qualified (ProperName 'ClassName)) [ImportRecord (ProperName 'ClassName)]

52 -- |

80 -- |

53 -- Local names for values within a module mapped to to their qualified names

81 -- Local names for values within a module mapped to to their qualified names

54 --

82 --

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

56 -- |

88 -- |

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.

58 --

91 --

59− , importedModules :: [ModuleName]

92+ , importedVirtualModules :: S.Set ModuleName

60 } deriving (Show, Read)

93 } deriving (Show, Read)

61

94

62-- |

95-- |

63-- An empty 'Imports' value.

96-- An empty 'Imports' value.

64--

97--

65nullImports :: Imports

98nullImports :: 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

67

100

68-- |

101-- |

69-- The exported declarations from a module.

102-- The exported declarations from a module.

@@ -74,12 +107,12 @@ data Exports = Exports

74 -- The types exported from each module along with the module they originally

107 -- The types exported from each module along with the module they originally

75 -- came from.

108 -- came from.

76 --

109 --

77− exportedTypes :: [((ProperName, [ProperName]), ModuleName)]

110+ exportedTypes :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]

78 -- |

111 -- |

79 -- The classes exported from each module along with the module they originally

112 -- The classes exported from each module along with the module they originally

80 -- came from.

113 -- came from.

81 --

114 --

82− , exportedTypeClasses :: [(ProperName, ModuleName)]

115+ , exportedTypeClasses :: [(ProperName 'ClassName, ModuleName)]

83 -- |

116 -- |

84 -- The values exported from each module along with the module they originally

117 -- The values exported from each module along with the module they originally

85 -- came from.

118 -- came from.

@@ -137,29 +170,28 @@ primEnv = M.singleton

137-- Safely adds a type and its data constructors to some exports, returning an

170-- Safely adds a type and its data constructors to some exports, returning an

138-- error if a conflict occurs.

171-- error if a conflict occurs.

139--

172--

140−exportType :: (MonadError MultipleErrors m) => Exports -> ProperName -> [ProperName] -> ModuleName -> m Exports

173+exportType :: (MonadError MultipleErrors m) => Exports -> ProperName 'TypeName -> [ProperName 'ConstructorName] -> ModuleName -> m Exports

141exportType exps name dctors mn = do

174exportType exps name dctors mn = do

142 let exTypes' = exportedTypes exps

175 let exTypes' = exportedTypes exps

143 let exTypes = filter ((/= mn) . snd) exTypes'

176 let exTypes = filter ((/= mn) . snd) exTypes'

144 let exDctors = (snd . fst) `concatMap` exTypes

177 let exDctors = (snd . fst) `concatMap` exTypes

145 let exClasses = exportedTypeClasses exps

178 let exClasses = exportedTypeClasses exps

146−

147 when (any ((== name) . fst . fst) exTypes) $ throwConflictError ConflictingTypeDecls name

179 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

149 forM_ dctors $ \dctor -> do

181 forM_ dctors $ \dctor -> do

150 when (dctor `elem` exDctors) $ throwConflictError ConflictingCtorDecls dctor

182 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

152 return $ exps { exportedTypes = nub $ ((name, dctors), mn) : exTypes' }

184 return $ exps { exportedTypes = nub $ ((name, dctors), mn) : exTypes' }

153

185

154-- |

186-- |

155-- Safely adds a class to some exports, returning an error if a conflict occurs.

187-- Safely adds a class to some exports, returning an error if a conflict occurs.

156--

188--

157−exportTypeClass :: (MonadError MultipleErrors m) => Exports -> ProperName -> ModuleName -> m Exports

189+exportTypeClass :: (MonadError MultipleErrors m) => Exports -> ProperName 'ClassName -> ModuleName -> m Exports

158exportTypeClass exps name mn = do

190exportTypeClass exps name mn = do

159 let exTypes = exportedTypes exps

191 let exTypes = exportedTypes exps

160 let exDctors = (snd . fst) `concatMap` exTypes

192 let exDctors = (snd . fst) `concatMap` exTypes

161− when (any ((== name) . fst . fst) exTypes) $ throwConflictError ClassConflictsWithType name

193+ when (any ((== coerceProperName name) . fst . fst) exTypes) $ throwConflictError ClassConflictsWithType name

162− when (name `elem` exDctors) $ throwConflictError ClassConflictsWithCtor name

194+ when (coerceProperName name `elem` exDctors) $ throwConflictError ClassConflictsWithCtor name

163 classes <- addExport DuplicateClassExport name mn (exportedTypeClasses exps)

195 classes <- addExport DuplicateClassExport name mn (exportedTypeClasses exps)

164 return $ exps { exportedTypeClasses = classes }

196 return $ exps { exportedTypeClasses = classes }

165

197

@@ -197,16 +229,29 @@ getExports env mn = maybe (throwError . errorMessage $ UnknownModule mn) (return

197--

229--

198checkImportConflicts

230checkImportConflicts

199 :: forall m a

231 :: forall m a

200− . (MonadError MultipleErrors m, Ord a)

232+ . (Show a, MonadError MultipleErrors m, MonadWriter MultipleErrors m, Ord a)

233+ => ModuleName

201− => (a -> String)

234+ -> (a -> String)

202− -> [(Qualified a, ModuleName)]

235+ -> [ImportRecord a]

203− -> m ()

236+ -> m (ModuleName, ModuleName)

204−checkImportConflicts render xs =

237+checkImportConflicts currentModule render xs =

238+ let

205− let byOrig = groupBy ((==) `on` snd) . sortBy (compare `on` snd) $ xs

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

206 in

244 in

207− if length byOrig > 1

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)

208− then throwError . errorMessage $ ScopeConflict (render' (fst . head $ xs)) (map (getQual . fst . head) byOrig)

251+ _ -> throwError . errorMessage $ ScopeConflict name conflictModules

252+ else

253+ let ImportRecord (Qualified (Just mnNew) _) mnOrig _ = head byOrig

209− else return ()

254+ in return (mnNew, mnOrig)

210 where

255 where

211 getQual :: Qualified a -> ModuleName

256 getQual :: Qualified a -> ModuleName

212 getQual (Qualified (Just mn) _) = mn

257 getQual (Qualified (Just mn) _) = mn

src/Language/PureScript/Sugar/Names/Exports.hs+38−15

@@ -31,7 +31,7 @@ import Language.PureScript.Sugar.Names.Env

31-- |

32-- Finds all exportable members of a module, disregarding any explicit exports.

33--

34−findExportable :: forall m. (Applicative m, MonadError MultipleErrors m) => Module -> m Exports

34+findExportable :: forall m. (MonadError MultipleErrors m) => Module -> m Exports

35findExportable (Module _ _ mn ds _) =

36 rethrow (addHint (ErrorInModule mn)) $ foldM updateExports nullExports ds

37 where

@@ -56,7 +56,7 @@ findExportable (Module _ _ mn ds _) =

56-- Resolves the exports for a module, filtering out members that have not been

57-- exported and elaborating re-exports of other modules.

58--

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

60resolveExports env mn imps exps refs =

61 rethrow (addHint (ErrorInModule mn)) $ do

62 filtered <- filterModule mn exps refs

@@ -75,7 +75,7 @@ resolveExports env mn imps exps refs =

75 ModuleRef name -> warnDupe $ "module " ++ runModuleName name

76 _ -> return ()

77

78− warnDupeDctors :: [ProperName] -> m ()

78+ warnDupeDctors :: [ProperName 'ConstructorName] -> m ()

79 warnDupeDctors = traverse_ (warnDupe . ("data constructor " ++) . runProperName)

80

81 warnDupe :: String -> m ()

@@ -110,17 +110,17 @@ resolveExports env mn imps exps refs =

110 -- Extracts a list of values for a module based on a lookup table. If the

111 -- boolean is true the values are filtered by the qualification

112 extract

113− :: (Ord a)

113+ :: (Show a, Ord a)

114 => Bool

115 -> ModuleName

116 -> (a -> String)

117− -> M.Map (Qualified a) [(Qualified a, ModuleName)]

117+ -> M.Map (Qualified a) [ImportRecord a]

118 -> 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

120 where

121 go = filterM $ \(name', options) -> do

122− let isMatch = if useQual then eqQual name name' else any (eqQual name . fst) options

122+ let isMatch = if useQual then eqQual name name' else any (eqQual name . importName) options

123− when (isMatch && length options > 1) $ checkImportConflicts render options

123+ when (isMatch && length options > 1) $ void $ checkImportConflicts mn render options

124 return isMatch

125

126 -- Check whether a module name refers to a "pseudo module" that came into

@@ -151,10 +151,15 @@ resolveExports env mn imps exps refs =

151

152 -- Constructs a list of types with their data constructors and the original

153 -- module they were defined in from a list of type and data constructor names.

154+ resolveTypeExports

155+ :: [Qualified (ProperName 'TypeName)]

156+ -> [Qualified (ProperName 'ConstructorName)]

154− resolveTypeExports :: [Qualified ProperName] -> [Qualified ProperName] -> [((ProperName, [ProperName]), ModuleName)]

157+ -> [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]

155 resolveTypeExports tctors dctors = map go tctors

158 resolveTypeExports tctors dctors = map go tctors

156 where

159 where

160+ go

161+ :: Qualified (ProperName 'TypeName)

157− go :: Qualified ProperName -> ((ProperName, [ProperName]), ModuleName)

162+ -> ((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)

158 go (Qualified (Just mn'') name) = fromMaybe (internalError "Missing value in resolveTypeExports") $ do

163 go (Qualified (Just mn'') name) = fromMaybe (internalError "Missing value in resolveTypeExports") $ do

159 exps' <- envModuleExports <$> mn'' `M.lookup` env

164 exps' <- envModuleExports <$> mn'' `M.lookup` env

160 ((_, dctors'), mnOrig) <- find (\((name', _), _) -> name == name') (exportedTypes exps')

165 ((_, dctors'), mnOrig) <- find (\((name', _), _) -> name == name') (exportedTypes exps')

@@ -165,7 +170,7 @@ resolveExports env mn imps exps refs =

165

170

166 -- Looks up an imported class and re-qualifies it with the original module it

171 -- Looks up an imported class and re-qualifies it with the original module it

167 -- came from.

172 -- came from.

168− resolveClass :: Qualified ProperName -> (ProperName, ModuleName)

173+ resolveClass :: Qualified (ProperName 'ClassName) -> (ProperName 'ClassName, ModuleName)

169 resolveClass className = splitQual $ fromMaybe (internalError "Missing value in resolveClass") $

174 resolveClass className = splitQual $ fromMaybe (internalError "Missing value in resolveClass") $

170 resolve exportedTypeClasses className

175 resolve exportedTypeClasses className

171

176

@@ -192,7 +197,13 @@ resolveExports env mn imps exps refs =

192-- Filters the full list of exportable values, types, and classes for a module

197-- Filters the full list of exportable values, types, and classes for a module

193-- based on a list of export declaration references.

198-- based on a list of export declaration references.

194--

199--

200+filterModule

201+ :: forall m

195−filterModule :: forall m. (Applicative m, MonadError MultipleErrors m) => ModuleName -> Exports -> [DeclarationRef] -> m Exports

202+ . (MonadError MultipleErrors m)

203+ => ModuleName

204+ -> Exports

205+ -> [DeclarationRef]

206+ -> m Exports

196filterModule mn exps refs = do

207filterModule mn exps refs = do

197 types <- foldM (filterTypes $ exportedTypes exps) [] refs

208 types <- foldM (filterTypes $ exportedTypes exps) [] refs

198 values <- foldM (filterValues $ exportedValues exps) [] refs

209 values <- foldM (filterValues $ exportedValues exps) [] refs

@@ -206,7 +217,11 @@ filterModule mn exps refs = do

206 -- explicit export. When the ref refers to a type in the list of exportable

217 -- explicit export. When the ref refers to a type in the list of exportable

207 -- values, the type and specified data constructors are included in the

218 -- values, the type and specified data constructors are included in the

208 -- result.

219 -- 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)]

210 filterTypes exps' result (PositionedDeclarationRef pos _ r) =

225 filterTypes exps' result (PositionedDeclarationRef pos _ r) =

211 rethrowWithPosition pos $ filterTypes exps' result r

226 rethrowWithPosition pos $ filterTypes exps' result r

212 filterTypes exps' result (TypeRef name expDcons) =

227 filterTypes exps' result (TypeRef name expDcons) =

@@ -221,7 +236,11 @@ filterModule mn exps refs = do

221 -- Ensures a data constructor is exportable for a given type. Takes a type

236 -- Ensures a data constructor is exportable for a given type. Takes a type

222 -- name, a list of exportable data constructors for the type, and the name of

237 -- name, a list of exportable data constructors for the type, and the name of

223 -- the data constructor to check.

238 -- the data constructor to check.

224− checkDcon :: ProperName -> [ProperName] -> ProperName -> m ()

239+ checkDcon

240+ :: ProperName 'TypeName

241+ -> [ProperName 'ConstructorName]

242+ -> ProperName 'ConstructorName

243+ -> m ()

225 checkDcon tcon exps' name =

244 checkDcon tcon exps' name =

226 unless (name `elem` exps') $

245 unless (name `elem` exps') $

227 throwError . errorMessage $ UnknownExportDataConstructor tcon name

246 throwError . errorMessage $ UnknownExportDataConstructor tcon name

@@ -230,7 +249,11 @@ filterModule mn exps refs = do

230 -- filtered exports, and a `DeclarationRef` for an explicit export. When the

249 -- filtered exports, and a `DeclarationRef` for an explicit export. When the

231 -- ref refers to a class in the list of exportable classes, the class is

250 -- ref refers to a class in the list of exportable classes, the class is

232 -- included in the result.

251 -- 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)]

234 filterClasses exps' result (PositionedDeclarationRef pos _ r) =

257 filterClasses exps' result (PositionedDeclarationRef pos _ r) =

235 rethrowWithPosition pos $ filterClasses exps' result r

258 rethrowWithPosition pos $ filterClasses exps' result r

236 filterClasses exps' result (TypeClassRef name) =

259 filterClasses exps' result (TypeClassRef name) =

src/Language/PureScript/Sugar/Names/Imports.hs+66−44

@@ -23,6 +23,7 @@ import Control.Monad.Error.Class (MonadError(..))

23import Control.Monad.Writer (MonadWriter(..))

24

25import qualified Data.Map as M

26+import qualified Data.Set as S

26

27

27import Language.PureScript.Crash

28import Language.PureScript.Crash

28import Language.PureScript.AST

29import Language.PureScript.AST

@@ -36,7 +37,7 @@ import Language.PureScript.Sugar.Names.Env

36--

37--

37findImports

38findImports

38 :: forall m

39 :: forall m

39− . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

40+ . (MonadError MultipleErrors m, MonadWriter MultipleErrors m)

40 => [Declaration]

41 => [Declaration]

41 -> m (M.Map ModuleName [(Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)])

42 -> m (M.Map ModuleName [(Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)])

42findImports = foldM (go Nothing) M.empty

43findImports = foldM (go Nothing) M.empty

@@ -55,7 +56,7 @@ type ImportDef = (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)

55--

56--

56resolveImports

57resolveImports

57 :: forall m

58 :: forall m

58− . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

59+ . (MonadError MultipleErrors m, MonadWriter MultipleErrors m)

59 => Env

60 => Env

60 -> Module

61 -> Module

61 -> m (Module, Imports)

62 -> m (Module, Imports)

@@ -98,7 +99,8 @@ resolveImports env (Module ss coms currentModule decls exps) =

98

99

99 return ()

100 return ()

100

101

102+ let imports' = M.map (map (\(ss', dt, mmn) -> (ss', Just dt, mmn))) imports

101− let scope = M.insert currentModule [(Nothing, Implicit True, Nothing)] imports

103+ scope = M.insert currentModule [(Nothing, Nothing, Nothing)] imports'

102 resolved <- foldM (resolveModuleImport env) nullImports (M.toList scope)

104 resolved <- foldM (resolveModuleImport env) nullImports (M.toList scope)

103 return (Module ss coms currentModule decls' exps, resolved)

105 return (Module ss coms currentModule decls' exps, resolved)

104

106

@@ -123,7 +125,7 @@ resolveImports env (Module ss coms currentModule decls exps) =

123 ModuleRef name -> warnDupe pos $ "module " ++ runModuleName name

125 ModuleRef name -> warnDupe pos $ "module " ++ runModuleName name

124 _ -> return ()

126 _ -> return ()

125

127

126− warnDupeDctors :: Maybe SourceSpan -> [ProperName] -> m ()

128+ warnDupeDctors :: Maybe SourceSpan -> [ProperName 'ConstructorName] -> m ()

127 warnDupeDctors pos = traverse_ (warnDupe pos . ("data constructor " ++) . runProperName)

129 warnDupeDctors pos = traverse_ (warnDupe pos . ("data constructor " ++) . runProperName)

128

130

129 warnDupe :: Maybe SourceSpan -> String -> m ()

131 warnDupe :: Maybe SourceSpan -> String -> m ()

@@ -134,11 +136,11 @@ resolveImports env (Module ss coms currentModule decls exps) =

134

136

135 updateImportRef :: Declaration -> m Declaration

137 updateImportRef :: Declaration -> m Declaration

136 updateImportRef (PositionedDeclaration pos com d) =

138 updateImportRef (PositionedDeclaration pos com d) =

137− warnWithPosition pos $ PositionedDeclaration pos com <$> updateImportRef d

139+ warnAndRethrowWithPosition pos $ PositionedDeclaration pos com <$> updateImportRef d

138 updateImportRef (ImportDeclaration mn typ qual isOldSyntax) = do

140 updateImportRef (ImportDeclaration mn typ qual isOldSyntax) = do

139 modExports <- getExports env mn

141 modExports <- getExports env mn

140 typ' <- case typ of

142 typ' <- case typ of

141− Implicit b -> return $ Implicit b

143+ Implicit -> return Implicit

142 Explicit refs -> Explicit <$> updateProperRef mn modExports `traverse` refs

144 Explicit refs -> Explicit <$> updateProperRef mn modExports `traverse` refs

143 Hiding refs -> Hiding <$> updateProperRef mn modExports `traverse` refs

145 Hiding refs -> Hiding <$> updateProperRef mn modExports `traverse` refs

144 return $ ImportDeclaration mn typ' qual isOldSyntax

146 return $ ImportDeclaration mn typ' qual isOldSyntax

@@ -146,11 +148,11 @@ resolveImports env (Module ss coms currentModule decls exps) =

146

148

147 updateProperRef :: ModuleName -> Exports -> DeclarationRef -> m DeclarationRef

149 updateProperRef :: ModuleName -> Exports -> DeclarationRef -> m DeclarationRef

148 updateProperRef importModule modExports (ProperRef name) =

150 updateProperRef importModule modExports (ProperRef name) =

149− if name `elem` (fst `map` exportedTypeClasses modExports)

151+ if ProperName name `elem` (fst `map` exportedTypeClasses modExports)

150 then do

152 then do

151− tell . errorMessage $ DeprecatedClassImport importModule name

153+ tell . errorMessage $ DeprecatedClassImport importModule (ProperName name)

152− return $ TypeClassRef name

154+ return . TypeClassRef $ ProperName name

153− else return $ TypeRef name (Just [])

155+ else return $ TypeRef (ProperName name) (Just [])

154 updateProperRef importModule modExports (PositionedDeclarationRef pos com ref) =

156 updateProperRef importModule modExports (PositionedDeclarationRef pos com ref) =

155 PositionedDeclarationRef pos com <$> updateProperRef importModule modExports ref

157 PositionedDeclarationRef pos com <$> updateProperRef importModule modExports ref

156 updateProperRef _ _ other = return other

158 updateProperRef _ _ other = return other

@@ -158,17 +160,22 @@ resolveImports env (Module ss coms currentModule decls exps) =

158-- | Constructs a set of imports for a single module import.

160-- | Constructs a set of imports for a single module import.

159resolveModuleImport

161resolveModuleImport

160 :: forall m

162 :: forall m

161− . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

163+ . (MonadError MultipleErrors m, MonadWriter MultipleErrors m)

162 => Env

164 => Env

163 -> Imports

165 -> Imports

164− -> (ModuleName, [(Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)])

166+ -> (ModuleName, [(Maybe SourceSpan, Maybe ImportDeclarationType, Maybe ModuleName)])

165 -> m Imports

167 -> m Imports

166resolveModuleImport env ie (mn, imps) = foldM go ie imps

168resolveModuleImport env ie (mn, imps) = foldM go ie imps

167 where

169 where

170+ go :: Imports

168− go :: Imports -> (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName) -> m Imports

171+ -> (Maybe SourceSpan, Maybe ImportDeclarationType, Maybe ModuleName)

172+ -> m Imports

169 go ie' (pos, typ, impQual) = do

173 go ie' (pos, typ, impQual) = do

170 modExports <- positioned $ maybe (throwError . errorMessage $ UnknownModule mn) (return . envModuleExports) $ mn `M.lookup` env

174 modExports <- positioned $ maybe (throwError . errorMessage $ UnknownModule mn) (return . envModuleExports) $ mn `M.lookup` env

175+ let virtualModules = importedVirtualModules ie'

171− let ie'' = ie' { importedModules = mn : importedModules ie' }

176+ ie'' = ie' { importedModules = S.insert mn (importedModules ie')

177+ , importedVirtualModules = maybe virtualModules (`S.insert` virtualModules) impQual

178+ }

172 positioned $ resolveImport mn modExports ie'' impQual typ

179 positioned $ resolveImport mn modExports ie'' impQual typ

173 where

180 where

174 positioned err = case pos of

181 positioned err = case pos of

@@ -180,20 +187,21 @@ resolveModuleImport env ie (mn, imps) = foldM go ie imps

180--

187--

181resolveImport

188resolveImport

182 :: forall m

189 :: forall m

183− . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

190+ . (MonadError MultipleErrors m, MonadWriter MultipleErrors m)

184 => ModuleName

191 => ModuleName

185 -> Exports

192 -> Exports

186 -> Imports

193 -> Imports

187 -> Maybe ModuleName

194 -> Maybe ModuleName

188− -> ImportDeclarationType

195+ -> Maybe ImportDeclarationType

189 -> m Imports

196 -> m Imports

190resolveImport importModule exps imps impQual = resolveByType

197resolveImport importModule exps imps impQual = resolveByType

191 where

198 where

192

199

193− resolveByType :: ImportDeclarationType -> m Imports

200+ resolveByType :: Maybe ImportDeclarationType -> m Imports

194− resolveByType (Implicit _) = importAll importExplicit

201+ resolveByType Nothing = importAll (importRef Local)

202+ resolveByType (Just Implicit) = importAll (importRef FromImplicit)

195− resolveByType (Explicit refs) = checkRefs False refs >> foldM importExplicit imps refs

203+ resolveByType (Just (Explicit refs)) = checkRefs False refs >> foldM (importRef FromExplicit) imps refs

196− resolveByType (Hiding refs) = do

204+ resolveByType (Just (Hiding refs)) = do

197 imps' <- checkRefs True refs >> importAll (importNonHidden refs)

205 imps' <- checkRefs True refs >> importAll (importNonHidden refs)

198 let isEmptyImport

206 let isEmptyImport

199 = M.null (importedTypes imps')

207 = M.null (importedTypes imps')

@@ -222,18 +230,27 @@ resolveImport importModule exps imps impQual = resolveByType

222 check r = internalError $ "Invalid argument to checkRefs: " ++ show r

230 check r = internalError $ "Invalid argument to checkRefs: " ++ show r

223

231

224 -- Check that an explicitly imported item exists in the module it is being imported from

232 -- Check that an explicitly imported item exists in the module it is being imported from

233+ checkImportExists

234+ :: Eq a

225− checkImportExists :: (Eq a) => (ModuleName -> a -> SimpleErrorMessage) -> [a] -> a -> m ()

235+ => (ModuleName -> a -> SimpleErrorMessage)

236+ -> [a]

237+ -> a

238+ -> m ()

226 checkImportExists unknown exports item =

239 checkImportExists unknown exports item =

227 when (item `notElem` exports) $ throwError . errorMessage $ unknown importModule item

240 when (item `notElem` exports) $ throwError . errorMessage $ unknown importModule item

228

241

229 -- Ensure that an explicitly imported data constructor exists for the type it is being imported

242 -- Ensure that an explicitly imported data constructor exists for the type it is being imported

230 -- from

243 -- from

231− checkDctorExists :: ProperName -> [ProperName] -> ProperName -> m ()

244+ checkDctorExists

245+ :: ProperName 'TypeName

246+ -> [ProperName 'ConstructorName]

247+ -> ProperName 'ConstructorName

248+ -> m ()

232 checkDctorExists tcon = checkImportExists (flip UnknownImportDataConstructor tcon)

249 checkDctorExists tcon = checkImportExists (flip UnknownImportDataConstructor tcon)

233

250

234 importNonHidden :: [DeclarationRef] -> Imports -> DeclarationRef -> m Imports

251 importNonHidden :: [DeclarationRef] -> Imports -> DeclarationRef -> m Imports

235 importNonHidden hidden m ref | isHidden ref = return m

252 importNonHidden hidden m ref | isHidden ref = return m

236− | otherwise = importExplicit m ref

253+ | otherwise = importRef FromImplicit m ref

237 where

254 where

238 -- TODO: rework this to be not confusing

255 -- TODO: rework this to be not confusing

239 isHidden :: DeclarationRef -> Bool

256 isHidden :: DeclarationRef -> Bool

@@ -255,30 +272,29 @@ resolveImport importModule exps imps impQual = resolveByType

255 imp'' <- foldM (\m (name, _) -> importer m (ValueRef name)) imp' (exportedValues exps)

272 imp'' <- foldM (\m (name, _) -> importer m (ValueRef name)) imp' (exportedValues exps)

256 foldM (\m (name, _) -> importer m (TypeClassRef name)) imp'' (exportedTypeClasses exps)

273 foldM (\m (name, _) -> importer m (TypeClassRef name)) imp'' (exportedTypeClasses exps)

257

274

258− -- Import something explicitly

259− importExplicit :: Imports -> DeclarationRef -> m Imports

275+ importRef :: ImportProvenance -> Imports -> DeclarationRef -> m Imports

260− importExplicit imp (PositionedDeclarationRef pos _ r) =

276+ importRef prov imp (PositionedDeclarationRef pos _ r) =

261− warnAndRethrowWithPosition pos $ importExplicit imp r

277+ warnAndRethrowWithPosition pos $ importRef prov imp r

262− importExplicit imp (ValueRef name) = do

278+ importRef prov imp (ValueRef name) = do

263− let values' = updateImports (importedValues imp) (exportedValues exps) name

279+ let values' = updateImports (importedValues imp) (exportedValues exps) name prov

264 return $ imp { importedValues = values' }

280 return $ imp { importedValues = values' }

265− importExplicit imp (TypeRef name dctors) = do

281+ importRef prov imp (TypeRef name dctors) = do

266− let types' = updateImports (importedTypes imp) (first fst `map` exportedTypes exps) name

282+ let types' = updateImports (importedTypes imp) (first fst `map` exportedTypes exps) name prov

267− let exportedDctors :: [(ProperName, ModuleName)]

283+ let exportedDctors :: [(ProperName 'ConstructorName, ModuleName)]

268 exportedDctors = allExportedDataConstructors name

284 exportedDctors = allExportedDataConstructors name

269− dctorNames :: [ProperName]

285+ dctorNames :: [ProperName 'ConstructorName]

270 dctorNames = fst `map` exportedDctors

286 dctorNames = fst `map` exportedDctors

271 maybe (return ()) (traverse_ $ checkDctorExists name dctorNames) dctors

287 maybe (return ()) (traverse_ $ checkDctorExists name dctorNames) dctors

272 when (null dctorNames && isNothing dctors) . tell . errorMessage $ MisleadingEmptyTypeImport importModule name

288 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)

274 return $ imp { importedTypes = types', importedDataConstructors = dctors' }

290 return $ imp { importedTypes = types', importedDataConstructors = dctors' }

275− importExplicit imp (TypeClassRef name) = do

291+ importRef prov imp (TypeClassRef name) = do

276− let typeClasses' = updateImports (importedTypeClasses imp) (exportedTypeClasses exps) name

292+ let typeClasses' = updateImports (importedTypeClasses imp) (exportedTypeClasses exps) name prov

277 return $ imp { importedTypeClasses = typeClasses' }

293 return $ imp { importedTypeClasses = typeClasses' }

278− importExplicit _ _ = internalError "Invalid argument to importExplicit"

294+ importRef _ _ _ = internalError "Invalid argument to importRef"

279

295

280 -- Find all exported data constructors for a given type

296 -- Find all exported data constructors for a given type

281− allExportedDataConstructors :: ProperName -> [(ProperName, ModuleName)]

297+ allExportedDataConstructors :: ProperName 'TypeName -> [(ProperName 'ConstructorName, ModuleName)]

282 allExportedDataConstructors name =

298 allExportedDataConstructors name =

283 case find ((== name) . fst . fst) (exportedTypes exps) of

299 case find ((== name) . fst . fst) (exportedTypes exps) of

284 Nothing -> internalError "Invalid state in allExportedDataConstructors"

300 Nothing -> internalError "Invalid state in allExportedDataConstructors"

@@ -287,11 +303,17 @@ resolveImport importModule exps imps impQual = resolveByType

287 -- Add something to an import resolution list

303 -- Add something to an import resolution list

288 updateImports

304 updateImports

289 :: (Ord a)

305 :: (Ord a)

290− => M.Map (Qualified a) [(Qualified a, ModuleName)]

306+ => M.Map (Qualified a) [ImportRecord a]

291 -> [(a, ModuleName)]

307 -> [(a, ModuleName)]

292 -> a

308 -> a

309+ -> ImportProvenance

293− -> M.Map (Qualified a) [(Qualified a, ModuleName)]

310+ -> M.Map (Qualified a) [ImportRecord a]

294− updateImports imps' exps' name =

311+ updateImports imps' exps' name prov =

312+ let

295− let mnOrig = fromMaybe (internalError "Invalid state in updateImports") (name `lookup` exps')

313+ 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'

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 @@

1{-# LANGUAGE FlexibleContexts #-}

2+{-# LANGUAGE PatternGuards #-}

2{-# LANGUAGE ScopedTypeVariables #-}

3{-# LANGUAGE ScopedTypeVariables #-}

3

4

4module Language.PureScript.Sugar.ObjectWildcards (

5module Language.PureScript.Sugar.ObjectWildcards (

@@ -8,46 +9,70 @@ module Language.PureScript.Sugar.ObjectWildcards (

8import Prelude ()

9import Prelude ()

9import Prelude.Compat

10import Prelude.Compat

10

11

11−import Control.Arrow (second)

12import Control.Monad.Error.Class (MonadError(..))

13import Control.Monad.Supply.Class

14

15import Data.List (partition)

16−import Data.Maybe (isJust, fromJust, catMaybes)

16+import Data.Maybe (catMaybes)

17

18import Language.PureScript.AST

19import Language.PureScript.Errors

20import Language.PureScript.Names

21

22+desugarObjectConstructors

23+ :: forall m

22−desugarObjectConstructors :: forall m. (Applicative m, MonadSupply m, MonadError MultipleErrors m) => Module -> m Module

24+ . (MonadSupply m, MonadError MultipleErrors m)

25+ => Module

26+ -> m Module

23desugarObjectConstructors (Module ss coms mn ds exts) = Module ss coms mn <$> mapM desugarDecl ds <*> pure exts

27desugarObjectConstructors (Module ss coms mn ds exts) = Module ss coms mn <$> mapM desugarDecl ds <*> pure exts

24 where

28 where

25

29

26 desugarDecl :: Declaration -> m Declaration

30 desugarDecl :: Declaration -> m Declaration

31+ desugarDecl (PositionedDeclaration pos com d) = rethrowWithPosition pos $ PositionedDeclaration pos com <$> desugarDecl d

32+ desugarDecl other = f other

33+ where

27− (desugarDecl, _, _) = everywhereOnValuesM return desugarExpr return

34+ (f, _, _) = everywhereOnValuesTopDownM return desugarExpr return

28

35

29 desugarExpr :: Expr -> m Expr

36 desugarExpr :: Expr -> m Expr

30− desugarExpr (ObjectConstructor ps) = wrapLambda ObjectLiteral ps

37+ desugarExpr AnonymousArgument = throwError . errorMessage $ IncorrectAnonymousArgument

31− desugarExpr (ObjectUpdater (Just obj) ps) = wrapLambda (ObjectUpdate obj) ps

38+ desugarExpr (Parens b)

32− desugarExpr (ObjectUpdater Nothing ps) = do

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

33 obj <- freshIdent'

47 obj <- freshIdent'

34 Abs (Left obj) <$> wrapLambda (ObjectUpdate (Var (Qualified Nothing obj))) ps

48 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

36 arg <- freshIdent'

51 arg <- freshIdent'

37 return $ Abs (Left arg) (Accessor prop (Var (Qualified Nothing arg)))

52 return $ Abs (Left arg) (Accessor prop (Var (Qualified Nothing arg)))

38 desugarExpr e = return e

53 desugarExpr e = return e

39

54

40− wrapLambda :: ([(String, Expr)] -> Expr) -> [(String, Maybe Expr)] -> m Expr

55+ wrapLambda :: ([(String, Expr)] -> Expr) -> [(String, Expr)] -> m Expr

41 wrapLambda mkVal ps =

56 wrapLambda mkVal ps =

42− let (props, args) = partition (isJust . snd) ps

57+ let (args, props) = partition (isAnonymousArgument . snd) ps

43 in if null args

58 in if null args

44− then return . mkVal $ second fromJust `map` props

59+ then return $ mkVal props

45 else do

60 else do

46 (args', ps') <- unzip <$> mapM mkProp ps

61 (args', ps') <- unzip <$> mapM mkProp ps

47 return $ foldr (Abs . Left) (mkVal ps') (catMaybes args')

62 return $ foldr (Abs . Left) (mkVal ps') (catMaybes args')

48

63

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+

49− mkProp :: (String, Maybe Expr) -> m (Maybe Ident, (String, Expr))

73+ mkProp :: (String, Expr) -> m (Maybe Ident, (String, Expr))

50− mkProp (name, Just e) = return (Nothing, (name, e))

74+ mkProp (name, e)

51− mkProp (name, Nothing) = do

75+ | isAnonymousArgument e = do

52− arg <- freshIdent'

76+ arg <- freshIdent'

53− return (Just arg, (name, Var (Qualified Nothing arg)))

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 @@

2{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE ScopedTypeVariables #-}

4{-# LANGUAGE RecordWildCards #-}

5+{-# LANGUAGE TupleSections #-}

5

6

6-- |

7-- |

7-- This module implements the desugaring pass which reapplies binary operators based

8-- This module implements the desugaring pass which reapplies binary operators based

@@ -19,52 +20,92 @@ module Language.PureScript.Sugar.Operators (

19import Prelude ()

20import Prelude ()

20import Prelude.Compat

21import Prelude.Compat

21

22

22−import Language.PureScript.Crash

23import Language.PureScript.AST

24+import Language.PureScript.Crash

24import Language.PureScript.Errors

25import Language.PureScript.Errors

25−import Language.PureScript.Names

26import 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)

27

31

28−import Control.Monad.State

29import Control.Monad.Error.Class (MonadError(..))

32import Control.Monad.Error.Class (MonadError(..))

30import Control.Monad.Supply.Class

33import Control.Monad.Supply.Class

31

34

32import Data.Function (on)

35import Data.Function (on)

33−import Data.Functor.Identity

34import Data.List (groupBy, sortBy)

36import Data.List (groupBy, sortBy)

35−import Data.Maybe (mapMaybe, fromMaybe)

37+import Data.Maybe (mapMaybe)

36import qualified Data.Map as M

38import qualified Data.Map as M

37

39

38−import qualified Text.Parsec as P

39−import qualified Text.Parsec.Pos as P

40−import qualified Text.Parsec.Expr as P

41−

42import qualified Language.PureScript.Constants as C

40import qualified Language.PureScript.Constants as C

43

41

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+

44-- |

55-- |

45-- Remove explicit parentheses and reorder binary operator applications

56-- Remove explicit parentheses and reorder binary operator applications

46--

57--

58+rebracket

59+ :: forall m

47−rebracket :: (Applicative m, MonadError MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module]

60+ . (MonadError MultipleErrors m)

61+ => [ExternsFile]

62+ -> [Module]

63+ -> m [Module]

48rebracket externs ms = do

64rebracket externs ms = do

49 let fixities = concatMap externsFixities externs ++ concatMap collectFixities ms

65 let fixities = concatMap externsFixities externs ++ concatMap collectFixities ms

50 ensureNoDuplicates $ map (\(i, pos, _, _) -> (i, pos)) fixities

66 ensureNoDuplicates $ map (\(i, pos, _, _) -> (i, pos)) fixities

51 let opTable = customOperatorTable $ map (\(i, _, f, _) -> (i, f)) fixities

67 let opTable = customOperatorTable $ map (\(i, _, f, _) -> (i, f)) fixities

52 ms' <- traverse (rebracketModule opTable) ms

68 ms' <- traverse (rebracketModule opTable) ms

53 let aliased = M.fromList (mapMaybe makeLookupEntry fixities)

69 let aliased = M.fromList (mapMaybe makeLookupEntry fixities)

54− return $ renameAliasedOperators aliased `map` ms'

70+ mapM (renameAliasedOperators aliased) ms'

55

71

56 where

72 where

57

73

58− makeLookupEntry :: (Qualified Ident, SourceSpan, Fixity, Maybe Ident) -> Maybe (Qualified Ident, Qualified Ident)

74+ makeLookupEntry :: FixityRecord -> Maybe (Qualified Ident, AliasName)

59− makeLookupEntry (qname@(Qualified qual _), _, _, Just alias) = Just (qname, Qualified qual alias)

75+ makeLookupEntry (qname, _, _, alias) = (qname, ) <$> alias

60− makeLookupEntry _ = Nothing

61

76

62− renameAliasedOperators :: M.Map (Qualified Ident) (Qualified Ident) -> Module -> Module

77+ renameAliasedOperators :: M.Map (Qualified Ident) AliasName -> Module -> m Module

63− renameAliasedOperators aliased (Module ss coms mn ds exts) = Module ss coms mn (map f' ds) exts

78+ renameAliasedOperators aliased (Module ss coms mn ds exts) =

79+ Module ss coms mn <$> mapM f' ds <*> pure exts

64 where

80 where

65− (f', _, _) = everywhereOnValues id go id

81+ (f', _, _, _, _) = everywhereWithContextOnValuesM Nothing goDecl goExpr goBinder defS defS

66− go (Var name) = Var $ fromMaybe name (name `M.lookup` aliased)

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"

67− go other = other

108+ goBinder pos other = return (pos, other)

68

109

69removeSignedLiterals :: Module -> Module

110removeSignedLiterals :: Module -> Module

70removeSignedLiterals (Module ss coms mn ds exts) = Module ss coms mn (map f' ds) exts

111removeSignedLiterals (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)

74 go (UnaryMinus val) = App (Var (Qualified Nothing (Ident C.negate))) val

115 go (UnaryMinus val) = App (Var (Qualified Nothing (Ident C.negate))) val

75 go other = other

116 go other = other

76

117

118+rebracketModule

119+ :: (MonadError MultipleErrors m)

77−rebracketModule :: (Applicative m, MonadError MultipleErrors m) => [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]] -> Module -> m Module

120+ => [[(Qualified Ident, Associativity)]]

121+ -> Module

122+ -> m Module

78rebracketModule opTable (Module ss coms mn ds exts) =

123rebracketModule opTable (Module ss coms mn ds exts) =

79− let (f, _, _) = everywhereOnValuesTopDownM return (matchOperators opTable) return

124+ let (f, _, _) = everywhereOnValuesTopDownM return (matchExprOperators opTable) (matchBinderOperators opTable)

80 in Module ss coms mn <$> (map removeParens <$> parU ds f) <*> pure exts

125 in Module ss coms mn <$> (map removeParens <$> parU ds f) <*> pure exts

81

126

82removeParens :: Declaration -> Declaration

127removeParens :: Declaration -> Declaration

83removeParens =

128removeParens =

84− let (f, _, _) = everywhereOnValues id go id

129+ let (f, _, _) = everywhereOnValues id goExpr goBinder

85 in f

130 in f

86 where

131 where

87− go (Parens val) = val

132+ goExpr (Parens val) = val

88− go val = val

133+ goExpr val = val

89−

134+ goBinder (ParensInBinder b) = b

90−externsFixities :: ExternsFile -> [(Qualified Ident, SourceSpan, Fixity, Maybe Ident)]

135+ goBinder b = b

136+

137+externsFixities

138+ :: ExternsFile

139+ -> [FixityRecord]

91externsFixities ExternsFile{..} =

140externsFixities ExternsFile{..} =

92− [ (Qualified (Just efModuleName) (Op op), internalModuleSourceSpan "", Fixity assoc prec, alias)

141+ [ (Qualified (Just efModuleName) (Op op), internalModuleSourceSpan "", Fixity assoc prec, alias)

93− | ExternsFixity assoc prec op alias <- efFixities

142+ | ExternsFixity assoc prec op alias <- efFixities

94− ]

143+ ]

95

144

96−collectFixities :: Module -> [(Qualified Ident, SourceSpan, Fixity, Maybe Ident)]

145+collectFixities :: Module -> [FixityRecord]

97collectFixities (Module _ _ moduleName ds _) = concatMap collect ds

146collectFixities (Module _ _ moduleName ds _) = concatMap collect ds

98 where

147 where

99− collect :: Declaration -> [(Qualified Ident, SourceSpan, Fixity, Maybe Ident)]

148+ collect :: Declaration -> [FixityRecord]

100 collect (PositionedDeclaration pos _ (FixityDeclaration fixity name alias)) =

149 collect (PositionedDeclaration pos _ (FixityDeclaration fixity name alias)) =

101 [(Qualified (Just moduleName) (Op name), pos, fixity, alias)]

150 [(Qualified (Just moduleName) (Op name), pos, fixity, alias)]

102 collect FixityDeclaration{} = internalError "Fixity without srcpos info"

151 collect FixityDeclaration{} = internalError "Fixity without srcpos info"

103 collect _ = []

152 collect _ = []

104

153

154+ensureNoDuplicates

105−ensureNoDuplicates :: (MonadError MultipleErrors m) => [(Qualified Ident, SourceSpan)] -> m ()

155+ :: MonadError MultipleErrors m

156+ => [(Qualified Ident, SourceSpan)]

157+ -> m ()

106ensureNoDuplicates m = go $ sortBy (compare `on` fst) m

158ensureNoDuplicates m = go $ sortBy (compare `on` fst) m

107 where

159 where

108 go [] = return ()

160 go [] = return ()

@@ -113,63 +165,24 @@ ensureNoDuplicates m = go $ sortBy (compare `on` fst) m

113 throwError . errorMessage $ MultipleFixities name

165 throwError . errorMessage $ MultipleFixities name

114 go (_ : rest) = go rest

166 go (_ : rest) = go rest

115

167

168+customOperatorTable

169+ :: [(Qualified Ident, Fixity)]

116−customOperatorTable :: [(Qualified Ident, Fixity)] -> [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]]

170+ -> [[(Qualified Ident, Associativity)]]

117customOperatorTable fixities =

171customOperatorTable fixities =

118 let

172 let

119− applyUserOp ident t1 = App (App (Var ident) t1)

120− userOps = map (\(name, Fixity a p) -> (name, applyUserOp name, p, a)) fixities

173+ userOps = map (\(name, Fixity a p) -> (name, p, a)) fixities

121− sorted = sortBy (flip compare `on` (\(_, _, p, _) -> p)) userOps

174+ sorted = sortBy (flip compare `on` (\(_, p, _) -> p)) userOps

122− groups = groupBy ((==) `on` (\(_, _, p, _) -> p)) sorted

175+ groups = groupBy ((==) `on` (\(_, p, _) -> p)) sorted

123 in

176 in

124− map (map (\(name, f, _, a) -> (name, f, a))) groups

177+ map (map (\(name, _, a) -> (name, a))) groups

125−

178+

126−type Chain = [Either Expr Expr]

179+desugarOperatorSections

127−

180+ :: forall m

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

181+ . (MonadSupply m, MonadError MultipleErrors m)

182+ => Module

183+ -> m Module

172−desugarOperatorSections (Module ss coms mn ds exts) = Module ss coms mn <$> traverse goDecl ds <*> pure exts

184+desugarOperatorSections (Module ss coms mn ds exts) =

185+ Module ss coms mn <$> traverse goDecl ds <*> pure exts

173 where

186 where

174

187

175 goDecl :: Declaration -> m Declaration

188 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−-----------------------------------------------------------------------------

1+{-# LANGUAGE FlexibleContexts #-}

2−--

2+{-# LANGUAGE RecordWildCards #-}

3−-- Module : Language.PureScript.Sugar.TypeClasses

3+{-# LANGUAGE ScopedTypeVariables #-}

4+

5−-- License : MIT (http://opensource.org/licenses/MIT)

6−--

7−-- Maintainer : Phil Freeman <paf31@cantab.net>

8−-- Stability : experimental

9−-- Portability :

10−--

11-- |

5-- |

12-- This module implements the desugaring pass which creates type synonyms for type class dictionaries

6-- This module implements the desugaring pass which creates type synonyms for type class dictionaries

13-- and dictionary expressions for type class instances.

7-- and dictionary expressions for type class instances.

14--

8--

15−-----------------------------------------------------------------------------

16−

17−{-# LANGUAGE FlexibleContexts #-}

18−{-# LANGUAGE RecordWildCards #-}

19−

20module Language.PureScript.Sugar.TypeClasses

9module Language.PureScript.Sugar.TypeClasses

21 ( desugarTypeClasses

10 ( desugarTypeClasses

22 , typeClassMemberName

11 , typeClassMemberName

@@ -47,7 +36,7 @@ import Data.Maybe (catMaybes, mapMaybe, isJust)

47

36

48import qualified Data.Map as M

37import qualified Data.Map as M

49

38

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])

51

40

52type Desugar = StateT MemberMap

41type Desugar = StateT MemberMap

53

42

@@ -55,17 +44,27 @@ type Desugar = StateT MemberMap

55-- Add type synonym declarations for type class dictionary types, and value declarations for type class

44-- Add type synonym declarations for type class dictionary types, and value declarations for type class

56-- instance dictionary expressions.

45-- instance dictionary expressions.

57--

46--

47+desugarTypeClasses

58−desugarTypeClasses :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module]

48+ :: (MonadSupply m, MonadError MultipleErrors m)

49+ => [ExternsFile]

50+ -> [Module]

51+ -> m [Module]

59desugarTypeClasses externs = flip evalStateT initialState . traverse desugarModule

52desugarTypeClasses externs = flip evalStateT initialState . traverse desugarModule

60 where

53 where

61 initialState :: MemberMap

54 initialState :: MemberMap

62 initialState = M.fromList (externs >>= \ExternsFile{..} -> mapMaybe (fromExternsDecl efModuleName) efDeclarations)

55 initialState = M.fromList (externs >>= \ExternsFile{..} -> mapMaybe (fromExternsDecl efModuleName) efDeclarations)

63

56

57+ fromExternsDecl

58+ :: ModuleName

59+ -> ExternsDeclaration

64− fromExternsDecl :: ModuleName -> ExternsDeclaration -> Maybe ((ModuleName, ProperName), ([(String, Maybe Kind)], [Constraint], [Declaration]))

60+ -> Maybe ((ModuleName, ProperName 'ClassName), ([(String, Maybe Kind)], [Constraint], [Declaration]))

65 fromExternsDecl mn (EDClass name args members implies) = Just ((mn, name), (args, implies, map (uncurry TypeDeclaration) members))

61 fromExternsDecl mn (EDClass name args members implies) = Just ((mn, name), (args, implies, map (uncurry TypeDeclaration) members))

66 fromExternsDecl _ _ = Nothing

62 fromExternsDecl _ _ = Nothing

67

63

64+desugarModule

68−desugarModule :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Module -> Desugar m Module

65+ :: (MonadSupply m, MonadError MultipleErrors m)

66+ => Module

67+ -> Desugar m Module

69desugarModule (Module ss coms name decls (Just exps)) = do

68desugarModule (Module ss coms name decls (Just exps)) = do

70 (newExpss, declss) <- unzip <$> parU (sortBy classesFirst decls) (desugarDecl name exps)

69 (newExpss, declss) <- unzip <$> parU (sortBy classesFirst decls) (desugarDecl name exps)

71 return $ Module ss coms name (concat declss) $ Just (exps ++ catMaybes newExpss)

70 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

171-- return new Sub(fooString, "");

170-- return new Sub(fooString, "");

172-- };

171-- };

173-}

172-}

173+desugarDecl

174+ :: (MonadSupply m, MonadError MultipleErrors m)

175+ => ModuleName

176+ -> [DeclarationRef]

177+ -> Declaration

174−desugarDecl :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => ModuleName -> [DeclarationRef] -> Declaration -> Desugar m (Maybe DeclarationRef, [Declaration])

178+ -> Desugar m (Maybe DeclarationRef, [Declaration])

175desugarDecl mn exps = go

179desugarDecl mn exps = go

176 where

180 where

177 go d@(TypeClassDeclaration name args implies members) = do

181 go d@(TypeClassDeclaration name args implies members) = do

@@ -187,48 +191,60 @@ desugarDecl mn exps = go

187 return (dr, map (PositionedDeclaration pos com) ds)

191 return (dr, map (PositionedDeclaration pos com) ds)

188 go other = return (Nothing, [other])

192 go other = return (Nothing, [other])

189

193

190− expRef :: Ident -> Qualified ProperName -> [Type] -> Maybe DeclarationRef

194+ expRef :: Ident -> Qualified (ProperName 'ClassName) -> [Type] -> Maybe DeclarationRef

191 expRef name className tys

195 expRef name className tys

192 | isExportedClass className && all isExportedType (getConstructors `concatMap` tys) = Just $ TypeInstanceRef name

196 | isExportedClass className && all isExportedType (getConstructors `concatMap` tys) = Just $ TypeInstanceRef name

193 | otherwise = Nothing

197 | otherwise = Nothing

194

198

195− isExportedClass :: Qualified ProperName -> Bool

199+ isExportedClass :: Qualified (ProperName 'ClassName) -> Bool

196 isExportedClass = isExported (elem . TypeClassRef)

200 isExportedClass = isExported (elem . TypeClassRef)

197

201

198− isExportedType :: Qualified ProperName -> Bool

202+ isExportedType :: Qualified (ProperName 'TypeName) -> Bool

199 isExportedType = isExported $ \pn -> isJust . find (matchesTypeRef pn)

203 isExportedType = isExported $ \pn -> isJust . find (matchesTypeRef pn)

200

204

205+ isExported

201− isExported :: (ProperName -> [DeclarationRef] -> Bool) -> Qualified ProperName -> Bool

206+ :: (ProperName a -> [DeclarationRef] -> Bool)

207+ -> Qualified (ProperName a)

208+ -> Bool

202 isExported test (Qualified (Just mn') pn) = mn /= mn' || test pn exps

209 isExported test (Qualified (Just mn') pn) = mn /= mn' || test pn exps

203 isExported _ _ = internalError "Names should have been qualified in name desugaring"

210 isExported _ _ = internalError "Names should have been qualified in name desugaring"

204

211

205− matchesTypeRef :: ProperName -> DeclarationRef -> Bool

212+ matchesTypeRef :: ProperName 'TypeName -> DeclarationRef -> Bool

206 matchesTypeRef pn (TypeRef pn' _) = pn == pn'

213 matchesTypeRef pn (TypeRef pn' _) = pn == pn'

207 matchesTypeRef _ _ = False

214 matchesTypeRef _ _ = False

208

215

209− getConstructors :: Type -> [Qualified ProperName]

216+ getConstructors :: Type -> [Qualified (ProperName 'TypeName)]

210 getConstructors = everythingOnTypes (++) getConstructor

217 getConstructors = everythingOnTypes (++) getConstructor

211−

218+ where

212− getConstructor :: Type -> [Qualified ProperName]

213− getConstructor (TypeConstructor tcname) = [tcname]

219+ getConstructor (TypeConstructor tcname) = [tcname]

214− getConstructor _ = []

220+ getConstructor _ = []

215

221

216memberToNameAndType :: Declaration -> (Ident, Type)

222memberToNameAndType :: Declaration -> (Ident, Type)

217memberToNameAndType (TypeDeclaration ident ty) = (ident, ty)

223memberToNameAndType (TypeDeclaration ident ty) = (ident, ty)

218memberToNameAndType (PositionedDeclaration _ _ d) = memberToNameAndType d

224memberToNameAndType (PositionedDeclaration _ _ d) = memberToNameAndType d

219memberToNameAndType _ = internalError "Invalid declaration in type class definition"

225memberToNameAndType _ = internalError "Invalid declaration in type class definition"

220

226

221−typeClassDictionaryDeclaration :: ProperName -> [(String, Maybe Kind)] -> [Constraint] -> [Declaration] -> Declaration

227+typeClassDictionaryDeclaration

228+ :: ProperName 'ClassName

229+ -> [(String, Maybe Kind)]

230+ -> [Constraint]

231+ -> [Declaration]

232+ -> Declaration

222typeClassDictionaryDeclaration name args implies members =

233typeClassDictionaryDeclaration name args implies members =

223 let superclassTypes = superClassDictionaryNames implies `zip`

234 let superclassTypes = superClassDictionaryNames implies `zip`

224− [ function unit (foldl TypeApp (TypeConstructor superclass) tyArgs)

235+ [ function unit (foldl TypeApp (TypeConstructor (fmap coerceProperName superclass)) tyArgs)

225 | (superclass, tyArgs) <- implies

236 | (superclass, tyArgs) <- implies

226 ]

237 ]

227 members' = map (first runIdent . memberToNameAndType) members

238 members' = map (first runIdent . memberToNameAndType) members

228 mtys = members' ++ superclassTypes

239 mtys = members' ++ superclassTypes

229− in TypeSynonymDeclaration name args (TypeApp tyObject $ rowFromList (mtys, REmpty))

240+ in TypeSynonymDeclaration (coerceProperName name) args (TypeApp tyObject $ rowFromList (mtys, REmpty))

230−

241+

231−typeClassMemberToDictionaryAccessor :: ModuleName -> ProperName -> [(String, Maybe Kind)] -> Declaration -> Declaration

242+typeClassMemberToDictionaryAccessor

243+ :: ModuleName

244+ -> ProperName 'ClassName

245+ -> [(String, Maybe Kind)]

246+ -> Declaration

247+ -> Declaration

232typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) =

248typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) =

233 let className = Qualified (Just mn) name

249 let className = Qualified (Just mn) name

234 in ValueDeclaration ident Private [] $ Right $

250 in ValueDeclaration ident Private [] $ Right $

@@ -241,7 +257,16 @@ typeClassMemberToDictionaryAccessor _ _ _ _ = internalError "Invalid declaration

241unit :: Type

257unit :: Type

242unit = TypeApp tyObject REmpty

258unit = TypeApp tyObject REmpty

243

259

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

245typeInstanceDictionaryDeclaration name mn deps className tys decls =

270typeInstanceDictionaryDeclaration name mn deps className tys decls =

246 rethrow (addHint (ErrorInInstance className tys)) $ do

271 rethrow (addHint (ErrorInInstance className tys)) $ do

247 m <- get

272 m <- get

@@ -272,8 +297,8 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =

272 , let tyArgs = map (replaceAllTypeVars (zip (map fst args) tys)) suTyArgs

297 , let tyArgs = map (replaceAllTypeVars (zip (map fst args) tys)) suTyArgs

273 ]

298 ]

274

299

275− let props = ObjectLiteral (members ++ superclasses)

300+ let props = Literal $ ObjectLiteral (members ++ superclasses)

276− dictTy = foldl TypeApp (TypeConstructor className) tys

301+ dictTy = foldl TypeApp (TypeConstructor (fmap coerceProperName className)) tys

277 constrainedTy = quantify (if null deps then dictTy else ConstrainedType deps dictTy)

302 constrainedTy = quantify (if null deps then dictTy else ConstrainedType deps dictTy)

278 dict = TypeClassDictionaryConstructorApp className props

303 dict = TypeClassDictionaryConstructorApp className props

279 result = ValueDeclaration name Private [] (Right (TypedValue True dict constrainedTy))

304 result = ValueDeclaration name Private [] (Right (TypedValue True dict constrainedTy))

@@ -287,7 +312,7 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =

287 declName (TypeDeclaration ident _) = Just ident

312 declName (TypeDeclaration ident _) = Just ident

288 declName _ = Nothing

313 declName _ = Nothing

289

314

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

291 memberToValue tys' (ValueDeclaration ident _ [] (Right val)) = do

316 memberToValue tys' (ValueDeclaration ident _ [] (Right val)) = do

292 _ <- maybe (throwError . errorMessage $ ExtraneousClassMember ident className) return $ lookup ident tys'

317 _ <- maybe (throwError . errorMessage $ ExtraneousClassMember ident className) return $ lookup ident tys'

293 return val

318 return val

src/Language/PureScript/Sugar/TypeClasses/Deriving.hs+337−149

@@ -8,9 +8,7 @@

8-- |

9-- This module implements the generic deriving elaboration that takes place during desugaring.

10--

11−module Language.PureScript.Sugar.TypeClasses.Deriving (

11+module Language.PureScript.Sugar.TypeClasses.Deriving (deriveInstances) where

12− deriveInstances

13−) where

14

12

15import Prelude ()

13import Prelude ()

16import Prelude.Compat

14import Prelude.Compat

@@ -19,6 +17,7 @@ import Data.List (foldl', find, sortBy)

19import Data.Maybe (fromMaybe)

17import Data.Maybe (fromMaybe)

20import Data.Ord (comparing)

18import Data.Ord (comparing)

21

19

20+import Control.Arrow (second)

22import Control.Monad (replicateM)

21import Control.Monad (replicateM)

23import Control.Monad.Supply.Class (MonadSupply)

22import Control.Monad.Supply.Class (MonadSupply)

24import Control.Monad.Error.Class (MonadError(..))

23import Control.Monad.Error.Class (MonadError(..))

@@ -32,28 +31,46 @@ import Language.PureScript.Types

32import qualified Language.PureScript.Constants as C

31import qualified Language.PureScript.Constants as C

33

32

34-- | Elaborates deriving instance declarations by code generation.

33-- | Elaborates deriving instance declarations by code generation.

34+deriveInstances

35−deriveInstances :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadSupply m) => Module -> m Module

35+ :: (MonadError MultipleErrors m, MonadSupply m)

36+ => Module

37+ -> m Module

36deriveInstances (Module ss coms mn ds exts) = Module ss coms mn <$> mapM (deriveInstance mn ds) ds <*> pure exts

38deriveInstances (Module ss coms mn ds exts) = Module ss coms mn <$> mapM (deriveInstance mn ds) ds <*> pure exts

37

39

38-- | Takes a declaration, and if the declaration is a deriving TypeInstanceDeclaration,

40-- | Takes a declaration, and if the declaration is a deriving TypeInstanceDeclaration,

39-- elaborates that into an instance declaration via code generation.

41-- elaborates that into an instance declaration via code generation.

42+deriveInstance

40−deriveInstance :: (Functor m, MonadError MultipleErrors m, MonadSupply m) => ModuleName -> [Declaration] -> Declaration -> m Declaration

43+ :: (MonadError MultipleErrors m, MonadSupply m)

44+ => ModuleName

45+ -> [Declaration]

46+ -> Declaration

47+ -> m Declaration

41deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@[ty] DerivedInstance)

48deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@[ty] DerivedInstance)

42 | className == Qualified (Just dataGeneric) (ProperName C.generic)

49 | className == Qualified (Just dataGeneric) (ProperName C.generic)

43 , Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor ty

50 , Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor ty

44 , mn == fromMaybe mn mn'

51 , mn == fromMaybe mn mn'

45 = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveGeneric mn ds tyCon args

52 = 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

46deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance)

61deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance)

47 = throwError . errorMessage $ CannotDerive className tys

62 = throwError . errorMessage $ CannotDerive className tys

48deriveInstance mn ds (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> deriveInstance mn ds d

63deriveInstance mn ds (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> deriveInstance mn ds d

49deriveInstance _ _ e = return e

64deriveInstance _ _ e = return e

50

65

51−unwrapTypeConstructor :: Type -> Maybe (Qualified ProperName, [Type])

66+unwrapTypeConstructor :: Type -> Maybe (Qualified (ProperName 'TypeName), [Type])

67+unwrapTypeConstructor = fmap (second reverse) . go

68+ where

52−unwrapTypeConstructor (TypeConstructor tyCon) = Just (tyCon, [])

69+ go (TypeConstructor tyCon) = Just (tyCon, [])

53−unwrapTypeConstructor (TypeApp ty arg) = do

70+ go (TypeApp ty arg) = do

54− (tyCon, args) <- unwrapTypeConstructor ty

71+ (tyCon, args) <- go ty

55− return (tyCon, arg : args)

72+ return (tyCon, arg : args)

56−unwrapTypeConstructor _ = Nothing

73+ go _ = Nothing

57

74

58dataGeneric :: ModuleName

75dataGeneric :: ModuleName

59dataGeneric = ModuleName [ ProperName "Data", ProperName "Generic" ]

76dataGeneric = ModuleName [ ProperName "Data", ProperName "Generic" ]

@@ -64,18 +81,306 @@ dataMaybe = ModuleName [ ProperName "Data", ProperName "Maybe" ]

64typesProxy :: ModuleName

81typesProxy :: ModuleName

65typesProxy = ModuleName [ ProperName "Type", ProperName "Proxy" ]

82typesProxy = ModuleName [ ProperName "Type", ProperName "Proxy" ]

66

83

84+deriveGeneric

67−deriveGeneric :: (Functor m, MonadError MultipleErrors m, MonadSupply m) => ModuleName -> [Declaration] -> ProperName -> [Type] -> m [Declaration]

85+ :: forall m. (MonadError MultipleErrors m, MonadSupply m)

86+ => ModuleName

87+ -> [Declaration]

88+ -> ProperName 'TypeName

89+ -> [Type]

90+ -> m [Declaration]

68−deriveGeneric mn ds tyConNm args = do

91+deriveGeneric mn ds tyConNm dargs = do

69 tyCon <- findTypeDecl tyConNm ds

92 tyCon <- findTypeDecl tyConNm ds

70− toSpine <- mkSpineFunction mn tyCon

93+ toSpine <- mkSpineFunction tyCon

71− fromSpine <- mkFromSpineFunction mn tyCon

94+ fromSpine <- mkFromSpineFunction tyCon

72− let toSignature = mkSignatureFunction mn tyCon args

95+ let toSignature = mkSignatureFunction tyCon dargs

73 return [ ValueDeclaration (Ident C.toSpine) Public [] (Right toSpine)

96 return [ ValueDeclaration (Ident C.toSpine) Public [] (Right toSpine)

74 , ValueDeclaration (Ident C.fromSpine) Public [] (Right fromSpine)

97 , ValueDeclaration (Ident C.fromSpine) Public [] (Right fromSpine)

75 , ValueDeclaration (Ident C.toSignature) Public [] (Right toSignature)

98 , ValueDeclaration (Ident C.toSignature) Public [] (Right toSignature)

76 ]

99 ]

77−

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 ::

78−findTypeDecl :: (Functor m, MonadError MultipleErrors m) => ProperName -> [Declaration] -> m Declaration

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

79findTypeDecl tyConNm = maybe (throwError . errorMessage $ CannotFindDerivingType tyConNm) return . find isTypeDecl

384findTypeDecl tyConNm = maybe (throwError . errorMessage $ CannotFindDerivingType tyConNm) return . find isTypeDecl

80 where

385 where

81 isTypeDecl :: Declaration -> Bool

386 isTypeDecl :: Declaration -> Bool

@@ -83,146 +388,29 @@ findTypeDecl tyConNm = maybe (throwError . errorMessage $ CannotFindDerivingType

83 isTypeDecl (PositionedDeclaration _ _ d) = isTypeDecl d

388 isTypeDecl (PositionedDeclaration _ _ d) = isTypeDecl d

84 isTypeDecl _ = False

389 isTypeDecl _ = False

85

390

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

391+lam :: Ident -> Expr -> Expr

202−lam s = Abs (Left (Ident s))

392+lam = Abs . Left

203

393

204lamNull :: Expr -> Expr

394lamNull :: Expr -> Expr

205−lamNull = lam "$q"

395+lamNull = lam (Ident "$q") -- TODO: use GenIdent

206

396

207−lamCase :: String -> [CaseAlternative] -> Expr

397+lamCase :: Ident -> [CaseAlternative] -> Expr

208lamCase s = lam s . Case [mkVar s]

398lamCase s = lam s . Case [mkVar s]

209

399

210−liftApplicative :: Expr -> [Expr] -> Expr

400+lamCase2 :: Ident -> Ident -> [CaseAlternative] -> Expr

211−liftApplicative = foldl' (\x e -> App (App (mkPrelVar "apply") x) e)

401+lamCase2 s t = lam s . lam t . Case [mkVar s, mkVar t]

212

402

213−mkVarMn :: Maybe ModuleName -> String -> Expr

403+mkVarMn :: Maybe ModuleName -> Ident -> Expr

214−mkVarMn mn s = Var (Qualified mn (Ident s))

404+mkVarMn mn = Var . Qualified mn

215

405

216−mkVar :: String -> Expr

406+mkVar :: Ident -> Expr

217mkVar = mkVarMn Nothing

407mkVar = mkVarMn Nothing

218

408

219−mkPrelVar :: String -> Expr

409+objectType :: Type -> Maybe Type

220−mkPrelVar = mkVarMn (Just (ModuleName [ProperName C.prelude]))

410+objectType (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName "Object"))) rec) = Just rec

221−

411+objectType _ = Nothing

222−mkGenVar :: String -> Expr

223−mkGenVar = mkVarMn (Just (ModuleName [ProperName "Data", ProperName C.generic]))

224

412

225decomposeRec :: Type -> [(String, Type)]

413decomposeRec :: Type -> [(String, Type)]

226decomposeRec = sortBy (comparing fst) . go

414decomposeRec = sortBy (comparing fst) . go

227− where go (RCons str typ typs) = (str, typ) : decomposeRec typs

415+ where go (RCons str typ typs) = (str, typ) : decomposeRec typs

228− go _ = []

416+ go _ = []

src/Language/PureScript/Sugar/TypeDeclarations.hs+1−1

@@ -36,7 +36,7 @@ import Language.PureScript.Traversals

36-- |

37-- Replace all top level type declarations in a module with type annotations

38--

39−desugarTypeDeclarationsModule :: forall m. (Functor m, Applicative m, MonadError MultipleErrors m) => [Module] -> m [Module]

39+desugarTypeDeclarationsModule :: forall m. (MonadError MultipleErrors m) => [Module] -> m [Module]

40desugarTypeDeclarationsModule ms = forM ms $ \(Module ss coms name ds exps) ->

41 rethrow (addHint (ErrorInModule name)) $

42 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

19import Language.PureScript.TypeChecker.Synonyms as T

20

21import Data.Maybe

22−import Data.List (nub, (\\), sort, group)

22+import Data.List (nub, nubBy, (\\), sort, group)

23import Data.Foldable (for_, traverse_)

24

25import qualified Data.Map as M

@@ -30,24 +30,24 @@ import Control.Monad.State.Class (MonadState(..), modify)

30import Control.Monad.Error.Class (MonadError(..))

31import Control.Monad.Writer.Class (MonadWriter(..))

32

33−import Language.PureScript.Crash

34−import Language.PureScript.Types

35−import Language.PureScript.Names

36−import Language.PureScript.Kinds

37import Language.PureScript.AST

33import Language.PureScript.AST

38−import Language.PureScript.TypeClassDictionaries

34+import Language.PureScript.Crash

39import Language.PureScript.Environment

35import Language.PureScript.Environment

40import Language.PureScript.Errors

36import Language.PureScript.Errors

37+import Language.PureScript.Kinds

38+import Language.PureScript.Names

39+import Language.PureScript.TypeClassDictionaries

40+import Language.PureScript.Types

41

42−addDataType ::

42+addDataType

43− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

43+ :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

44− ModuleName ->

44+ => ModuleName

45− DataDeclType ->

45+ -> DataDeclType

46− ProperName ->

46+ -> ProperName 'TypeName

47− [(String, Maybe Kind)] ->

47+ -> [(String, Maybe Kind)]

48− [(ProperName, [Type])] ->

48+ -> [(ProperName 'ConstructorName, [Type])]

49− Kind ->

49+ -> Kind

50− m ()

50+ -> m ()

51addDataType moduleName dtype name args dctors ctorKind = do

52 env <- getEnv

53 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

55 warnAndRethrow (addHint (ErrorInDataConstructor dctor)) $

56 addDataConstructor moduleName dtype name (map fst args) dctor tys

57

58−addDataConstructor ::

58+addDataConstructor

59− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

59+ :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

60− ModuleName ->

60+ => ModuleName

61− DataDeclType ->

61+ -> DataDeclType

62− ProperName ->

62+ -> ProperName 'TypeName

63− [String] ->

63+ -> [String]

64− ProperName ->

64+ -> ProperName 'ConstructorName

65− [Type] ->

65+ -> [Type]

66− m ()

66+ -> m ()

67addDataConstructor moduleName dtype name args dctor tys = do

68 env <- getEnv

69 traverse_ checkTypeSynonyms tys

@@ -73,50 +73,50 @@ addDataConstructor moduleName dtype name args dctor tys = do

73 let fields = [Ident ("value" ++ show n) | n <- [0..(length tys - 1)]]

74 putEnv $ env { dataConstructors = M.insert (Qualified (Just moduleName) dctor) (dtype, name, polyType, fields) (dataConstructors env) }

75

76−addTypeSynonym ::

76+addTypeSynonym

77− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

77+ :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

78− ModuleName ->

78+ => ModuleName

79− ProperName ->

79+ -> ProperName 'TypeName

80− [(String, Maybe Kind)] ->

80+ -> [(String, Maybe Kind)]

81− Type ->

81+ -> Type

82− Kind ->

82+ -> Kind

83− m ()

83+ -> m ()

84addTypeSynonym moduleName name args ty kind = do

85 env <- getEnv

86 checkTypeSynonyms ty

87 putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (kind, TypeSynonym) (types env)

88 , typeSynonyms = M.insert (Qualified (Just moduleName) name) (args, ty) (typeSynonyms env) }

89

90−valueIsNotDefined ::

90+valueIsNotDefined

91− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

91+ :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

92− ModuleName ->

92+ => ModuleName

93− Ident ->

93+ -> Ident

94− m ()

94+ -> m ()

95valueIsNotDefined moduleName name = do

96 env <- getEnv

97 case M.lookup (moduleName, name) (names env) of

98 Just _ -> throwError . errorMessage $ RedefinedIdent name

99 Nothing -> return ()

100

101−addValue ::

101+addValue

102− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

102+ :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

103− ModuleName ->

103+ => ModuleName

104− Ident ->

104+ -> Ident

105− Type ->

105+ -> Type

106− NameKind ->

106+ -> NameKind

107− m ()

107+ -> m ()

108addValue moduleName name ty nameKind = do

109 env <- getEnv

110 putEnv (env { names = M.insert (moduleName, name) (ty, nameKind, Defined) (names env) })

111

112−addTypeClass ::

112+addTypeClass

113− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

113+ :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

114− ModuleName ->

114+ => ModuleName

115− ProperName ->

115+ -> ProperName 'ClassName

116− [(String, Maybe Kind)] ->

116+ -> [(String, Maybe Kind)]

117− [Constraint] ->

117+ -> [Constraint]

118− [Declaration] ->

118+ -> [Declaration]

119− m ()

119+ -> m ()

120addTypeClass moduleName pn args implies ds =

121 let members = map toPair ds in

122 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 =

125 toPair (PositionedDeclaration _ _ d) = toPair d

126 toPair _ = internalError "Invalid declaration in TypeClassDeclaration"

127

128−addTypeClassDictionaries ::

128+addTypeClassDictionaries

129− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

129+ :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

130− Maybe ModuleName ->

130+ => Maybe ModuleName

131− M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope) ->

131+ -> M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope)

132− m ()

132+ -> m ()

133addTypeClassDictionaries mn entries =

134 modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = insertState st } }

135 where insertState st = M.insertWith (M.unionWith M.union) mn entries (typeClassDictionaries . checkEnv $ st)

136

137−checkDuplicateTypeArguments ::

137+checkDuplicateTypeArguments

138− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

138+ :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

139− [String] ->

139+ => [String]

140− m ()

140+ -> m ()

141checkDuplicateTypeArguments args = for_ firstDup $ \dup ->

142 throwError . errorMessage $ DuplicateTypeArgument dup

143 where

144 firstDup :: Maybe String

145 firstDup = listToMaybe $ args \\ nub args

146

147−checkTypeClassInstance ::

147+checkTypeClassInstance

148− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

148+ :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

149− ModuleName ->

149+ => ModuleName

150− Type ->

150+ -> Type

151− m ()

151+ -> m ()

152checkTypeClassInstance _ (TypeVar _) = return ()

153checkTypeClassInstance _ (TypeConstructor ctor) = do

154 env <- getEnv

@@ -160,10 +160,10 @@ checkTypeClassInstance _ ty = throwError . errorMessage $ InvalidInstanceHead ty

160-- |

161-- Check that type synonyms are fully-applied in a type

162--

163−checkTypeSynonyms ::

163+checkTypeSynonyms

164− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

164+ :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

165− Type ->

165+ => Type

166− m ()

166+ -> m ()

167checkTypeSynonyms = void . replaceAllTypeSynonyms

168

169-- |

@@ -179,12 +179,13 @@ checkTypeSynonyms = void . replaceAllTypeSynonyms

179--

180-- * Process module imports

181--

182−typeCheckAll :: forall m.

182+typeCheckAll

183+ :: forall m

183− (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

184+ . (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

184− ModuleName ->

185+ => ModuleName

185− [DeclarationRef] ->

186+ -> [DeclarationRef]

186− [Declaration] ->

187+ -> [Declaration]

187− m [Declaration]

188+ -> m [Declaration]

188typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds

189typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds

189 where

190 where

190 go :: Declaration -> m Declaration

191 go :: Declaration -> m Declaration

@@ -197,7 +198,7 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds

197 addDataType moduleName dtype name args' dctors ctorKind

198 addDataType moduleName dtype name args' dctors ctorKind

198 return $ DataDeclaration dtype name args dctors

199 return $ DataDeclaration dtype name args dctors

199 where

200 where

200− checkNewtype :: [(ProperName, [Type])] -> m ()

201+ checkNewtype :: [(ProperName 'ConstructorName, [Type])] -> m ()

201 checkNewtype [(_, [_])] = return ()

202 checkNewtype [(_, [_])] = return ()

202 checkNewtype [(_, _)] = throwError . errorMessage $ InvalidNewtype name

203 checkNewtype [(_, _)] = throwError . errorMessage $ InvalidNewtype name

203 checkNewtype _ = throwError . errorMessage $ InvalidNewtype name

204 checkNewtype _ = throwError . errorMessage $ InvalidNewtype name

@@ -229,14 +230,14 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds

229 let args' = args `withKinds` kind

230 let args' = args `withKinds` kind

230 addTypeSynonym moduleName name args' ty kind

231 addTypeSynonym moduleName name args' ty kind

231 return $ TypeSynonymDeclaration name args ty

232 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"

233 go (ValueDeclaration name nameKind [] (Right val)) =

234 go (ValueDeclaration name nameKind [] (Right val)) =

234 warnAndRethrow (addHint (ErrorInValueDeclaration name)) $ do

235 warnAndRethrow (addHint (ErrorInValueDeclaration name)) $ do

235 valueIsNotDefined moduleName name

236 valueIsNotDefined moduleName name

236 [(_, (val', ty))] <- typesOf moduleName [(name, val)]

237 [(_, (val', ty))] <- typesOf moduleName [(name, val)]

237 addValue moduleName name ty nameKind

238 addValue moduleName name ty nameKind

238 return $ ValueDeclaration name nameKind [] $ Right val'

239 return $ ValueDeclaration name nameKind [] $ Right val'

239− go (ValueDeclaration{}) = internalError "Binders were not desugared"

240+ go ValueDeclaration{} = internalError "Binders were not desugared"

240 go (BindingGroupDeclaration vals) =

241 go (BindingGroupDeclaration vals) =

241 warnAndRethrow (addHint (ErrorInBindingGroup (map (\(ident, _, _) -> ident) vals))) $ do

242 warnAndRethrow (addHint (ErrorInBindingGroup (map (\(ident, _, _) -> ident) vals))) $ do

242 for_ (map (\(ident, _, _) -> ident) vals) $ \name ->

243 for_ (map (\(ident, _, _) -> ident) vals) $ \name ->

@@ -263,8 +264,8 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds

263 Just _ -> throwError . errorMessage $ RedefinedIdent name

264 Just _ -> throwError . errorMessage $ RedefinedIdent name

264 Nothing -> putEnv (env { names = M.insert (moduleName, name) (ty, External, Defined) (names env) })

265 Nothing -> putEnv (env { names = M.insert (moduleName, name) (ty, External, Defined) (names env) })

265 return d

266 return d

266− go (d@(FixityDeclaration{})) = return d

267+ go (d@FixityDeclaration{}) = return d

267− go (d@(ImportDeclaration{})) = return d

268+ go (d@ImportDeclaration{}) = return d

268 go (d@(TypeClassDeclaration pn args implies tys)) = do

269 go (d@(TypeClassDeclaration pn args implies tys)) = do

269 addTypeClass moduleName pn args implies tys

270 addTypeClass moduleName pn args implies tys

270 return d

271 return d

@@ -280,9 +281,14 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds

280 warnAndRethrowWithPosition pos $ PositionedDeclaration pos com <$> go d

281 warnAndRethrowWithPosition pos $ PositionedDeclaration pos com <$> go d

281

282

282 checkFixities :: Declaration -> m ()

283 checkFixities :: Declaration -> m ()

283− checkFixities (FixityDeclaration _ name (Just alias)) = do

284+ checkFixities (FixityDeclaration _ name (Just (Left alias))) = do

284− ty <- lookupVariable moduleName (Qualified (Just moduleName) alias)

285+ ty <- lookupVariable moduleName alias

285 addValue moduleName (Op name) ty Public

286 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

286 checkFixities (FixityDeclaration _ name _) = do

292 checkFixities (FixityDeclaration _ name _) = do

287 env <- getEnv

293 env <- getEnv

288 guardWith (errorMessage (OrphanFixityDeclaration name)) $ M.member (moduleName, Op name) $ names env

294 guardWith (errorMessage (OrphanFixityDeclaration name)) $ M.member (moduleName, Op name) $ names env

@@ -308,7 +314,7 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds

308 | otherwise = firstDuplicate xs

314 | otherwise = firstDuplicate xs

309 firstDuplicate _ = Nothing

315 firstDuplicate _ = Nothing

310

316

311− checkOrphanInstance :: Ident -> Qualified ProperName -> [Type] -> m ()

317+ checkOrphanInstance :: Ident -> Qualified (ProperName 'ClassName) -> [Type] -> m ()

312 checkOrphanInstance dictName className@(Qualified (Just mn') _) tys'

318 checkOrphanInstance dictName className@(Qualified (Just mn') _) tys'

313 | moduleName == mn' || any checkType tys' = return ()

319 | moduleName == mn' || any checkType tys' = return ()

314 | otherwise = throwError . errorMessage $ OrphanInstance dictName className tys'

320 | otherwise = throwError . errorMessage $ OrphanInstance dictName className tys'

@@ -335,10 +341,11 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds

335-- Type check an entire module and ensure all types and classes defined within the module that are

341-- Type check an entire module and ensure all types and classes defined within the module that are

336-- required by exported members are also exported.

342-- required by exported members are also exported.

337--

343--

338−typeCheckModule :: forall m.

344+typeCheckModule

345+ :: forall m

339− (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

346+ . (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

340− Module ->

347+ => Module

341− m Module

348+ -> m Module

342typeCheckModule (Module _ _ _ _ Nothing) = internalError "exports should have been elaborated"

349typeCheckModule (Module _ _ _ _ Nothing) = internalError "exports should have been elaborated"

343typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint (ErrorInModule mn)) $ do

350typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint (ErrorInModule mn)) $ do

344 modify (\s -> s { checkCurrentModule = Just mn })

351 modify (\s -> s { checkCurrentModule = Just mn })

@@ -347,7 +354,7 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint

347 checkTypesAreExported e

354 checkTypesAreExported e

348 checkClassMembersAreExported e

355 checkClassMembersAreExported e

349 checkClassesAreExported e

356 checkClassesAreExported e

350− checkNonAliasesAreExported e

357+ checkNonAliasesAreExported (exportedDataConstructors exps) e

351 return $ Module ss coms mn decls' (Just exps)

358 return $ Module ss coms mn decls' (Just exps)

352 where

359 where

353

360

@@ -372,7 +379,7 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint

372 checkExport :: DeclarationRef -> (Type -> [DeclarationRef]) -> Type -> m ()

379 checkExport :: DeclarationRef -> (Type -> [DeclarationRef]) -> Type -> m ()

373 checkExport dr extract ty = case filter (not . exported) (extract ty) of

380 checkExport dr extract ty = case filter (not . exported) (extract ty) of

374 [] -> return ()

381 [] -> return ()

375− hidden -> throwError . errorMessage $ TransitiveExportError dr hidden

382+ hidden -> throwError . errorMessage $ TransitiveExportError dr (nubBy nubEq hidden)

376 where

383 where

377 exported e = any (exports e) exps

384 exported e = any (exports e) exps

378 exports (TypeRef pn1 _) (TypeRef pn2 _) = pn1 == pn2

385 exports (TypeRef pn1 _) (TypeRef pn2 _) = pn1 == pn2

@@ -381,6 +388,11 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint

381 exports (PositionedDeclarationRef _ _ r1) r2 = exports r1 r2

388 exports (PositionedDeclarationRef _ _ r1) r2 = exports r1 r2

382 exports r1 (PositionedDeclarationRef _ _ r2) = exports r1 r2

389 exports r1 (PositionedDeclarationRef _ _ r2) = exports r1 r2

383 exports _ _ = False

390 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+

384

396

385 -- Check that all the type constructors defined in the current module that appear in member types

397 -- Check that all the type constructors defined in the current module that appear in member types

386 -- have also been exported from the module

398 -- have also been exported from the module

@@ -403,7 +415,7 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint

403 where

415 where

404 go (ConstrainedType cs _) = mapMaybe (fmap TypeClassRef . extractCurrentModuleClass . fst) cs

416 go (ConstrainedType cs _) = mapMaybe (fmap TypeClassRef . extractCurrentModuleClass . fst) cs

405 go _ = []

417 go _ = []

406− extractCurrentModuleClass :: Qualified ProperName -> Maybe ProperName

418+ extractCurrentModuleClass :: Qualified (ProperName 'ClassName) -> Maybe (ProperName 'ClassName)

407 extractCurrentModuleClass (Qualified (Just mn') name) | mn == mn' = Just name

419 extractCurrentModuleClass (Qualified (Just mn') name) | mn == mn' = Just name

408 extractCurrentModuleClass _ = Nothing

420 extractCurrentModuleClass _ = Nothing

409

421

@@ -423,16 +435,30 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint

423 extractMemberName _ = internalError "Unexpected declaration in typeclass member list"

435 extractMemberName _ = internalError "Unexpected declaration in typeclass member list"

424 checkClassMembersAreExported _ = return ()

436 checkClassMembersAreExported _ = return ()

425

437

426− checkNonAliasesAreExported :: DeclarationRef -> m ()

438+ checkNonAliasesAreExported :: [ProperName 'ConstructorName] -> DeclarationRef -> m ()

427− checkNonAliasesAreExported dr@(ValueRef (Op name)) =

439+ checkNonAliasesAreExported exportedDctors dr@(ValueRef (Op name)) =

428 case listToMaybe (mapMaybe getAlias decls) of

440 case listToMaybe (mapMaybe getAlias decls) of

429− Just alias ->

441+ Just (Left ident) ->

430− when (not $ any (== ValueRef alias) exps) $

442+ unless (ValueRef ident `elem` exps) $

431− throwError . errorMessage $ TransitiveExportError dr [ValueRef alias]

443+ throwError . errorMessage $ TransitiveExportError dr [ValueRef ident]

444+ Just (Right ctor) ->

445+ unless (ctor `elem` exportedDctors) $

446+ throwError . errorMessage $ TransitiveDctorExportError dr ctor

432 _ -> return ()

447 _ -> return ()

433 where

448 where

434− getAlias :: Declaration -> Maybe Ident

449+ getAlias :: Declaration -> Maybe (Either Ident (ProperName 'ConstructorName))

435 getAlias (PositionedDeclaration _ _ d) = getAlias d

450 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

437 getAlias _ = Nothing

456 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−

16{-# LANGUAGE ScopedTypeVariables #-}

1{-# LANGUAGE ScopedTypeVariables #-}

17{-# LANGUAGE FlexibleContexts #-}

2{-# LANGUAGE FlexibleContexts #-}

18

3

4+-- |

5+-- Type class entailment

6+--

19−module Language.PureScript.TypeChecker.Entailment (

7+module Language.PureScript.TypeChecker.Entailment (entails) where

20− entails

21−) where

22

8

23import Prelude ()

9import Prelude ()

24import Prelude.Compat

10import Prelude.Compat

@@ -46,15 +32,16 @@ import qualified Language.PureScript.Constants as C

46-- Check that the current set of type class dictionaries entail the specified type class goal, and, if so,

32-- Check that the current set of type class dictionaries entail the specified type class goal, and, if so,

47-- return a type class dictionary reference.

33-- return a type class dictionary reference.

48--

34--

49−entails :: forall m.

35+entails

36+ :: forall m

50− (Functor m, Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

37+ . (MonadError MultipleErrors m, MonadWriter MultipleErrors m)

51− ModuleName ->

38+ => ModuleName

52− M.Map (Maybe ModuleName) (M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope)) ->

39+ -> M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope))

53− Constraint ->

40+ -> Constraint

54− m Expr

41+ -> m Expr

55entails moduleName context = solve

42entails moduleName context = solve

56 where

43 where

57− forClassName :: Qualified ProperName -> [Type] -> [TypeClassDictionaryInScope]

44+ forClassName :: Qualified (ProperName 'ClassName) -> [Type] -> [TypeClassDictionaryInScope]

58 forClassName cn@(Qualified (Just mn) _) tys = concatMap (findDicts cn) (Nothing : Just mn : map Just (mapMaybe ctorModules tys))

45 forClassName cn@(Qualified (Just mn) _) tys = concatMap (findDicts cn) (Nothing : Just mn : map Just (mapMaybe ctorModules tys))

59 forClassName _ _ = internalError "forClassName: expected qualified class name"

46 forClassName _ _ = internalError "forClassName: expected qualified class name"

60

47

@@ -64,7 +51,7 @@ entails moduleName context = solve

64 ctorModules (TypeApp ty _) = ctorModules ty

51 ctorModules (TypeApp ty _) = ctorModules ty

65 ctorModules _ = Nothing

52 ctorModules _ = Nothing

66

53

67− findDicts :: Qualified ProperName -> Maybe ModuleName -> [TypeClassDictionaryInScope]

54+ findDicts :: Qualified (ProperName 'ClassName) -> Maybe ModuleName -> [TypeClassDictionaryInScope]

68 findDicts cn = maybe [] M.elems . (>>= M.lookup cn) . flip M.lookup context

55 findDicts cn = maybe [] M.elems . (>>= M.lookup cn) . flip M.lookup context

69

56

70 solve :: Constraint -> m Expr

57 solve :: Constraint -> m Expr

@@ -72,7 +59,7 @@ entails moduleName context = solve

72 dict <- go 0 className tys

59 dict <- go 0 className tys

73 return $ dictionaryValueToValue dict

60 return $ dictionaryValueToValue dict

74 where

61 where

75− go :: Int -> Qualified ProperName -> [Type] -> m DictionaryValue

62+ go :: Int -> Qualified (ProperName 'ClassName) -> [Type] -> m DictionaryValue

76 go work className' tys' | work > 1000 = throwError . errorMessage $ PossiblyInfiniteInstance className' tys'

63 go work className' tys' | work > 1000 = throwError . errorMessage $ PossiblyInfiniteInstance className' tys'

77 go work className' tys' = do

64 go work className' tys' = do

78 let instances = do

65 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−

16{-# LANGUAGE MultiParamTypeClasses #-}

1{-# LANGUAGE MultiParamTypeClasses #-}

17{-# LANGUAGE FlexibleInstances #-}

2{-# LANGUAGE FlexibleInstances #-}

18{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE FlexibleContexts #-}

@@ -20,12 +5,15 @@

20{-# LANGUAGE ScopedTypeVariables #-}

5{-# LANGUAGE ScopedTypeVariables #-}

21{-# LANGUAGE RankNTypes #-}

6{-# LANGUAGE RankNTypes #-}

22

7

8+-- |

9+-- This module implements the kind checker

10+--

23−module Language.PureScript.TypeChecker.Kinds (

11+module Language.PureScript.TypeChecker.Kinds

24− kindOf,

12+ ( kindOf

25− kindOfWithScopedVars,

13+ , kindOfWithScopedVars

26− kindsOf,

14+ , kindsOf

27− kindsOfAll

15+ , kindsOfAll

28−) where

16+ ) where

29

17

30import Prelude ()

18import Prelude ()

31import Prelude.Compat

19import Prelude.Compat

@@ -54,7 +42,11 @@ freshKind = do

54 return $ KUnknown k

42 return $ KUnknown k

55

43

56-- | Update the substitution to solve a kind constraint

44-- | Update the substitution to solve a kind constraint

45+solveKind

57−solveKind :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Int -> Kind -> m ()

46+ :: (MonadError MultipleErrors m, MonadState CheckState m)

47+ => Int

48+ -> Kind

49+ -> m ()

58solveKind u k = do

50solveKind u k = do

59 occursCheck u k

51 occursCheck u k

60 modify $ \cs -> cs { checkSubstitution =

52 modify $ \cs -> cs { checkSubstitution =

@@ -75,7 +67,11 @@ substituteKind sub = everywhereOnKinds go

75 go other = other

67 go other = other

76

68

77-- | Make sure that an unknown does not occur in a kind

69-- | Make sure that an unknown does not occur in a kind

70+occursCheck

78−occursCheck :: (Functor m, Applicative m, MonadError MultipleErrors m) => Int -> Kind -> m ()

71+ :: (MonadError MultipleErrors m)

72+ => Int

73+ -> Kind

74+ -> m ()

79occursCheck _ KUnknown{} = return ()

75occursCheck _ KUnknown{} = return ()

80occursCheck u k = void $ everywhereOnKindsM go k

76occursCheck u k = void $ everywhereOnKindsM go k

81 where

77 where

@@ -83,7 +79,11 @@ occursCheck u k = void $ everywhereOnKindsM go k

83 go other = return other

79 go other = return other

84

80

85-- | Unify two kinds

81-- | Unify two kinds

82+unifyKinds

86−unifyKinds :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Kind -> Kind -> m ()

83+ :: (MonadError MultipleErrors m, MonadState CheckState m)

84+ => Kind

85+ -> Kind

86+ -> m ()

87unifyKinds k1 k2 = do

88 sub <- gets checkSubstitution

89 go (substituteKind sub k1) (substituteKind sub k2)

@@ -100,15 +100,15 @@ unifyKinds k1 k2 = do

100 go k1' k2' = throwError . errorMessage $ KindsDoNotUnify k1' k2'

101

102-- | Infer the kind of a single type

103−kindOf ::

103+kindOf

104− (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m) =>

104+ :: (MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m)

105− Type ->

105+ => Type

106− m Kind

106+ -> m Kind

107kindOf ty = fst <$> kindOfWithScopedVars ty

108

109-- | Infer the kind of a single type, returning the kinds of any scoped type variables

110kindOfWithScopedVars ::

111− (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m) =>

111+ (MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m) =>

112 Type ->

113 m (Kind, [(String, Kind)])

114kindOfWithScopedVars ty =

@@ -120,14 +120,14 @@ kindOfWithScopedVars ty =

120 )

121

122-- | Infer the kind of a type constructor with a collection of arguments and a collection of associated data constructors

123−kindsOf ::

123+kindsOf

124− (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m) =>

124+ :: (MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m)

125− Bool ->

125+ => Bool

126− ModuleName ->

126+ -> ModuleName

127− ProperName ->

127+ -> ProperName 'TypeName

128− [(String, Maybe Kind)] ->

128+ -> [(String, Maybe Kind)]

129− [Type] ->

129+ -> [Type]

130− m Kind

130+ -> m Kind

131kindsOf isData moduleName name args ts = fmap tidyUp . liftUnify $ do

132 tyCon <- freshKind

133 kargs <- replicateM (length args) freshKind

@@ -138,23 +138,23 @@ kindsOf isData moduleName name args ts = fmap tidyUp . liftUnify $ do

138 where

139 tidyUp (k, sub) = starIfUnknown $ substituteKind sub k

140

141−freshKindVar ::

141+freshKindVar

142− (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) =>

142+ :: (MonadError MultipleErrors m, MonadState CheckState m)

143− (String, Maybe Kind) ->

143+ => (String, Maybe Kind)

144− Kind ->

144+ -> Kind

145− m (ProperName, Kind)

145+ -> m (ProperName 'TypeName, Kind)

146freshKindVar (arg, Nothing) kind = return (ProperName arg, kind)

147freshKindVar (arg, Just kind') kind = do

148 unifyKinds kind kind'

149 return (ProperName arg, kind')

150

151-- | Simultaneously infer the kinds of several mutually recursive type constructors

152−kindsOfAll ::

152+kindsOfAll

153− (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m) =>

153+ :: (MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m)

154− ModuleName ->

154+ => ModuleName

155− [(ProperName, [(String, Maybe Kind)], Type)] ->

155+ -> [(ProperName 'TypeName, [(String, Maybe Kind)], Type)]

156− [(ProperName, [(String, Maybe Kind)], [Type])] ->

156+ -> [(ProperName 'TypeName, [(String, Maybe Kind)], [Type])]

157− m ([Kind], [Kind])

157+ -> m ([Kind], [Kind])

158kindsOfAll moduleName syns tys = fmap tidyUp . liftUnify $ do

159 synVars <- replicateM (length syns) freshKind

160 let dict = zipWith (\(name, _, _) var -> (name, var)) syns synVars

@@ -177,7 +177,13 @@ kindsOfAll moduleName syns tys = fmap tidyUp . liftUnify $ do

177 tidyUp ((ks1, ks2), sub) = (map (starIfUnknown . substituteKind sub) ks1, map (starIfUnknown . substituteKind sub) ks2)

178

179-- | Solve the set of kind constraints associated with the data constructors for a type constructor

180+solveTypes

180−solveTypes :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Bool -> [Type] -> [Kind] -> Kind -> m Kind

181+ :: (MonadError MultipleErrors m, MonadState CheckState m)

182+ => Bool

183+ -> [Type]

184+ -> [Kind]

185+ -> Kind

186+ -> m Kind

181solveTypes isData ts kargs tyCon = do

187solveTypes isData ts kargs tyCon = do

182 ks <- traverse (fmap fst . infer) ts

188 ks <- traverse (fmap fst . infer) ts

183 when isData $ do

189 when isData $ do

@@ -195,10 +201,17 @@ starIfUnknown (FunKind k1 k2) = FunKind (starIfUnknown k1) (starIfUnknown k2)

195starIfUnknown k = k

201starIfUnknown k = k

196

202

197-- | Infer a kind for a type

203-- | Infer a kind for a type

204+infer

198−infer :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Type -> m (Kind, [(String, Kind)])

205+ :: (MonadError MultipleErrors m, MonadState CheckState m)

206+ => Type

207+ -> m (Kind, [(String, Kind)])

199infer ty = rethrow (addHint (ErrorCheckingKind ty)) $ infer' ty

208infer ty = rethrow (addHint (ErrorCheckingKind ty)) $ infer' ty

200

209

210+infer'

211+ :: forall m

201−infer' :: forall m. (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Type -> m (Kind, [(String, Kind)])

212+ . (MonadError MultipleErrors m, MonadState CheckState m)

213+ => Type

214+ -> m (Kind, [(String, Kind)])

202infer' (ForAll ident ty _) = do

215infer' (ForAll ident ty _) = do

203 k1 <- freshKind

216 k1 <- freshKind

204 Just moduleName <- checkCurrentModule <$> get

217 Just moduleName <- checkCurrentModule <$> get

@@ -250,7 +263,7 @@ infer' other = (, []) <$> go other

250 return $ Row k1

263 return $ Row k1

251 go (ConstrainedType deps ty) = do

264 go (ConstrainedType deps ty) = do

252 forM_ deps $ \(className, tys) -> do

265 forM_ deps $ \(className, tys) -> do

253− k <- go $ foldl TypeApp (TypeConstructor className) tys

266+ k <- go $ foldl TypeApp (TypeConstructor (fmap coerceProperName className)) tys

254 unifyKinds k Star

267 unifyKinds k Star

255 k <- go ty

268 k <- go ty

256 unifyKinds k Star

269 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−

16{-# LANGUAGE GeneralizedNewtypeDeriving #-}

1{-# LANGUAGE GeneralizedNewtypeDeriving #-}

17{-# LANGUAGE FlexibleInstances #-}

2{-# LANGUAGE FlexibleInstances #-}

18{-# LANGUAGE RankNTypes #-}

3{-# LANGUAGE RankNTypes #-}

@@ -20,6 +5,9 @@

20{-# LANGUAGE FlexibleContexts #-}

5{-# LANGUAGE FlexibleContexts #-}

21{-# LANGUAGE GADTs #-}

6{-# LANGUAGE GADTs #-}

22

7

8+-- |

9+-- Monads for type checking and type inference and associated data types

10+--

23module Language.PureScript.TypeChecker.Monad where

11module Language.PureScript.TypeChecker.Monad where

24

12

25import Prelude ()

13import Prelude ()

@@ -69,7 +57,11 @@ emptyCheckState env = CheckState env 0 0 0 0 Nothing emptySubstitution

69type Unknown = Int

57type Unknown = Int

70

58

71-- | Temporarily bind a collection of names to values

59-- | Temporarily bind a collection of names to values

60+bindNames

61+ :: MonadState CheckState m

72−bindNames :: (MonadState CheckState m) => M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility) -> m a -> m a

62+ => M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility)

63+ -> m a

64+ -> m a

73bindNames newNames action = do

65bindNames newNames action = do

74 orig <- get

66 orig <- get

75 modify $ \st -> st { checkEnv = (checkEnv st) { names = newNames `M.union` (names . checkEnv $ st) } }

67 modify $ \st -> st { checkEnv = (checkEnv st) { names = newNames `M.union` (names . checkEnv $ st) } }

@@ -78,7 +70,11 @@ bindNames newNames action = do

78 return a

70 return a

79

71

80-- | Temporarily bind a collection of names to types

72-- | Temporarily bind a collection of names to types

73+bindTypes

74+ :: MonadState CheckState m

81−bindTypes :: (MonadState CheckState m) => M.Map (Qualified ProperName) (Kind, TypeKind) -> m a -> m a

75+ => M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind)

76+ -> m a

77+ -> m a

82bindTypes newNames action = do

78bindTypes newNames action = do

83 orig <- get

79 orig <- get

84 modify $ \st -> st { checkEnv = (checkEnv st) { types = newNames `M.union` (types . checkEnv $ st) } }

80 modify $ \st -> st { checkEnv = (checkEnv st) { types = newNames `M.union` (types . checkEnv $ st) } }

@@ -87,7 +83,12 @@ bindTypes newNames action = do

87 return a

83 return a

88

84

89-- | Temporarily bind a collection of names to types

85-- | Temporarily bind a collection of names to types

86+withScopedTypeVars

90−withScopedTypeVars :: (Functor m, Applicative m, MonadState CheckState m, MonadWriter MultipleErrors m) => ModuleName -> [(String, Kind)] -> m a -> m a

87+ :: (MonadState CheckState m, MonadWriter MultipleErrors m)

88+ => ModuleName

89+ -> [(String, Kind)]

90+ -> m a

91+ -> m a

91withScopedTypeVars mn ks ma = do

92withScopedTypeVars mn ks ma = do

92 orig <- get

93 orig <- get

93 forM_ ks $ \(name, _) ->

94 forM_ ks $ \(name, _) ->

@@ -96,7 +97,11 @@ withScopedTypeVars mn ks ma = do

96 bindTypes (M.fromList (map (\(name, k) -> (Qualified (Just mn) (ProperName name), (k, ScopedTypeVar))) ks)) ma

97 bindTypes (M.fromList (map (\(name, k) -> (Qualified (Just mn) (ProperName name), (k, ScopedTypeVar))) ks)) ma

97

98

98-- | Temporarily make a collection of type class dictionaries available

99-- | Temporarily make a collection of type class dictionaries available

100+withTypeClassDictionaries

101+ :: MonadState CheckState m

99−withTypeClassDictionaries :: (MonadState CheckState m) => [TypeClassDictionaryInScope] -> m a -> m a

102+ => [TypeClassDictionaryInScope]

103+ -> m a

104+ -> m a

100withTypeClassDictionaries entries action = do

105withTypeClassDictionaries entries action = do

101 orig <- get

106 orig <- get

102 let mentries = M.fromListWith (M.unionWith M.union) [ (mn, M.singleton className (M.singleton (tcdName entry) entry)) | entry@TypeClassDictionaryInScope{ tcdName = Qualified mn _, tcdClassName = className } <- entries ]

107 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

106 return a

111 return a

107

112

108-- | Get the currently available map of type class dictionaries

113-- | Get the currently available map of type class dictionaries

109−getTypeClassDictionaries ::

114+getTypeClassDictionaries

110− (Functor m, MonadState CheckState m) =>

115+ :: (MonadState CheckState m)

111− m (M.Map (Maybe ModuleName) (M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope)))

116+ => m (M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope)))

112getTypeClassDictionaries = typeClassDictionaries . checkEnv <$> get

117getTypeClassDictionaries = typeClassDictionaries . checkEnv <$> get

113

118

114-- | Lookup type class dictionaries in a module.

119-- | Lookup type class dictionaries in a module.

115−lookupTypeClassDictionaries ::

120+lookupTypeClassDictionaries

116− (Functor m, MonadState CheckState m) =>

121+ :: (MonadState CheckState m)

117− Maybe ModuleName ->

122+ => Maybe ModuleName

118− m (M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope))

123+ -> m (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope))

119lookupTypeClassDictionaries mn = fromMaybe M.empty . M.lookup mn . typeClassDictionaries . checkEnv <$> get

124lookupTypeClassDictionaries mn = fromMaybe M.empty . M.lookup mn . typeClassDictionaries . checkEnv <$> get

120

125

121-- | Temporarily bind a collection of names to local variables

126-- | Temporarily bind a collection of names to local variables

127+bindLocalVariables

128+ :: (MonadState CheckState m)

129+ => ModuleName

122−bindLocalVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(Ident, Type, NameVisibility)] -> m a -> m a

130+ -> [(Ident, Type, NameVisibility)]

131+ -> m a

132+ -> m a

123bindLocalVariables moduleName bindings =

133bindLocalVariables moduleName bindings =

124 bindNames (M.fromList $ flip map bindings $ \(name, ty, visibility) -> ((moduleName, name), (ty, Private, visibility)))

134 bindNames (M.fromList $ flip map bindings $ \(name, ty, visibility) -> ((moduleName, name), (ty, Private, visibility)))

125

135

126-- | Temporarily bind a collection of names to local type variables

136-- | 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

128bindLocalTypeVariables moduleName bindings =

143bindLocalTypeVariables moduleName bindings =

129 bindTypes (M.fromList $ flip map bindings $ \(pn, kind) -> (Qualified (Just moduleName) pn, (kind, LocalTypeVariable)))

144 bindTypes (M.fromList $ flip map bindings $ \(pn, kind) -> (Qualified (Just moduleName) pn, (kind, LocalTypeVariable)))

130

145

131-- | Update the visibility of all names to Defined

146-- | Update the visibility of all names to Defined

132−makeBindingGroupVisible :: (Functor m, MonadState CheckState m) => m ()

147+makeBindingGroupVisible :: (MonadState CheckState m) => m ()

133makeBindingGroupVisible = modifyEnv $ \e -> e { names = M.map (\(ty, nk, _) -> (ty, nk, Defined)) (names e) }

148makeBindingGroupVisible = modifyEnv $ \e -> e { names = M.map (\(ty, nk, _) -> (ty, nk, Defined)) (names e) }

134

149

135-- | Update the visibility of all names to Defined in the scope of the provided action

150-- | 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

137withBindingGroupVisible action = preservingNames $ makeBindingGroupVisible >> action

152withBindingGroupVisible action = preservingNames $ makeBindingGroupVisible >> action

138

153

139-- | Perform an action while preserving the names from the @Environment@.

154-- | 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

141preservingNames action = do

156preservingNames action = do

142 orig <- gets (names . checkEnv)

157 orig <- gets (names . checkEnv)

143 a <- action

158 a <- action

@@ -145,7 +160,11 @@ preservingNames action = do

145 return a

160 return a

146

161

147-- | Lookup the type of a value by name in the @Environment@

162-- | Lookup the type of a value by name in the @Environment@

163+lookupVariable

148−lookupVariable :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m Type

164+ :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m)

165+ => ModuleName

166+ -> Qualified Ident

167+ -> m Type

149lookupVariable currentModule (Qualified moduleName var) = do

168lookupVariable currentModule (Qualified moduleName var) = do

150 env <- getEnv

169 env <- getEnv

151 case M.lookup (fromMaybe currentModule moduleName, var) (names env) of

170 case M.lookup (fromMaybe currentModule moduleName, var) (names env) of

@@ -153,7 +172,11 @@ lookupVariable currentModule (Qualified moduleName var) = do

153 Just (ty, _, _) -> return ty

172 Just (ty, _, _) -> return ty

154

173

155-- | Lookup the visibility of a value by name in the @Environment@

174-- | Lookup the visibility of a value by name in the @Environment@

175+getVisibility

156−getVisibility :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m NameVisibility

176+ :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m)

177+ => ModuleName

178+ -> Qualified Ident

179+ -> m NameVisibility

157getVisibility currentModule (Qualified moduleName var) = do

180getVisibility currentModule (Qualified moduleName var) = do

158 env <- getEnv

181 env <- getEnv

159 case M.lookup (fromMaybe currentModule moduleName, var) (names env) of

182 case M.lookup (fromMaybe currentModule moduleName, var) (names env) of

@@ -161,7 +184,11 @@ getVisibility currentModule (Qualified moduleName var) = do

161 Just (_, _, vis) -> return vis

184 Just (_, _, vis) -> return vis

162

185

163-- | Assert that a name is visible

186-- | Assert that a name is visible

187+checkVisibility

164−checkVisibility :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m ()

188+ :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m)

189+ => ModuleName

190+ -> Qualified Ident

191+ -> m ()

165checkVisibility currentModule name@(Qualified _ var) = do

192checkVisibility currentModule name@(Qualified _ var) = do

166 vis <- getVisibility currentModule name

193 vis <- getVisibility currentModule name

167 case vis of

194 case vis of

@@ -169,7 +196,11 @@ checkVisibility currentModule name@(Qualified _ var) = do

169 _ -> return ()

196 _ -> return ()

170

197

171-- | Lookup the kind of a type by name in the @Environment@

198-- | Lookup the kind of a type by name in the @Environment@

199+lookupTypeVariable

172−lookupTypeVariable :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified ProperName -> m Kind

200+ :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m)

201+ => ModuleName

202+ -> Qualified (ProperName 'TypeName)

203+ -> m Kind

173lookupTypeVariable currentModule (Qualified moduleName name) = do

204lookupTypeVariable currentModule (Qualified moduleName name) = do

174 env <- getEnv

205 env <- getEnv

175 case M.lookup (Qualified (Just $ fromMaybe currentModule moduleName) name) (types env) of

206 case M.lookup (Qualified (Just $ fromMaybe currentModule moduleName) name) (types env) of

@@ -177,7 +208,7 @@ lookupTypeVariable currentModule (Qualified moduleName name) = do

177 Just (k, _) -> return k

208 Just (k, _) -> return k

178

209

179-- | Get the current @Environment@

210-- | Get the current @Environment@

180−getEnv :: (Functor m, MonadState CheckState m) => m Environment

211+getEnv :: (MonadState CheckState m) => m Environment

181getEnv = checkEnv <$> get

212getEnv = checkEnv <$> get

182

213

183-- | Update the @Environment@

214-- | Update the @Environment@

@@ -203,14 +234,14 @@ guardWith e False = throwError e

203

234

204-- | Run a computation in the substitution monad, generating a return value and the final substitution.

235-- | Run a computation in the substitution monad, generating a return value and the final substitution.

205liftUnify ::

236liftUnify ::

206− (Functor m, MonadState CheckState m, MonadWriter MultipleErrors m, MonadError MultipleErrors m) =>

237+ (MonadState CheckState m, MonadWriter MultipleErrors m, MonadError MultipleErrors m) =>

207 m a ->

238 m a ->

208 m (a, Substitution)

239 m (a, Substitution)

209liftUnify = liftUnifyWarnings (const id)

240liftUnify = liftUnifyWarnings (const id)

210

241

211-- | Run a computation in the substitution monad, generating a return value, the final substitution and updating warnings values.

242-- | Run a computation in the substitution monad, generating a return value, the final substitution and updating warnings values.

212liftUnifyWarnings ::

243liftUnifyWarnings ::

213− (Functor m, MonadState CheckState m, MonadWriter MultipleErrors m, MonadError MultipleErrors m) =>

244+ (MonadState CheckState m, MonadWriter MultipleErrors m, MonadError MultipleErrors m) =>

214 (Substitution -> ErrorMessage -> ErrorMessage) ->

245 (Substitution -> ErrorMessage -> ErrorMessage) ->

215 m a ->

246 m a ->

216 m (a, Substitution)

247 m (a, Substitution)

src/Language/PureScript/TypeChecker/Rows.hs+1−1

@@ -36,7 +36,7 @@ import Language.PureScript.TypeChecker.Monad

36import Language.PureScript.Types

37

38-- | 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 ()

40checkDuplicateLabels =

41 let (_, f, _) = everywhereOnValuesM def go def

42 in void . f

src/Language/PureScript/TypeChecker/Skolems.hs+1−1

@@ -53,7 +53,7 @@ newSkolemConstant = do

53-- |

54-- Introduce skolem scope at every occurence of a ForAll

55--

56−introduceSkolemScope :: (Functor m, Applicative m, MonadState CheckState m) => Type -> m Type

56+introduceSkolemScope :: (MonadState CheckState m) => Type -> m Type

57introduceSkolemScope = everywhereOnTypesM go

58 where

59 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

39import Language.PureScript.Types

40

41-- | 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)

43subsumes val ty1 ty2 = rethrow (addHint (ErrorInSubsumption ty1 ty2)) $ subsumes' val ty1 ty2

44

45-- | 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) =>

47 Maybe Expr ->

48 Type ->

49 Type ->

src/Language/PureScript/TypeChecker/Synonyms.hs+1−1

@@ -57,7 +57,7 @@ replaceAllTypeSynonyms' env = everywhereOnTypesTopDownM try

57 go c args (TypeApp f arg) = go (c + 1) (arg : args) f

58 go _ _ _ = return Nothing

59

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

61replaceAllTypeSynonyms d = do

62 env <- getEnv

63 either throwError return $ replaceAllTypeSynonyms' env d

src/Language/PureScript/TypeChecker/Types.hs+65−51

@@ -61,7 +61,7 @@ import Language.PureScript.Types

61-- | Infer the types of multiple mutually-recursive values, and return elaborated values including

62-- type class dictionaries and type annotations.

63typesOf ::

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) =>

65 ModuleName ->

66 [(Ident, Expr)] ->

67 m [(Ident, (Expr, Type))]

@@ -93,7 +93,7 @@ type TypeData = M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility)

93type UntypedData = [(Ident, Type)]

94

95typeDictionaryForBindingGroup ::

96− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

96+ (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

97 ModuleName ->

98 [(Ident, Expr)] ->

99 m ([(Ident, Expr)], [(Ident, (Expr, Type, Bool))], TypeData, UntypedData)

@@ -118,7 +118,7 @@ typeDictionaryForBindingGroup moduleName vals = do

118 return (untyped, typed, dict, untypedDict)

119

120checkTypedBindingGroupElement ::

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) =>

122 ModuleName ->

123 (Ident, (Expr, Type, Bool)) ->

124 TypeData ->

@@ -137,7 +137,7 @@ checkTypedBindingGroupElement mn (ident, (val', ty, checkType)) dict = do

137 return (ident, (val'', ty''))

138

139typeForBindingGroupElement ::

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) =>

141 Bool ->

142 (Ident, Expr) ->

143 TypeData ->

@@ -168,7 +168,7 @@ overTypes f = let (_, f', _) = everywhereOnValues id g id in f'

168

169-- | Replace type class dictionary placeholders with inferred type class dictionaries

170replaceTypeClassDictionaries ::

171− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

171+ (MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

172 ModuleName ->

173 Expr ->

174 m Expr

@@ -181,7 +181,7 @@ replaceTypeClassDictionaries mn =

181

182-- | Check the kind of a type, failing if it is not of kind *.

183checkTypeKind ::

184− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m) =>

184+ (MonadState CheckState m, MonadError MultipleErrors m) =>

185 Type ->

186 Kind ->

187 m ()

@@ -193,7 +193,7 @@ checkTypeKind ty kind = guardWith (errorMessage (ExpectedType ty kind)) $ kind =

193-- This is necessary during type checking to avoid unifying a polymorphic type with a

194-- unification variable.

195instantiatePolyTypeWithUnknowns ::

196− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m) =>

196+ (MonadState CheckState m, MonadError MultipleErrors m) =>

197 Expr ->

198 Type ->

199 m (Expr, Type)

@@ -207,32 +207,32 @@ instantiatePolyTypeWithUnknowns val ty = return (val, ty)

207

208-- | Infer a type for a value, rethrowing any error to provide a more useful error message

209infer ::

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) =>

211 Expr ->

212 m Expr

213infer val = rethrow (addHint (ErrorInferringType val)) $ infer' val

214

215-- | Infer a type for a value

216infer' ::

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) =>

218 Expr ->

219 m Expr

220−infer' v@(NumericLiteral (Left _)) = return $ TypedValue True v tyInt

220+infer' v@(Literal (NumericLiteral (Left _))) = return $ TypedValue True v tyInt

221−infer' v@(NumericLiteral (Right _)) = return $ TypedValue True v tyNumber

221+infer' v@(Literal (NumericLiteral (Right _))) = return $ TypedValue True v tyNumber

222−infer' v@(StringLiteral _) = return $ TypedValue True v tyString

222+infer' v@(Literal (StringLiteral _)) = return $ TypedValue True v tyString

223−infer' v@(CharLiteral _) = return $ TypedValue True v tyChar

223+infer' v@(Literal (CharLiteral _)) = return $ TypedValue True v tyChar

224−infer' v@(BooleanLiteral _) = return $ TypedValue True v tyBoolean

224+infer' v@(Literal (BooleanLiteral _)) = return $ TypedValue True v tyBoolean

225−infer' (ArrayLiteral vals) = do

225+infer' (Literal (ArrayLiteral vals)) = do

226 ts <- traverse infer vals

227 els <- freshType

228 forM_ ts $ \(TypedValue _ _ t) -> unifyTypes els t

229− return $ TypedValue True (ArrayLiteral ts) (TypeApp tyArray els)

229+ return $ TypedValue True (Literal (ArrayLiteral ts)) (TypeApp tyArray els)

230−infer' (ObjectLiteral ps) = do

230+infer' (Literal (ObjectLiteral ps)) = do

231 ensureNoDuplicateProperties ps

232 ts <- traverse (infer . snd) ps

233 let fields = zipWith (\name (TypedValue _ _ t) -> (name, t)) (map fst ps) ts

234 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

236infer' (ObjectUpdate o ps) = do

237 ensureNoDuplicateProperties ps

238 row <- freshType

@@ -297,11 +297,13 @@ infer' (TypedValue checkType val ty) = do

297 ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty

298 val' <- if checkType then withScopedTypeVars moduleName args (check val ty') else return val

299 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

301infer' _ = internalError "Invalid argument to infer"

303infer' _ = internalError "Invalid argument to infer"

302

304

303inferLetBinding ::

305inferLetBinding ::

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) =>

305 [Declaration] ->

307 [Declaration] ->

306 [Declaration] ->

308 [Declaration] ->

307 Expr ->

309 Expr ->

@@ -339,16 +341,16 @@ inferLetBinding _ _ _ _ = internalError "Invalid argument to inferLetBinding"

339

341

340-- | Infer the types of variables brought into scope by a binder

342-- | Infer the types of variables brought into scope by a binder

341inferBinder :: forall m.

343inferBinder :: 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) =>

343 Type ->

345 Type ->

344 Binder ->

346 Binder ->

345 m (M.Map Ident Type)

347 m (M.Map Ident Type)

346inferBinder _ NullBinder = return M.empty

348inferBinder _ NullBinder = return M.empty

347−inferBinder val (StringBinder _) = unifyTypes val tyString >> return M.empty

349+inferBinder val (LiteralBinder (StringLiteral _)) = unifyTypes val tyString >> return M.empty

348−inferBinder val (CharBinder _) = unifyTypes val tyChar >> return M.empty

350+inferBinder val (LiteralBinder (CharLiteral _)) = unifyTypes val tyChar >> return M.empty

349−inferBinder val (NumberBinder (Left _)) = unifyTypes val tyInt >> return M.empty

351+inferBinder val (LiteralBinder (NumericLiteral (Left _))) = unifyTypes val tyInt >> return M.empty

350−inferBinder val (NumberBinder (Right _)) = unifyTypes val tyNumber >> return M.empty

352+inferBinder val (LiteralBinder (NumericLiteral (Right _))) = unifyTypes val tyNumber >> return M.empty

351−inferBinder val (BooleanBinder _) = unifyTypes val tyBoolean >> return M.empty

353+inferBinder val (LiteralBinder (BooleanLiteral _)) = unifyTypes val tyBoolean >> return M.empty

352inferBinder val (VarBinder name) = return $ M.singleton name val

354inferBinder val (VarBinder name) = return $ M.singleton name val

353inferBinder val (ConstructorBinder ctor binders) = do

355inferBinder val (ConstructorBinder ctor binders) = do

354 env <- getEnv

356 env <- getEnv

@@ -367,7 +369,7 @@ inferBinder val (ConstructorBinder ctor binders) = do

367 where

369 where

368 go args (TypeApp (TypeApp fn arg) ret) | fn == tyFunction = go (arg : args) ret

370 go args (TypeApp (TypeApp fn arg) ret) | fn == tyFunction = go (arg : args) ret

369 go args ret = (args, ret)

371 go args ret = (args, ret)

370−inferBinder val (ObjectBinder props) = do

372+inferBinder val (LiteralBinder (ObjectLiteral props)) = do

371 row <- freshType

373 row <- freshType

372 rest <- freshType

374 rest <- freshType

373 m1 <- inferRowProperties row rest props

375 m1 <- inferRowProperties row rest props

@@ -381,7 +383,7 @@ inferBinder val (ObjectBinder props) = do

381 m1 <- inferBinder propTy binder

383 m1 <- inferBinder propTy binder

382 m2 <- inferRowProperties nrow (RCons name propTy row) binders

384 m2 <- inferRowProperties nrow (RCons name propTy row) binders

383 return $ m1 `M.union` m2

385 return $ m1 `M.union` m2

384−inferBinder val (ArrayBinder binders) = do

386+inferBinder val (LiteralBinder (ArrayLiteral binders)) = do

385 el <- freshType

387 el <- freshType

386 m1 <- M.unions <$> traverse (inferBinder el) binders

388 m1 <- M.unions <$> traverse (inferBinder el) binders

387 unifyTypes val (TypeApp tyArray el)

389 unifyTypes val (TypeApp tyArray el)

@@ -400,6 +402,12 @@ inferBinder val (TypedBinder ty binder) = do

400 ty1 <- replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty

402 ty1 <- replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty

401 unifyTypes val ty1

403 unifyTypes val ty1

402 inferBinder val binder

404 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"

403

411

404-- | Returns true if a binder requires its argument type to be a monotype.

412-- | Returns true if a binder requires its argument type to be a monotype.

405-- | If this is the case, we need to instantiate any polymorphic types before checking binders.

413-- | If this is the case, we need to instantiate any polymorphic types before checking binders.

@@ -412,7 +420,7 @@ binderRequiresMonotype _ = True

412

420

413-- | Instantiate polytypes only when necessitated by a binder.

421-- | Instantiate polytypes only when necessitated by a binder.

414instantiateForBinders ::

422instantiateForBinders ::

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) =>

416 [Expr] ->

424 [Expr] ->

417 [CaseAlternative] ->

425 [CaseAlternative] ->

418 m ([Expr], [Type])

426 m ([Expr], [Type])

@@ -429,7 +437,7 @@ instantiateForBinders vals cas = unzip <$> zipWithM (\val inst -> do

429-- Check the types of the return values in a set of binders in a case statement

437-- Check the types of the return values in a set of binders in a case statement

430--

438--

431checkBinders ::

439checkBinders ::

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) =>

433 [Type] ->

441 [Type] ->

434 Type ->

442 Type ->

435 [CaseAlternative] ->

443 [CaseAlternative] ->

@@ -459,7 +467,7 @@ checkBinders nvals ret (CaseAlternative binders result : bs) = do

459-- Check the type of a value, rethrowing errors to provide a better error message

467-- Check the type of a value, rethrowing errors to provide a better error message

460--

468--

461check ::

469check ::

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) =>

463 Expr ->

471 Expr ->

464 Type ->

472 Type ->

465 m Expr

473 m Expr

@@ -468,11 +476,12 @@ check val ty = rethrow (addHint (ErrorCheckingType val ty)) $ check' val ty

468-- |

476-- |

469-- Check the type of a value

477-- Check the type of a value

470--

478--

479+check'

471−check' :: forall m.

480+ :: forall m

472− (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

481+ . (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

473− Expr ->

482+ => Expr

474− Type ->

483+ -> Type

475− m Expr

484+ -> m Expr

476check' val (ForAll ident ty _) = do

485check' val (ForAll ident ty _) = do

477 scope <- newSkolemScope

486 scope <- newSkolemScope

478 sko <- newSkolemConstant

487 sko <- newSkolemConstant

@@ -492,7 +501,11 @@ check' val t@(ConstrainedType constraints ty) = do

492 where

501 where

493 -- | Add a dictionary for the constraint to the scope, and dictionaries

502 -- | Add a dictionary for the constraint to the scope, and dictionaries

494 -- for all implied superclass instances.

503 -- for all implied superclass instances.

504+ newDictionaries

505+ :: [(Qualified (ProperName 'ClassName), Integer)]

506+ -> Qualified Ident

507+ -> (Qualified (ProperName 'ClassName), [Type])

495− newDictionaries :: [(Qualified ProperName, Integer)] -> Qualified Ident -> (Qualified ProperName, [Type]) -> m [TypeClassDictionaryInScope]

508+ -> m [TypeClassDictionaryInScope]

496 newDictionaries path name (className, instanceTy) = do

509 newDictionaries path name (className, instanceTy) = do

497 tcs <- gets (typeClasses . checkEnv)

510 tcs <- gets (typeClasses . checkEnv)

498 let (args, _, superclasses) = fromMaybe (internalError "newDictionaries: type class lookup failed") $ M.lookup className tcs

511 let (args, _, superclasses) = fromMaybe (internalError "newDictionaries: type class lookup failed") $ M.lookup className tcs

@@ -511,19 +524,19 @@ check' val u@(TUnknown _) = do

511 (val'', ty') <- instantiatePolyTypeWithUnknowns val' ty

524 (val'', ty') <- instantiatePolyTypeWithUnknowns val' ty

512 unifyTypes ty' u

525 unifyTypes ty' u

513 return $ TypedValue True val'' ty'

526 return $ TypedValue True val'' ty'

514−check' v@(NumericLiteral (Left _)) t | t == tyInt =

527+check' v@(Literal (NumericLiteral (Left _))) t | t == tyInt =

515 return $ TypedValue True v t

528 return $ TypedValue True v t

516−check' v@(NumericLiteral (Right _)) t | t == tyNumber =

529+check' v@(Literal (NumericLiteral (Right _))) t | t == tyNumber =

517 return $ TypedValue True v t

530 return $ TypedValue True v t

518−check' v@(StringLiteral _) t | t == tyString =

531+check' v@(Literal (StringLiteral _)) t | t == tyString =

519 return $ TypedValue True v t

532 return $ TypedValue True v t

520−check' v@(CharLiteral _) t | t == tyChar =

533+check' v@(Literal (CharLiteral _)) t | t == tyChar =

521 return $ TypedValue True v t

534 return $ TypedValue True v t

522−check' v@(BooleanLiteral _) t | t == tyBoolean =

535+check' v@(Literal (BooleanLiteral _)) t | t == tyBoolean =

523 return $ TypedValue True v t

536 return $ TypedValue True v t

524−check' (ArrayLiteral vals) t@(TypeApp a ty) = do

537+check' (Literal (ArrayLiteral vals)) t@(TypeApp a ty) = do

525 unifyTypes a tyArray

538 unifyTypes a tyArray

526− array <- ArrayLiteral <$> forM vals (`check` ty)

539+ array <- Literal . ArrayLiteral <$> forM vals (`check` ty)

527 return $ TypedValue True array t

540 return $ TypedValue True array t

528check' (Abs (Left arg) ret) ty@(TypeApp (TypeApp t argTy) retTy) = do

541check' (Abs (Left arg) ret) ty@(TypeApp (TypeApp t argTy) retTy) = do

529 unifyTypes t tyFunction

542 unifyTypes t tyFunction

@@ -574,10 +587,10 @@ check' (IfThenElse cond th el) ty = do

574 th' <- check th ty

587 th' <- check th ty

575 el' <- check el ty

588 el' <- check el ty

576 return $ TypedValue True (IfThenElse cond' th' el') ty

589 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

578 ensureNoDuplicateProperties ps

591 ensureNoDuplicateProperties ps

579 ps' <- checkProperties e ps row False

592 ps' <- checkProperties e ps row False

580− return $ TypedValue True (ObjectLiteral ps') t

593+ return $ TypedValue True (Literal (ObjectLiteral ps')) t

581check' (TypeClassDictionaryConstructorApp name ps) t = do

594check' (TypeClassDictionaryConstructorApp name ps) t = do

582 ps' <- check' ps t

595 ps' <- check' ps t

583 return $ TypedValue True (TypeClassDictionaryConstructorApp name ps') t

596 return $ TypedValue True (TypeClassDictionaryConstructorApp name ps') t

@@ -612,8 +625,9 @@ check' val kt@(KindedType ty kind) = do

612 checkTypeKind ty kind

625 checkTypeKind ty kind

613 val' <- check' val ty

626 val' <- check' val ty

614 return $ TypedValue True val' kt

627 return $ TypedValue True val' kt

615−check' (PositionedValue pos _ val) ty =

628+check' (PositionedValue pos c val) ty = warnAndRethrowWithPosition pos $ do

616− warnAndRethrowWithPosition pos $ check' val ty

629+ TypedValue t v ty' <- check' val ty

630+ return $ TypedValue t (PositionedValue pos c v) ty'

617check' val ty = do

631check' val ty = do

618 TypedValue _ val' ty' <- infer val

632 TypedValue _ val' ty' <- infer val

619 mt <- subsumes (Just val') ty' ty

633 mt <- subsumes (Just val') ty' ty

@@ -627,7 +641,7 @@ check' val ty = do

627-- The @lax@ parameter controls whether or not every record member has to be provided. For object updates, this is not the case.

641-- The @lax@ parameter controls whether or not every record member has to be provided. For object updates, this is not the case.

628--

642--

629checkProperties ::

643checkProperties ::

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) =>

631 Expr ->

645 Expr ->

632 [(String, Expr)] ->

646 [(String, Expr)] ->

633 Type ->

647 Type ->

@@ -659,7 +673,7 @@ checkProperties expr ps row lax = let (ts, r') = rowToList row in go ps ts r' wh

659

673

660-- | Check the type of a function application, rethrowing errors to provide a better error message

674-- | Check the type of a function application, rethrowing errors to provide a better error message

661checkFunctionApplication ::

675checkFunctionApplication ::

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) =>

663 Expr ->

677 Expr ->

664 Type ->

678 Type ->

665 Expr ->

679 Expr ->

@@ -671,7 +685,7 @@ checkFunctionApplication fn fnTy arg ret = rethrow (addHint (ErrorInApplication

671

685

672-- | Check the type of a function application

686-- | Check the type of a function application

673checkFunctionApplication' ::

687checkFunctionApplication' ::

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) =>

675 Expr ->

689 Expr ->

676 Type ->

690 Type ->

677 Expr ->

691 Expr ->

src/Language/PureScript/TypeChecker/Unify.hs+5−5

@@ -56,7 +56,7 @@ freshType = do

56 return $ TUnknown t

57

58-- | 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 ()

60solveType u t = do

61 occursCheck u t

62 modify $ \cs -> cs { checkSubstitution =

@@ -77,7 +77,7 @@ substituteType sub = everywhereOnTypes go

77 go other = other

78

79-- | 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 ()

81occursCheck _ TUnknown{} = return ()

82occursCheck u t = void $ everywhereOnTypesM go t

83 where

@@ -93,7 +93,7 @@ unknownsInType t = everythingOnTypes (.) go t []

93 go _ = id

94

95-- | 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 ()

97unifyTypes t1 t2 = do

98 sub <- gets checkSubstitution

99 rethrow (addHint (ErrorUnifyingTypes t1 t2)) $ unifyTypes' (substituteType sub t1) (substituteType sub t2)

@@ -139,7 +139,7 @@ unifyTypes t1 t2 = do

139-- trailing row unification variable, if appropriate, otherwise leftover labels result in a unification

140-- error.

141--

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 ()

143unifyRows r1 r2 =

144 let

145 (s1, r1') = rowToList r1

@@ -205,7 +205,7 @@ replaceVarWithUnknown ident ty = do

205-- |

206-- Replace type wildcards with unknowns

207--

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

209replaceTypeWildcards = everywhereOnTypesM replace

210 where

211 replace TypeWildcard = do

src/Language/PureScript/TypeClassDictionaries.hs+5−22

@@ -1,23 +1,5 @@

1−-----------------------------------------------------------------------------

2−--

3−-- Module : Language.PureScript.TypeClassDictionaries

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−

17module Language.PureScript.TypeClassDictionaries where

1module Language.PureScript.TypeClassDictionaries where

18

2

19−import Data.Data

20−

21import Language.PureScript.Names

3import Language.PureScript.Names

22import Language.PureScript.Types

4import Language.PureScript.Types

23

5

@@ -29,14 +11,15 @@ data TypeClassDictionaryInScope

29 -- | The identifier with which the dictionary can be accessed at runtime

11 -- | The identifier with which the dictionary can be accessed at runtime

30 tcdName :: Qualified Ident

12 tcdName :: Qualified Ident

31 -- | How to obtain this instance via superclass relationships

13 -- | How to obtain this instance via superclass relationships

32− , tcdPath :: [(Qualified ProperName, Integer)]

14+ , tcdPath :: [(Qualified (ProperName 'ClassName), Integer)]

33 -- | The name of the type class to which this type class instance applies

15 -- | The name of the type class to which this type class instance applies

34− , tcdClassName :: Qualified ProperName

16+ , tcdClassName :: Qualified (ProperName 'ClassName)

35 -- | The types to which this type class instance applies

17 -- | The types to which this type class instance applies

36 , tcdInstanceTypes :: [Type]

18 , tcdInstanceTypes :: [Type]

37 -- | Type class dependencies which must be satisfied to construct this dictionary

19 -- | Type class dependencies which must be satisfied to construct this dictionary

38 , tcdDependencies :: Maybe [Constraint]

20 , tcdDependencies :: Maybe [Constraint]

21+ }

39− } deriving (Show, Read, Data, Typeable)

22+ deriving (Show, Read)

40

23

41-- |

24-- |

42-- A simplified representation of expressions which are used to represent type

25-- A simplified representation of expressions which are used to represent type

@@ -58,5 +41,5 @@ data DictionaryValue

58 -- |

41 -- |

59 -- A subclass dictionary

42 -- A subclass dictionary

60 --

43 --

61− | SubclassDictionaryValue DictionaryValue (Qualified ProperName) Integer

44+ | SubclassDictionaryValue DictionaryValue (Qualified (ProperName 'ClassName)) Integer

62 deriving (Show, Read, Ord, Eq)

45 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 #-}

17{-# LANGUAGE GeneralizedNewtypeDeriving #-}

1{-# LANGUAGE GeneralizedNewtypeDeriving #-}

18{-# LANGUAGE TemplateHaskell #-}

2{-# LANGUAGE TemplateHaskell #-}

19

3

4+-- |

5+-- Data types for types

6+--

20module Language.PureScript.Types where

7module Language.PureScript.Types where

21

8

22import Prelude ()

9import Prelude ()

23import Prelude.Compat

10import Prelude.Compat

24

11

25−import Data.Data

26import Data.List (nub)

12import Data.List (nub)

27import Data.Maybe (fromMaybe)

13import Data.Maybe (fromMaybe)

28import qualified Data.Aeson as A

14import qualified Data.Aeson as A

@@ -39,7 +25,8 @@ import Language.PureScript.AST.SourcePos

39-- |

25-- |

40-- An identifier for the scope of a skolem variable

26-- An identifier for the scope of a skolem variable

41--

27--

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)

43

30

44-- |

31-- |

45-- The type of types

32-- The type of types

@@ -60,7 +47,7 @@ data Type

60 -- |

47 -- |

61 -- A type constructor

48 -- A type constructor

62 --

49 --

63− | TypeConstructor (Qualified ProperName)

50+ | TypeConstructor (Qualified (ProperName 'TypeName))

64 -- |

51 -- |

65 -- A type application

52 -- A type application

66 --

53 --

@@ -101,12 +88,13 @@ data Type

101 -- |

88 -- |

102 -- A placeholder used in pretty printing

89 -- A placeholder used in pretty printing

103 --

90 --

104− | PrettyPrintForAll [String] Type deriving (Show, Read,Eq, Ord, Data, Typeable)

91+ | PrettyPrintForAll [String] Type

92+ deriving (Show, Read, Eq, Ord)

105

93

106-- |

94-- |

107-- A typeclass constraint

95-- A typeclass constraint

108--

96--

109−type Constraint = (Qualified ProperName, [Type])

97+type Constraint = (Qualified (ProperName 'ClassName), [Type])

110

98

111$(A.deriveJSON A.defaultOptions ''Type)

99$(A.deriveJSON A.defaultOptions ''Type)

112

100

@@ -260,7 +248,7 @@ everywhereOnTypesTopDown f = go . f

260 go (PrettyPrintForAll args t) = PrettyPrintForAll args (go (f t))

248 go (PrettyPrintForAll args t) = PrettyPrintForAll args (go (f t))

261 go other = f other

249 go other = f other

262

250

263−everywhereOnTypesM :: (Functor m, Applicative m, Monad m) => (Type -> m Type) -> Type -> m Type

251+everywhereOnTypesM :: Monad m => (Type -> m Type) -> Type -> m Type

264everywhereOnTypesM f = go

252everywhereOnTypesM f = go

265 where

253 where

266 go (TypeApp t1 t2) = (TypeApp <$> go t1 <*> go t2) >>= f

254 go (TypeApp t1 t2) = (TypeApp <$> go t1 <*> go t2) >>= f

@@ -273,7 +261,7 @@ everywhereOnTypesM f = go

273 go (PrettyPrintForAll args t) = (PrettyPrintForAll args <$> go t) >>= f

261 go (PrettyPrintForAll args t) = (PrettyPrintForAll args <$> go t) >>= f

274 go other = f other

262 go other = f other

275

263

276−everywhereOnTypesTopDownM :: (Functor m, Applicative m, Monad m) => (Type -> m Type) -> Type -> m Type

264+everywhereOnTypesTopDownM :: Monad m => (Type -> m Type) -> Type -> m Type

277everywhereOnTypesTopDownM f = go <=< f

265everywhereOnTypesTopDownM f = go <=< f

278 where

266 where

279 go (TypeApp t1 t2) = TypeApp <$> (f t1 >>= go) <*> (f t2 >>= go)

267 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 @@

1flags: {}

2packages:

3- '.'

4−extra-deps:

4+extra-deps: []

5−resolver: nightly-2015-09-29

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 @@

16{-# LANGUAGE TupleSections #-}

17{-# LANGUAGE FlexibleInstances #-}

18

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−

34module Main (main) where

19module Main (main) where

35

20

36import Prelude ()

21import Prelude ()

37import Prelude.Compat

22import Prelude.Compat

38

23

39−import qualified Language.PureScript as P

24+import qualified TestCompiler

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

25+import qualified TestPscPublish

72−

26+import qualified TestDocs

73−modulesDir :: FilePath

27+import qualified TestPsci

74−modulesDir = ".test_modules" </> "node_modules"

28+import qualified TestPscIde

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

172

29

173main :: IO ()

30main :: IO ()

174main = do

31main = do

175− testCompiler

32+ heading "Main compiler test suite"

176− testPscPublish

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

177

42

178−testCompiler :: IO ()

43+ where

179−testCompiler = do

44+ heading msg = do

180− fetchSupportCode

45+ putStrLn ""

181− cwd <- getCurrentDirectory

46+ putStrLn $ replicate 79 '#'

182−

47+ putStrLn $ "# " ++ msg

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:"

48+ putStrLn $ replicate 79 '#'

207− forM_ failures $ \(fp, err) ->

208− let fp' = fromMaybe fp $ stripPrefix (failing ++ [pathSeparator]) fp

209− in putStrLn $ fp' ++ ": " ++ err

49+ putStrLn ""

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− ]

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

20import Language.PureScript.Docs

21import Language.PureScript.Publish

22

23−pushd :: forall a. FilePath -> IO a -> IO a

23+import TestUtils

24−pushd dir act = do

24+

25− original <- getCurrentDirectory

25+main :: IO ()

26− setCurrentDirectory dir

26+main = do

27− result <- try act :: IO (Either IOException a)

27+ testPackage "tests/support/prelude"

28− setCurrentDirectory original

29− either throwIO return result

30

28

31data TestResult

29data TestResult

32 = ParseFailed String

30 = ParseFailed String

@@ -48,6 +46,7 @@ roundTrip pkg =

48testRunOptions :: PublishOptions

46testRunOptions :: PublishOptions

49testRunOptions = defaultPublishOptions

47testRunOptions = defaultPublishOptions

50 { publishGetVersion = return testVersion

48 { publishGetVersion = return testVersion

49+ , publishWorkingTreeDirty = return ()

51 }

50 }

52 where testVersion = ("v999.0.0", Version [999,0,0] [])

51 where testVersion = ("v999.0.0", Version [999,0,0] [])

53

52

@@ -58,8 +57,10 @@ testPackage dir = do

58 pushd dir $ do

57 pushd dir $ do

59 r <- roundTrip <$> preparePackage testRunOptions

58 r <- roundTrip <$> preparePackage testRunOptions

60 case r of

59 case r of

61− Pass _ -> pure ()

60+ Pass _ -> do

61+ putStrLn ("psc-publish test passed for: " ++ dir)

62+ pure ()

62 other -> do

63 other -> do

63− hPutStrLn stderr ("psc-publish tests failed on " ++ dir ++ ":")

64+ putStrLn ("psc-publish tests failed on " ++ dir ++ ":")

64− hPutStrLn stderr (show other)

65+ putStrLn (show other)

65− exitFailure

66+ exitFailure

psci/tests/Main.hs → tests/TestPsci.hsrenamed+8−11

@@ -1,7 +1,7 @@

1{-# LANGUAGE RecordWildCards #-}

2{-# LANGUAGE TupleSections #-}

3

4−module Main where

4+module TestPsci where

5

6import Prelude ()

7import Prelude.Compat

@@ -23,15 +23,12 @@ import Test.HUnit

23

24import qualified Language.PureScript as P

25

26−import PSCi

26+import PSCi.Module (loadAllModules)

27−import Completion

27+import PSCi.Completion

28−import Types

28+import PSCi.Types

29−

30−import TestsSetup

31

29

32main :: IO ()

30main :: IO ()

33main = do

31main = do

34− fetchSupportCode

35 Counts{..} <- runTestTT allTests

32 Counts{..} <- runTestTT allTests

36 when (errors + failures > 0) exitFailure

33 when (errors + failures > 0) exitFailure

37

34

@@ -65,8 +62,8 @@ completionTestData =

65 , ("import qualified Control.Monad.Eff.", map ("import qualified Control.Monad.Eff" ++) [".Unsafe", ".Class", ".Console"])

62 , ("import qualified Control.Monad.Eff.", map ("import qualified Control.Monad.Eff" ++) [".Unsafe", ".Class", ".Console"])

66

63

67 -- :load, :module should complete file paths

64 -- :load, :module should complete file paths

68− , (":l psci/tests/data/", [":l psci/tests/data/Sample.purs"])

65+ , (":l tests/support/psci/", [":l tests/support/psci/Sample.purs"])

69− , (":module psci/tests/data/", [":module psci/tests/data/Sample.purs"])

66+ , (":module tests/support/psci/", [":module tests/support/psci/Sample.purs"])

70

67

71 -- :quit, :help, :reset should not complete

68 -- :quit, :help, :reset should not complete

72 , (":help ", [])

69 , (":help ", [])

@@ -141,11 +138,11 @@ getPSCiState = do

141 Left err ->

138 Left err ->

142 print err >> exitFailure

139 print err >> exitFailure

143 Right modules ->

140 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)]

145 in return (mkPSCiState imports modules foreigns [] [])

142 in return (mkPSCiState imports modules foreigns [] [])

146

143

147controlMonadSTasST :: ImportedModule

144controlMonadSTasST :: ImportedModule

148−controlMonadSTasST = (s "Control.Monad.ST", P.Implicit True, Just (s "ST"))

145+controlMonadSTasST = (s "Control.Monad.ST", P.Implicit, Just (s "ST"))

149 where

146 where

150 s = P.moduleNameFromString

147 s = P.moduleNameFromString

151

148

tests/common/TestsSetup.hs → tests/TestUtils.hsrenamed+23−3

@@ -10,7 +10,9 @@

10-- |

11--

12-----------------------------------------------------------------------------

13+{-# LANGUAGE ScopedTypeVariables #-}

14+

13−module TestsSetup where

15+module TestUtils where

14

16

15import Prelude ()

17import Prelude ()

16import Prelude.Compat

18import Prelude.Compat

@@ -18,6 +20,7 @@ import Prelude.Compat

18import Data.Maybe (fromMaybe)

20import Data.Maybe (fromMaybe)

19import Control.Monad

21import Control.Monad

20import Control.Monad.Trans.Maybe

22import Control.Monad.Trans.Maybe

23+import Control.Exception

21

24

22import System.Process

25import System.Process

23import System.Directory

26import System.Directory

@@ -30,8 +33,16 @@ findNodeProcess = runMaybeT . msum $ map (MaybeT . findExecutable) names

30 where

33 where

31 names = ["nodejs", "node"]

34 names = ["nodejs", "node"]

32

35

33−fetchSupportCode :: IO ()

36+-- |

34−fetchSupportCode = do

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

35 node <- fromMaybe (internalError "cannot find node executable") <$> findNodeProcess

46 node <- fromMaybe (internalError "cannot find node executable") <$> findNodeProcess

36 setCurrentDirectory "tests/support"

47 setCurrentDirectory "tests/support"

37 if System.Info.os == "mingw32"

48 if System.Info.os == "mingw32"

@@ -43,3 +54,12 @@ fetchSupportCode = do

43 callProcess "node_modules/.bin/bower" ["--allow-root", "install", "--config.interactive=false"]

54 callProcess "node_modules/.bin/bower" ["--allow-root", "install", "--config.interactive=false"]

44 callProcess node ["setup.js"]

55 callProcess node ["setup.js"]

45 setCurrentDirectory "../.."

56 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.