ccf33d6 · rowtype-yoga/purescript-native

.gitignore+2

compare with golang

unifiedsplit

@@ -16,3 +16,5 @@ tmp/

16.stack-work/

17tests/support/flattened/

18output

19+examples/docs/docs/

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

.travis.yml+2

@@ -57,6 +57,8 @@ install:

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

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

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

61+ - npm install -g bower

60script:

62script:

61 - ./travis/configure.sh

63 - ./travis/configure.sh

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

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

CONTRIBUTORS.md+5

@@ -12,6 +12,7 @@ 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).

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

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

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

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

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

@@ -50,6 +51,7 @@ 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).

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

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

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

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

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

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

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

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

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

@@ -60,6 +62,9 @@ This file lists the contributors to the PureScript compiler project, and the ter

60<http://opensource.org/licenses/MIT>.

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

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

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

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

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

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

63

68

64### Companies

69### Companies

65

70

INSTALL.md+1−1

@@ -27,7 +27,7 @@ GHC 7.6.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 lts purescript

31```

32

33This will then copy the compiler and utilities into `~/.local/bin`.

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/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/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/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-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.parseAndDesugar input []

72− case e of

73+ >>= ((\(ms, _, env) -> D.convertModulesInPackage env ms)))

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 (map P.runModuleName 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 (map (first P.runModuleName) 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 \"" ++ 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 (" * " ++ 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/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+3−3

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

psci/Completion.hs+6−4

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

1+{-# LANGUAGE DataKinds #-}

2+

1module Completion where

3module Completion where

2

4

3import Prelude ()

5import Prelude ()

@@ -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/PSCi.hs+37−14

@@ -2,6 +2,7 @@

2{-# LANGUAGE GeneralizedNewtypeDeriving #-}

3{-# LANGUAGE RecordWildCards #-}

4{-# LANGUAGE TupleSections #-}

5+{-# LANGUAGE DataKinds #-}

5

6

6-- |

7-- |

7-- PureScript Compiler Interactive.

8-- PureScript Compiler Interactive.

@@ -13,7 +14,7 @@ import Prelude.Compat

13

14

14import Data.Foldable (traverse_)

15import Data.Foldable (traverse_)

15import Data.Maybe (mapMaybe)

16import Data.Maybe (mapMaybe)

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

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

17import Data.Tuple (swap)

18import Data.Tuple (swap)

18import Data.Version (showVersion)

19import Data.Version (showVersion)

19import qualified Data.Map as M

20import qualified Data.Map as M

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

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

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

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

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

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

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

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

330+ showRef (P.ProperRef pn) = pn

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

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

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

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

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

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

@@ -391,10 +392,15 @@ printModuleSignatures moduleName (P.Environment {..}) =

391 showNameType (mIdent, Just (mType, _, _)) = Box.text (P.showIdent mIdent ++ " :: ") Box.<> P.typeAsBox mType

392 showNameType (mIdent, Just (mType, _, _)) = Box.text (P.showIdent mIdent ++ " :: ") Box.<> P.typeAsBox mType

392 showNameType _ = P.internalError "The impossible happened in printModuleSignatures."

393 showNameType _ = P.internalError "The impossible happened in printModuleSignatures."

393

394

395+ findTypeClass

396+ :: M.Map (P.Qualified (P.ProperName 'P.ClassName)) ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint])

397+ -> P.Qualified (P.ProperName 'P.ClassName)

394− 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]))

398+ -> (P.Qualified (P.ProperName 'P.ClassName), Maybe ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint]))

395 findTypeClass envTypeClasses name = (name, M.lookup name envTypeClasses)

399 findTypeClass envTypeClasses name = (name, M.lookup name envTypeClasses)

396

400

401+ showTypeClass

397− showTypeClass :: (P.Qualified P.ProperName, Maybe ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint])) -> Maybe Box.Box

402+ :: (P.Qualified (P.ProperName 'P.ClassName), Maybe ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint]))

403+ -> Maybe Box.Box

398 showTypeClass (_, Nothing) = Nothing

404 showTypeClass (_, Nothing) = Nothing

399 showTypeClass (P.Qualified _ name, Just (vars, body, constrs)) =

405 showTypeClass (P.Qualified _ name, Just (vars, body, constrs)) =

400 let constraints =

406 let constraints =

@@ -418,18 +424,22 @@ printModuleSignatures moduleName (P.Environment {..}) =

418 Box.// Box.moveRight 2 classBody

424 Box.// Box.moveRight 2 classBody

419

425

420

426

427+ findType

421− findType :: M.Map (P.Qualified P.ProperName) (P.Kind, P.TypeKind) -> P.Qualified P.ProperName -> (P.Qualified P.ProperName, Maybe (P.Kind, P.TypeKind))

428+ :: M.Map (P.Qualified (P.ProperName 'P.TypeName)) (P.Kind, P.TypeKind)

429+ -> P.Qualified (P.ProperName 'P.TypeName)

430+ -> (P.Qualified (P.ProperName 'P.TypeName), Maybe (P.Kind, P.TypeKind))

422 findType envTypes name = (name, M.lookup name envTypes)

431 findType envTypes name = (name, M.lookup name envTypes)

423

432

433+ showType

424− showType :: M.Map (P.Qualified P.ProperName) ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint])

434+ :: M.Map (P.Qualified (P.ProperName 'P.ClassName)) ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint])

425− -> M.Map (P.Qualified P.ProperName) (P.DataDeclType, P.ProperName, P.Type, [P.Ident])

435+ -> M.Map (P.Qualified (P.ProperName 'P.ConstructorName)) (P.DataDeclType, P.ProperName 'P.TypeName, P.Type, [P.Ident])

426− -> M.Map (P.Qualified P.ProperName) ([(String, Maybe P.Kind)], P.Type)

436+ -> M.Map (P.Qualified (P.ProperName 'P.TypeName)) ([(String, Maybe P.Kind)], P.Type)

427− -> (P.Qualified P.ProperName, Maybe (P.Kind, P.TypeKind))

437+ -> (P.Qualified (P.ProperName 'P.TypeName), Maybe (P.Kind, P.TypeKind))

428− -> Maybe Box.Box

438+ -> Maybe Box.Box

429 showType typeClassesEnv dataConstructorsEnv typeSynonymsEnv (n@(P.Qualified modul name), typ) =

439 showType typeClassesEnv dataConstructorsEnv typeSynonymsEnv (n@(P.Qualified modul name), typ) =

430 case (typ, M.lookup n typeSynonymsEnv) of

440 case (typ, M.lookup n typeSynonymsEnv) of

431 (Just (_, P.TypeSynonym), Just (typevars, dtType)) ->

441 (Just (_, P.TypeSynonym), Just (typevars, dtType)) ->

432− if M.member n typeClassesEnv

442+ if M.member (fmap P.coerceProperName n) typeClassesEnv

433 then

443 then

434 Nothing

444 Nothing

435 else

445 else

@@ -476,9 +486,22 @@ handleBrowse moduleName = do

476 case env of

486 case env of

477 Left errs -> printErrors errs

487 Left errs -> printErrors errs

478 Right env' ->

488 Right env' ->

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

489+ if isModInEnv moduleName st

490+ then printModuleSignatures moduleName env'

491+ else case lookupUnQualifiedModName moduleName st of

492+ Just unQualifiedName ->

493+ if isModInEnv unQualifiedName st

494+ then printModuleSignatures unQualifiedName env'

495+ else failNotInEnv moduleName

496+ Nothing ->

497+ failNotInEnv moduleName

498+ where

499+ isModInEnv modName =

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

501+ failNotInEnv modName =

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

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

481− else printModuleSignatures moduleName env'

503+ lookupUnQualifiedModName quaModName st =

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

482

505

483-- | Pretty-print errors

506-- | Pretty-print errors

484printErrors :: P.MultipleErrors -> PSCI ()

507printErrors :: P.MultipleErrors -> PSCI ()

psci/Types.hs+2−2

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

51 -> [P.Declaration]

52 -> [String]

53 -> PSCiState

54−mkPSCiState imported loaded foreign lets nodeFlags =

54+mkPSCiState imported loaded foreigns lets nodeFlags =

55 (initialPSCiState

56 |> each imported updateImportedModules

57 |> updateModules loaded)

58− { psciForeignFiles = foreign

58+ { psciForeignFiles = foreigns

59 , psciLetBindings = lets

60 , psciNodeFlags = nodeFlags

61 }

purescript.cabal+10−1

@@ -20,6 +20,9 @@ tested-with: GHC==7.8

20

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

22 , examples/failing/*.purs

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

24+ , examples/docs/bower.json

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

23 , tests/support/setup.js

26 , tests/support/setup.js

24 , tests/support/package.json

27 , tests/support/package.json

25 , tests/support/bower.json

28 , tests/support/bower.json

@@ -175,6 +178,8 @@ library

175

178

176 Language.PureScript.Docs

179 Language.PureScript.Docs

177 Language.PureScript.Docs.Convert

180 Language.PureScript.Docs.Convert

181+ Language.PureScript.Docs.Convert.Single

182+ Language.PureScript.Docs.Convert.ReExports

178 Language.PureScript.Docs.Render

183 Language.PureScript.Docs.Render

179 Language.PureScript.Docs.Types

184 Language.PureScript.Docs.Types

180 Language.PureScript.Docs.RenderedCode

185 Language.PureScript.Docs.RenderedCode

@@ -194,6 +199,8 @@ library

194 Control.Monad.Supply.Class

199 Control.Monad.Supply.Class

195

200

196 System.IO.UTF8

201 System.IO.UTF8

202+

203+ extensions: DataKinds

197 exposed: True

204 exposed: True

198 buildable: True

205 buildable: True

199 hs-source-dirs: src

206 hs-source-dirs: src

@@ -234,7 +241,8 @@ executable psc-docs

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

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

235 optparse-applicative >= 0.10.0, process -any, mtl -any,

242 optparse-applicative >= 0.10.0, process -any, mtl -any,

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

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

237− filepath -any, Glob -any

244+ filepath -any, Glob -any, transformers -any,

245+ transformers-compat -any

238 main-is: Main.hs

246 main-is: Main.hs

239 buildable: True

247 buildable: True

240 hs-source-dirs: psc-docs

248 hs-source-dirs: psc-docs

@@ -298,6 +306,7 @@ test-suite tests

298 main-is: Main.hs

306 main-is: Main.hs

299 other-modules: TestsSetup

307 other-modules: TestsSetup

300 TestPscPublish

308 TestPscPublish

309+ TestDocs

301 buildable: True

310 buildable: True

302 hs-source-dirs: tests tests/common

311 hs-source-dirs: tests tests/common

303

312

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/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/Binders.hs+5−19

@@ -1,23 +1,8 @@

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

22import Language.PureScript.Names

7import Language.PureScript.Names

23import Language.PureScript.Comments

8import Language.PureScript.Comments

@@ -54,7 +39,7 @@ data Binder

54 -- |

39 -- |

55 -- A binder which matches a data constructor

40 -- A binder which matches a data constructor

56 --

41 --

57− | ConstructorBinder (Qualified ProperName) [Binder]

42+ | ConstructorBinder (Qualified (ProperName 'ConstructorName)) [Binder]

58 -- |

43 -- |

59 -- A binder which matches a record and binds its properties

44 -- A binder which matches a record and binds its properties

60 --

45 --

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

74 -- |

59 -- |

75 -- A binder with a type annotation

60 -- A binder with a type annotation

76 --

61 --

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

62+ | TypedBinder Type Binder

63+ deriving (Show, Read, Eq)

78

64

79-- |

65-- |

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

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

src/Language/PureScript/AST/Declarations.hs+30−25

@@ -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,7 +14,6 @@ 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

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

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

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

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

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

37--

35--

38−data Module = Module SourceSpan [Comment] ModuleName [Declaration] (Maybe [DeclarationRef]) deriving (Show, Read, D.Data, D.Typeable)

36+data Module = Module SourceSpan [Comment] ModuleName [Declaration] (Maybe [DeclarationRef])

37+ deriving (Show, Read)

39

38

40-- | Return a module's name.

39-- | Return a module's name.

41getModuleName :: Module -> ModuleName

40getModuleName :: Module -> ModuleName

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

60 -- |

59 -- |

61 -- A type constructor with data constructors

60 -- A type constructor with data constructors

62 --

61 --

63− = TypeRef ProperName (Maybe [ProperName])

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

64 -- |

63 -- |

65 -- A value

64 -- A value

66 --

65 --

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

68 -- |

67 -- |

69 -- A type class

68 -- A type class

70 --

69 --

71− | TypeClassRef ProperName

70+ | TypeClassRef (ProperName 'ClassName)

72 -- |

71 -- |

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

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

74 --

73 --

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

80 -- |

79 -- |

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

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

82 -- or TypeRef during name desugaring.

81 -- or TypeRef during name desugaring.

83− | ProperRef ProperName

82+ | ProperRef String

84 -- |

83 -- |

85 -- A declaration reference with source position information

84 -- A declaration reference with source position information

86 --

85 --

87 | PositionedDeclarationRef SourceSpan [Comment] DeclarationRef

86 | PositionedDeclarationRef SourceSpan [Comment] DeclarationRef

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

87+ deriving (Show, Read)

89

88

90instance Eq DeclarationRef where

89instance Eq DeclarationRef where

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

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

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

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

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

109-- list of duplicate data constructors.

108-- list of duplicate data constructors.

110--

109--

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

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

112findDuplicateRefs refs =

111findDuplicateRefs refs =

113 let positionless = stripPosInfo `map` refs

112 let positionless = stripPosInfo `map` refs

114 simplified = simplifyTypeRefs `map` positionless

113 simplified = simplifyTypeRefs `map` positionless

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

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

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

142 --

141 --

143 | Hiding [DeclarationRef]

142 | Hiding [DeclarationRef]

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

143+ deriving (Eq, Show, Read)

145

144

146isImplicit :: ImportDeclarationType -> Bool

145isImplicit :: ImportDeclarationType -> Bool

147isImplicit Implicit = True

146isImplicit Implicit = True

148isImplicit _ = False

147isImplicit _ = False

149

148

149+isExplicit :: ImportDeclarationType -> Bool

150+isExplicit (Explicit _) = True

151+isExplicit _ = False

152+

150-- |

153-- |

151-- The data type of declarations

154-- The data type of declarations

152--

155--

@@ -154,7 +157,7 @@ data Declaration

154 -- |

157 -- |

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

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

156 --

159 --

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

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

158 -- |

161 -- |

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

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

160 --

163 --

@@ -162,7 +165,7 @@ data Declaration

162 -- |

165 -- |

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

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

164 --

167 --

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

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

166 -- |

169 -- |

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

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

168 --

171 --

@@ -182,11 +185,11 @@ data Declaration

182 -- |

185 -- |

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

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

184 --

187 --

185− | ExternDataDeclaration ProperName Kind

188+ | ExternDataDeclaration (ProperName 'TypeName) Kind

186 -- |

189 -- |

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

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

188 --

191 --

189− | FixityDeclaration Fixity String (Maybe Ident)

192+ | FixityDeclaration Fixity String (Maybe (Qualified Ident))

190 -- |

193 -- |

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

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

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

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

@@ -195,17 +198,17 @@ data Declaration

195 -- |

198 -- |

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

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

197 --

200 --

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

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

199 -- |

202 -- |

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

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

201 -- declarations)

204 -- declarations)

202 --

205 --

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

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

204 -- |

207 -- |

205 -- A declaration with source position information

208 -- A declaration with source position information

206 --

209 --

207 | PositionedDeclaration SourceSpan [Comment] Declaration

210 | PositionedDeclaration SourceSpan [Comment] Declaration

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

211+ deriving (Show, Read)

209

212

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

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

211data TypeInstanceBody

214data TypeInstanceBody

@@ -213,7 +216,7 @@ data TypeInstanceBody

213 = DerivedInstance

216 = DerivedInstance

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

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

215 | ExplicitInstance [Declaration]

218 | ExplicitInstance [Declaration]

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

219+ deriving (Show, Read)

217

220

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

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

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

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

@@ -390,7 +393,7 @@ data Expr

390 -- |

393 -- |

391 -- A data constructor

394 -- A data constructor

392 --

395 --

393− | Constructor (Qualified ProperName)

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

394 -- |

397 -- |

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

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

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

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

@@ -412,7 +415,7 @@ data Expr

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

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

413 -- an ObjectLiteral.

416 -- an ObjectLiteral.

414 --

417 --

415− | TypeClassDictionaryConstructorApp (Qualified ProperName) Expr

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

416 -- |

419 -- |

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

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

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

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

@@ -420,19 +423,20 @@ data Expr

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

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

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

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

422 --

425 --

423− | TypeClassDictionary Constraint (M.Map (Maybe ModuleName) (M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope)))

426+ | TypeClassDictionary Constraint (M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope)))

424 -- |

427 -- |

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

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

426 --

429 --

427− | TypeClassDictionaryAccessor (Qualified ProperName) Ident

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

428 -- |

431 -- |

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

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

430 --

433 --

431− | SuperClassDictionary (Qualified ProperName) [Type]

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

432 -- |

435 -- |

433 -- A value with source position information

436 -- A value with source position information

434 --

437 --

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

438+ | PositionedValue SourceSpan [Comment] Expr

439+ deriving (Show, Read)

436

440

437-- |

441-- |

438-- An alternative in a case statement

442-- An alternative in a case statement

@@ -446,7 +450,7 @@ data CaseAlternative = CaseAlternative

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

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

447 --

451 --

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

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

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

453+ } deriving (Show, Read)

450

454

451-- |

455-- |

452-- A statement in a do-notation block

456-- A statement in a do-notation block

@@ -467,7 +471,8 @@ data DoNotationElement

467 -- |

471 -- |

468 -- A do notation element with source position information

472 -- A do notation element with source position information

469 --

473 --

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

474+ | PositionedDoNotationElement SourceSpan [Comment] DoNotationElement

475+ deriving (Show, Read)

471

476

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

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

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

478$(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/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/Bundle.hs+14−11

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

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

src/Language/PureScript/CodeGen/Cpp.hs+1−22

@@ -67,8 +67,6 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do

67 let cppImports' = "PureScript" : cppImports

68 cppDecls <- concat <$> mapM bindToCpp decls

69 optimized <- traverse optimize cppDecls

70− -- datas <- datasToCpps env mn

71− synonyms <- synonymsToCpp env mn

72 let moduleHeader = fileBegin mn "HH"

70 let moduleHeader = fileBegin mn "HH"

73 ++ P.linebreak

71 ++ P.linebreak

74 ++ ((\i -> CppInclude i i) <$> cppImports')

72 ++ ((\i -> CppInclude i i) <$> cppImports')

@@ -79,7 +77,6 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do

79 ++ P.linebreak

77 ++ P.linebreak

80 ++ [CppNamespace (runModuleName mn) $

78 ++ [CppNamespace (runModuleName mn) $

81 (CppUseNamespace <$> cppImports') ++ P.linebreak

79 (CppUseNamespace <$> cppImports') ++ P.linebreak

82− ++ synonyms

83 ++ toHeader optimized

80 ++ toHeader optimized

84 ++ toHeaderFns optimized

81 ++ toHeaderFns optimized

85 ]

82 ]

@@ -509,27 +506,9 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do

509 -- |

506 -- |

510 -- Find a class in scope by name, retrieving its list of constraints, function names and types.

507 -- Find a class in scope by name, retrieving its list of constraints, function names and types.

511 --

508 --

512− findClass :: Qualified ProperName -> Maybe ([String], [T.Constraint], [(String, T.Type)])

509+ findClass :: Qualified (ProperName ClassName) -> Maybe ([String], [T.Constraint], [(String, T.Type)])

513 findClass name

510 findClass name

514 | Just (params, fns, constraints) <- M.lookup name (E.typeClasses env),

511 | Just (params, fns, constraints) <- M.lookup name (E.typeClasses env),

515 fns' <- (\(i,t) -> (runIdent i, t)) <$> fns

512 fns' <- (\(i,t) -> (runIdent i, t)) <$> fns

516 = Just (fst <$> params, constraints, (sortBy (compare `on` normalizedName . fst) fns'))

513 = Just (fst <$> params, constraints, (sortBy (compare `on` normalizedName . fst) fns'))

517 findClass _ = Nothing

514 findClass _ = Nothing

518−

519−-------------------------------------------------------------------------------------------------

520−synonymsToCpp :: Monad m => E.Environment -> ModuleName -> m [Cpp]

521−-------------------------------------------------------------------------------------------------

522−synonymsToCpp env mn

523− | tcs <- E.typeClasses env,

524− ds@(_:_) <- M.toList

525− . M.filterWithKey (\k@(Qualified mn' _) _ -> mn' == Just mn && M.lookup k tcs == Nothing)

526− $ E.typeSynonyms env = do

527− let names' = qualifiedToStr mn (Ident . runProperName) . fst <$> ds

528− typs = replicate (length ds) (CppAny [])

529− syns = zip names' typs

530− cpps = toTypeAlias <$> syns

531− return $ cpps

532− | otherwise = return []

533− where

534− toTypeAlias :: (String, CppType) -> Cpp

535− toTypeAlias (n, t) = CppTypeAlias (n, []) t []

src/Language/PureScript/CodeGen/Cpp/AST.hs+5−3

@@ -51,7 +51,8 @@ data CppUnaryOp

51 -- |

52 -- Constructor

53 --

54+ | CppNew

54− | CppNew deriving (Show, Eq, Data, Typeable)

55+ deriving (Show, Read, Eq)

55

56

56-- |

57-- |

57-- Built-in binary operators

58-- Built-in binary operators

@@ -134,7 +135,7 @@ data BinaryOp

134 --

135 --

135 | ShiftRight

136 | ShiftRight

136 --

137 --

137− deriving (Show, Eq, Data, Typeable)

138+ deriving (Show, Read, Eq)

138

139

139-- |

140-- |

140-- Data type for simplified C++11 expressions

141-- Data type for simplified C++11 expressions

@@ -263,7 +264,8 @@ data Cpp

263 -- |

264 -- |

264 -- Commented C++11

265 -- Commented C++11

265 --

266 --

266− | CppComment [Comment] Cpp deriving (Show, Eq, Data, Typeable)

267+ | CppComment [Comment] Cpp

268+ deriving (Show, Read, Eq)

267

269

268--

270--

269-- Traversals

271-- Traversals

src/Language/PureScript/CodeGen/Cpp/Types.hs+4−5

@@ -28,10 +28,10 @@ import qualified Language.PureScript.Constants as C

28-- import Debug.Trace

29

30data CppType = CppPrimitive String | CppAuto | CppAny [CppTypeQual]

31− deriving (Eq, Show, Data, Typeable)

31+ deriving (Show, Read, Eq)

32

33data CppTypeQual = CppConst | CppRef

34− deriving (Eq, Show, Data)

34+ deriving (Show, Read, Eq)

35

36-- |

37-- Value C++11 qualifiers

@@ -57,14 +57,13 @@ data CppValueQual

57 -- Function or lambda is involved in recursion

58 --

59 | CppRecursive

60−

61− deriving (Show, Eq, Data, Typeable)

60+ deriving (Show, Read, Eq)

62

61

63-- |

62-- |

64-- C++ lambda capture list

63-- C++ lambda capture list

65--

64--

66data CppCaptureType = CppCaptureAll

65data CppCaptureType = CppCaptureAll

67− deriving (Show, Eq, Data, Typeable)

66+ deriving (Show, Read, Eq)

68

67

69runType :: CppType -> String

68runType :: CppType -> String

70runType (CppPrimitive t) = t

69runType (CppPrimitive t) = t

src/Language/PureScript/CodeGen/JS.hs+1−1

@@ -90,7 +90,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =

90 go :: M.Map ModuleName ModuleName -> [Ident] -> [ModuleName] -> M.Map ModuleName ModuleName

91 go acc used (mn' : mns') =

92 let mni = Ident $ runModuleName mn'

93− in if mni `elem` used

93+ in if mn' /= mn && mni `elem` used

94 then let newName = freshModuleName 1 mn' used

95 in go (M.insert mn' newName acc) (Ident (runModuleName newName) : used) mns'

96 else go (M.insert mn' mn' acc) (mni : used) mns'

src/Language/PureScript/CodeGen/JS/AST.hs+6−18

@@ -1,27 +1,12 @@

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

@@ -49,7 +34,8 @@ data UnaryOperator

49 -- |

34 -- |

50 -- Constructor

35 -- Constructor

51 --

36 --

37+ | JSNew

52− | JSNew deriving (Show, Read, Eq, Data, Typeable)

38+ deriving (Show, Read, Eq)

53

39

54-- |

40-- |

55-- Built-in binary operators

41-- Built-in binary operators

@@ -130,7 +116,8 @@ data BinaryOperator

130 -- |

116 -- |

131 -- Bitwise right shift with zero-fill

117 -- Bitwise right shift with zero-fill

132 --

118 --

133− | ZeroFillShiftRight deriving (Show, Read, Eq, Data, Typeable)

119+ | ZeroFillShiftRight

120+ deriving (Show, Read, Eq)

134

121

135-- |

122-- |

136-- Data type for simplified Javascript expressions

123-- Data type for simplified Javascript expressions

@@ -251,7 +238,8 @@ data JS

251 -- |

238 -- |

252 -- Commented Javascript

239 -- Commented Javascript

253 --

240 --

254− | JSComment [Comment] JS deriving (Show, Read, Eq, Data, Typeable)

241+ | JSComment [Comment] JS

242+ deriving (Show, Read, Eq)

255

243

256--

244--

257-- Traversals

245-- Traversals

src/Language/PureScript/CodeGen/JS/Optimizer.hs+17−25

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

@@ -65,11 +51,21 @@ optimize js = do

65optimize' :: (Monad m, MonadReader Options m, Applicative m, MonadSupply m) => JS -> m JS

51optimize' :: (Monad m, MonadReader Options m, Applicative 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 f [x]

57+ , inlineOperator (C.dataFunction, C.apply) $ \f x -> JSApp f [x]

58+ , inlineOperator (C.prelude, (C.#)) $ \x f -> JSApp f [x]

59+ , inlineOperator (C.dataFunction, C.applyFlipped) $ \x f -> JSApp f [x]

60+ , inlineOperator (C.dataArrayUnsafe, C.unsafeIndex) $ flip JSIndexer

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/Common.hs+15−12

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

@@ -76,3 +64,18 @@ isUpdated var1 = everythingOnJS (||) check

76removeFromBlock :: ([JS] -> [JS]) -> JS -> JS

64removeFromBlock :: ([JS] -> [JS]) -> JS -> JS

77removeFromBlock go (JSBlock sts) = JSBlock (go sts)

65removeFromBlock go (JSBlock sts) = JSBlock (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+190−138

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

@@ -89,30 +77,30 @@ inlineVariables = everywhereOnJS $ removeFromBlock go

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 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 (Left 0)

99− | isDict semiringInt dict && isFn fnOne fn = JSNumericLiteral (Left 1)

86+ | isDict' (semiringNumber ++ semiringInt) dict && isFn' fnOne fn = JSNumericLiteral (Left 1)

100− | isDict boundedBoolean dict && isFn fnBottom fn = JSBooleanLiteral False

87+ | isDict' boundedBoolean dict && isFn' fnBottom fn = JSBooleanLiteral False

101− | isDict boundedBoolean dict && isFn fnTop fn = JSBooleanLiteral True

88+ | isDict' boundedBoolean dict && isFn' fnTop fn = JSBooleanLiteral True

102 convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y])

89 convert (JSApp (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 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 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 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 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 op x y = JSBinary BitwiseOr (JSBinary op x y) (JSNumericLiteral (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

@@ -126,43 +114,54 @@ inlineOperator (m, op) f = everywhereOnJS convert

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,11 +173,11 @@ 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 (JSApp (JSApp fn [dict']) [x]) [y]) | isDict' dict dict' && isFn' fns fn = JSBinary 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

@@ -186,17 +185,11 @@ inlineCommonOperators = applyAll $

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 (JSApp fn [x]) [y]) | isFn (moduleName, opString) fn = JSBinary op x y

188 convert other = other

187 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

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 (JSApp fn [dict']) [x]) | isDict' dicts dict' && isFn' fns fn = JSUnary 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

@@ -246,71 +239,130 @@ inlineFnComposition :: (Applicative m, 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 (JSApp (JSApp (JSApp fn [dict']) [x]) [y]) [z])

243+ | isFnCompose dict' fn = return $ JSApp x [JSApp y [z]]

250− return $ JSApp x [JSApp y [z]]

244+ | isFnComposeFlipped dict' fn = return $ JSApp y [JSApp x [z]]

251− convert (JSApp (JSApp (JSApp fn [dict']) [x]) [y]) | isFnCompose dict' fn = do

245+ convert (JSApp (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 Nothing [arg] (JSBlock [JSReturn $ JSApp x [JSApp y [JSVar arg]]])

249+ | isFnComposeFlipped dict' fn = do

250+ arg <- freshName

251+ return $ JSFunction Nothing [arg] (JSBlock [JSReturn $ JSApp y [JSApp x [JSVar 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+11−42

@@ -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,9 +39,7 @@ 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 Nothing [] (JSBlock js)]) | isBind bind =

@@ -72,33 +55,19 @@ magicDo' = everywhereOnJS undo . everywhereOnJSTopDown convert

72 JSApp (JSFunction Nothing [] (JSBlock [ JSWhile (JSApp arg1 []) (JSBlock [ JSApp arg2 [] ]), JSReturn $ JSObjectLiteral []])) []

55 JSApp (JSFunction Nothing [] (JSBlock [ JSWhile (JSApp arg1 []) (JSBlock [ JSApp arg2 [] ]), JSReturn $ JSObjectLiteral []])) []

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

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+101−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,107 @@ 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+

68(&&) :: String

101(&&) :: String

69(&&) = "&&"

102(&&) = "&&"

70

103

104+conj :: String

105+conj = "conj"

106+

71(||) :: String

107(||) :: String

72(||) = "||"

108(||) = "||"

73

109

74−bind :: String

110+disj :: String

75−bind = "bind"

111+disj = "disj"

76

112

77unsafeIndex :: String

113unsafeIndex :: String

78unsafeIndex = "unsafeIndex"

114unsafeIndex = "unsafeIndex"

@@ -92,6 +128,12 @@ unsafeIndex = "unsafeIndex"

92compose :: String

128compose :: String

93compose = "compose"

129compose = "compose"

94

130

131+(>>>) :: String

132+(>>>) = ">>>"

133+

134+composeFlipped :: String

135+composeFlipped = "composeFlipped"

136+

95-- Functions

137-- Functions

96

138

97negate :: String

139negate :: String

@@ -100,15 +142,6 @@ negate = "negate"

100not :: String

142not :: String

101not = "not"

143not = "not"

102

144

103−conj :: String

104−conj = "conj"

105−

106−disj :: String

107−disj = "disj"

108−

109−mod :: String

110−mod = "mod"

111−

112shl :: String

145shl :: String

113shl = "shl"

146shl = "shl"

114

147

@@ -211,12 +244,21 @@ moduloSemiringNumber = "moduloSemiringNumber"

211moduloSemiringInt :: String

244moduloSemiringInt :: String

212moduloSemiringInt = "moduloSemiringInt"

245moduloSemiringInt = "moduloSemiringInt"

213

246

247+ordBoolean :: String

248+ordBoolean = "ordBoolean"

249+

214ordNumber :: String

250ordNumber :: String

215ordNumber = "ordNumber"

251ordNumber = "ordNumber"

216

252

217ordInt :: String

253ordInt :: String

218ordInt = "ordInt"

254ordInt = "ordInt"

219

255

256+ordString :: String

257+ordString = "ordString"

258+

259+ordChar :: String

260+ordChar = "ordChar"

261+

220eqNumber :: String

262eqNumber :: String

221eqNumber = "eqNumber"

263eqNumber = "eqNumber"

222

264

@@ -226,6 +268,9 @@ eqInt = "eqInt"

226eqString :: String

268eqString :: String

227eqString = "eqString"

269eqString = "eqString"

228

270

271+eqChar :: String

272+eqChar = "eqChar"

273+

229eqBoolean :: String

274eqBoolean :: String

230eqBoolean = "eqBoolean"

275eqBoolean = "eqBoolean"

231

276

@@ -285,6 +330,39 @@ eff = "Control_Monad_Eff"

285st :: String

330st :: String

286st = "Control_Monad_ST"

331st = "Control_Monad_ST"

287

332

333+controlApplicative :: String

334+controlApplicative = "Control_Applicative"

335+

336+controlSemigroupoid :: String

337+controlSemigroupoid = "Control_Semigroupoid"

338+

339+controlBind :: String

340+controlBind = "Control_Bind"

341+

342+dataBounded :: String

343+dataBounded = "Data_Bounded"

344+

345+dataSemigroup :: String

346+dataSemigroup = "Data_Semigroup"

347+

348+dataModuloSemiring :: String

349+dataModuloSemiring = "Data_ModuloSemiring"

350+

351+dataBooleanAlgebra :: String

352+dataBooleanAlgebra = "Data_BooleanAlgebra"

353+

354+dataEq :: String

355+dataEq = "Data_Eq"

356+

357+dataOrd :: String

358+dataOrd = "Data_Ord"

359+

360+dataSemiring :: String

361+dataSemiring = "Data_Semiring"

362+

363+dataRing :: String

364+dataRing = "Data_Ring"

365+

288dataFunction :: String

366dataFunction :: String

289dataFunction = "Data_Function"

367dataFunction = "Data_Function"

290

368

src/Language/PureScript/CoreFn/Binders.hs+7−20

@@ -1,24 +1,10 @@

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−

22import Language.PureScript.CoreFn.Literals

8import Language.PureScript.CoreFn.Literals

23import Language.PureScript.Names

9import Language.PureScript.Names

24

10

@@ -39,10 +25,11 @@ 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)

35+ deriving (Show, Read, Functor)

src/Language/PureScript/CoreFn/Desugar.hs+12−6

@@ -55,8 +55,7 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =

55 declToCoreFn ss com (A.ValueDeclaration name _ _ (Right e)) =

56 [NonRec name (exprToCoreFn ss com Nothing e)]

57 declToCoreFn ss com (A.FixityDeclaration _ name (Just alias)) =

58− let qname = Qualified (Just mn) alias

59− in [NonRec (Op name) (Var (ss, com, Nothing, getValueMeta qname) (Qualified Nothing alias))]

58+ [NonRec (Op name) (Var (ss, com, Nothing, getValueMeta alias) alias)]

60 declToCoreFn ss _ (A.BindingGroupDeclaration ds) =

59 declToCoreFn ss _ (A.BindingGroupDeclaration ds) =

61 [Rec $ map (\(name, _, e) -> (name, exprToCoreFn ss [] Nothing e)) ds]

60 [Rec $ map (\(name, _, e) -> (name, exprToCoreFn ss [] Nothing e)) ds]

62 declToCoreFn ss com (A.TypeClassDeclaration name _ supers members) =

61 declToCoreFn ss com (A.TypeClassDeclaration name _ supers members) =

@@ -171,7 +170,7 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =

171 -- |

170 -- |

172 -- Gets metadata for data constructors.

171 -- Gets metadata for data constructors.

173 --

172 --

174− getConstructorMeta :: Qualified ProperName -> Meta

173+ getConstructorMeta :: Qualified (ProperName 'ConstructorName) -> Meta

175 getConstructorMeta ctor =

174 getConstructorMeta ctor =

176 case lookupConstructor env ctor of

175 case lookupConstructor env ctor of

177 (Newtype, _, _, _) -> IsNewtype

176 (Newtype, _, _, _) -> IsNewtype

@@ -179,9 +178,15 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =

179 let constructorType = if numConstructors (ctor, dc) == 1 then ProductType else SumType

178 let constructorType = if numConstructors (ctor, dc) == 1 then ProductType else SumType

180 in IsConstructor constructorType fields

179 in IsConstructor constructorType fields

181 where

180 where

181+

182+ numConstructors

182− numConstructors :: (Qualified ProperName, (DataDeclType, ProperName, Type, [Ident])) -> Int

183+ :: (Qualified (ProperName 'ConstructorName), (DataDeclType, ProperName 'TypeName, Type, [Ident]))

184+ -> Int

183 numConstructors ty = length $ filter (((==) `on` typeConstructor) ty) $ M.toList $ dataConstructors env

185 numConstructors ty = length $ filter (((==) `on` typeConstructor) ty) $ M.toList $ dataConstructors env

186+

187+ typeConstructor

184− typeConstructor :: (Qualified ProperName, (DataDeclType, ProperName, Type, [Ident])) -> (ModuleName, ProperName)

188+ :: (Qualified (ProperName 'ConstructorName), (DataDeclType, ProperName 'TypeName, Type, [Ident]))

189+ -> (ModuleName, ProperName 'TypeName)

185 typeConstructor (Qualified (Just mn') _, (_, tyCtor, _, _)) = (mn', tyCtor)

190 typeConstructor (Qualified (Just mn') _, (_, tyCtor, _, _)) = (mn', tyCtor)

186 typeConstructor _ = internalError "Invalid argument to typeConstructor"

191 typeConstructor _ = internalError "Invalid argument to typeConstructor"

187

192

@@ -197,6 +202,7 @@ findQualModules decls =

197 where

202 where

198 fqDecls :: A.Declaration -> [ModuleName]

203 fqDecls :: A.Declaration -> [ModuleName]

199 fqDecls (A.TypeInstanceDeclaration _ _ (Qualified (Just mn) _) _ _) = [mn]

204 fqDecls (A.TypeInstanceDeclaration _ _ (Qualified (Just mn) _) _ _) = [mn]

205+ fqDecls (A.FixityDeclaration _ _ (Just (Qualified (Just mn) _))) = [mn]

200 fqDecls _ = []

206 fqDecls _ = []

201

207

202 fqValues :: A.Expr -> [ModuleName]

208 fqValues :: A.Expr -> [ModuleName]

@@ -255,5 +261,5 @@ mkTypeClassConstructor ss com supers members =

255-- |

261-- |

256-- Converts a ProperName to an Ident.

262-- Converts a ProperName to an Ident.

257--

263--

258−properToIdent :: ProperName -> Ident

264+properToIdent :: ProperName a -> Ident

259properToIdent = Ident . runProperName

265properToIdent = Ident . runProperName

src/Language/PureScript/CoreFn/Expr.hs+10−21

@@ -1,26 +1,12 @@

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

25import Language.PureScript.CoreFn.Literals

11import Language.PureScript.CoreFn.Literals

26import Language.PureScript.Names

12import Language.PureScript.Names

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

@@ -77,7 +64,8 @@ data Bind a

77 -- |

64 -- |

78 -- Mutually recursive binding group for several values

65 -- Mutually recursive binding group for several values

79 --

66 --

67+ | Rec [(Ident, Expr a)]

80− | Rec [(Ident, Expr a)] deriving (Show, Read, D.Data, D.Typeable, Functor)

68+ deriving (Show, Read, Functor)

81

69

82-- |

70-- |

83-- A guard is just a boolean-valued expression that appears alongside a set of binders

71-- A guard is just a boolean-valued expression that appears alongside a set of binders

@@ -96,7 +84,8 @@ data CaseAlternative a = CaseAlternative

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

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

97 --

85 --

98 , caseAlternativeResult :: Either [(Guard a, Expr a)] (Expr a)

86 , caseAlternativeResult :: Either [(Guard a, Expr a)] (Expr a)

87+ }

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

88+ deriving (Show, Read)

100

89

101instance Functor CaseAlternative where

90instance Functor CaseAlternative where

102

91

src/Language/PureScript/CoreFn/Literals.hs+5−18

@@ -1,24 +1,10 @@

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

1{-# LANGUAGE DeriveFunctor #-}

17

2

3+-- |

4+-- The core functional representation for literal values.

5+--

18module Language.PureScript.CoreFn.Literals where

6module Language.PureScript.CoreFn.Literals where

19

7

20−import qualified Data.Data as D

21−

22-- |

8-- |

23-- Data type for literal values. Parameterised so it can be used for Exprs and

9-- Data type for literal values. Parameterised so it can be used for Exprs and

24-- Binders.

10-- Binders.

@@ -47,4 +33,5 @@ data Literal a

47 -- |

33 -- |

48 -- An object literal

34 -- An object literal

49 --

35 --

36+ | ObjectLiteral [(String, a)]

50− | ObjectLiteral [(String, a)] deriving (Show, Read, D.Data, D.Typeable, Functor)

37+ deriving (Show, Read, Functor)

src/Language/PureScript/CoreFn/Meta.hs+6−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,8 @@ data Meta

39 -- |

24 -- |

40 -- The contained reference is for a foreign member

25 -- The contained reference is for a foreign member

41 --

26 --

27+ | IsForeign

42− | IsForeign deriving (Show, Read, D.Data, D.Typeable)

28+ deriving (Show, Read)

43

29

44-- |

30-- |

45-- Data constructor metadata

31-- Data constructor metadata

@@ -52,4 +38,5 @@ data ConstructorType

52 -- |

38 -- |

53 -- The constructor is for a type with multiple construcors

39 -- The constructor is for a type with multiple construcors

54 --

40 --

41+ | SumType

55− | SumType deriving (Show, Read, D.Data, D.Typeable)

42+ deriving (Show, Read)

src/Language/PureScript/CoreFn/Traversals.hs+1

@@ -40,6 +40,7 @@ everywhereOnValues f g h = (f', g', h')

40

41 h' (LiteralBinder a b) = h (LiteralBinder a (handleLiteral h' b))

42 h' (NamedBinder a name b) = h (NamedBinder a name (h' b))

43+ h' (ConstructorBinder a q1 q2 bs) = h (ConstructorBinder a q1 q2 (map h' bs))

43 h' b = h b

44 h' b = h b

44

45

45 handleCaseAlternative ca =

46 handleCaseAlternative ca =

src/Language/PureScript/Docs/AsMarkdown.hs+34−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,9 +28,14 @@ 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+ (Functor m, Applicative m,

33+ MonadError P.MultipleErrors m) =>

34+ P.Env ->

35+ [P.Module] ->

36+ m String

23−renderModulesAsMarkdown =

37+renderModulesAsMarkdown env =

24− runDocs . modulesAsMarkdown . map Convert.convertModule

38+ fmap (runDocs . modulesAsMarkdown) . Convert.convertModules env

25

39

26modulesAsMarkdown :: [Module] -> Docs

40modulesAsMarkdown :: [Module] -> Docs

27modulesAsMarkdown = mapM_ moduleAsMarkdown

41modulesAsMarkdown = mapM_ moduleAsMarkdown

@@ -31,21 +45,27 @@ moduleAsMarkdown Module{..} = do

31 headerLevel 2 $ "Module " ++ modName

45 headerLevel 2 $ "Module " ++ modName

32 spacer

46 spacer

33 for_ modComments tell'

47 for_ modComments tell'

34− mapM_ declAsMarkdown modDeclarations

48+ mapM_ (declAsMarkdown modName) modDeclarations

35 spacer

49 spacer

50+ for_ modReExports $ \(mn, decls) -> do

51+ let modName' = P.runModuleName mn

52+ headerLevel 3 $ "Re-exported from " ++ modName' ++ ":"

53+ spacer

54+ mapM_ (declAsMarkdown modName') decls

36

55

37−declAsMarkdown :: Declaration -> Docs

56+declAsMarkdown :: String -> Declaration -> Docs

38−declAsMarkdown decl@Declaration{..} = do

57+declAsMarkdown mn decl@Declaration{..} = do

58+ let options = defaultRenderTypeOptions { currentModule = Just (P.moduleNameFromString mn) }

39 headerLevel 4 (ticks declTitle)

59 headerLevel 4 (ticks declTitle)

40 spacer

60 spacer

41

61

42 let (instances, children) = partition (isChildInstance . cdeclInfo) declChildren

62 let (instances, children) = partition (isChildInstance . cdeclInfo) declChildren

43 fencedBlock $ do

63 fencedBlock $ do

44− tell' (codeToString $ Render.renderDeclaration decl)

64+ tell' (codeToString $ Render.renderDeclarationWithOptions options decl)

45 zipWithM_ (\f c -> tell' (childToString f c)) (First : repeat NotFirst) children

65 zipWithM_ (\f c -> tell' (childToString f c)) (First : repeat NotFirst) children

46 spacer

66 spacer

47

67

48− for_ declFixity (\(fixity, alias) -> fixityAsMarkdown fixity alias >> spacer)

68+ for_ declFixity (\fixity -> fixityAsMarkdown fixity >> spacer)

49

69

50 for_ declComments tell'

70 for_ declComments tell'

51

71

@@ -68,11 +88,9 @@ codeToString = outputWith elemAsMarkdown

68 elemAsMarkdown (Keyword x) = x

88 elemAsMarkdown (Keyword x) = x

69 elemAsMarkdown Space = " "

89 elemAsMarkdown Space = " "

70

90

71−fixityAsMarkdown :: P.Fixity -> Maybe String -> Docs

91+fixityAsMarkdown :: P.Fixity -> Docs

72−fixityAsMarkdown (P.Fixity associativity precedence) alias =

92+fixityAsMarkdown (P.Fixity associativity precedence) =

73− -- TODO: link alias name to member

74 tell' $ concat [ "_"

93 tell' $ concat [ "_"

75− , maybe "" (\i -> "alias for " ++ i ++ " - ") alias

76 , associativityStr

94 , associativityStr

77 , " / precedence "

95 , " / precedence "

78 , show precedence

96 , show precedence

src/Language/PureScript/Docs/Convert.hs+56−198

@@ -2,228 +2,86 @@

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.Monad.Error.Class (MonadError)

20+import Control.Arrow ((&&&))

18import Control.Category ((>>>))

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

19−import Data.Either

22+import qualified Data.Map as Map

20−import Data.Maybe (mapMaybe, isNothing)

21−import Data.List (nub, isPrefixOf, isSuffixOf)

22

23

23import qualified Language.PureScript as P

24import qualified Language.PureScript as P

24

25

25import Language.PureScript.Docs.Types

26import Language.PureScript.Docs.Types

27+import Language.PureScript.Docs.Convert.Single (convertSingleModule, collectBookmarks)

28+import Language.PureScript.Docs.Convert.ReExports (updateReExports)

26

29

27-- |

30-- |

28−-- Convert a single Module.

31+-- Like convertModules, except that it takes a list of modules, together with

32+-- their dependency status, and discards dependency modules in the resulting

33+-- documentation.

29--

34--

30−convertModule :: P.Module -> Module

35+convertModulesInPackage ::

31−convertModule m@(P.Module _ coms moduleName _ _) =

36+ (Functor m, MonadError P.MultipleErrors m) =>

32− Module (P.runModuleName moduleName) comments (declarations m)

37+ P.Env ->

38+ [InPackage P.Module] ->

39+ m [Module]

40+convertModulesInPackage env modules =

41+ go modules

33 where

42 where

34− comments = convertComments coms

43+ localNames =

35− declarations =

44+ map (P.runModuleName . P.getModuleName) (takeLocals modules)

36− P.exportedDeclarations

45+ go =

37− >>> mapMaybe (\d -> getDeclarationTitle d >>= convertDeclaration d)

46+ map ignorePackage

38− >>> augmentDeclarations

47+ >>> convertModules env

39− >>> map addDefaultFixity

48+ >>> fmap (filter ((`elem` localNames) . modName))

40

49

41−-- | The data type for an intermediate stage which we go through during

50+-- |

42−-- converting.

51+-- Convert a group of modules to the intermediate format, designed for

43−--

52+-- 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

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

54+-- documenting re-exports.

46−-- declarations. These two situation correspond to the Right and Left

47−-- constructors, respectively.

48--

55--

49−-- In the second pass, we go over all of the Left values and augment the

56+-- Preconditions:

50−-- relevant declarations, leaving only the augmented Right values.

51--

57--

52−-- Note that in the Left case, we provide a [String] as well as augment

58+-- * If any module in the list re-exports documentation from other

53−-- information. The [String] value should be a list of titles of declarations

59+-- modules, those modules must also be included in the list.

54−-- that the augmentation should apply to. For example, for a type instance

60+-- * The modules passed must have had names desugared and re-exports

55−-- declaration, that would be any types or type classes mentioned in the

61+-- elaborated first.

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

62--

64−-- The AugmentChild constructor allows us to move all children under their

63+-- If either of these are not satisfied, an internal error will be thrown. To

65−-- respective parents. It is only necessary for type instance declarations,

64+-- avoid this, it is recommended to use

66−-- since they appear at the top level in the AST, and since they might need to

65+-- Language.PureScript.Docs.ParseAndDesugar to construct the inputs to this

67−-- appear as children in two places (for example, if a data type defined in a

66+-- function.

68−-- module is an instance of a type class also defined in that module).

69--

67--

70−-- The AugmentFixity constructor allows us to augment operator definitions

68+convertModules ::

71−-- with their associativity and precedence.

69+ (Functor m, MonadError P.MultipleErrors m) =>

72−data DeclarationAugment

70+ P.Env ->

73− = AugmentChild ChildDeclaration

71+ [P.Module] ->

74− | AugmentFixity P.Fixity (Maybe P.Ident)

72+ m [Module]

73+convertModules env =

74+ P.sortModules >>> fmap (convertSorted env . fst)

75

76−-- | Augment top-level declarations; the second pass. See the comments under

76+-- |

77−-- the type synonym IntermediateDeclaration for more information.

77+-- Convert a sorted list of modules.

78−augmentDeclarations :: [IntermediateDeclaration] -> [Declaration]

79−augmentDeclarations (partitionEithers -> (augments, toplevels)) =

80− foldl go toplevels augments

81− where

82− go ds (parentTitles, a) =

83− map (\d ->

84− if declTitle d `elem` parentTitles

85− then augmentWith a d

86− else d) ds

87−

88− augmentWith a d =

89− case a of

90− AugmentChild child ->

91− d { declChildren = declChildren d ++ [child] }

92− AugmentFixity fixity alias ->

93− d { declFixity = Just (fixity, P.runIdent <$> alias) }

94−

95−-- | Add the default operator fixity for operators which do not have associated

96−-- fixity declarations.

97--

78--

98−-- TODO: This may no longer be necessary after issue 806 is resolved, hopefully

79+convertSorted :: P.Env -> [P.Module] -> [Module]

99−-- in 0.9.

80+convertSorted env modules =

100−addDefaultFixity :: Declaration -> Declaration

81+ let

101−addDefaultFixity decl@Declaration{..}

82+ traversalOrder =

102− | isOp declTitle && isNothing declFixity =

83+ map P.getModuleName modules

103− decl { declFixity = Just (defaultFixity, Nothing) }

84+ moduleMap =

104− | otherwise =

85+ Map.fromList $ map (P.getModuleName &&& convertSingleModule) modules

105− decl

86+ in

106− where

87+ Map.elems (updateReExports env traversalOrder moduleMap)

107− isOp :: String -> Bool

108− isOp str = "(" `isPrefixOf` str && ")" `isSuffixOf` str

109− defaultFixity = P.Fixity P.Infixl (-1)

110−

111−getDeclarationTitle :: P.Declaration -> Maybe String

112−getDeclarationTitle (P.TypeDeclaration name _) = Just (P.showIdent name)

113−getDeclarationTitle (P.ExternDeclaration name _) = Just (P.showIdent name)

114−getDeclarationTitle (P.DataDeclaration _ name _ _) = Just (P.runProperName name)

115−getDeclarationTitle (P.ExternDataDeclaration name _) = Just (P.runProperName name)

116−getDeclarationTitle (P.TypeSynonymDeclaration name _ _) = Just (P.runProperName name)

117−getDeclarationTitle (P.TypeClassDeclaration name _ _ _) = Just (P.runProperName name)

118−getDeclarationTitle (P.TypeInstanceDeclaration name _ _ _ _) = Just (P.showIdent name)

119−getDeclarationTitle (P.FixityDeclaration _ name _) = Just ("(" ++ name ++ ")")

120−getDeclarationTitle (P.PositionedDeclaration _ _ d) = getDeclarationTitle d

121−getDeclarationTitle _ = Nothing

122−

123−-- | Create a basic Declaration value.

124−mkDeclaration :: String -> DeclarationInfo -> Declaration

125−mkDeclaration title info =

126− Declaration { declTitle = title

127− , declComments = Nothing

128− , declSourceSpan = Nothing

129− , declChildren = []

130− , declFixity = Nothing

131− , declInfo = info

132− }

133−

134−basicDeclaration :: String -> DeclarationInfo -> Maybe IntermediateDeclaration

135−basicDeclaration title info = Just $ Right $ mkDeclaration title info

136−

137−convertDeclaration :: P.Declaration -> String -> Maybe IntermediateDeclaration

138−convertDeclaration (P.TypeDeclaration _ ty) title =

139− basicDeclaration title (ValueDeclaration ty)

140−convertDeclaration (P.ExternDeclaration _ ty) title =

141− basicDeclaration title (ValueDeclaration ty)

142−convertDeclaration (P.DataDeclaration dtype _ args ctors) title =

143− Just (Right (mkDeclaration title info) { declChildren = children })

144− where

145− info = DataDeclaration dtype args

146− children = map convertCtor ctors

147− convertCtor (ctor', tys) =

148− ChildDeclaration (P.runProperName ctor') Nothing Nothing (ChildDataConstructor tys)

149−convertDeclaration (P.ExternDataDeclaration _ kind') title =

150− basicDeclaration title (ExternDataDeclaration kind')

151−convertDeclaration (P.TypeSynonymDeclaration _ args ty) title =

152− basicDeclaration title (TypeSynonymDeclaration args ty)

153−convertDeclaration (P.TypeClassDeclaration _ args implies ds) title =

154− Just (Right (mkDeclaration title info) { declChildren = children })

155− where

156− info = TypeClassDeclaration args implies

157− children = map convertClassMember ds

158− convertClassMember (P.PositionedDeclaration _ _ d) =

159− convertClassMember d

160− convertClassMember (P.TypeDeclaration ident' ty) =

161− ChildDeclaration (P.showIdent ident') Nothing Nothing (ChildTypeClassMember ty)

162− convertClassMember _ =

163− P.internalError "convertDeclaration: Invalid argument to convertClassMember."

164−convertDeclaration (P.TypeInstanceDeclaration _ constraints className tys _) title =

165− Just (Left (classNameString : typeNameStrings, AugmentChild childDecl))

166− where

167− classNameString = unQual className

168− typeNameStrings = nub (concatMap (P.everythingOnTypes (++) extractProperNames) tys)

169− unQual x = let (P.Qualified _ y) = x in P.runProperName y

170−

171− extractProperNames (P.TypeConstructor n) = [unQual n]

172− extractProperNames _ = []

173−

174− childDecl = ChildDeclaration title Nothing Nothing (ChildInstance constraints classApp)

175− classApp = foldl P.TypeApp (P.TypeConstructor className) tys

176−convertDeclaration (P.FixityDeclaration fixity _ alias) title =

177− Just (Left ([title], AugmentFixity fixity alias))

178−convertDeclaration (P.PositionedDeclaration srcSpan com d') title =

179− fmap (addComments . addSourceSpan) (convertDeclaration d' title)

180− where

181− addComments (Right d) =

182− Right (d { declComments = convertComments com })

183− addComments (Left augment) =

184− Left (withAugmentChild (\d -> d { cdeclComments = convertComments com })

185− augment)

186−

187− addSourceSpan (Right d) =

188− Right (d { declSourceSpan = Just srcSpan })

189− addSourceSpan (Left augment) =

190− Left (withAugmentChild (\d -> d { cdeclSourceSpan = Just srcSpan })

191− augment)

192−

193− withAugmentChild f (t, a) =

194− case a of

195− AugmentChild d -> (t, AugmentChild (f d))

196− _ -> (t, a)

197−convertDeclaration _ _ = Nothing

198−

199−convertComments :: [P.Comment] -> Maybe String

200−convertComments cs = do

201− let raw = concatMap toLines cs

202− guard (all hasPipe raw && not (null raw))

203− return (go raw)

204− where

205− go = unlines . map stripPipes

206−

207− toLines (P.LineComment s) = [s]

208− toLines (P.BlockComment s) = lines s

209−

210− hasPipe s = case dropWhile (== ' ') s of { ('|':_) -> True; _ -> False }

211−

212− stripPipes = dropPipe . dropWhile (== ' ')

213−

214− dropPipe ('|':' ':s) = s

215− dropPipe ('|':s) = s

216− dropPipe s = s

217−

218−-- | Go through a PureScript module and extract a list of Bookmarks; references

219−-- to data types or values, to be used as a kind of index. These are used for

220−-- generating links in the HTML documentation, for example.

221−collectBookmarks :: InPackage P.Module -> [Bookmark]

222−collectBookmarks (Local m) = map Local (collectBookmarks' m)

223−collectBookmarks (FromDep pkg m) = map (FromDep pkg) (collectBookmarks' m)

224−

225−collectBookmarks' :: P.Module -> [(P.ModuleName, String)]

226−collectBookmarks' m =

227− map (P.getModuleName m, )

228− (mapMaybe getDeclarationTitle

229− (P.exportedDeclarations m))

src/Language/PureScript/Docs/Convert/ReExports.hsnew file+486

@@ -0,0 +1,486 @@

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+ (Functor m, Applicative m,

73+ MonadState (Map P.ModuleName Module) m) =>

74+ P.Env ->

75+ P.ModuleName ->

76+ m [(P.ModuleName, [Declaration])]

77+getReExports env mn =

78+ case Map.lookup mn env of

79+ Nothing ->

80+ internalError ("Module missing: " ++ P.runModuleName mn)

81+ Just (_, imports, exports) -> do

82+ allExports <- runReaderT (collectDeclarations imports exports) mn

83+ pure (filter notLocal allExports)

84+

85+ where

86+ notLocal = (/= mn) . fst

87+

88+-- |

89+-- Assemble a list of declarations re-exported from a particular module, based

90+-- on the Imports and Exports value for that module, and by extracting the

91+-- declarations from the current state.

92+--

93+-- This function works by searching through the lists of exported declarations

94+-- in the Exports, and looking them up in the associated Imports value to find

95+-- the module they were imported from.

96+--

97+-- Additionally:

98+--

99+-- * Attempts to move re-exported type class members under their parent

100+-- type classes, if possible, or otherwise, "promote" them from

101+-- ChildDeclarations to proper Declarations.

102+-- * Filters data declarations to ensure that only re-exported data

103+-- constructors are listed.

104+-- * Filters type class declarations to ensure that only re-exported type

105+-- class members are listed.

106+--

107+collectDeclarations ::

108+ (Functor m, Applicative m,

109+ MonadState (Map P.ModuleName Module) m,

110+ MonadReader P.ModuleName m) =>

111+ P.Imports ->

112+ P.Exports ->

113+ m [(P.ModuleName, [Declaration])]

114+collectDeclarations imports exports = do

115+ valsAndMembers <- collect lookupValueDeclaration impVals expVals

116+ typeClasses <- collect lookupTypeClassDeclaration impTCs expTCs

117+ types <- collect lookupTypeDeclaration impTypes expTypes

118+

119+ (vals, classes) <- handleTypeClassMembers valsAndMembers typeClasses

120+

121+ let filteredTypes = filterDataConstructors expCtors types

122+ let filteredClasses = filterTypeClassMembers (map fst expVals) classes

123+

124+ pure (Map.toList (Map.unionsWith (<>) [filteredTypes, filteredClasses, vals]))

125+

126+ where

127+ collect lookup' imps exps = do

128+ imps' <- traverse (findImport imps) exps

129+ Map.fromListWith (<>) <$> traverse (uncurry lookup') imps'

130+

131+ expVals = P.exportedValues exports

132+ impVals = concat (Map.elems (P.importedValues imports))

133+

134+ expTypes = map (first fst) (P.exportedTypes exports)

135+ impTypes = concat (Map.elems (P.importedTypes imports))

136+

137+ expCtors = concatMap (snd . fst) (P.exportedTypes exports)

138+

139+ expTCs = P.exportedTypeClasses exports

140+ impTCs = concat (Map.elems (P.importedTypeClasses imports))

141+

142+-- |

143+-- Given a list of imported declarations (of a particular kind, ie. type, data,

144+-- class, value, etc), and the name of an exported declaration of the same

145+-- kind, together with the module it was originally defined in, return a tuple

146+-- of:

147+--

148+-- * the module that exported declaration was imported from (note that

149+-- this can be different from the module it was originally defined in, if

150+-- it is a re-export),

151+-- * that same declaration's name.

152+--

153+-- This function uses a type variable for names because we want to be able to

154+-- instantiate @name@ as both 'P.Ident' and 'P.ProperName'.

155+--

156+findImport ::

157+ (Show name, Eq name, Applicative m, MonadReader P.ModuleName m) =>

158+ [(P.Qualified name, P.ModuleName)] ->

159+ (name, P.ModuleName) ->

160+ m (P.ModuleName, name)

161+findImport imps (name, orig) =

162+ let

163+ matches (qual, mn) = P.disqualify qual == name && mn == orig

164+ matching = filter matches imps

165+ getQualified (P.Qualified mname _) = mname

166+ in

167+ case mapMaybe (getQualified . fst) matching of

168+ -- A value can occur more than once if it is imported twice (eg, if it is

169+ -- exported by A, re-exported from A by B, and C imports it from both A

170+ -- and B). In this case, we just take its first appearance.

171+ (importedFrom:_) ->

172+ pure (importedFrom, name)

173+ [] ->

174+ internalErrorInModule ("findImport: not found: " ++ show (name, orig))

175+

176+lookupValueDeclaration ::

177+ (Applicative m,

178+ MonadState (Map P.ModuleName Module) m,

179+ MonadReader P.ModuleName m) =>

180+ P.ModuleName ->

181+ P.Ident ->

182+ m (P.ModuleName, [Either (String, P.Constraint, ChildDeclaration) Declaration])

183+lookupValueDeclaration importedFrom ident = do

184+ decls <- lookupModuleDeclarations "lookupValueDeclaration" importedFrom

185+ let

186+ rs =

187+ filter (\d -> declTitle d == P.showIdent ident

188+ && (isValue d || isAlias d)) decls

189+ errOther other =

190+ internalErrorInModule

191+ ("lookupValueDeclaration: unexpected result:\n" ++

192+ "other: " ++ show other ++ "\n" ++

193+ "ident: " ++ show ident ++ "\n" ++

194+ "decls: " ++ show decls)

195+

196+ case rs of

197+ [r] ->

198+ pure (importedFrom, [Right r])

199+ [] ->

200+ -- It's a type class member.

201+ -- Note that we need to filter based on the child declaration info using

202+ -- `isTypeClassMember` anyway, because child declarations of type classes

203+ -- are not necessarily members; they could also be instances.

204+ let

205+ allTypeClassChildDecls =

206+ decls

207+ |> mapMaybe (\d -> (d,) <$> typeClassConstraintFor d)

208+ |> concatMap (\(d, constr) ->

209+ map (declTitle d, constr,)

210+ (declChildren d))

211+

212+ matchesIdent cdecl =

213+ cdeclTitle cdecl == P.showIdent ident

214+

215+ matchesAndIsTypeClassMember =

216+ uncurry (&&) . (matchesIdent &&& isTypeClassMember)

217+

218+ in

219+ case filter (matchesAndIsTypeClassMember . thd) allTypeClassChildDecls of

220+ [r'] ->

221+ pure (importedFrom, [Left r'])

222+ other ->

223+ errOther other

224+ other -> do

225+ errOther other

226+

227+ where

228+ thd :: (a, b, c) -> c

229+ thd (_, _, x) = x

230+

231+-- |

232+-- Extract a particular type declaration. For data declarations, constructors

233+-- are only included in the output if they are listed in the arguments.

234+--

235+lookupTypeDeclaration ::

236+ (Applicative m,

237+ MonadState (Map P.ModuleName Module) m,

238+ MonadReader P.ModuleName m) =>

239+ P.ModuleName ->

240+ P.ProperName 'P.TypeName ->

241+ m (P.ModuleName, [Declaration])

242+lookupTypeDeclaration importedFrom ty = do

243+ decls <- lookupModuleDeclarations "lookupTypeDeclaration" importedFrom

244+ let

245+ ds = filter (\d -> declTitle d == P.runProperName ty && isType d) decls

246+ case ds of

247+ [d] ->

248+ pure (importedFrom, [d])

249+ other ->

250+ internalErrorInModule

251+ ("lookupTypeDeclaration: unexpected result: " ++ show other)

252+

253+lookupTypeClassDeclaration ::

254+ (Applicative m,

255+ MonadState (Map P.ModuleName Module) m,

256+ MonadReader P.ModuleName m) =>

257+ P.ModuleName ->

258+ P.ProperName 'P.ClassName ->

259+ m (P.ModuleName, [Declaration])

260+lookupTypeClassDeclaration importedFrom tyClass = do

261+ decls <- lookupModuleDeclarations "lookupTypeClassDeclaration" importedFrom

262+ let

263+ ds = filter (\d -> declTitle d == P.runProperName tyClass

264+ && isTypeClass d)

265+ decls

266+ case ds of

267+ [d] ->

268+ pure (importedFrom, [d])

269+ other ->

270+ internalErrorInModule

271+ ("lookupTypeClassDeclaration: unexpected result: "

272+ ++ (unlines . map show) other)

273+

274+-- |

275+-- Get the full list of declarations for a particular module out of the

276+-- state, or raise an internal error if it is not there.

277+--

278+lookupModuleDeclarations ::

279+ (Applicative m,

280+ MonadState (Map P.ModuleName Module) m,

281+ MonadReader P.ModuleName m) =>

282+ String ->

283+ P.ModuleName ->

284+ m [Declaration]

285+lookupModuleDeclarations definedIn moduleName = do

286+ mmdl <- gets (Map.lookup moduleName)

287+ case mmdl of

288+ Nothing ->

289+ internalErrorInModule

290+ (definedIn ++ ": module missing: "

291+ ++ P.runModuleName moduleName)

292+ Just mdl ->

293+ pure (allDeclarations mdl)

294+

295+handleTypeClassMembers ::

296+ (Functor m, Applicative m,

297+ MonadReader P.ModuleName m) =>

298+ Map P.ModuleName [Either (String, P.Constraint, ChildDeclaration) Declaration] ->

299+ Map P.ModuleName [Declaration] ->

300+ m (Map P.ModuleName [Declaration], Map P.ModuleName [Declaration])

301+handleTypeClassMembers valsAndMembers typeClasses =

302+ let

303+ moduleEnvs =

304+ Map.unionWith (<>)

305+ (fmap valsAndMembersToEnv valsAndMembers)

306+ (fmap typeClassesToEnv typeClasses)

307+ in

308+ moduleEnvs

309+ |> traverse handleEnv

310+ |> fmap splitMap

311+

312+valsAndMembersToEnv ::

313+ [Either (String, P.Constraint, ChildDeclaration) Declaration] -> TypeClassEnv

314+valsAndMembersToEnv xs =

315+ let (envUnhandledMembers, envValues) = partitionEithers xs

316+ envTypeClasses = []

317+ in TypeClassEnv{..}

318+

319+typeClassesToEnv :: [Declaration] -> TypeClassEnv

320+typeClassesToEnv classes =

321+ TypeClassEnv

322+ { envUnhandledMembers = []

323+ , envValues = []

324+ , envTypeClasses = classes

325+ }

326+

327+-- |

328+-- An intermediate data type, used for either moving type class members under

329+-- their parent type classes, or promoting them to normal Declaration values

330+-- if their parent type class has not been re-exported.

331+--

332+data TypeClassEnv = TypeClassEnv

333+ { -- |

334+ -- Type class members which have not yet been dealt with. The String is the

335+ -- name of the type class they belong to, and the constraint is used to

336+ -- make sure that they have the correct type if they get promoted.

337+ --

338+ envUnhandledMembers :: [(String, P.Constraint, ChildDeclaration)]

339+ -- |

340+ -- A list of normal value declarations. Type class members will be added to

341+ -- this list if their parent type class is not available.

342+ --

343+ , envValues :: [Declaration]

344+ -- |

345+ -- A list of type class declarations. Type class members will be added to

346+ -- their parents in this list, if they exist.

347+ --

348+ , envTypeClasses :: [Declaration]

349+ }

350+ deriving (Show)

351+

352+instance Monoid TypeClassEnv where

353+ mempty =

354+ TypeClassEnv mempty mempty mempty

355+ mappend (TypeClassEnv a1 b1 c1)

356+ (TypeClassEnv a2 b2 c2) =

357+ TypeClassEnv (a1 <> a2) (b1 <> b2) (c1 <> c2)

358+

359+-- |

360+-- Take a TypeClassEnv and handle all of the type class members in it, either

361+-- adding them to their parent classes, or promoting them to normal Declaration

362+-- values.

363+--

364+-- Returns a tuple of (values, type classes).

365+--

366+handleEnv ::

367+ (Functor m, Applicative m,

368+ MonadReader P.ModuleName m) =>

369+ TypeClassEnv ->

370+ m ([Declaration], [Declaration])

371+handleEnv TypeClassEnv{..} =

372+ envUnhandledMembers

373+ |> foldM go (envValues, mkMap envTypeClasses)

374+ |> fmap (second Map.elems)

375+

376+ where

377+ mkMap =

378+ Map.fromList . map (declTitle &&& id)

379+

380+ go (values, tcs) (title, constraint, childDecl) =

381+ case Map.lookup title tcs of

382+ Just _ ->

383+ -- Leave the state unchanged; if the type class is there, the child

384+ -- will be too.

385+ pure (values, tcs)

386+ Nothing -> do

387+ c <- promoteChild constraint childDecl

388+ pure (c : values, tcs)

389+

390+ promoteChild constraint ChildDeclaration{..} =

391+ case cdeclInfo of

392+ ChildTypeClassMember typ ->

393+ pure $ Declaration

394+ { declTitle = cdeclTitle

395+ , declComments = cdeclComments

396+ , declSourceSpan = cdeclSourceSpan

397+ , declChildren = []

398+ , declFixity = Nothing

399+ , declInfo = ValueDeclaration (addConstraint constraint typ)

400+ }

401+ _ ->

402+ internalErrorInModule

403+ ("handleEnv: Bad child declaration passed to promoteChild: "

404+ ++ cdeclTitle)

405+

406+ addConstraint constraint =

407+ P.quantify . P.moveQuantifiersToFront . P.ConstrainedType [constraint]

408+

409+splitMap :: (Ord k) => Map k (v1, v2) -> (Map k v1, Map k v2)

410+splitMap = foldl go (Map.empty, Map.empty) . Map.toList

411+ where

412+ go (m1, m2) (k, (v1, v2)) =

413+ (Map.insert k v1 m1, Map.insert k v2 m2)

414+

415+-- |

416+-- Given a list of exported constructor names, remove any data constructor

417+-- names in the provided Map of declarations which are not in the list.

418+--

419+filterDataConstructors ::

420+ [P.ProperName 'P.ConstructorName] ->

421+ Map P.ModuleName [Declaration] ->

422+ Map P.ModuleName [Declaration]

423+filterDataConstructors =

424+ filterExportedChildren isDataConstructor P.runProperName

425+

426+-- |

427+-- Given a list of exported type class member names, remove any data

428+-- type class member names in the provided Map of declarations which are not in

429+-- the list.

430+--

431+filterTypeClassMembers ::

432+ [P.Ident] ->

433+ Map P.ModuleName [Declaration] ->

434+ Map P.ModuleName [Declaration]

435+filterTypeClassMembers =

436+ filterExportedChildren isTypeClassMember P.showIdent

437+

438+filterExportedChildren ::

439+ (Functor f) =>

440+ (ChildDeclaration -> Bool) ->

441+ (name -> String) ->

442+ [name] ->

443+ f [Declaration] ->

444+ f [Declaration]

445+filterExportedChildren isTargetedKind runName expNames =

446+ fmap filterDecls

447+ where

448+ filterDecls =

449+ map (filterChildren (\c -> not (isTargetedKind c) ||

450+ cdeclTitle c `elem` expNames'))

451+

452+ expNames' = map runName expNames

453+

454+allDeclarations :: Module -> [Declaration]

455+allDeclarations Module{..} =

456+ modDeclarations ++ concatMap snd modReExports

457+

458+(|>) :: a -> (a -> b) -> b

459+x |> f = f x

460+

461+internalError :: String -> a

462+internalError = P.internalError . ("Docs.Convert.ReExports: " ++)

463+

464+internalErrorInModule ::

465+ (MonadReader P.ModuleName m) =>

466+ String ->

467+ m a

468+internalErrorInModule msg = do

469+ mn <- ask

470+ internalError

471+ ("while collecting re-exports for module: " ++ P.runModuleName mn ++

472+ ", " ++ msg)

473+

474+-- |

475+-- If the provided Declaration is a TypeClassDeclaration, construct an

476+-- appropriate Constraint for use with the types of its members.

477+--

478+typeClassConstraintFor :: Declaration -> Maybe P.Constraint

479+typeClassConstraintFor Declaration{..} =

480+ case declInfo of

481+ TypeClassDeclaration tyArgs _ ->

482+ Just (P.Qualified Nothing (P.ProperName declTitle), mkConstraint tyArgs)

483+ _ ->

484+ Nothing

485+ where

486+ mkConstraint = map (P.TypeVar . fst)

src/Language/PureScript/Docs/Convert/Single.hsnew file+232

@@ -0,0 +1,232 @@

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 (P.runModuleName 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.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 (fmap P.coerceProperName className)) tys

176+convertDeclaration (P.FixityDeclaration fixity _ Nothing) title =

177+ Just (Left ([title], AugmentFixity fixity))

178+convertDeclaration (P.FixityDeclaration fixity _ (Just alias)) title =

179+ Just $ Right $ (mkDeclaration title (AliasDeclaration alias fixity)) { declFixity = Just fixity }

180+convertDeclaration (P.PositionedDeclaration srcSpan com d') title =

181+ fmap (addComments . addSourceSpan) (convertDeclaration d' title)

182+ where

183+ addComments (Right d) =

184+ Right (d { declComments = convertComments com })

185+ addComments (Left augment) =

186+ Left (withAugmentChild (\d -> d { cdeclComments = convertComments com })

187+ augment)

188+

189+ addSourceSpan (Right d) =

190+ Right (d { declSourceSpan = Just srcSpan })

191+ addSourceSpan (Left augment) =

192+ Left (withAugmentChild (\d -> d { cdeclSourceSpan = Just srcSpan })

193+ augment)

194+

195+ withAugmentChild f (t, a) =

196+ case a of

197+ AugmentChild d -> (t, AugmentChild (f d))

198+ _ -> (t, a)

199+convertDeclaration _ _ = Nothing

200+

201+convertComments :: [P.Comment] -> Maybe String

202+convertComments cs = do

203+ let raw = concatMap toLines cs

204+ let docs = catMaybes (map stripPipe raw)

205+ guard (not (null docs))

206+ pure (unlines docs)

207+

208+ where

209+ toLines (P.LineComment s) = [s]

210+ toLines (P.BlockComment s) = lines s

211+

212+ stripPipe s' =

213+ case dropWhile (== ' ') s' of

214+ ('|':' ':s) ->

215+ Just s

216+ ('|':s) ->

217+ Just s

218+ _ ->

219+ Nothing

220+

221+-- | Go through a PureScript module and extract a list of Bookmarks; references

222+-- to data types or values, to be used as a kind of index. These are used for

223+-- generating links in the HTML documentation, for example.

224+collectBookmarks :: InPackage P.Module -> [Bookmark]

225+collectBookmarks (Local m) = map Local (collectBookmarks' m)

226+collectBookmarks (FromDep pkg m) = map (FromDep pkg) (collectBookmarks' m)

227+

228+collectBookmarks' :: P.Module -> [(P.ModuleName, String)]

229+collectBookmarks' m =

230+ map (P.getModuleName m, )

231+ (mapMaybe getDeclarationTitle

232+ (P.exportedDeclarations m))

src/Language/PureScript/Docs/ParseAndDesugar.hs+36−35

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

1{-# LANGUAGE TupleSections #-}

2+{-# LANGUAGE FlexibleContexts #-}

2

3

3module Language.PureScript.Docs.ParseAndDesugar

4module Language.PureScript.Docs.ParseAndDesugar

4 ( parseAndDesugar

5 ( parseAndDesugar

5− , ParseDesugarError(..)

6 ) where

7

8import Prelude ()

@@ -12,7 +12,6 @@ import qualified Data.Map as M

12import Control.Arrow (first)

13import Control.Monad

14

15−import Control.Monad.Trans.Except

16import Control.Monad.Writer.Strict (runWriterT)

15import Control.Monad.Writer.Strict (runWriterT)

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

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

18import Control.Monad.IO.Class (MonadIO(..))

17import Control.Monad.IO.Class (MonadIO(..))

@@ -24,73 +23,69 @@ import qualified Language.PureScript.Constants as C

24import Language.PureScript.Docs.Types

23import Language.PureScript.Docs.Types

25import Language.PureScript.Docs.Convert (collectBookmarks)

24import Language.PureScript.Docs.Convert (collectBookmarks)

26

25

27−data ParseDesugarError

28− = ParseError P.MultipleErrors

29− | SortModulesError P.MultipleErrors

30− | DesugarError P.MultipleErrors

31− deriving (Show)

32−

33-- |

26-- |

34-- Given:

27-- Given:

35--

28--

36-- * A list of local source files

29-- * A list of local source files

37-- * A list of source files from external dependencies, together with their

30-- * A list of source files from external dependencies, together with their

38-- package names

31-- package names

39−-- * A callback, taking a list of bookmarks, and a list of desugared modules

40--

32--

41-- This function does the following:

33-- This function does the following:

42--

34--

43-- * Parse all of the input and dependency source files

35-- * Parse all of the input and dependency source files

36+-- * Associate each dependency module with its package name, thereby

37+-- distinguishing these from local modules

44−-- * Partially desugar all of the resulting modules

38+-- * Partially desugar all of the resulting modules (just enough for

39+-- producing documentation from them)

45-- * Collect a list of bookmarks from the whole set of source files

40-- * 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

41+-- * Return the desugared modules, the bookmarks, and the imports/exports

47−-- dependencies)

42+-- Env (which is needed for producing documentation).

48−-- * Call the callback with the bookmarks and desugared module list.

49parseAndDesugar ::

43parseAndDesugar ::

44+ (Functor m, Applicative m, MonadError P.MultipleErrors m, MonadIO m) =>

50 [FilePath]

45 [FilePath]

51 -> [(PackageName, FilePath)]

46 -> [(PackageName, FilePath)]

52− -> ([Bookmark] -> [P.Module] -> IO a)

47+ -> m ([InPackage P.Module], [Bookmark], P.Env)

53− -> IO (Either ParseDesugarError a)

54−parseAndDesugar inputFiles depsFiles callback = do

48+parseAndDesugar inputFiles depsFiles = do

55 inputFiles' <- traverse (parseAs Local) inputFiles

49 inputFiles' <- traverse (parseAs Local) inputFiles

56 depsFiles' <- traverse (\(pkgName, f) -> parseAs (FromDep pkgName) f) depsFiles

50 depsFiles' <- traverse (\(pkgName, f) -> parseAs (FromDep pkgName) f) depsFiles

57

51

58− runExceptT $ do

59− ms <- parseFiles (inputFiles' ++ depsFiles')

52+ ms <- parseFiles (inputFiles' ++ depsFiles')

60− ms' <- sortModules (map snd ms)

53+ ms' <- sortModules (map snd ms)

61− (bs, ms'') <- desugarWithBookmarks ms ms'

54+ desugarWithBookmarks ms ms'

62− liftIO $ callback bs ms''

63

55

64parseFiles ::

56parseFiles ::

57+ (MonadError P.MultipleErrors m, MonadIO m) =>

65 [(FileInfo, FilePath)]

58 [(FileInfo, FilePath)]

66− -> ExceptT ParseDesugarError IO [(FileInfo, P.Module)]

59+ -> m [(FileInfo, P.Module)]

67parseFiles =

60parseFiles =

68− throwLeft ParseError . P.parseModulesFromFiles fileInfoToString

61+ throwLeft . P.parseModulesFromFiles fileInfoToString

69

62

70sortModules ::

63sortModules ::

64+ (Functor m, MonadError P.MultipleErrors m, MonadIO m) =>

71 [P.Module]

65 [P.Module]

72− -> ExceptT ParseDesugarError IO [P.Module]

66+ -> m [P.Module]

73sortModules =

67sortModules =

74− fmap fst . throwLeft SortModulesError . sortModules' . map importPrim

68+ fmap fst . throwLeft . sortModules' . map importPrim

75 where

69 where

76 sortModules' :: [P.Module] -> Either P.MultipleErrors ([P.Module], P.ModuleGraph)

70 sortModules' :: [P.Module] -> Either P.MultipleErrors ([P.Module], P.ModuleGraph)

77 sortModules' = P.sortModules

71 sortModules' = P.sortModules

78

72

79desugarWithBookmarks ::

73desugarWithBookmarks ::

74+ (MonadError P.MultipleErrors m, MonadIO m) =>

80 [(FileInfo, P.Module)]

75 [(FileInfo, P.Module)]

81 -> [P.Module]

76 -> [P.Module]

82− -> ExceptT ParseDesugarError IO ([Bookmark], [P.Module])

77+ -> m ([InPackage P.Module], [Bookmark], P.Env)

83desugarWithBookmarks msInfo msSorted = do

78desugarWithBookmarks msInfo msSorted = do

84− msDesugared <- throwLeft DesugarError (desugar msSorted)

79+ (env, msDesugared) <- throwLeft (desugar msSorted)

85

80

86 let msDeps = getDepsModuleNames (map (\(fp, m) -> (,m) <$> fp) msInfo)

81 let msDeps = getDepsModuleNames (map (\(fp, m) -> (,m) <$> fp) msInfo)

87 msPackages = map (addPackage msDeps) msDesugared

82 msPackages = map (addPackage msDeps) msDesugared

88 bookmarks = concatMap collectBookmarks msPackages

83 bookmarks = concatMap collectBookmarks msPackages

89

84

90− return (bookmarks, takeLocals msPackages)

85+ return (msPackages, bookmarks, env)

91

86

92−throwLeft :: (MonadError e m) => (l -> e) -> Either l r -> m r

87+throwLeft :: (MonadError l m) => Either l r -> m r

93−throwLeft f = either (throwError . f) return

88+throwLeft = either throwError return

94

89

95-- | Specifies whether a PureScript source file is considered as:

90-- | Specifies whether a PureScript source file is considered as:

96--

91--

@@ -108,18 +103,24 @@ fileInfoToString (FromDep _ fn) = fn

108importPrim :: P.Module -> P.Module

103importPrim :: P.Module -> P.Module

109importPrim = P.addDefaultImport (P.ModuleName [P.ProperName C.prim])

104importPrim = P.addDefaultImport (P.ModuleName [P.ProperName C.prim])

110

105

111−desugar :: [P.Module] -> Either P.MultipleErrors [P.Module]

106+desugar ::

107+ (Functor m, Applicative m, MonadError P.MultipleErrors m) =>

108+ [P.Module]

109+ -> m (P.Env, [P.Module])

112desugar = P.evalSupplyT 0 . desugar'

110desugar = P.evalSupplyT 0 . desugar'

113 where

111 where

114− desugar' :: [P.Module] -> P.SupplyT (Either P.MultipleErrors) [P.Module]

112+ desugar' =

115− desugar' = traverse P.desugarDoModule >=> P.desugarCasesModule >=> ignoreWarnings . P.desugarImports []

113+ traverse P.desugarDoModule

114+ >=> P.desugarCasesModule

115+ >=> ignoreWarnings . P.desugarImportsWithEnv []

116+

116 ignoreWarnings m = liftM fst (runWriterT m)

117 ignoreWarnings m = liftM fst (runWriterT m)

117

118

118parseFile :: FilePath -> IO (FilePath, String)

119parseFile :: FilePath -> IO (FilePath, String)

119parseFile input' = (,) input' <$> readFile input'

120parseFile input' = (,) input' <$> readFile input'

120

121

121−parseAs :: (FilePath -> a) -> FilePath -> IO (a, String)

122+parseAs :: (Functor m, MonadIO m) => (FilePath -> a) -> FilePath -> m (a, String)

122−parseAs g = fmap (first g) . parseFile

123+parseAs g = fmap (first g) . liftIO . parseFile

123

124

124getDepsModuleNames :: [InPackage (FilePath, P.Module)] -> M.Map P.ModuleName PackageName

125getDepsModuleNames :: [InPackage (FilePath, P.Module)] -> M.Map P.ModuleName PackageName

125getDepsModuleNames = foldl go M.empty

126getDepsModuleNames = foldl go M.empty

src/Language/PureScript/Docs/Render.hs+15−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,19 @@ 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 $ P.showQualified P.runIdent $ dequalifyCurrentModule for

65+ , keyword "as"

66+ , ident . tail . init $ declTitle

67+ ]

61

68

62− isTypeClassMember (ChildTypeClassMember _) = True

63− isTypeClassMember _ = False

64 where

69 where

65 renderType' = renderTypeWithOptions opts

70 renderType' = renderTypeWithOptions opts

71+ dequalifyCurrentModule (P.Qualified mn a)

72+ | mn == currentModule opts = P.Qualified Nothing a

73+ | otherwise = P.Qualified mn a

66

74

67renderChildDeclaration :: ChildDeclaration -> RenderedCode

75renderChildDeclaration :: ChildDeclaration -> RenderedCode

68renderChildDeclaration = renderChildDeclarationWithOptions defaultRenderTypeOptions

76renderChildDeclaration = renderChildDeclarationWithOptions defaultRenderTypeOptions

@@ -86,12 +94,12 @@ renderChildDeclarationWithOptions opts ChildDeclaration{..} =

86 where

94 where

87 renderType' = renderTypeWithOptions opts

95 renderType' = renderTypeWithOptions opts

88

96

89−renderConstraint :: (P.Qualified P.ProperName, [P.Type]) -> RenderedCode

97+renderConstraint :: P.Constraint -> RenderedCode

90renderConstraint = renderConstraintWithOptions defaultRenderTypeOptions

98renderConstraint = renderConstraintWithOptions defaultRenderTypeOptions

91

99

92−renderConstraintWithOptions :: RenderTypeOptions -> (P.Qualified P.ProperName, [P.Type]) -> RenderedCode

100+renderConstraintWithOptions :: RenderTypeOptions -> P.Constraint -> RenderedCode

93renderConstraintWithOptions opts (pn, tys) =

101renderConstraintWithOptions opts (pn, tys) =

94− renderTypeWithOptions opts $ foldl P.TypeApp (P.TypeConstructor pn) tys

102+ renderTypeWithOptions opts $ foldl P.TypeApp (P.TypeConstructor (fmap P.coerceProperName pn)) tys

95

103

96renderConstraints :: [P.Constraint] -> Maybe RenderedCode

104renderConstraints :: [P.Constraint] -> Maybe RenderedCode

97renderConstraints = renderConstraintsWithOptions defaultRenderTypeOptions

105renderConstraints = renderConstraintsWithOptions defaultRenderTypeOptions

@@ -108,7 +116,7 @@ renderConstraintsWithOptions opts constraints

108 mintersperse (syntax "," <> sp)

116 mintersperse (syntax "," <> sp)

109 (map (renderConstraintWithOptions opts) constraints)

117 (map (renderConstraintWithOptions opts) constraints)

110

118

111−notQualified :: String -> P.Qualified P.ProperName

119+notQualified :: String -> P.Qualified (P.ProperName a)

112notQualified = P.Qualified Nothing . P.ProperName

120notQualified = P.Qualified Nothing . P.ProperName

113

121

114typeApp :: String -> [(String, Maybe P.Kind)] -> P.Type

122typeApp :: 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+86−14

@@ -76,6 +76,8 @@ data Module = Module

76 { modName :: String

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 (P.Qualified P.Ident) 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)

@@ -297,6 +349,7 @@ asModule =

297 Module <$> key "name" asString

349 Module <$> key "name" 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,6 +405,9 @@ 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" asQualifiedIdent

410+ <*> key "fixity" asFixity

344 other ->

411 other ->

345 throwCustomError (InvalidDeclarationType other)

412 throwCustomError (InvalidDeclarationType other)

346

413

@@ -391,20 +458,19 @@ asConstraint :: Parse PackageError P.Constraint

391asConstraint = (,) <$> nth 0 asQualifiedProperName

458asConstraint = (,) <$> nth 0 asQualifiedProperName

392 <*> nth 1 (eachInArray asType)

459 <*> nth 1 (eachInArray asType)

393

460

394−asQualifiedProperName :: Parse e (P.Qualified P.ProperName)

461+asQualifiedProperName :: Parse e (P.Qualified (P.ProperName a))

395asQualifiedProperName = fromAesonParser

462asQualifiedProperName = fromAesonParser

396

463

464+asQualifiedIdent :: Parse e (P.Qualified P.Ident)

465+asQualifiedIdent = fromAesonParser

466+

397asBookmarks :: Parse BowerError [Bookmark]

467asBookmarks :: Parse BowerError [Bookmark]

398asBookmarks = eachInArray asBookmark

468asBookmarks = eachInArray asBookmark

399

469

400asBookmark :: Parse BowerError Bookmark

470asBookmark :: Parse BowerError Bookmark

401asBookmark =

471asBookmark =

402− build <$> key "package" (perhaps (withString parsePackageName))

403− <*> key "item" ((,) <$> nth 0 (P.moduleNameFromString <$> asString)

472+ asInPackage ((,) <$> nth 0 (P.moduleNameFromString <$> asString)

404− <*> nth 1 asString)

473+ <*> nth 1 asString)

405− where

406− build Nothing = Local

407− build (Just pn) = FromDep pn

408

474

409asResolvedDependencies :: Parse PackageError [(PackageName, Version)]

475asResolvedDependencies :: Parse PackageError [(PackageName, Version)]

410asResolvedDependencies =

476asResolvedDependencies =

@@ -449,7 +515,12 @@ instance A.ToJSON Module where

449 A.object [ "name" .= modName

515 A.object [ "name" .= modName

450 , "comments" .= modComments

516 , "comments" .= modComments

451 , "declarations" .= modDeclarations

517 , "declarations" .= modDeclarations

518+ , "reExports" .= map toObj modReExports

452 ]

519 ]

520+ where

521+ toObj (mn, decls) = A.object [ "moduleName" .= mn

522+ , "declarations" .= decls

523+ ]

453

524

454instance A.ToJSON Declaration where

525instance A.ToJSON Declaration where

455 toJSON Declaration{..} =

526 toJSON Declaration{..} =

@@ -478,6 +549,7 @@ instance A.ToJSON DeclarationInfo where

478 ExternDataDeclaration kind -> ["kind" .= kind]

549 ExternDataDeclaration kind -> ["kind" .= kind]

479 TypeSynonymDeclaration args ty -> ["arguments" .= args, "type" .= ty]

550 TypeSynonymDeclaration args ty -> ["arguments" .= args, "type" .= ty]

480 TypeClassDeclaration args super -> ["arguments" .= args, "superclasses" .= super]

551 TypeClassDeclaration args super -> ["arguments" .= args, "superclasses" .= super]

552+ AliasDeclaration for fixity -> ["for" .= for, "fixity" .= fixity]

481

553

482instance A.ToJSON ChildDeclarationInfo where

554instance A.ToJSON ChildDeclarationInfo where

483 toJSON info = A.object $ "declType" .= childDeclInfoToString info : props

555 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+172−87

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

@@ -53,63 +53,63 @@ data SimpleErrorMessage

53 | RedefinedIdent Ident

54 | OverlappingNamesInLet

55 | UnknownModule ModuleName

56− | UnknownType (Qualified ProperName)

56+ | UnknownType (Qualified (ProperName 'TypeName))

57− | UnknownTypeClass (Qualified ProperName)

57+ | UnknownTypeClass (Qualified (ProperName 'ClassName))

58 | UnknownValue (Qualified Ident)

59− | UnknownDataConstructor (Qualified ProperName) (Maybe (Qualified ProperName))

59+ | UnknownDataConstructor (Qualified (ProperName 'ConstructorName)) (Maybe (Qualified (ProperName 'ConstructorName)))

60− | UnknownTypeConstructor (Qualified ProperName)

60+ | UnknownTypeConstructor (Qualified (ProperName 'TypeName))

61− | UnknownImportType ModuleName ProperName

61+ | UnknownImportType ModuleName (ProperName 'TypeName)

62− | UnknownExportType ProperName

62+ | UnknownExportType (ProperName 'TypeName)

63− | UnknownImportTypeClass ModuleName ProperName

63+ | UnknownImportTypeClass ModuleName (ProperName 'ClassName)

64− | UnknownExportTypeClass ProperName

64+ | UnknownExportTypeClass (ProperName 'ClassName)

65 | UnknownImportValue ModuleName Ident

66 | UnknownExportValue Ident

67 | UnknownExportModule ModuleName

68− | UnknownImportDataConstructor ModuleName ProperName ProperName

68+ | UnknownImportDataConstructor ModuleName (ProperName 'TypeName) (ProperName 'ConstructorName)

69− | UnknownExportDataConstructor ProperName ProperName

69+ | UnknownExportDataConstructor (ProperName 'TypeName) (ProperName 'ConstructorName)

70 | ScopeConflict String [ModuleName]

71− | ConflictingTypeDecls ProperName

71+ | ConflictingTypeDecls (ProperName 'TypeName)

72− | ConflictingCtorDecls ProperName

72+ | ConflictingCtorDecls (ProperName 'ConstructorName)

73− | TypeConflictsWithClass ProperName

73+ | TypeConflictsWithClass (ProperName 'TypeName)

74− | CtorConflictsWithClass ProperName

74+ | CtorConflictsWithClass (ProperName 'ConstructorName)

75− | ClassConflictsWithType ProperName

75+ | ClassConflictsWithType (ProperName 'ClassName)

76− | ClassConflictsWithCtor ProperName

76+ | ClassConflictsWithCtor (ProperName 'ClassName)

77 | DuplicateModuleName ModuleName

78− | DuplicateClassExport ProperName

78+ | DuplicateClassExport (ProperName 'ClassName)

79 | DuplicateValueExport Ident

80 | DuplicateTypeArgument String

81 | InvalidDoBind

82 | InvalidDoLet

83 | CycleInDeclaration Ident

84− | CycleInTypeSynonym (Maybe ProperName)

84+ | CycleInTypeSynonym (Maybe (ProperName 'TypeName))

85 | CycleInModules [ModuleName]

86 | NameIsUndefined Ident

87− | UndefinedTypeVariable ProperName

87+ | UndefinedTypeVariable (ProperName 'TypeName)

88− | PartiallyAppliedSynonym (Qualified ProperName)

88+ | PartiallyAppliedSynonym (Qualified (ProperName 'TypeName))

89 | EscapedSkolem (Maybe Expr)

90 | TypesDoNotUnify Type Type

91 | KindsDoNotUnify Kind Kind

92 | ConstrainedTypeUnified Type Type

93− | OverlappingInstances (Qualified ProperName) [Type] [Qualified Ident]

93+ | OverlappingInstances (Qualified (ProperName 'ClassName)) [Type] [Qualified Ident]

94− | NoInstanceFound (Qualified ProperName) [Type]

94+ | NoInstanceFound (Qualified (ProperName 'ClassName)) [Type]

95− | PossiblyInfiniteInstance (Qualified ProperName) [Type]

95+ | PossiblyInfiniteInstance (Qualified (ProperName 'ClassName)) [Type]

96− | CannotDerive (Qualified ProperName) [Type]

96+ | CannotDerive (Qualified (ProperName 'ClassName)) [Type]

97− | CannotFindDerivingType ProperName

97+ | CannotFindDerivingType (ProperName 'TypeName)

98 | DuplicateLabel String (Maybe Expr)

99 | DuplicateValueDeclaration Ident

100 | ArgListLengthsDiffer Ident

101 | OverlappingArgNames (Maybe Ident)

102 | MissingClassMember Ident

103− | ExtraneousClassMember Ident (Qualified ProperName)

103+ | ExtraneousClassMember Ident (Qualified (ProperName 'ClassName))

104 | ExpectedType Type Kind

105− | IncorrectConstructorArity (Qualified ProperName)

105+ | IncorrectConstructorArity (Qualified (ProperName 'ConstructorName))

106 | ExprDoesNotHaveType Expr Type

107 | PropertyIsMissing String

108 | AdditionalProperty String

109 | CannotApplyFunction Type Expr

110 | TypeSynonymInstance

111− | OrphanInstance Ident (Qualified ProperName) [Type]

111+ | OrphanInstance Ident (Qualified (ProperName 'ClassName)) [Type]

112− | InvalidNewtype ProperName

112+ | InvalidNewtype (ProperName 'TypeName)

113 | InvalidInstanceHead Type

114 | TransitiveExportError DeclarationRef [DeclarationRef]

115 | ShadowedName Ident

@@ -120,17 +120,17 @@ data SimpleErrorMessage

120 | NotExhaustivePattern [[Binder]] Bool

121 | OverlappingPattern [[Binder]] Bool

122 | IncompleteExhaustivityCheck

123− | ClassOperator ProperName Ident

123+ | ClassOperator (ProperName 'ClassName) Ident

124− | MisleadingEmptyTypeImport ModuleName ProperName

124+ | MisleadingEmptyTypeImport ModuleName (ProperName 'TypeName)

125 | ImportHidingModule ModuleName

126 | UnusedImport ModuleName

127− | UnusedExplicitImport ModuleName [String]

127+ | UnusedExplicitImport ModuleName [String] (Maybe ModuleName) [DeclarationRef]

128− | UnusedDctorImport ProperName

128+ | UnusedDctorImport (ProperName 'TypeName)

129− | UnusedDctorExplicitImport ProperName [ProperName]

129+ | UnusedDctorExplicitImport (ProperName 'TypeName) [ProperName 'ConstructorName]

130 | DeprecatedOperatorDecl String

131 | DeprecatedQualifiedSyntax ModuleName ModuleName

132− | DeprecatedClassImport ModuleName ProperName

132+ | DeprecatedClassImport ModuleName (ProperName 'ClassName)

133− | DeprecatedClassExport ProperName

133+ | DeprecatedClassExport (ProperName 'ClassName)

134 | RedundantUnqualifiedImport ModuleName ImportDeclarationType

135 | DuplicateSelectiveImport ModuleName

136 | DuplicateImport ModuleName ImportDeclarationType (Maybe ModuleName)

@@ -138,7 +138,9 @@ data SimpleErrorMessage

138 | DuplicateExportRef String

139 | IntOutOfRange Integer String Integer Integer

140 | RedundantEmptyHidingImport ModuleName

141+ | ImplicitQualifiedImport ModuleName ModuleName [DeclarationRef]

141 | ImplicitImport ModuleName [DeclarationRef]

142 | ImplicitImport ModuleName [DeclarationRef]

143+ | HidingImport ModuleName [DeclarationRef]

142 | CaseBinderLengthDiffers Int [Binder]

144 | CaseBinderLengthDiffers Int [Binder]

143 deriving (Show)

145 deriving (Show)

144

146

@@ -147,7 +149,7 @@ data ErrorMessageHint

147 = ErrorUnifyingTypes Type Type

149 = ErrorUnifyingTypes Type Type

148 | ErrorInExpression Expr

150 | ErrorInExpression Expr

149 | ErrorInModule ModuleName

151 | ErrorInModule ModuleName

150− | ErrorInInstance (Qualified ProperName) [Type]

152+ | ErrorInInstance (Qualified (ProperName 'ClassName)) [Type]

151 | ErrorInSubsumption Type Type

153 | ErrorInSubsumption Type Type

152 | ErrorCheckingAccessor Expr String

154 | ErrorCheckingAccessor Expr String

153 | ErrorCheckingType Expr Type

155 | ErrorCheckingType Expr Type

@@ -155,11 +157,11 @@ data ErrorMessageHint

155 | ErrorCheckingGuard

157 | ErrorCheckingGuard

156 | ErrorInferringType Expr

158 | ErrorInferringType Expr

157 | ErrorInApplication Expr Type Expr

159 | ErrorInApplication Expr Type Expr

158− | ErrorInDataConstructor ProperName

160+ | ErrorInDataConstructor (ProperName 'ConstructorName)

159− | ErrorInTypeConstructor ProperName

161+ | ErrorInTypeConstructor (ProperName 'TypeName)

160 | ErrorInBindingGroup [Ident]

162 | ErrorInBindingGroup [Ident]

161 | ErrorInDataBindingGroup

163 | ErrorInDataBindingGroup

162− | ErrorInTypeSynonym ProperName

164+ | ErrorInTypeSynonym (ProperName 'TypeName)

163 | ErrorInValueDeclaration Ident

165 | ErrorInValueDeclaration Ident

164 | ErrorInTypeDeclaration Ident

166 | ErrorInTypeDeclaration Ident

165 | ErrorInForeignImport Ident

167 | ErrorInForeignImport Ident

@@ -177,6 +179,8 @@ data HintCategory

177

179

178data ErrorMessage = ErrorMessage [ErrorMessageHint] SimpleErrorMessage deriving (Show)

180data ErrorMessage = ErrorMessage [ErrorMessageHint] SimpleErrorMessage deriving (Show)

179

181

182+newtype ErrorSuggestion = ErrorSuggestion String

183+

180-- | Get the source span for an error

184-- | Get the source span for an error

181errorSpan :: ErrorMessage -> Maybe SourceSpan

185errorSpan :: ErrorMessage -> Maybe SourceSpan

182errorSpan = findHint matchSpan

186errorSpan = findHint matchSpan

@@ -309,7 +313,9 @@ errorCode em = case unwrapErrorMessage em of

309 DuplicateExportRef{} -> "DuplicateExportRef"

313 DuplicateExportRef{} -> "DuplicateExportRef"

310 IntOutOfRange{} -> "IntOutOfRange"

314 IntOutOfRange{} -> "IntOutOfRange"

311 RedundantEmptyHidingImport{} -> "RedundantEmptyHidingImport"

315 RedundantEmptyHidingImport{} -> "RedundantEmptyHidingImport"

316+ ImplicitQualifiedImport{} -> "ImplicitQualifiedImport"

312 ImplicitImport{} -> "ImplicitImport"

317 ImplicitImport{} -> "ImplicitImport"

318+ HidingImport{} -> "HidingImport"

313 CaseBinderLengthDiffers{} -> "CaseBinderLengthDiffers"

319 CaseBinderLengthDiffers{} -> "CaseBinderLengthDiffers"

314

320

315-- |

321-- |

@@ -412,11 +418,48 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse

412 gHint (ErrorInInstance cl ts) = ErrorInInstance cl <$> traverse f ts

418 gHint (ErrorInInstance cl ts) = ErrorInInstance cl <$> traverse f ts

413 gHint other = pure other

419 gHint other = pure other

414

420

421+wikiUri :: ErrorMessage -> String

422+wikiUri e = "https://github.com/purescript/purescript/wiki/Error-Code-" ++ errorCode e

423+

424+-- TODO Other possible suggestions:

425+-- WildcardInferredType - source span not small enough

426+-- DuplicateSelectiveImport - would require 2 ranges to remove and 1 insert

427+-- DeprecatedClassExport, DeprecatedClassImport, would want to replace smaller span?

428+errorSuggestion :: SimpleErrorMessage -> Maybe ErrorSuggestion

429+errorSuggestion err = case err of

430+ UnusedImport{} -> emptySuggestion

431+ RedundantEmptyHidingImport{} -> emptySuggestion

432+ DuplicateImport{} -> emptySuggestion

433+ RedundantUnqualifiedImport{} -> emptySuggestion

434+ DeprecatedQualifiedSyntax name qualName -> suggest $

435+ "import " ++ runModuleName name ++ " as " ++ runModuleName qualName

436+ UnusedExplicitImport mn _ qual refs -> suggest $ importSuggestion mn refs qual

437+ ImplicitImport mn refs -> suggest $ importSuggestion mn refs Nothing

438+ ImplicitQualifiedImport mn asModule refs -> suggest $ importSuggestion mn refs (Just asModule)

439+ _ -> Nothing

440+

441+ where

442+ emptySuggestion = Just $ ErrorSuggestion ""

443+ suggest = Just . ErrorSuggestion

444+

445+ importSuggestion :: ModuleName -> [ DeclarationRef ] -> Maybe ModuleName -> String

446+ importSuggestion mn refs qual =

447+ "import " ++ runModuleName mn ++ " (" ++ intercalate ", " (map prettyPrintRef refs) ++ ")" ++ qstr qual

448+

449+ qstr :: Maybe ModuleName -> String

450+ qstr (Just mn) = " as " ++ runModuleName mn

451+ qstr Nothing = ""

452+

453+showSuggestion :: SimpleErrorMessage -> String

454+showSuggestion suggestion = case errorSuggestion suggestion of

455+ Just (ErrorSuggestion x) -> x

456+ _ -> ""

457+

415-- |

458-- |

416-- Pretty print a single error, simplifying if necessary

459-- Pretty print a single error, simplifying if necessary

417--

460--

418−prettyPrintSingleError :: Bool -> Level -> ErrorMessage -> Box.Box

461+prettyPrintSingleError :: Bool -> Level -> Bool -> ErrorMessage -> Box.Box

419−prettyPrintSingleError full level e = flip evalState defaultUnknownMap $ do

462+prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap $ do

420 em <- onTypesInErrorMessageM replaceUnknowns (if full then e else simplifyErrorMessage e)

463 em <- onTypesInErrorMessageM replaceUnknowns (if full then e else simplifyErrorMessage e)

421 um <- get

464 um <- get

422 return (prettyPrintErrorMessage um em)

465 return (prettyPrintErrorMessage um em)

@@ -425,20 +468,19 @@ prettyPrintSingleError full level e = flip evalState defaultUnknownMap $ do

425 -- Pretty print an ErrorMessage

468 -- Pretty print an ErrorMessage

426 prettyPrintErrorMessage :: TypeMap -> ErrorMessage -> Box.Box

469 prettyPrintErrorMessage :: TypeMap -> ErrorMessage -> Box.Box

427 prettyPrintErrorMessage typeMap (ErrorMessage hints simple) =

470 prettyPrintErrorMessage typeMap (ErrorMessage hints simple) =

428− paras

471+ paras $

429 [ foldr renderHint (indent (renderSimpleErrorMessage simple)) hints

472 [ foldr renderHint (indent (renderSimpleErrorMessage simple)) hints

473+ ] ++

430− , Box.moveDown 1 typeInformation

474+ maybe [] (return . Box.moveDown 1) typeInformation ++

431− , Box.moveDown 1 $ paras [ line $ "See " ++ wikiUri ++ " for more information, "

475+ [ Box.moveDown 1 $ paras [ line $ "See " ++ wikiUri e ++ " for more information, "

432− , line $ "or to contribute content related to this " ++ levelText ++ "."

476+ , line $ "or to contribute content related to this " ++ levelText ++ "."

433− ]

477+ ]

478+ | showWiki

434 ]

479 ]

435 where

480 where

436− wikiUri :: String

481+ typeInformation :: Maybe Box.Box

437− wikiUri = "https://github.com/purescript/purescript/wiki/Error-Code-" ++ errorCode e

438−

439− typeInformation :: Box.Box

440− typeInformation | not (null types) = Box.hsep 1 Box.left [ line "where", paras types]

482+ typeInformation | not (null types) = Just $ Box.hsep 1 Box.left [ line "where", paras types ]

441− | otherwise = Box.emptyBox 0 0

483+ | otherwise = Nothing

442 where

484 where

443 types :: [Box.Box]

485 types :: [Box.Box]

444 types = map skolemInfo (M.elems (umSkolemMap typeMap)) ++

486 types = map skolemInfo (M.elems (umSkolemMap typeMap)) ++

@@ -790,9 +832,11 @@ prettyPrintSingleError full level e = flip evalState defaultUnknownMap $ do

790 renderSimpleErrorMessage (UnusedImport name) =

832 renderSimpleErrorMessage (UnusedImport name) =

791 line $ "The import of module " ++ runModuleName name ++ " is redundant"

833 line $ "The import of module " ++ runModuleName name ++ " is redundant"

792

834

793− renderSimpleErrorMessage (UnusedExplicitImport name names) =

835+ renderSimpleErrorMessage msg@(UnusedExplicitImport mn names _ _) =

794− paras [ line $ "The import of module " ++ runModuleName name ++ " contains the following unused references:"

836+ paras [ line $ "The import of module " ++ runModuleName mn ++ " contains the following unused references:"

795− , indent $ paras $ map line names ]

837+ , indent $ paras $ map line names

838+ , line $ "It could be replaced with:"

839+ , indent $ line $ showSuggestion msg ]

796

840

797 renderSimpleErrorMessage (UnusedDctorImport name) =

841 renderSimpleErrorMessage (UnusedDctorImport name) =

798 line $ "The import of type " ++ runProperName name ++ " includes data constructors but only the type is used"

842 line $ "The import of type " ++ runProperName name ++ " includes data constructors but only the type is used"

@@ -854,8 +898,19 @@ prettyPrintSingleError full level e = flip evalState defaultUnknownMap $ do

854 renderSimpleErrorMessage (RedundantEmptyHidingImport mn) =

898 renderSimpleErrorMessage (RedundantEmptyHidingImport mn) =

855 line $ "The import for module " ++ runModuleName mn ++ " is redundant as all members have been explicitly hidden."

899 line $ "The import for module " ++ runModuleName mn ++ " is redundant as all members have been explicitly hidden."

856

900

857− renderSimpleErrorMessage (ImplicitImport mn refs) =

901+ renderSimpleErrorMessage msg@(ImplicitQualifiedImport importedModule asModule _) =

902+ paras [ line $ "Module " ++ runModuleName importedModule ++ " was imported as " ++ runModuleName asModule ++ " with unspecified imports."

903+ , line $ "As there are multiple modules being imported as " ++ runModuleName asModule ++ ", consider using the explicit form:"

904+ , indent $ line $ showSuggestion msg

905+ ]

906+

907+ renderSimpleErrorMessage msg@(ImplicitImport mn _) =

858 paras [ line $ "Module " ++ runModuleName mn ++ " has unspecified imports, consider using the explicit form: "

908 paras [ line $ "Module " ++ runModuleName mn ++ " has unspecified imports, consider using the explicit form: "

909+ , indent $ line $ showSuggestion msg

910+ ]

911+

912+ renderSimpleErrorMessage (HidingImport mn refs) =

913+ paras [ line $ "Module " ++ runModuleName mn ++ " has unspecified imports, consider using the inclusive form: "

859 , indent $ line $ "import " ++ runModuleName mn ++ " (" ++ intercalate ", " (map prettyPrintRef refs) ++ ")"

914 , indent $ line $ "import " ++ runModuleName mn ++ " (" ++ intercalate ", " (map prettyPrintRef refs) ++ ")"

860 ]

915 ]

861

916

@@ -992,37 +1047,13 @@ prettyPrintSingleError full level e = flip evalState defaultUnknownMap $ do

992 paras :: [Box.Box] -> Box.Box

1047 paras :: [Box.Box] -> Box.Box

993 paras = Box.vcat Box.left

1048 paras = Box.vcat Box.left

994

1049

995− -- Pretty print and export declaration

996− prettyPrintExport :: DeclarationRef -> String

997− prettyPrintExport (TypeRef pn _) = runProperName pn

998− prettyPrintExport ref = prettyPrintRef ref

999−

1000− prettyPrintRef :: DeclarationRef -> String

1001− prettyPrintRef (TypeRef pn Nothing) = runProperName pn ++ "(..)"

1002− prettyPrintRef (TypeRef pn (Just [])) = runProperName pn

1003− prettyPrintRef (TypeRef pn (Just dctors)) = runProperName pn ++ "(" ++ intercalate ", " (map runProperName dctors) ++ ")"

1004− prettyPrintRef (ValueRef ident) = showIdent ident

1005− prettyPrintRef (TypeClassRef pn) = "class " ++ runProperName pn

1006− prettyPrintRef (ProperRef pn) = runProperName pn

1007− prettyPrintRef (TypeInstanceRef ident) = showIdent ident

1008− prettyPrintRef (ModuleRef name) = "module " ++ runModuleName name

1009− prettyPrintRef (PositionedDeclarationRef _ _ ref) = prettyPrintExport ref

1010−

1011− prettyPrintImport :: ModuleName -> ImportDeclarationType -> Maybe ModuleName -> String

1012− prettyPrintImport mn idt qual =

1013− let i = case idt of

1014− Implicit -> runModuleName mn

1015− Explicit refs -> runModuleName mn ++ " (" ++ intercalate ", " (map prettyPrintRef refs) ++ ")"

1016− Hiding refs -> runModuleName mn ++ " hiding (" ++ intercalate "," (map prettyPrintRef refs) ++ ")"

1017− in i ++ maybe "" (\q -> " as " ++ runModuleName q) qual

1018−

1019 -- | Simplify an error message

1050 -- | Simplify an error message

1020 simplifyErrorMessage :: ErrorMessage -> ErrorMessage

1051 simplifyErrorMessage :: ErrorMessage -> ErrorMessage

1021 simplifyErrorMessage (ErrorMessage hints simple) = ErrorMessage (simplifyHints hints) simple

1052 simplifyErrorMessage (ErrorMessage hints simple) = ErrorMessage (simplifyHints hints) simple

1022 where

1053 where

1023 -- Take the last instance of each "hint category"

1054 -- Take the last instance of each "hint category"

1024 simplifyHints :: [ErrorMessageHint] -> [ErrorMessageHint]

1055 simplifyHints :: [ErrorMessageHint] -> [ErrorMessageHint]

1025− simplifyHints = reverse . nubBy categoriesEqual . reverse

1056+ simplifyHints = reverse . nubBy categoriesEqual . stripRedudantHints simple . reverse

1026

1057

1027 -- Don't remove hints in the "other" category

1058 -- Don't remove hints in the "other" category

1028 categoriesEqual :: ErrorMessageHint -> ErrorMessageHint -> Bool

1059 categoriesEqual :: ErrorMessageHint -> ErrorMessageHint -> Bool

@@ -1032,6 +1063,30 @@ prettyPrintSingleError full level e = flip evalState defaultUnknownMap $ do

1032 (_, OtherHint) -> False

1063 (_, OtherHint) -> False

1033 (c1, c2) -> c1 == c2

1064 (c1, c2) -> c1 == c2

1034

1065

1066+ -- | See https://github.com/purescript/purescript/issues/1802

1067+ stripRedudantHints :: SimpleErrorMessage -> [ErrorMessageHint] -> [ErrorMessageHint]

1068+ stripRedudantHints CannotApplyFunction{} = stripFirst isApplicationHint

1069+ where

1070+ isApplicationHint ErrorInApplication{} = True

1071+ isApplicationHint _ = False

1072+ stripRedudantHints ExprDoesNotHaveType{} = stripFirst isCheckHint

1073+ where

1074+ isCheckHint ErrorCheckingType{} = True

1075+ isCheckHint _ = False

1076+ stripRedudantHints TypesDoNotUnify{} = stripFirst isUnifyHint

1077+ where

1078+ isUnifyHint ErrorUnifyingTypes{} = True

1079+ isUnifyHint _ = False

1080+ stripRedudantHints _ = id

1081+

1082+ stripFirst :: (ErrorMessageHint -> Bool) -> [ErrorMessageHint] -> [ErrorMessageHint]

1083+ stripFirst p (PositionedError pos : hs) = PositionedError pos : stripFirst p hs

1084+ stripFirst p (ErrorInModule mn : hs) = ErrorInModule mn : stripFirst p hs

1085+ stripFirst p (hint : hs)

1086+ | p hint = hs

1087+ | otherwise = hint : hs

1088+ stripFirst _ [] = []

1089+

1035 hintCategory :: ErrorMessageHint -> HintCategory

1090 hintCategory :: ErrorMessageHint -> HintCategory

1036 hintCategory ErrorCheckingType{} = ExprHint

1091 hintCategory ErrorCheckingType{} = ExprHint

1037 hintCategory ErrorInferringType{} = ExprHint

1092 hintCategory ErrorInferringType{} = ExprHint

@@ -1043,6 +1098,30 @@ prettyPrintSingleError full level e = flip evalState defaultUnknownMap $ do

1043 hintCategory PositionedError{} = PositionHint

1098 hintCategory PositionedError{} = PositionHint

1044 hintCategory _ = OtherHint

1099 hintCategory _ = OtherHint

1045

1100

1101+-- Pretty print and export declaration

1102+prettyPrintExport :: DeclarationRef -> String

1103+prettyPrintExport (TypeRef pn _) = runProperName pn

1104+prettyPrintExport ref = prettyPrintRef ref

1105+

1106+prettyPrintImport :: ModuleName -> ImportDeclarationType -> Maybe ModuleName -> String

1107+prettyPrintImport mn idt qual =

1108+ let i = case idt of

1109+ Implicit -> runModuleName mn

1110+ Explicit refs -> runModuleName mn ++ " (" ++ intercalate ", " (map prettyPrintRef refs) ++ ")"

1111+ Hiding refs -> runModuleName mn ++ " hiding (" ++ intercalate "," (map prettyPrintRef refs) ++ ")"

1112+ in i ++ maybe "" (\q -> " as " ++ runModuleName q) qual

1113+

1114+prettyPrintRef :: DeclarationRef -> String

1115+prettyPrintRef (TypeRef pn Nothing) = runProperName pn ++ "(..)"

1116+prettyPrintRef (TypeRef pn (Just [])) = runProperName pn

1117+prettyPrintRef (TypeRef pn (Just dctors)) = runProperName pn ++ "(" ++ intercalate ", " (map runProperName dctors) ++ ")"

1118+prettyPrintRef (ValueRef ident) = showIdent ident

1119+prettyPrintRef (TypeClassRef pn) = "class " ++ runProperName pn

1120+prettyPrintRef (ProperRef name) = name

1121+prettyPrintRef (TypeInstanceRef ident) = showIdent ident

1122+prettyPrintRef (ModuleRef name) = "module " ++ runModuleName name

1123+prettyPrintRef (PositionedDeclarationRef _ _ ref) = prettyPrintExport ref

1124+

1046-- |

1125-- |

1047-- Pretty print multiple errors

1126-- Pretty print multiple errors

1048--

1127--

@@ -1065,12 +1144,12 @@ prettyPrintMultipleErrorsBox full = prettyPrintMultipleErrorsWith Error "Error f

1065

1144

1066prettyPrintMultipleErrorsWith :: Level -> String -> String -> Bool -> MultipleErrors -> Box.Box

1145prettyPrintMultipleErrorsWith :: Level -> String -> String -> Bool -> MultipleErrors -> Box.Box

1067prettyPrintMultipleErrorsWith level intro _ full (MultipleErrors [e]) =

1146prettyPrintMultipleErrorsWith level intro _ full (MultipleErrors [e]) =

1068− let result = prettyPrintSingleError full level e

1147+ let result = prettyPrintSingleError full level True e

1069 in Box.vcat Box.left [ Box.text intro

1148 in Box.vcat Box.left [ Box.text intro

1070 , result

1149 , result

1071 ]

1150 ]

1072prettyPrintMultipleErrorsWith level _ intro full (MultipleErrors es) =

1151prettyPrintMultipleErrorsWith level _ intro full (MultipleErrors es) =

1073− let result = map (prettyPrintSingleError full level) es

1152+ let result = map (prettyPrintSingleError full level True) es

1074 in Box.vsep 1 Box.left $ concat $ zipWith withIntro [1 :: Int ..] result

1153 in Box.vsep 1 Box.left $ concat $ zipWith withIntro [1 :: Int ..] result

1075 where

1154 where

1076 withIntro i err = [ Box.text (intro ++ " " ++ show i ++ " of " ++ show (length es) ++ ":")

1155 withIntro i err = [ Box.text (intro ++ " " ++ show i ++ " of " ++ show (length es) ++ ":")

@@ -1133,9 +1212,15 @@ line :: String -> Box.Box

1133line = Box.text

1212line = Box.text

1134

1213

1135renderBox :: Box.Box -> String

1214renderBox :: Box.Box -> String

1136−renderBox = unlines . map trimEnd . lines . Box.render

1215+renderBox = unlines

1216+ . map (dropWhileEnd isSpace)

1217+ . dropWhile whiteSpace

1218+ . dropWhileEnd whiteSpace

1219+ . lines

1220+ . Box.render

1137 where

1221 where

1138− trimEnd = reverse . dropWhile (== ' ') . reverse

1222+ dropWhileEnd p = reverse . dropWhile p . reverse

1223+ whiteSpace = all isSpace

1139

1224

1140-- |

1225-- |

1141-- Rethrow an error with a more detailed error message in the case of failure

1226-- Rethrow an error with a more detailed error message in the case of failure

src/Language/PureScript/Externs.hs+12−12

@@ -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 (Qualified Ident)

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]

@@ -178,7 +178,7 @@ moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..}

178 Just (kind, tk@(DataType _ tys)) ->

179 EDType pn kind tk : [ EDDataConstructor dctor dty pn ty args

180 | dctor <- fromMaybe (map fst tys) dctors

181− , (dty, _, ty, args) <- maybeToList (M.lookup (Qualified (Just mn) dctor) (dataConstructors env))

181+ , (dty, _, ty, args) <- maybeToList (Qualified (Just mn) dctor `M.lookup` dataConstructors env)

182 ]

183 _ -> internalError "toExternsDeclaration: Invalid input"

184 toExternsDeclaration (ValueRef ident)

@@ -186,10 +186,10 @@ moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..}

186 = [ EDValue ident ty ]

187 toExternsDeclaration (TypeClassRef className)

188 | Just (args, members, implies) <- Qualified (Just mn) className `M.lookup` typeClasses env

189− , Just (kind, TypeSynonym) <- M.lookup (Qualified (Just mn) className) (types env)

189+ , Just (kind, TypeSynonym) <- Qualified (Just mn) (coerceProperName className) `M.lookup` types env

190− , Just (_, synTy) <- Qualified (Just mn) className `M.lookup` typeSynonyms env

190+ , Just (_, synTy) <- Qualified (Just mn) (coerceProperName className) `M.lookup` typeSynonyms env

191− = [ EDType className kind TypeSynonym

191+ = [ EDType (coerceProperName className) kind TypeSynonym

192− , EDTypeSynonym className args synTy

192+ , EDTypeSynonym (coerceProperName className) args synTy

193 , EDClass className args members implies

194 ]

195 toExternsDeclaration (TypeInstanceRef ident)

src/Language/PureScript/Kinds.hs+2−17

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

src/Language/PureScript/Linter/Exhaustive.hs+39−49

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

@@ -43,18 +31,22 @@ import Language.PureScript.Kinds

43import Language.PureScript.Types as P

31import Language.PureScript.Types as P

44import Language.PureScript.Errors

32import Language.PureScript.Errors

45

33

46−-- | There are two modes of failure for the redudancy check:

34+-- | There are two modes of failure for the redundancy check:

47--

35--

48-- 1. Exhaustivity was incomplete due to too many cases, so we couldn't determine redundancy.

36-- 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.

37-- 2. We didn't attempt to determine redundancy for a binder, e.g. an integer binder.

50--

38--

51-- We want to warn the user in the first case.

39-- We want to warn the user in the first case.

52−data RedudancyError = Incomplete | Unknown

40+data RedundancyError = Incomplete | Unknown

53

41

54-- |

42-- |

55-- Qualifies a propername from a given qualified propername and a default module name

43-- Qualifies a propername from a given qualified propername and a default module name

56--

44--

57−qualifyName :: a -> ModuleName -> Qualified a -> Qualified a

45+qualifyName

46+ :: (ProperName a)

47+ -> ModuleName

48+ -> Qualified (ProperName b)

49+ -> Qualified (ProperName a)

58qualifyName n defmn qn = Qualified (Just mn) n

50qualifyName n defmn qn = Qualified (Just mn) n

59 where

51 where

60 (mn, _) = qualify defmn qn

52 (mn, _) = qualify defmn qn

@@ -65,31 +57,28 @@ qualifyName n defmn qn = Qualified (Just mn) n

65-- where: - ProperName is the name of the constructor (for example, "Nothing" in Maybe)

57-- 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"])

58-- - [Type] is the list of arguments, if it has (for example, "Just" has [TypeVar "a"])

67--

59--

68−getConstructors :: Environment -> ModuleName -> Qualified ProperName -> [(ProperName, [Type])]

60+getConstructors :: Environment -> ModuleName -> Qualified (ProperName 'ConstructorName) -> [(ProperName 'ConstructorName, [Type])]

69getConstructors env defmn n = extractConstructors lnte

61getConstructors env defmn n = extractConstructors lnte

70 where

62 where

71− qpn :: Qualified ProperName

72− qpn = getConsDataName n

73

63

74− getConsDataName :: Qualified ProperName -> Qualified ProperName

64+ extractConstructors :: Maybe (Kind, TypeKind) -> [(ProperName 'ConstructorName, [Type])]

75− getConsDataName con = qualifyName nm defmn con

65+ extractConstructors (Just (_, DataType _ pt)) = pt

76− where

66+ 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

67

87 lnte :: Maybe (Kind, TypeKind)

68 lnte :: Maybe (Kind, TypeKind)

88 lnte = M.lookup qpn (types env)

69 lnte = M.lookup qpn (types env)

89

70

90− extractConstructors :: Maybe (Kind, TypeKind) -> [(ProperName, [Type])]

71+ qpn :: Qualified (ProperName 'TypeName)

91− extractConstructors (Just (_, DataType _ pt)) = pt

72+ qpn = getConsDataName n

73+

74+ getConsDataName :: Qualified (ProperName 'ConstructorName) -> Qualified (ProperName 'TypeName)

75+ getConsDataName con =

76+ case getConsInfo con of

92− extractConstructors _ = internalError "Data name not in the scope of the current environment in extractConstructors"

77+ Nothing -> internalError $ "Constructor " ++ showQualified runProperName con ++ " not in the scope of the current environment in getConsDataName."

78+ Just (_, pm, _, _) -> qualifyName pm defmn con

79+

80+ getConsInfo :: Qualified (ProperName 'ConstructorName) -> Maybe (DataDeclType, ProperName 'TypeName, Type, [Ident])

81+ getConsInfo con = M.lookup con (dataConstructors env)

93

82

94-- |

83-- |

95-- Replicates a wildcard binder

84-- Replicates a wildcard binder

@@ -117,7 +106,7 @@ genericMerge f bsl@((s, b):bs) bsr@((s', b'):bs')

117-- Find the uncovered set between two binders:

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

107-- the first binder is the case we are trying to cover, the second one is the matching binder

119--

108--

120−missingCasesSingle :: Environment -> ModuleName -> Binder -> Binder -> ([Binder], Either RedudancyError Bool)

109+missingCasesSingle :: Environment -> ModuleName -> Binder -> Binder -> ([Binder], Either RedundancyError Bool)

121missingCasesSingle _ _ _ NullBinder = ([], return True)

110missingCasesSingle _ _ _ NullBinder = ([], return True)

122missingCasesSingle _ _ _ (VarBinder _) = ([], return True)

111missingCasesSingle _ _ _ (VarBinder _) = ([], return True)

123missingCasesSingle env mn (VarBinder _) b = missingCasesSingle env mn NullBinder b

112missingCasesSingle env mn (VarBinder _) b = missingCasesSingle env mn NullBinder b

@@ -186,7 +175,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

175-- 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.

176-- (which ought to be available soon), or increase the complexity of the algorithm.

188--

177--

189−missingCasesMultiple :: Environment -> ModuleName -> [Binder] -> [Binder] -> ([[Binder]], Either RedudancyError Bool)

178+missingCasesMultiple :: Environment -> ModuleName -> [Binder] -> [Binder] -> ([[Binder]], Either RedundancyError Bool)

190missingCasesMultiple env mn = go

179missingCasesMultiple env mn = go

191 where

180 where

192 go [] [] = ([], pure True)

181 go [] [] = ([], pure True)

@@ -214,16 +203,17 @@ isExhaustiveGuard (Left gs) = not . null $ filter (\(g, _) -> isOtherwise g) gs

214 isOtherwise :: Expr -> Bool

203 isOtherwise :: Expr -> Bool

215 isOtherwise (TypedValue _ (BooleanLiteral True) _) = True

204 isOtherwise (TypedValue _ (BooleanLiteral True) _) = True

216 isOtherwise (TypedValue _ (Var (Qualified (Just (ModuleName [ProperName "Prelude"])) (Ident "otherwise"))) _) = True

205 isOtherwise (TypedValue _ (Var (Qualified (Just (ModuleName [ProperName "Prelude"])) (Ident "otherwise"))) _) = True

206+ isOtherwise (TypedValue _ (Var (Qualified (Just (ModuleName [ProperName "Data", ProperName "Boolean"])) (Ident "otherwise"))) _) = True

217 isOtherwise _ = False

207 isOtherwise _ = False

218isExhaustiveGuard (Right _) = True

208isExhaustiveGuard (Right _) = True

219

209

220-- |

210-- |

221-- Returns the uncovered set of case alternatives

211-- Returns the uncovered set of case alternatives

222--

212--

223−missingCases :: Environment -> ModuleName -> [Binder] -> CaseAlternative -> ([[Binder]], Either RedudancyError Bool)

213+missingCases :: Environment -> ModuleName -> [Binder] -> CaseAlternative -> ([[Binder]], Either RedundancyError Bool)

224missingCases env mn uncovered ca = missingCasesMultiple env mn uncovered (caseAlternativeBinders ca)

214missingCases env mn uncovered ca = missingCasesMultiple env mn uncovered (caseAlternativeBinders ca)

225

215

226−missingAlternative :: Environment -> ModuleName -> CaseAlternative -> [Binder] -> ([[Binder]], Either RedudancyError Bool)

216+missingAlternative :: Environment -> ModuleName -> CaseAlternative -> [Binder] -> ([[Binder]], Either RedundancyError Bool)

227missingAlternative env mn ca uncovered

217missingAlternative env mn ca uncovered

228 | isExhaustiveGuard (caseAlternativeResult ca) = mcases

218 | isExhaustiveGuard (caseAlternativeResult ca) = mcases

229 | otherwise = ([uncovered], snd mcases)

219 | otherwise = ([uncovered], snd mcases)

@@ -239,13 +229,13 @@ missingAlternative env mn ca uncovered

239checkExhaustive :: forall m. (MonadWriter MultipleErrors m) => Bool -> Environment -> ModuleName -> Int -> [CaseAlternative] -> m ()

229checkExhaustive :: 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

230checkExhaustive hasConstraint env mn numArgs cas = makeResult . first nub $ foldl' step ([initialize numArgs], (pure True, [])) cas

241 where

231 where

242− step :: ([[Binder]], (Either RedudancyError Bool, [[Binder]])) -> CaseAlternative -> ([[Binder]], (Either RedudancyError Bool, [[Binder]]))

232+ step :: ([[Binder]], (Either RedundancyError Bool, [[Binder]])) -> CaseAlternative -> ([[Binder]], (Either RedundancyError Bool, [[Binder]]))

243 step (uncovered, (nec, redundant)) ca =

233 step (uncovered, (nec, redundant)) ca =

244 let (missed, pr) = unzip (map (missingAlternative env mn ca) uncovered)

234 let (missed, pr) = unzip (map (missingAlternative env mn ca) uncovered)

245 (missed', approx) = splitAt 10000 (nub (concat missed))

235 (missed', approx) = splitAt 10000 (nub (concat missed))

246− cond = liftA2 (&&) (or <$> sequenceA pr) nec

236+ cond = or <$> sequenceA pr

247 in (missed', ( if null approx

237 in (missed', ( if null approx

248− then cond

238+ then liftA2 (&&) cond nec

249 else Left Incomplete

239 else Left Incomplete

250 , if either (const True) id cond

240 , if either (const True) id cond

251 then redundant

241 then redundant

@@ -253,7 +243,7 @@ checkExhaustive hasConstraint env mn numArgs cas = makeResult . first nub $ fold

253 )

243 )

254 )

244 )

255

245

256− makeResult :: ([[Binder]], (Either RedudancyError Bool, [[Binder]])) -> m ()

246+ makeResult :: ([[Binder]], (Either RedundancyError Bool, [[Binder]])) -> m ()

257 makeResult (bss, (rr, bss')) =

247 makeResult (bss, (rr, bss')) =

258 do unless (hasConstraint || null bss) tellNonExhaustive

248 do unless (hasConstraint || null bss) tellNonExhaustive

259 unless (null bss') tellRedundant

249 unless (null bss') tellRedundant

@@ -303,14 +293,14 @@ checkExhaustiveDecls env mn = mapM_ onDecl

303 hasPartialConstraint :: Type -> Bool

293 hasPartialConstraint :: Type -> Bool

304 hasPartialConstraint (ConstrainedType cs _) = any (go . fst) cs

294 hasPartialConstraint (ConstrainedType cs _) = any (go . fst) cs

305 where

295 where

306− go :: Qualified ProperName -> Bool

296+ go :: Qualified (ProperName 'ClassName) -> Bool

307 go qname

297 go qname

308 | qname == partialClass = True

298 | qname == partialClass = True

309 | otherwise =

299 | otherwise =

310 case qname `M.lookup` typeClasses env of

300 case qname `M.lookup` typeClasses env of

311 Just ([], _, cs') -> any (go . fst) cs'

301 Just ([], _, cs') -> any (go . fst) cs'

312 _ -> False

302 _ -> False

313− partialClass :: Qualified ProperName

303+ partialClass :: Qualified (ProperName 'ClassName)

314 partialClass = primName "Partial"

304 partialClass = primName "Partial"

315 hasPartialConstraint _ = False

305 hasPartialConstraint _ = False

316

306

src/Language/PureScript/Linter/Imports.hs+242−89

@@ -1,18 +1,23 @@

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

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 qualified Data.Map as M

16

21

17import Language.PureScript.AST.Declarations

22import Language.PureScript.AST.Declarations

18import Language.PureScript.AST.SourcePos

23import Language.PureScript.AST.SourcePos

@@ -28,125 +33,271 @@ import qualified Language.PureScript.Constants as C

28-- | Imported name used in some type or expression.

33-- | Imported name used in some type or expression.

29data Name

34data Name

30 = IdentName (Qualified Ident)

35 = IdentName (Qualified Ident)

31− | TypeName (Qualified ProperName)

36+ | TyName (Qualified (ProperName 'TypeName))

32− | DctorName (Qualified ProperName)

37+ | DctorName (Qualified (ProperName 'ConstructorName))

33− | ClassName (Qualified ProperName)

38+ | TyClassName (Qualified (ProperName 'ClassName))

34− deriving (Eq)

39+ deriving (Eq, Show)

35

40

36−getIdentName :: Name -> Maybe Ident

41+getIdentName :: Maybe ModuleName -> Name -> Maybe Ident

37−getIdentName (IdentName (Qualified _ name)) = Just name

42+getIdentName q (IdentName (Qualified q' name)) | q == q' = Just name

38−getIdentName _ = Nothing

43+getIdentName _ _ = Nothing

39

44

40−getTypeName :: Name -> Maybe ProperName

45+getTypeName :: Maybe ModuleName -> Name -> Maybe (ProperName 'TypeName)

41−getTypeName (TypeName (Qualified _ name)) = Just name

46+getTypeName q (TyName (Qualified q' name)) | q == q' = Just name

42−getTypeName _ = Nothing

47+getTypeName _ _ = Nothing

43

48

44−getClassName :: Name -> Maybe ProperName

49+getClassName :: Maybe ModuleName -> Name -> Maybe (ProperName 'ClassName)

45−getClassName (ClassName (Qualified _ name)) = Just name

50+getClassName q (TyClassName (Qualified q' name)) | q == q' = Just name

46−getClassName _ = Nothing

51+getClassName _ _ = Nothing

47

52

48-- | Map of module name to list of imported names from that module which have been used.

53-- | Map of module name to list of imported names from that module which have been used.

49type UsedImports = M.Map ModuleName [Name]

54type UsedImports = M.Map ModuleName [Name]

50

55

51-- |

56-- |

57+-- Find and warn on:

58+--

52−-- Find and warn on any unused import statements (qualified or unqualified)

59+-- * Unused import statements (qualified or unqualified)

60+--

53−-- or references in an explicit import list.

61+-- * Unused references in an explicit import list

54--

62--

63+-- * Implicit imports of modules

64+--

65+-- * Implicit imports into a virtual module (unless the virtual module only has

66+-- members from one module imported)

67+--

68+-- * Imports using `hiding` (this is another form of implicit importing)

69+--

70+lintImports

71+ :: forall m

55−findUnusedImports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Module -> Env -> UsedImports -> m ()

72+ . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

73+ => Module

74+ -> Env

75+ -> UsedImports

76+ -> m ()

56−findUnusedImports (Module _ _ _ mdecls mexports) env usedImps = do

77+lintImports (Module _ _ mn mdecls mexports) env usedImps = do

78+

79+ let scope = maybe nullImports (\(_, imps, _) -> imps) (M.lookup mn env)

80+ usedImps' = foldr (elaborateUsed scope) usedImps exportedModules

81+

57− imps <- findImports mdecls

82+ imps <- M.toAscList <$> findImports mdecls

83+

58− forM_ (M.toAscList imps) $ \(mni, decls) -> unless (mni `elem` alwaysUsedModules) $

84+ forM_ imps $ \(mni, decls) ->

85+ unless (isPrim mni) $ do

59− forM_ decls $ \(ss, declType, qualifierName) ->

86+ forM_ decls $ \(ss, declType, qualifierName) ->

60− censor (onErrorMessages $ addModuleLocError ss) $ unless (qnameUsed qualifierName) $

87+ censor (onErrorMessages $ addModuleLocError ss) $ do

61− let names = nub $ M.findWithDefault [] mni usedImps

88+ let names = nub $ M.findWithDefault [] mni usedImps'

62− usedNames = mapMaybe (matchName (typeForDCtor mni) qualifierName) names

89+ lintImportDecl env mni qualifierName names declType

63− usedDctors = mapMaybe (matchDctor qualifierName) names

90+

64− in case declType of

91+ forM_ (M.toAscList (byQual imps)) $ \(mnq, entries) -> do

65− Implicit | isNothing qualifierName ->

92+ let mnis = nub $ map (\(_, _, mni) -> mni) entries

66− let classRefs = TypeClassRef <$> mapMaybe getClassName names

93+ unless (length mnis == 1) $ do

67− valueRefs = ValueRef <$> mapMaybe getIdentName names

94+ let implicits = filter (\(_, declType, _) -> not $ isExplicit declType) entries

68− types = mapMaybe getTypeName names

95+ forM_ implicits $ \(ss, _, mni) ->

69− typesWithDctors = reconstructTypeRefs mni usedDctors

96+ censor (onErrorMessages $ addModuleLocError ss) $ do

70− typesWithoutDctors = filter (`M.notMember` typesWithDctors) types

97+ let names = nub $ M.findWithDefault [] mni usedImps'

71− typesRefs

98+ usedRefs = findUsedRefs env mni (Just mnq) names

72− = map (flip TypeRef (Just [])) typesWithoutDctors

99+ unless (null usedRefs) $

73− ++ map (\(ty, ds) -> TypeRef ty (Just ds)) (M.toList typesWithDctors)

100+ tell $ errorMessage $ ImplicitQualifiedImport mni mnq usedRefs

74− in tell $ errorMessage $ ImplicitImport mni (classRefs ++ typesRefs ++ valueRefs)

101+

75− Explicit declrefs -> do

76− let idents = nub (mapMaybe runDeclRef declrefs)

77− let diff = idents \\ usedNames

78− case (length diff, length idents) of

79− (0, _) -> return ()

80− (n, m) | n == m -> tell $ errorMessage $ UnusedImport mni

81− _ -> tell $ errorMessage $ UnusedExplicitImport mni diff

82−

83− -- If we've not already warned a type is unused, check its data constructors

84− forM_ (mapMaybe getTypeRef declrefs) $ \(tn, c) -> do

85− let allCtors = dctorsForType mni tn

86− when (runProperName tn `elem` usedNames) $ case (c, null $ usedDctors `intersect` allCtors) of

87− (Nothing, True) -> tell $ errorMessage $ UnusedDctorImport tn

88− (Just (_:_), True) -> tell $ errorMessage $ UnusedDctorImport tn

89− (Just ctors, _) ->

90− let ddiff = ctors \\ usedDctors

91− in unless (null ddiff) $ tell $ errorMessage $ UnusedDctorExplicitImport tn ddiff

92− _ -> return ()

93−

94− return ()

102+ return ()

95−

103+

96− _ -> return ()

97 where

104 where

98− reconstructTypeRefs :: ModuleName -> [ProperName] -> M.Map ProperName [ProperName]

99− reconstructTypeRefs mni = foldr accumDctors M.empty

100− where

101− accumDctors dctor = M.alter (Just . maybe [dctor] (dctor :)) (findTypeForDctor mni dctor)

102

105

103− findTypeForDctor :: ModuleName -> ProperName -> ProperName

106+ -- Checks whether a module is the Prim module - used to suppress any checks

104− findTypeForDctor mn dctor =

107+ -- made, as Prim is always implicitly imported.

105− case mn `M.lookup` env of

108+ isPrim :: ModuleName -> Bool

106− Just (_, _, exps) ->

109+ isPrim = (== ModuleName [ProperName C.prim])

107− case find (elem dctor . snd . fst) (exportedTypes exps) of

110+

108− Just ((ty, _), _) -> ty

111+ -- Creates a map of virtual modules mapped to all the declarations that

109− Nothing -> internalError $ "missing type for data constructor " ++ runProperName dctor ++ " in findTypeForDctor"

112+ -- import to that module, with the corresponding source span, import type,

110− Nothing -> internalError $ "missing module " ++ runModuleName mn ++ " in findTypeForDctor"

113+ -- and module being imported

114+ byQual

115+ :: [(ModuleName, [(Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)])]

116+ -> M.Map ModuleName [(Maybe SourceSpan, ImportDeclarationType, ModuleName)]

117+ byQual = foldr goImp M.empty

118+ where

119+ goImp (mni, xs) acc = foldr (goDecl mni) acc xs

120+ goDecl mni (ss, declType, Just qmn) acc =

121+ let entry = (ss, declType, mni)

122+ in M.alter (Just . maybe [entry] (entry :)) qmn acc

123+ goDecl _ _ acc = acc

111

124

112− -- rely on exports being elaborated by this point

125+ -- The list of modules that are being re-exported by the current module. Any

113− alwaysUsedModules :: [ ModuleName ]

126+ -- module that appears in this list is always considered to be used.

127+ exportedModules :: [ModuleName]

114− alwaysUsedModules = ModuleName [ProperName C.prim] : maybe [] (mapMaybe extractModule) mexports

128+ exportedModules = nub $ maybe [] (mapMaybe extractModule) mexports

115 where

129 where

116 extractModule (PositionedDeclarationRef _ _ r) = extractModule r

130 extractModule (PositionedDeclarationRef _ _ r) = extractModule r

117− extractModule (ModuleRef mn) = Just mn

131+ extractModule (ModuleRef mne) = Just mne

118 extractModule _ = Nothing

132 extractModule _ = Nothing

119

133

134+ -- Elaborates the UsedImports to include values from modules that are being

135+ -- re-exported. This ensures explicit export hints are printed for modules

136+ -- that are implicitly exported and then re-exported.

137+ elaborateUsed :: Imports -> ModuleName -> UsedImports -> UsedImports

138+ elaborateUsed scope mne used =

139+ let classes = extractByQual mne (importedTypeClasses scope) TyClassName

140+ types = extractByQual mne (importedTypes scope) TyName

141+ dctors = extractByQual mne (importedDataConstructors scope) DctorName

142+ values = extractByQual mne (importedValues scope) IdentName

143+ in foldr go used (classes ++ types ++ dctors ++ values)

144+ where

145+ go :: (ModuleName, Name) -> UsedImports -> UsedImports

146+ go (q, name) acc = M.alter (Just . maybe [name] (name :)) q acc

147+

148+ extractByQual

149+ :: (Eq a)

150+ => ModuleName

151+ -> M.Map (Qualified a) [(Qualified a, ModuleName)]

152+ -> (Qualified a -> Name)

153+ -> [(ModuleName, Name)]

154+ extractByQual k m toName = mapMaybe go (M.toList m)

155+ where

156+ go (q@(Qualified mnq _), is) | isUnqualified q || isQualifiedWith k q =

157+ case fst (head is) of

158+ Qualified (Just mn') name -> Just (mn', toName $ Qualified mnq name)

159+ _ -> internalError "unqualified name in extractByQual"

160+ go _ = Nothing

161+

162+lintImportDecl

163+ :: forall m

164+ . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

165+ => Env

166+ -> ModuleName

120− qnameUsed :: Maybe ModuleName -> Bool

167+ -> Maybe ModuleName

121− qnameUsed (Just qn) = qn `elem` alwaysUsedModules

168+ -> [Name]

122− qnameUsed Nothing = False

169+ -> ImportDeclarationType

170+ -> m ()

171+lintImportDecl env mni qualifierName names declType =

172+ case declType of

173+ Implicit -> case qualifierName of

174+ Nothing -> checkImplicit ImplicitImport

175+ Just q ->

176+ let usedModuleNames = mapMaybe extractQualName names

177+ in unless (q `elem` usedModuleNames) unused

178+ Hiding _ -> checkImplicit HidingImport

179+ Explicit [] -> unused

180+ Explicit declrefs -> checkExplicit declrefs

181+

182+ where

123

183

184+ checkImplicit

185+ :: (ModuleName -> [DeclarationRef] -> SimpleErrorMessage)

186+ -> m ()

187+ checkImplicit warning =

188+ if null allRefs

189+ then unused

190+ else tell $ errorMessage $ warning mni allRefs

191+

192+ checkExplicit

193+ :: [DeclarationRef]

194+ -> m ()

195+ checkExplicit declrefs = do

196+ let idents = nub (mapMaybe runDeclRef declrefs)

197+ dctors = mapMaybe (matchDctor qualifierName) names

198+ usedNames = mapMaybe (matchName (typeForDCtor mni) qualifierName) names

199+ diff = idents \\ usedNames

200+ case (length diff, length idents) of

201+ (0, _) -> return ()

202+ (n, m) | n == m -> unused

203+ _ -> tell $ errorMessage $ UnusedExplicitImport mni diff qualifierName allRefs

204+

205+ -- If we've not already warned a type is unused, check its data constructors

206+ forM_ (mapMaybe getTypeRef declrefs) $ \(tn, c) -> do

207+ let allCtors = dctorsForType mni tn

208+ when (runProperName tn `elem` usedNames) $ case (c, dctors `intersect` allCtors) of

209+ (_, []) | c /= Just [] ->

210+ tell $ errorMessage $ UnusedDctorImport tn

211+ (Just ctors, dctors') ->

212+ let ddiff = ctors \\ dctors'

213+ in unless (null ddiff) $ tell $ errorMessage $ UnusedDctorExplicitImport tn ddiff

214+ _ -> return ()

215+ return ()

216+

217+ unused :: m ()

218+ unused = tell $ errorMessage $ UnusedImport mni

219+

220+ allRefs :: [DeclarationRef]

221+ allRefs = findUsedRefs env mni qualifierName names

222+

223+ dtys

224+ :: ModuleName

124− dtys :: ModuleName -> [((ProperName, [ProperName]), ModuleName)]

225+ -> [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]

125 dtys mn = maybe [] exportedTypes $ envModuleExports <$> mn `M.lookup` env

226 dtys mn = maybe [] exportedTypes $ envModuleExports <$> mn `M.lookup` env

126

227

127− dctorsForType :: ModuleName -> ProperName -> [ProperName]

228+ dctorsForType

229+ :: ModuleName

230+ -> ProperName 'TypeName

231+ -> [ProperName 'ConstructorName]

128 dctorsForType mn tn =

232 dctorsForType mn tn =

129 maybe [] getDctors (find matches $ dtys mn)

233 maybe [] getDctors (find matches $ dtys mn)

130 where

234 where

131 matches ((ty, _),_) = ty == tn

235 matches ((ty, _),_) = ty == tn

132 getDctors ((_,ctors),_) = ctors

236 getDctors ((_,ctors),_) = ctors

133

237

238+ typeForDCtor

239+ :: ModuleName

240+ -> ProperName 'ConstructorName

134− typeForDCtor :: ModuleName -> ProperName -> Maybe ProperName

241+ -> Maybe (ProperName 'TypeName)

135 typeForDCtor mn pn =

242 typeForDCtor mn pn =

136 getTy <$> find matches (dtys mn)

243 getTy <$> find matches (dtys mn)

137 where

244 where

138 matches ((_, ctors), _) = pn `elem` ctors

245 matches ((_, ctors), _) = pn `elem` ctors

139 getTy ((ty, _), _) = ty

246 getTy ((ty, _), _) = ty

140

247

248+findUsedRefs :: Env -> ModuleName -> Maybe ModuleName -> [Name] -> [DeclarationRef]

249+findUsedRefs env mni qualifierName names =

250+ let

251+ classRefs = TypeClassRef <$> mapMaybe (getClassName qualifierName) names

252+ valueRefs = ValueRef <$> mapMaybe (getIdentName qualifierName) names

253+ types = mapMaybe (getTypeName qualifierName) names

254+ dctors = mapMaybe (matchDctor qualifierName) names

255+ typesWithDctors = reconstructTypeRefs dctors

256+ typesWithoutDctors = filter (`M.notMember` typesWithDctors) types

257+ typesRefs

258+ = map (flip TypeRef (Just [])) typesWithoutDctors

259+ ++ map (\(ty, ds) -> TypeRef ty (Just ds)) (M.toList typesWithDctors)

260+ in classRefs ++ typesRefs ++ valueRefs

261+

262+ where

263+

264+ reconstructTypeRefs

265+ :: [ProperName 'ConstructorName]

266+ -> M.Map (ProperName 'TypeName) [ProperName 'ConstructorName]

267+ reconstructTypeRefs = foldr accumDctors M.empty

268+ where

269+ accumDctors dctor = M.alter (Just . maybe [dctor] (dctor :)) (findTypeForDctor mni dctor)

141

270

271+ findTypeForDctor

272+ :: ModuleName

273+ -> ProperName 'ConstructorName

274+ -> ProperName 'TypeName

275+ findTypeForDctor mn dctor =

276+ case mn `M.lookup` env of

277+ Just (_, _, exps) ->

278+ case find (elem dctor . snd . fst) (exportedTypes exps) of

279+ Just ((ty, _), _) -> ty

280+ Nothing -> internalError $ "missing type for data constructor " ++ runProperName dctor ++ " in findTypeForDctor"

281+ Nothing -> internalError $ "missing module " ++ runModuleName mn ++ " in findTypeForDctor"

282+

283+matchName

142−matchName :: (ProperName -> Maybe ProperName) -> Maybe ModuleName -> Name -> Maybe String

284+ :: (ProperName 'ConstructorName -> Maybe (ProperName 'TypeName))

285+ -> Maybe ModuleName

286+ -> Name

287+ -> Maybe String

143matchName _ qual (IdentName (Qualified q x)) | q == qual = Just $ showIdent x

288matchName _ qual (IdentName (Qualified q x)) | q == qual = Just $ showIdent x

144−matchName _ qual (TypeName (Qualified q x)) | q == qual = Just $ runProperName x

289+matchName _ qual (TyName (Qualified q x)) | q == qual = Just $ runProperName x

145−matchName _ qual (ClassName (Qualified q x)) | q == qual = Just $ runProperName x

290+matchName _ qual (TyClassName (Qualified q x)) | q == qual = Just $ runProperName x

146matchName lookupDc qual (DctorName (Qualified q x)) | q == qual = runProperName <$> lookupDc x

291matchName lookupDc qual (DctorName (Qualified q x)) | q == qual = runProperName <$> lookupDc x

147matchName _ _ _ = Nothing

292matchName _ _ _ = Nothing

148

293

294+extractQualName :: Name -> Maybe ModuleName

295+extractQualName (IdentName (Qualified q _)) = q

296+extractQualName (TyName (Qualified q _)) = q

297+extractQualName (TyClassName (Qualified q _)) = q

298+extractQualName (DctorName (Qualified q _)) = q

299+

149−matchDctor :: Maybe ModuleName -> Name -> Maybe ProperName

300+matchDctor :: Maybe ModuleName -> Name -> Maybe (ProperName 'ConstructorName)

150matchDctor qual (DctorName (Qualified q x)) | q == qual = Just x

301matchDctor qual (DctorName (Qualified q x)) | q == qual = Just x

151matchDctor _ _ = Nothing

302matchDctor _ _ = Nothing

152

303

@@ -157,7 +308,9 @@ runDeclRef (TypeRef pn _) = Just $ runProperName pn

157runDeclRef (TypeClassRef pn) = Just $ runProperName pn

308runDeclRef (TypeClassRef pn) = Just $ runProperName pn

158runDeclRef _ = Nothing

309runDeclRef _ = Nothing

159

310

311+getTypeRef

312+ :: DeclarationRef

160−getTypeRef :: DeclarationRef -> Maybe (ProperName, Maybe [ProperName])

313+ -> Maybe (ProperName 'TypeName, Maybe [ProperName 'ConstructorName])

161getTypeRef (PositionedDeclarationRef _ _ ref) = getTypeRef ref

314getTypeRef (PositionedDeclarationRef _ _ ref) = getTypeRef ref

162getTypeRef (TypeRef pn x) = Just (pn, x)

315getTypeRef (TypeRef pn x) = Just (pn, x)

163getTypeRef _ = Nothing

316getTypeRef _ = Nothing

src/Language/PureScript/Make.hs−1

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

src/Language/PureScript/ModuleDependencies.hs+7−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,24 @@ 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 (Qualified (Just mn) _))) = [mn]

65+ forDecls (TypeInstanceDeclaration _ _ (Qualified (Just mn) _) _ _) = [mn]

61 forDecls _ = []

66 forDecls _ = []

62

67

63 forValues :: Expr -> [ModuleName]

68 forValues :: Expr -> [ModuleName]

64 forValues (Var (Qualified (Just mn) _)) = [mn]

69 forValues (Var (Qualified (Just mn) _)) = [mn]

65 forValues (Constructor (Qualified (Just mn) _)) = [mn]

70 forValues (Constructor (Qualified (Just mn) _)) = [mn]

66− forValues (TypedValue _ _ ty) = forTypes ty

67 forValues _ = []

71 forValues _ = []

68

72

69 forTypes :: Type -> [ModuleName]

73 forTypes :: Type -> [ModuleName]

70 forTypes (TypeConstructor (Qualified (Just mn) _)) = [mn]

74 forTypes (TypeConstructor (Qualified (Just mn) _)) = [mn]

71− forTypes (ConstrainedType cs _) = mapMaybe (\(Qualified mn _, _) -> mn) cs

72 forTypes _ = []

75 forTypes _ = []

73

76

74-- |

77-- |

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/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+2−2

@@ -122,7 +122,7 @@ parseFixityDeclaration :: TokenParser Declaration

122parseFixityDeclaration = do

123 fixity <- parseFixity

124 indented

125− alias <- P.optionMaybe $ (Ident <$> identifier) <* reserved "as"

125+ alias <- P.optionMaybe $ parseQualified (Ident <$> identifier) <* reserved "as"

126 name <- symbol

127 return $ FixityDeclaration fixity name alias

128

@@ -165,7 +165,7 @@ parseDeclarationRef =

165 parseProperRef = do

166 name <- properName

167 dctors <- P.optionMaybe $ parens (symbol' ".." *> pure Nothing <|> Just <$> commaSep properName)

168− return $ maybe (ProperRef name) (TypeRef name) dctors

168+ return $ maybe (ProperRef (runProperName name)) (TypeRef name) dctors

169

170parseTypeClassDeclaration :: TokenParser Declaration

171parseTypeClassDeclaration = 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/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/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, env) <- parseAndDesugar inputFiles depsFiles

150− >>= either (userError . ParseAndDesugarError) return

150+

151+ case runExcept (D.convertModulesInPackage env modules') of

152+ Right modules -> return (bookmarks, modules)

153+ Left err -> userError (CompileError err)

154+

151 where

155 where

152− renderModules bookmarks modules =

156+ parseAndDesugar inputFiles depsFiles = do

153− return (bookmarks, map D.convertModule modules)

157+ r <- liftIO . runExceptT $ D.parseAndDesugar 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+3−14

@@ -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,19 +187,9 @@ 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)

200− ]

201− ParseAndDesugarError (D.DesugarError err) ->

202− vcat

203− [ para "Error while desugaring:"

204 , indented (P.prettyPrintMultipleErrorsBox False err)

193 , indented (P.prettyPrintMultipleErrorsBox False err)

205 ]

194 ]

206 DirtyWorkingTree ->

195 DirtyWorkingTree ->

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

37+createBindingGroupsModule

48−createBindingGroupsModule :: (Functor m, Applicative m, MonadError MultipleErrors m) => [Module] -> m [Module]

38+ :: (Functor m, Applicative m, 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+

53+createBindingGroups

54+ :: forall m

57−createBindingGroups :: forall m. (Functor m, Applicative m, MonadError MultipleErrors m) => ModuleName -> [Declaration] -> m [Declaration]

55+ . (Functor m, Applicative m, 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+ . (Functor m, 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+9−18

@@ -150,7 +150,7 @@ toTuple _ = internalError "Not a value declaration"

150makeCaseDeclaration :: forall m. (Functor m, Applicative 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/Names.hs+89−29

@@ -1,8 +1,15 @@

1{-# LANGUAGE FlexibleContexts #-}

2{-# LANGUAGE RecordWildCards #-}

3{-# LANGUAGE ScopedTypeVariables #-}

4+{-# LANGUAGE TupleSections #-}

4

5

5−module Language.PureScript.Sugar.Names (desugarImports) where

6+module Language.PureScript.Sugar.Names

7+ ( desugarImports

8+ , desugarImportsWithEnv

9+ , Env

10+ , Imports(..)

11+ , Exports(..)

12+ ) where

6

13

7import Prelude ()

14import Prelude ()

8import Prelude.Compat

15import Prelude.Compat

@@ -16,6 +23,7 @@ import Control.Monad.Writer (MonadWriter(..), censor)

16import Control.Monad.State.Lazy

23import Control.Monad.State.Lazy

17

24

18import qualified Data.Map as M

25import qualified Data.Map as M

26+import qualified Data.Set as S

19

27

20import Language.PureScript.Crash

28import Language.PureScript.Crash

21import Language.PureScript.AST

29import Language.PureScript.AST

@@ -34,11 +42,20 @@ import Language.PureScript.Linter.Imports

34-- modules should be topologically sorted beforehand.

42-- modules should be topologically sorted beforehand.

35--

43--

36desugarImports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module]

44desugarImports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module]

37−desugarImports externs modules = do

45+desugarImports externs modules =

46+ fmap snd (desugarImportsWithEnv externs modules)

47+

48+desugarImportsWithEnv

49+ :: forall m

50+ . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

51+ => [ExternsFile]

52+ -> [Module]

53+ -> m (Env, [Module])

54+desugarImportsWithEnv externs modules = do

38 env <- silence $ foldM externsEnv primEnv externs

55 env <- silence $ foldM externsEnv primEnv externs

39 modules' <- traverse updateExportRefs modules

56 modules' <- traverse updateExportRefs modules

40 (modules'', env') <- foldM updateEnv ([], env) modules'

57 (modules'', env') <- foldM updateEnv ([], env) modules'

41− traverse (renameInModule' env') modules''

58+ (env',) <$> traverse (renameInModule' env') modules''

42 where

59 where

43 silence :: m a -> m a

60 silence :: m a -> m a

44 silence = censor (const mempty)

61 silence = censor (const mempty)

@@ -55,17 +72,17 @@ desugarImports externs modules = do

55 return $ M.insert efModuleName (ss, imps, exps) env

72 return $ M.insert efModuleName (ss, imps, exps) env

56 where

73 where

57

74

58− exportedTypes :: [((ProperName, [ProperName]), ModuleName)]

75+ exportedTypes :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]

59 exportedTypes = mapMaybe toExportedType efExports

76 exportedTypes = mapMaybe toExportedType efExports

60 where

77 where

61 toExportedType (TypeRef tyCon dctors) = Just ((tyCon, fromMaybe (mapMaybe forTyCon efDeclarations) dctors), efModuleName)

78 toExportedType (TypeRef tyCon dctors) = Just ((tyCon, fromMaybe (mapMaybe forTyCon efDeclarations) dctors), efModuleName)

62 where

79 where

63− forTyCon :: ExternsDeclaration -> Maybe ProperName

80+ forTyCon :: ExternsDeclaration -> Maybe (ProperName 'ConstructorName)

64 forTyCon (EDDataConstructor pn _ tNm _ _) | tNm == tyCon = Just pn

81 forTyCon (EDDataConstructor pn _ tNm _ _) | tNm == tyCon = Just pn

65 forTyCon _ = Nothing

82 forTyCon _ = Nothing

66 toExportedType (PositionedDeclarationRef _ _ r) = toExportedType r

83 toExportedType (PositionedDeclarationRef _ _ r) = toExportedType r

67 toExportedType _ = Nothing

84 toExportedType _ = Nothing

68− exportedTypeClasses :: [(ProperName, ModuleName)]

85+ exportedTypeClasses :: [(ProperName 'ClassName, ModuleName)]

69 exportedTypeClasses = mapMaybe toExportedTypeClass efExports

86 exportedTypeClasses = mapMaybe toExportedTypeClass efExports

70 where

87 where

71 toExportedTypeClass (TypeClassRef className) = Just (className, efModuleName)

88 toExportedTypeClass (TypeClassRef className) = Just (className, efModuleName)

@@ -94,7 +111,7 @@ desugarImports externs modules = do

94 warnAndRethrow (addHint (ErrorInModule mn)) $ do

111 warnAndRethrow (addHint (ErrorInModule mn)) $ do

95 let (_, imps, exps) = fromMaybe (internalError "Module is missing in renameInModule'") $ M.lookup mn env

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

113 (m', used) <- flip runStateT M.empty $ renameInModule env imps (elaborateExports exps m)

97− findUnusedImports m env used

114+ lintImports m env used

98 return m'

115 return m'

99

116

100-- |

117-- |

@@ -119,14 +136,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

136-- Replaces all local names with qualified names within a module and checks that all existing

120-- qualified names are valid.

137-- qualified names are valid.

121--

138--

139+renameInModule

140+ :: forall m

122−renameInModule :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadState UsedImports m) => Env -> Imports -> Module -> m Module

141+ . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadState UsedImports m)

142+ => Env

143+ -> Imports

144+ -> Module

145+ -> m Module

123renameInModule env imports (Module ss coms mn decls exps) =

146renameInModule env imports (Module ss coms mn decls exps) =

124 Module ss coms mn <$> parU decls go <*> pure exps

147 Module ss coms mn <$> parU decls go <*> pure exps

125 where

148 where

126

149

127 (go, _, _, _, _) = everywhereWithContextOnValuesM (Nothing, []) updateDecl updateValue updateBinder updateCase defS

150 (go, _, _, _, _) = everywhereWithContextOnValuesM (Nothing, []) updateDecl updateValue updateBinder updateCase defS

128

151

152+ updateDecl

153+ :: (Maybe SourceSpan, [Ident])

154+ -> Declaration

129− updateDecl :: (Maybe SourceSpan, [Ident]) -> Declaration -> m ((Maybe SourceSpan, [Ident]), Declaration)

155+ -> m ((Maybe SourceSpan, [Ident]), Declaration)

130 updateDecl (_, bound) d@(PositionedDeclaration pos _ _) =

156 updateDecl (_, bound) d@(PositionedDeclaration pos _ _) =

131 return ((Just pos, bound), d)

157 return ((Just pos, bound), d)

132 updateDecl (pos, bound) (DataDeclaration dtype name args dctors) =

158 updateDecl (pos, bound) (DataDeclaration dtype name args dctors) =

@@ -141,9 +167,14 @@ renameInModule env imports (Module ss coms mn decls exps) =

141 (,) (pos, bound) <$> (TypeDeclaration name <$> updateTypesEverywhere pos ty)

167 (,) (pos, bound) <$> (TypeDeclaration name <$> updateTypesEverywhere pos ty)

142 updateDecl (pos, bound) (ExternDeclaration name ty) =

168 updateDecl (pos, bound) (ExternDeclaration name ty) =

143 (,) (pos, name : bound) <$> (ExternDeclaration name <$> updateTypesEverywhere pos ty)

169 (,) (pos, name : bound) <$> (ExternDeclaration name <$> updateTypesEverywhere pos ty)

170+ updateDecl (pos, bound) (FixityDeclaration fx name alias) =

171+ (,) (pos, bound) <$> (FixityDeclaration fx name <$> traverse (`updateValueName` pos) alias)

144 updateDecl s d = return (s, d)

172 updateDecl s d = return (s, d)

145

173

174+ updateValue

175+ :: (Maybe SourceSpan, [Ident])

176+ -> Expr

146− updateValue :: (Maybe SourceSpan, [Ident]) -> Expr -> m ((Maybe SourceSpan, [Ident]), Expr)

177+ -> m ((Maybe SourceSpan, [Ident]), Expr)

147 updateValue (_, bound) v@(PositionedValue pos' _ _) =

178 updateValue (_, bound) v@(PositionedValue pos' _ _) =

148 return ((Just pos', bound), v)

179 return ((Just pos', bound), v)

149 updateValue (pos, bound) (Abs (Left arg) val') =

180 updateValue (pos, bound) (Abs (Left arg) val') =

@@ -164,7 +195,10 @@ renameInModule env imports (Module ss coms mn decls exps) =

164 (,) s <$> (TypedValue check val <$> updateTypesEverywhere pos ty)

195 (,) s <$> (TypedValue check val <$> updateTypesEverywhere pos ty)

165 updateValue s v = return (s, v)

196 updateValue s v = return (s, v)

166

197

198+ updateBinder

199+ :: (Maybe SourceSpan, [Ident])

200+ -> Binder

167− updateBinder :: (Maybe SourceSpan, [Ident]) -> Binder -> m ((Maybe SourceSpan, [Ident]), Binder)

201+ -> m ((Maybe SourceSpan, [Ident]), Binder)

168 updateBinder (_, bound) v@(PositionedBinder pos _ _) =

202 updateBinder (_, bound) v@(PositionedBinder pos _ _) =

169 return ((Just pos, bound), v)

203 return ((Just pos, bound), v)

170 updateBinder s@(pos, _) (ConstructorBinder name b) =

204 updateBinder s@(pos, _) (ConstructorBinder name b) =

@@ -176,7 +210,10 @@ renameInModule env imports (Module ss coms mn decls exps) =

176 updateBinder s v =

210 updateBinder s v =

177 return (s, v)

211 return (s, v)

178

212

213+ updateCase

214+ :: (Maybe SourceSpan, [Ident])

215+ -> CaseAlternative

179− updateCase :: (Maybe SourceSpan, [Ident]) -> CaseAlternative -> m ((Maybe SourceSpan, [Ident]), CaseAlternative)

216+ -> m ((Maybe SourceSpan, [Ident]), CaseAlternative)

180 updateCase (pos, bound) c@(CaseAlternative bs _) =

217 updateCase (pos, bound) c@(CaseAlternative bs _) =

181 return ((pos, concatMap binderNames bs ++ bound), c)

218 return ((pos, concatMap binderNames bs ++ bound), c)

182

219

@@ -196,16 +233,25 @@ renameInModule env imports (Module ss coms mn decls exps) =

196 updateConstraints :: Maybe SourceSpan -> [Constraint] -> m [Constraint]

233 updateConstraints :: Maybe SourceSpan -> [Constraint] -> m [Constraint]

197 updateConstraints pos = traverse (\(name, ts) -> (,) <$> updateClassName name pos <*> traverse (updateTypesEverywhere pos) ts)

234 updateConstraints pos = traverse (\(name, ts) -> (,) <$> updateClassName name pos <*> traverse (updateTypesEverywhere pos) ts)

198

235

236+ updateTypeName

237+ :: Qualified (ProperName 'TypeName)

238+ -> Maybe SourceSpan

199− updateTypeName :: Qualified ProperName -> Maybe SourceSpan -> m (Qualified ProperName)

239+ -> m (Qualified (ProperName 'TypeName))

200− updateTypeName = update UnknownType (importedTypes imports) (resolveType . exportedTypes) TypeName (("type " ++) . runProperName)

240+ updateTypeName = update UnknownType (importedTypes imports) (resolveType . exportedTypes) TyName (("type " ++) . runProperName)

201

241

202− updateDataConstructorName :: Qualified ProperName -> Maybe SourceSpan -> m (Qualified ProperName)

242+ updateDataConstructorName

243+ :: Qualified (ProperName 'ConstructorName)

244+ -> Maybe SourceSpan

245+ -> m (Qualified (ProperName 'ConstructorName))

203 updateDataConstructorName = update (flip UnknownDataConstructor Nothing) (importedDataConstructors imports) (resolveDctor . exportedTypes) DctorName (("data constructor " ++) . runProperName)

246 updateDataConstructorName = update (flip UnknownDataConstructor Nothing) (importedDataConstructors imports) (resolveDctor . exportedTypes) DctorName (("data constructor " ++) . runProperName)

204

247

248+ updateClassName

249+ :: Qualified (ProperName 'ClassName)

250+ -> Maybe SourceSpan

205− updateClassName :: Qualified ProperName -> Maybe SourceSpan -> m (Qualified ProperName)

251+ -> m (Qualified (ProperName 'ClassName))

206− updateClassName = update UnknownTypeClass (importedTypeClasses imports) (resolve . exportedTypeClasses) ClassName (("class " ++) . runProperName)

252+ updateClassName = update UnknownTypeClass (importedTypeClasses imports) (resolve . exportedTypeClasses) TyClassName (("class " ++) . runProperName)

207

253

208− updateValueName :: Qualified Ident -> Maybe SourceSpan -> m (Qualified Ident)

254+ updateValueName :: Qualified Ident -> Maybe SourceSpan -> m (Qualified Ident)

209 updateValueName = update UnknownValue (importedValues imports) (resolve . exportedValues) IdentName (("value " ++) . runIdent)

255 updateValueName = update UnknownValue (importedValues imports) (resolve . exportedValues) IdentName (("value " ++) . runIdent)

210

256

211 -- Used when performing an update to qualify values and classes with their

257 -- Used when performing an update to qualify values and classes with their

@@ -215,12 +261,18 @@ renameInModule env imports (Module ss coms mn decls exps) =

215

261

216 -- Used when performing an update to qualify types with their module of

262 -- Used when performing an update to qualify types with their module of

217 -- original definition.

263 -- original definition.

264+ resolveType

218− resolveType :: [((ProperName, [ProperName]), ModuleName)] -> ProperName -> Maybe (Qualified ProperName)

265+ :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]

266+ -> ProperName 'TypeName

267+ -> Maybe (Qualified (ProperName 'TypeName))

219 resolveType tys name = mkQualified name . snd <$> find ((== name) . fst . fst) tys

268 resolveType tys name = mkQualified name . snd <$> find ((== name) . fst . fst) tys

220

269

221 -- Used when performing an update to qualify data constructors with their

270 -- Used when performing an update to qualify data constructors with their

222 -- module of original definition.

271 -- module of original definition.

272+ resolveDctor

223− resolveDctor :: [((ProperName, [ProperName]), ModuleName)] -> ProperName -> Maybe (Qualified ProperName)

273+ :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]

274+ -> ProperName 'ConstructorName

275+ -> Maybe (Qualified (ProperName 'ConstructorName))

224 resolveDctor tys name = mkQualified name . snd <$> find (elem name . snd . fst) tys

276 resolveDctor tys name = mkQualified name . snd <$> find (elem name . snd . fst) tys

225

277

226 -- Update names so unqualified references become qualified, and locally

278 -- Update names so unqualified references become qualified, and locally

@@ -255,42 +307,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

307 -- by qualified importing). If that's not the case, then we just need to

256 -- check it refers to a symbol in another module.

308 -- check it refers to a symbol in another module.

257 (Nothing, Just mn'') -> do

309 (Nothing, Just mn'') -> do

258− modExports <- getExports env mn''

310+ case M.lookup mn'' env of

311+ Nothing

312+ | mn'' `S.member` importedVirtualModules imports -> throwUnknown

259− maybe (throwError . errorMessage $ unknown qname) return (getE modExports name)

313+ | otherwise -> throwError . errorMessage $ UnknownModule mn''

314+ Just env' -> maybe throwUnknown return (getE (envModuleExports env') name)

260

315

261 -- If neither of the above cases are true then it's an undefined or

316 -- If neither of the above cases are true then it's an undefined or

262 -- unimported symbol.

317 -- unimported symbol.

263− _ -> throwError . errorMessage $ unknown qname

318+ _ -> throwUnknown

264

319

265 where

320 where

266 positioned err = case pos of

321 positioned err = case pos of

267 Nothing -> err

322 Nothing -> err

268 Just pos' -> rethrowWithPosition pos' err

323 Just pos' -> rethrowWithPosition pos' err

324+ throwUnknown = throwError . errorMessage $ unknown qname

269

325

270-- |

326-- |

271-- Replaces `ProperRef` export values with a `TypeRef` or `TypeClassRef`

327-- Replaces `ProperRef` export values with a `TypeRef` or `TypeClassRef`

272-- depending on what is availble within the module. Warns when a `ProperRef`

328-- depending on what is availble within the module. Warns when a `ProperRef`

273-- desugars into a `TypeClassRef`.

329-- desugars into a `TypeClassRef`.

274--

330--

331+updateExportRefs

332+ :: forall m

275−updateExportRefs :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Module -> m Module

333+ . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

334+ => Module

335+ -> m Module

276updateExportRefs (Module ss coms mn decls exps) =

336updateExportRefs (Module ss coms mn decls exps) =

277 Module ss coms mn decls <$> traverse (traverse updateRef) exps

337 Module ss coms mn decls <$> traverse (traverse updateRef) exps

278 where

338 where

279

339

280 updateRef :: DeclarationRef -> m DeclarationRef

340 updateRef :: DeclarationRef -> m DeclarationRef

281 updateRef (ProperRef name)

341 updateRef (ProperRef name)

282− | name `elem` classNames = do

342+ | ProperName name `elem` classNames = do

283− tell . errorMessage $ DeprecatedClassExport name

343+ tell . errorMessage . DeprecatedClassExport $ ProperName name

284− return $ TypeClassRef name

344+ return . TypeClassRef $ ProperName name

285 -- Fall through case here - assume it's a type if it's not a class.

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

346 -- If it's a reference to something that doesn't actually exist it will

287 -- be picked up elsewhere

347 -- be picked up elsewhere

288− | otherwise = return $ TypeRef name (Just [])

348+ | otherwise = return $ TypeRef (ProperName name) (Just [])

289 updateRef (PositionedDeclarationRef pos com ref) =

349 updateRef (PositionedDeclarationRef pos com ref) =

290 warnWithPosition pos $ PositionedDeclarationRef pos com <$> updateRef ref

350 warnWithPosition pos $ PositionedDeclarationRef pos com <$> updateRef ref

291 updateRef other = return other

351 updateRef other = return other

292

352

293− classNames :: [ProperName]

353+ classNames :: [ProperName 'ClassName]

294 classNames = mapMaybe go decls

354 classNames = mapMaybe go decls

295 where

355 where

296 go (PositionedDeclaration _ _ d) = go d

356 go (PositionedDeclaration _ _ d) = go d

src/Language/PureScript/Sugar/Names/Env.hs+20−15

@@ -22,6 +22,7 @@ import Data.Function (on)

22import Data.List (groupBy, sortBy, nub)

23import Data.Maybe (fromJust)

24import qualified Data.Map as M

25+import qualified Data.Set as S

25

26

26import Control.Monad

27import Control.Monad

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

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

@@ -40,30 +41,35 @@ data Imports = Imports

40 -- |

41 -- |

41 -- Local names for types within a module mapped to to their qualified names

42 -- Local names for types within a module mapped to to their qualified names

42 --

43 --

43− importedTypes :: M.Map (Qualified ProperName) [(Qualified ProperName, ModuleName)]

44+ importedTypes :: M.Map (Qualified (ProperName 'TypeName)) [(Qualified (ProperName 'TypeName), ModuleName)]

44 -- |

45 -- |

45 -- Local names for data constructors within a module mapped to to their qualified names

46 -- Local names for data constructors within a module mapped to to their qualified names

46 --

47 --

47− , importedDataConstructors :: M.Map (Qualified ProperName) [(Qualified ProperName, ModuleName)]

48+ , importedDataConstructors :: M.Map (Qualified (ProperName 'ConstructorName)) [(Qualified (ProperName 'ConstructorName), ModuleName)]

48 -- |

49 -- |

49 -- Local names for classes within a module mapped to to their qualified names

50 -- Local names for classes within a module mapped to to their qualified names

50 --

51 --

51− , importedTypeClasses :: M.Map (Qualified ProperName) [(Qualified ProperName, ModuleName)]

52+ , importedTypeClasses :: M.Map (Qualified (ProperName 'ClassName)) [(Qualified (ProperName 'ClassName), ModuleName)]

52 -- |

53 -- |

53 -- Local names for values within a module mapped to to their qualified names

54 -- Local names for values within a module mapped to to their qualified names

54 --

55 --

55 , importedValues :: M.Map (Qualified Ident) [(Qualified Ident, ModuleName)]

56 , importedValues :: M.Map (Qualified Ident) [(Qualified Ident, ModuleName)]

56 -- |

57 -- |

57− -- The list of modules that have been imported into the current scope.

58+ -- The modules that have been imported into the current scope.

58 --

59 --

59− , importedModules :: [ModuleName]

60+ , importedModules :: S.Set ModuleName

61+ -- |

62+ -- The names of "virtual" modules that come into existence when "import as"

63+ -- is used.

64+ --

65+ , importedVirtualModules :: S.Set ModuleName

60 } deriving (Show, Read)

66 } deriving (Show, Read)

61

67

62-- |

68-- |

63-- An empty 'Imports' value.

69-- An empty 'Imports' value.

64--

70--

65nullImports :: Imports

71nullImports :: Imports

66−nullImports = Imports M.empty M.empty M.empty M.empty []

72+nullImports = Imports M.empty M.empty M.empty M.empty S.empty S.empty

67

73

68-- |

74-- |

69-- The exported declarations from a module.

75-- The exported declarations from a module.

@@ -74,12 +80,12 @@ data Exports = Exports

74 -- The types exported from each module along with the module they originally

80 -- The types exported from each module along with the module they originally

75 -- came from.

81 -- came from.

76 --

82 --

77− exportedTypes :: [((ProperName, [ProperName]), ModuleName)]

83+ exportedTypes :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]

78 -- |

84 -- |

79 -- The classes exported from each module along with the module they originally

85 -- The classes exported from each module along with the module they originally

80 -- came from.

86 -- came from.

81 --

87 --

82− , exportedTypeClasses :: [(ProperName, ModuleName)]

88+ , exportedTypeClasses :: [(ProperName 'ClassName, ModuleName)]

83 -- |

89 -- |

84 -- The values exported from each module along with the module they originally

90 -- The values exported from each module along with the module they originally

85 -- came from.

91 -- came from.

@@ -137,29 +143,28 @@ primEnv = M.singleton

137-- Safely adds a type and its data constructors to some exports, returning an

143-- Safely adds a type and its data constructors to some exports, returning an

138-- error if a conflict occurs.

144-- error if a conflict occurs.

139--

145--

140−exportType :: (MonadError MultipleErrors m) => Exports -> ProperName -> [ProperName] -> ModuleName -> m Exports

146+exportType :: (MonadError MultipleErrors m) => Exports -> ProperName 'TypeName -> [ProperName 'ConstructorName] -> ModuleName -> m Exports

141exportType exps name dctors mn = do

147exportType exps name dctors mn = do

142 let exTypes' = exportedTypes exps

148 let exTypes' = exportedTypes exps

143 let exTypes = filter ((/= mn) . snd) exTypes'

149 let exTypes = filter ((/= mn) . snd) exTypes'

144 let exDctors = (snd . fst) `concatMap` exTypes

150 let exDctors = (snd . fst) `concatMap` exTypes

145 let exClasses = exportedTypeClasses exps

151 let exClasses = exportedTypeClasses exps

146−

147 when (any ((== name) . fst . fst) exTypes) $ throwConflictError ConflictingTypeDecls name

152 when (any ((== name) . fst . fst) exTypes) $ throwConflictError ConflictingTypeDecls name

148− when (any ((== name) . fst) exClasses) $ throwConflictError TypeConflictsWithClass name

153+ when (any ((== coerceProperName name) . fst) exClasses) $ throwConflictError TypeConflictsWithClass name

149 forM_ dctors $ \dctor -> do

154 forM_ dctors $ \dctor -> do

150 when (dctor `elem` exDctors) $ throwConflictError ConflictingCtorDecls dctor

155 when (dctor `elem` exDctors) $ throwConflictError ConflictingCtorDecls dctor

151− when (any ((== dctor) . fst) exClasses) $ throwConflictError CtorConflictsWithClass dctor

156+ when (any ((== coerceProperName dctor) . fst) exClasses) $ throwConflictError CtorConflictsWithClass dctor

152 return $ exps { exportedTypes = nub $ ((name, dctors), mn) : exTypes' }

157 return $ exps { exportedTypes = nub $ ((name, dctors), mn) : exTypes' }

153

158

154-- |

159-- |

155-- Safely adds a class to some exports, returning an error if a conflict occurs.

160-- Safely adds a class to some exports, returning an error if a conflict occurs.

156--

161--

157−exportTypeClass :: (MonadError MultipleErrors m) => Exports -> ProperName -> ModuleName -> m Exports

162+exportTypeClass :: (MonadError MultipleErrors m) => Exports -> ProperName 'ClassName -> ModuleName -> m Exports

158exportTypeClass exps name mn = do

163exportTypeClass exps name mn = do

159 let exTypes = exportedTypes exps

164 let exTypes = exportedTypes exps

160 let exDctors = (snd . fst) `concatMap` exTypes

165 let exDctors = (snd . fst) `concatMap` exTypes

161− when (any ((== name) . fst . fst) exTypes) $ throwConflictError ClassConflictsWithType name

166+ when (any ((== coerceProperName name) . fst . fst) exTypes) $ throwConflictError ClassConflictsWithType name

162− when (name `elem` exDctors) $ throwConflictError ClassConflictsWithCtor name

167+ when (coerceProperName name `elem` exDctors) $ throwConflictError ClassConflictsWithCtor name

163 classes <- addExport DuplicateClassExport name mn (exportedTypeClasses exps)

168 classes <- addExport DuplicateClassExport name mn (exportedTypeClasses exps)

164 return $ exps { exportedTypeClasses = classes }

169 return $ exps { exportedTypeClasses = classes }

165

170

src/Language/PureScript/Sugar/Names/Exports.hs+31−8

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

@@ -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+ . (Applicative m, 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+25−12

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

@@ -123,7 +124,7 @@ resolveImports env (Module ss coms currentModule decls exps) =

123 ModuleRef name -> warnDupe pos $ "module " ++ runModuleName name

124 ModuleRef name -> warnDupe pos $ "module " ++ runModuleName name

124 _ -> return ()

125 _ -> return ()

125

126

126− warnDupeDctors :: Maybe SourceSpan -> [ProperName] -> m ()

127+ warnDupeDctors :: Maybe SourceSpan -> [ProperName 'ConstructorName] -> m ()

127 warnDupeDctors pos = traverse_ (warnDupe pos . ("data constructor " ++) . runProperName)

128 warnDupeDctors pos = traverse_ (warnDupe pos . ("data constructor " ++) . runProperName)

128

129

129 warnDupe :: Maybe SourceSpan -> String -> m ()

130 warnDupe :: Maybe SourceSpan -> String -> m ()

@@ -134,7 +135,7 @@ resolveImports env (Module ss coms currentModule decls exps) =

134

135

135 updateImportRef :: Declaration -> m Declaration

136 updateImportRef :: Declaration -> m Declaration

136 updateImportRef (PositionedDeclaration pos com d) =

137 updateImportRef (PositionedDeclaration pos com d) =

137− warnWithPosition pos $ PositionedDeclaration pos com <$> updateImportRef d

138+ warnAndRethrowWithPosition pos $ PositionedDeclaration pos com <$> updateImportRef d

138 updateImportRef (ImportDeclaration mn typ qual isOldSyntax) = do

139 updateImportRef (ImportDeclaration mn typ qual isOldSyntax) = do

139 modExports <- getExports env mn

140 modExports <- getExports env mn

140 typ' <- case typ of

141 typ' <- case typ of

@@ -146,11 +147,11 @@ resolveImports env (Module ss coms currentModule decls exps) =

146

147

147 updateProperRef :: ModuleName -> Exports -> DeclarationRef -> m DeclarationRef

148 updateProperRef :: ModuleName -> Exports -> DeclarationRef -> m DeclarationRef

148 updateProperRef importModule modExports (ProperRef name) =

149 updateProperRef importModule modExports (ProperRef name) =

149− if name `elem` (fst `map` exportedTypeClasses modExports)

150+ if ProperName name `elem` (fst `map` exportedTypeClasses modExports)

150 then do

151 then do

151− tell . errorMessage $ DeprecatedClassImport importModule name

152+ tell . errorMessage $ DeprecatedClassImport importModule (ProperName name)

152− return $ TypeClassRef name

153+ return . TypeClassRef $ ProperName name

153− else return $ TypeRef name (Just [])

154+ else return $ TypeRef (ProperName name) (Just [])

154 updateProperRef importModule modExports (PositionedDeclarationRef pos com ref) =

155 updateProperRef importModule modExports (PositionedDeclarationRef pos com ref) =

155 PositionedDeclarationRef pos com <$> updateProperRef importModule modExports ref

156 PositionedDeclarationRef pos com <$> updateProperRef importModule modExports ref

156 updateProperRef _ _ other = return other

157 updateProperRef _ _ other = return other

@@ -168,7 +169,10 @@ resolveModuleImport env ie (mn, imps) = foldM go ie imps

168 go :: Imports -> (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName) -> m Imports

169 go :: Imports -> (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName) -> m Imports

169 go ie' (pos, typ, impQual) = do

170 go ie' (pos, typ, impQual) = do

170 modExports <- positioned $ maybe (throwError . errorMessage $ UnknownModule mn) (return . envModuleExports) $ mn `M.lookup` env

171 modExports <- positioned $ maybe (throwError . errorMessage $ UnknownModule mn) (return . envModuleExports) $ mn `M.lookup` env

172+ let virtualModules = importedVirtualModules ie'

171− let ie'' = ie' { importedModules = mn : importedModules ie' }

173+ ie'' = ie' { importedModules = S.insert mn (importedModules ie')

174+ , importedVirtualModules = maybe virtualModules (`S.insert` virtualModules) impQual

175+ }

172 positioned $ resolveImport mn modExports ie'' impQual typ

176 positioned $ resolveImport mn modExports ie'' impQual typ

173 where

177 where

174 positioned err = case pos of

178 positioned err = case pos of

@@ -222,13 +226,22 @@ resolveImport importModule exps imps impQual = resolveByType

222 check r = internalError $ "Invalid argument to checkRefs: " ++ show r

226 check r = internalError $ "Invalid argument to checkRefs: " ++ show r

223

227

224 -- Check that an explicitly imported item exists in the module it is being imported from

228 -- Check that an explicitly imported item exists in the module it is being imported from

229+ checkImportExists

230+ :: Eq a

225− checkImportExists :: (Eq a) => (ModuleName -> a -> SimpleErrorMessage) -> [a] -> a -> m ()

231+ => (ModuleName -> a -> SimpleErrorMessage)

232+ -> [a]

233+ -> a

234+ -> m ()

226 checkImportExists unknown exports item =

235 checkImportExists unknown exports item =

227 when (item `notElem` exports) $ throwError . errorMessage $ unknown importModule item

236 when (item `notElem` exports) $ throwError . errorMessage $ unknown importModule item

228

237

229 -- Ensure that an explicitly imported data constructor exists for the type it is being imported

238 -- Ensure that an explicitly imported data constructor exists for the type it is being imported

230 -- from

239 -- from

231− checkDctorExists :: ProperName -> [ProperName] -> ProperName -> m ()

240+ checkDctorExists

241+ :: ProperName 'TypeName

242+ -> [ProperName 'ConstructorName]

243+ -> ProperName 'ConstructorName

244+ -> m ()

232 checkDctorExists tcon = checkImportExists (flip UnknownImportDataConstructor tcon)

245 checkDctorExists tcon = checkImportExists (flip UnknownImportDataConstructor tcon)

233

246

234 importNonHidden :: [DeclarationRef] -> Imports -> DeclarationRef -> m Imports

247 importNonHidden :: [DeclarationRef] -> Imports -> DeclarationRef -> m Imports

@@ -264,9 +277,9 @@ resolveImport importModule exps imps impQual = resolveByType

264 return $ imp { importedValues = values' }

277 return $ imp { importedValues = values' }

265 importExplicit imp (TypeRef name dctors) = do

278 importExplicit imp (TypeRef name dctors) = do

266 let types' = updateImports (importedTypes imp) (first fst `map` exportedTypes exps) name

279 let types' = updateImports (importedTypes imp) (first fst `map` exportedTypes exps) name

267− let exportedDctors :: [(ProperName, ModuleName)]

280+ let exportedDctors :: [(ProperName 'ConstructorName, ModuleName)]

268 exportedDctors = allExportedDataConstructors name

281 exportedDctors = allExportedDataConstructors name

269− dctorNames :: [ProperName]

282+ dctorNames :: [ProperName 'ConstructorName]

270 dctorNames = fst `map` exportedDctors

283 dctorNames = fst `map` exportedDctors

271 maybe (return ()) (traverse_ $ checkDctorExists name dctorNames) dctors

284 maybe (return ()) (traverse_ $ checkDctorExists name dctorNames) dctors

272 when (null dctorNames && isNothing dctors) . tell . errorMessage $ MisleadingEmptyTypeImport importModule name

285 when (null dctorNames && isNothing dctors) . tell . errorMessage $ MisleadingEmptyTypeImport importModule name

@@ -278,7 +291,7 @@ resolveImport importModule exps imps impQual = resolveByType

278 importExplicit _ _ = internalError "Invalid argument to importExplicit"

291 importExplicit _ _ = internalError "Invalid argument to importExplicit"

279

292

280 -- Find all exported data constructors for a given type

293 -- Find all exported data constructors for a given type

281− allExportedDataConstructors :: ProperName -> [(ProperName, ModuleName)]

294+ allExportedDataConstructors :: ProperName 'TypeName -> [(ProperName 'ConstructorName, ModuleName)]

282 allExportedDataConstructors name =

295 allExportedDataConstructors name =

283 case find ((== name) . fst . fst) (exportedTypes exps) of

296 case find ((== name) . fst . fst) (exportedTypes exps) of

284 Nothing -> internalError "Invalid state in allExportedDataConstructors"

297 Nothing -> internalError "Invalid state in allExportedDataConstructors"

src/Language/PureScript/Sugar/Operators.hs+9−9

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

@@ -55,9 +56,8 @@ rebracket externs ms = do

55

56

56 where

57 where

57

58

58− makeLookupEntry :: (Qualified Ident, SourceSpan, Fixity, Maybe Ident) -> Maybe (Qualified Ident, Qualified Ident)

59+ makeLookupEntry :: (Qualified Ident, SourceSpan, Fixity, Maybe (Qualified Ident)) -> Maybe (Qualified Ident, Qualified Ident)

59− makeLookupEntry (qname@(Qualified qual _), _, _, Just alias) = Just (qname, Qualified qual alias)

60+ makeLookupEntry (qname, _, _, alias) = (qname, ) <$> alias

60− makeLookupEntry _ = Nothing

61

62 renameAliasedOperators :: M.Map (Qualified Ident) (Qualified Ident) -> Module -> Module

63 renameAliasedOperators aliased (Module ss coms mn ds exts) = Module ss coms mn (map f' ds) exts

@@ -87,16 +87,16 @@ removeParens =

87 go (Parens val) = val

88 go val = val

89

90−externsFixities :: ExternsFile -> [(Qualified Ident, SourceSpan, Fixity, Maybe Ident)]

90+externsFixities :: ExternsFile -> [(Qualified Ident, SourceSpan, Fixity, Maybe (Qualified Ident))]

91externsFixities ExternsFile{..} =

92− [ (Qualified (Just efModuleName) (Op op), internalModuleSourceSpan "", Fixity assoc prec, alias)

92+ [ (Qualified (Just efModuleName) (Op op), internalModuleSourceSpan "", Fixity assoc prec, alias)

93− | ExternsFixity assoc prec op alias <- efFixities

93+ | ExternsFixity assoc prec op alias <- efFixities

94− ]

94+ ]

95

96−collectFixities :: Module -> [(Qualified Ident, SourceSpan, Fixity, Maybe Ident)]

96+collectFixities :: Module -> [(Qualified Ident, SourceSpan, Fixity, Maybe (Qualified Ident))]

97collectFixities (Module _ _ moduleName ds _) = concatMap collect ds

98 where

99− collect :: Declaration -> [(Qualified Ident, SourceSpan, Fixity, Maybe Ident)]

99+ collect :: Declaration -> [(Qualified Ident, SourceSpan, Fixity, Maybe (Qualified Ident))]

100 collect (PositionedDeclaration pos _ (FixityDeclaration fixity name alias)) =

101 [(Qualified (Just moduleName) (Op name), pos, fixity, alias)]

102 collect FixityDeclaration{} = internalError "Fixity without srcpos info"

src/Language/PureScript/Sugar/TypeClasses.hs+63−38

@@ -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+ :: (Functor m, Applicative m, 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+ :: (Functor m, Applicative m, 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−desugarDecl :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => ModuleName -> [DeclarationRef] -> Declaration -> Desugar m (Maybe DeclarationRef, [Declaration])

174+ :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m)

175+ => ModuleName

176+ -> [DeclarationRef]

177+ -> 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

260+typeInstanceDictionaryDeclaration

261+ :: forall m

244−typeInstanceDictionaryDeclaration :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Ident -> ModuleName -> [Constraint] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar m Declaration

262+ . (Functor m, Applicative m, 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

@@ -273,7 +298,7 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =

273 ]

298 ]

274

299

275 let props = ObjectLiteral (members ++ superclasses)

300 let props = 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+40−19

@@ -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,12 +31,20 @@ 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+ :: (Functor m, Applicative m, 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+ :: (Functor m, 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

@@ -48,12 +55,14 @@ deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance)

48deriveInstance mn ds (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> deriveInstance mn ds d

55deriveInstance mn ds (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> deriveInstance mn ds d

49deriveInstance _ _ e = return e

56deriveInstance _ _ e = return e

50

57

51−unwrapTypeConstructor :: Type -> Maybe (Qualified ProperName, [Type])

58+unwrapTypeConstructor :: Type -> Maybe (Qualified (ProperName 'TypeName), [Type])

59+unwrapTypeConstructor = fmap (second reverse) . go

60+ where

52−unwrapTypeConstructor (TypeConstructor tyCon) = Just (tyCon, [])

61+ go (TypeConstructor tyCon) = Just (tyCon, [])

53−unwrapTypeConstructor (TypeApp ty arg) = do

62+ go (TypeApp ty arg) = do

54− (tyCon, args) <- unwrapTypeConstructor ty

63+ (tyCon, args) <- go ty

55− return (tyCon, arg : args)

64+ return (tyCon, arg : args)

56−unwrapTypeConstructor _ = Nothing

65+ go _ = Nothing

57

66

58dataGeneric :: ModuleName

67dataGeneric :: ModuleName

59dataGeneric = ModuleName [ ProperName "Data", ProperName "Generic" ]

68dataGeneric = ModuleName [ ProperName "Data", ProperName "Generic" ]

@@ -64,7 +73,13 @@ dataMaybe = ModuleName [ ProperName "Data", ProperName "Maybe" ]

64typesProxy :: ModuleName

73typesProxy :: ModuleName

65typesProxy = ModuleName [ ProperName "Type", ProperName "Proxy" ]

74typesProxy = ModuleName [ ProperName "Type", ProperName "Proxy" ]

66

75

76+deriveGeneric

67−deriveGeneric :: (Functor m, MonadError MultipleErrors m, MonadSupply m) => ModuleName -> [Declaration] -> ProperName -> [Type] -> m [Declaration]

77+ :: (Functor m, MonadError MultipleErrors m, MonadSupply m)

78+ => ModuleName

79+ -> [Declaration]

80+ -> ProperName 'TypeName

81+ -> [Type]

82+ -> m [Declaration]

68deriveGeneric mn ds tyConNm args = do

83deriveGeneric mn ds tyConNm args = do

69 tyCon <- findTypeDecl tyConNm ds

84 tyCon <- findTypeDecl tyConNm ds

70 toSpine <- mkSpineFunction mn tyCon

85 toSpine <- mkSpineFunction mn tyCon

@@ -75,7 +90,11 @@ deriveGeneric mn ds tyConNm args = do

75 , ValueDeclaration (Ident C.toSignature) Public [] (Right toSignature)

90 , ValueDeclaration (Ident C.toSignature) Public [] (Right toSignature)

76 ]

91 ]

77

92

93+findTypeDecl

78−findTypeDecl :: (Functor m, MonadError MultipleErrors m) => ProperName -> [Declaration] -> m Declaration

94+ :: (Functor m, MonadError MultipleErrors m)

95+ => ProperName 'TypeName

96+ -> [Declaration]

97+ -> m Declaration

79findTypeDecl tyConNm = maybe (throwError . errorMessage $ CannotFindDerivingType tyConNm) return . find isTypeDecl

98findTypeDecl tyConNm = maybe (throwError . errorMessage $ CannotFindDerivingType tyConNm) return . find isTypeDecl

80 where

99 where

81 isTypeDecl :: Declaration -> Bool

100 isTypeDecl :: Declaration -> Bool

@@ -92,7 +111,7 @@ mkSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> mapM mkCtorCl

92 recordConstructor :: Expr -> Expr

111 recordConstructor :: Expr -> Expr

93 recordConstructor = App (Constructor (Qualified (Just dataGeneric) (ProperName "SRecord")))

112 recordConstructor = App (Constructor (Qualified (Just dataGeneric) (ProperName "SRecord")))

94

113

95− mkCtorClause :: (ProperName, [Type]) -> m CaseAlternative

114+ mkCtorClause :: (ProperName 'ConstructorName, [Type]) -> m CaseAlternative

96 mkCtorClause (ctorName, tys) = do

115 mkCtorClause (ctorName, tys) = do

97 idents <- replicateM (length tys) freshIdent'

116 idents <- replicateM (length tys) freshIdent'

98 return $ CaseAlternative [ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)] (Right (caseResult idents))

117 return $ CaseAlternative [ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)] (Right (caseResult idents))

@@ -125,10 +144,12 @@ mkSignatureFunction mn (DataDeclaration _ name tyArgs args) classArgs = lamNull

125 proxy :: Type -> Type

144 proxy :: Type -> Type

126 proxy = TypeApp (TypeConstructor (Qualified (Just typesProxy) (ProperName "Proxy")))

145 proxy = TypeApp (TypeConstructor (Qualified (Just typesProxy) (ProperName "Proxy")))

127

146

128− mkProdClause :: (ProperName, [Type]) -> Expr

147+ mkProdClause :: (ProperName 'ConstructorName, [Type]) -> Expr

148+ mkProdClause (ctorName, tys) =

149+ ObjectLiteral

129− mkProdClause (ctorName, tys) = ObjectLiteral [ ("sigConstructor", StringLiteral (showQualified runProperName (Qualified (Just mn) ctorName)))

150+ [ ("sigConstructor", StringLiteral (showQualified runProperName (Qualified (Just mn) ctorName)))

130− , ("sigValues", ArrayLiteral . map (mkProductSignature . instantiate) $ tys)

151+ , ("sigValues", ArrayLiteral . map (mkProductSignature . instantiate) $ tys)

131− ]

152+ ]

132

153

133 mkProductSignature :: Type -> Expr

154 mkProductSignature :: Type -> Expr

134 mkProductSignature r | Just rec <- objectType r =

155 mkProductSignature r | Just rec <- objectType r =

@@ -158,7 +179,7 @@ mkFromSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> (addCatch

158 recordBinder :: [Binder] -> Binder

179 recordBinder :: [Binder] -> Binder

159 recordBinder = ConstructorBinder (Qualified (Just dataGeneric) (ProperName "SRecord"))

180 recordBinder = ConstructorBinder (Qualified (Just dataGeneric) (ProperName "SRecord"))

160

181

161− mkAlternative :: (ProperName, [Type]) -> m CaseAlternative

182+ mkAlternative :: (ProperName 'ConstructorName, [Type]) -> m CaseAlternative

162 mkAlternative (ctorName, tys) = do

183 mkAlternative (ctorName, tys) = do

163 idents <- replicateM (length tys) freshIdent'

184 idents <- replicateM (length tys) freshIdent'

164 return $ CaseAlternative [ prodBinder [ StringBinder (showQualified runProperName (Qualified (Just mn) ctorName)), ArrayBinder (map VarBinder idents)]]

185 return $ CaseAlternative [ prodBinder [ StringBinder (showQualified runProperName (Qualified (Just mn) ctorName)), ArrayBinder (map VarBinder idents)]]

src/Language/PureScript/TypeChecker.hs+82−79

@@ -39,15 +39,15 @@ import Language.PureScript.TypeClassDictionaries

39import Language.PureScript.Environment

40import Language.PureScript.Errors

41

42−addDataType ::

42+addDataType

43− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

43+ :: (Functor m, Applicative m, 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+ :: (Functor m, Applicative m, 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+ :: (Functor m, Applicative m, 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+ :: (Functor m, Applicative m, 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+ :: (Functor m, Applicative m, 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+ :: (Functor m, Applicative m, 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+ :: (Functor m, Applicative m, 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+ :: (Functor m, Applicative m, 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+ :: (Functor m, Applicative m, 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+ :: (Functor m, Applicative m, 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+ . (Functor m, Applicative m, 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

@@ -281,7 +282,7 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds

281

282

282 checkFixities :: Declaration -> m ()

283 checkFixities :: Declaration -> m ()

283 checkFixities (FixityDeclaration _ name (Just alias)) = do

284 checkFixities (FixityDeclaration _ name (Just 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

286 checkFixities (FixityDeclaration _ name _) = do

287 checkFixities (FixityDeclaration _ name _) = do

287 env <- getEnv

288 env <- getEnv

@@ -308,7 +309,7 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds

308 | otherwise = firstDuplicate xs

309 | otherwise = firstDuplicate xs

309 firstDuplicate _ = Nothing

310 firstDuplicate _ = Nothing

310

311

311− checkOrphanInstance :: Ident -> Qualified ProperName -> [Type] -> m ()

312+ checkOrphanInstance :: Ident -> Qualified (ProperName 'ClassName) -> [Type] -> m ()

312 checkOrphanInstance dictName className@(Qualified (Just mn') _) tys'

313 checkOrphanInstance dictName className@(Qualified (Just mn') _) tys'

313 | moduleName == mn' || any checkType tys' = return ()

314 | moduleName == mn' || any checkType tys' = return ()

314 | otherwise = throwError . errorMessage $ OrphanInstance dictName className tys'

315 | otherwise = throwError . errorMessage $ OrphanInstance dictName className tys'

@@ -335,10 +336,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

336-- 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.

337-- required by exported members are also exported.

337--

338--

338−typeCheckModule :: forall m.

339+typeCheckModule

340+ :: forall m

339− (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

341+ . (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

340− Module ->

342+ => Module

341− m Module

343+ -> m Module

342typeCheckModule (Module _ _ _ _ Nothing) = internalError "exports should have been elaborated"

344typeCheckModule (Module _ _ _ _ Nothing) = internalError "exports should have been elaborated"

343typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint (ErrorInModule mn)) $ do

345typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint (ErrorInModule mn)) $ do

344 modify (\s -> s { checkCurrentModule = Just mn })

346 modify (\s -> s { checkCurrentModule = Just mn })

@@ -403,7 +405,7 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint

403 where

405 where

404 go (ConstrainedType cs _) = mapMaybe (fmap TypeClassRef . extractCurrentModuleClass . fst) cs

406 go (ConstrainedType cs _) = mapMaybe (fmap TypeClassRef . extractCurrentModuleClass . fst) cs

405 go _ = []

407 go _ = []

406− extractCurrentModuleClass :: Qualified ProperName -> Maybe ProperName

408+ extractCurrentModuleClass :: Qualified (ProperName 'ClassName) -> Maybe (ProperName 'ClassName)

407 extractCurrentModuleClass (Qualified (Just mn') name) | mn == mn' = Just name

409 extractCurrentModuleClass (Qualified (Just mn') name) | mn == mn' = Just name

408 extractCurrentModuleClass _ = Nothing

410 extractCurrentModuleClass _ = Nothing

409

411

@@ -433,6 +435,7 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint

433 where

435 where

434 getAlias :: Declaration -> Maybe Ident

436 getAlias :: Declaration -> Maybe Ident

435 getAlias (PositionedDeclaration _ _ d) = getAlias d

437 getAlias (PositionedDeclaration _ _ d) = getAlias d

436− getAlias (FixityDeclaration _ name' alias) | name == name' = alias

438+ getAlias (FixityDeclaration _ name' (Just (Qualified (Just mn') alias)))

439+ | mn == mn' && name == name' = Just alias

437 getAlias _ = Nothing

440 getAlias _ = Nothing

438 checkNonAliasesAreExported _ = return ()

441 checkNonAliasesAreExported _ = return ()

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+ . (Functor m, Applicative m, 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+64−51

@@ -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+ :: (Functor m, Applicative m, 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+ :: (Functor m, Applicative m, 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+ :: (Functor m, Applicative m, 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,10 +100,10 @@ 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+ :: (Functor m, Applicative m, 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

@@ -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+ :: (Functor m, Applicative m, 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+ :: (Functor m, Applicative m, 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+ :: (Functor m, Applicative m, 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+ :: (Functor m, Applicative m, 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+ :: (Functor m, Applicative m, 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+ . (Functor m, Applicative m, 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+63−32

@@ -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+ :: (Functor m, Applicative m, 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,25 +111,35 @@ 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+ :: (Functor m, 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+ :: (Functor m, 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

122−bindLocalVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(Ident, Type, NameVisibility)] -> m a -> m a

128+ :: (Functor m, MonadState CheckState m)

129+ => ModuleName

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

137+bindLocalTypeVariables

127−bindLocalTypeVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(ProperName, Kind)] -> m a -> m a

138+ :: (Functor m, 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

@@ -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, Functor m, 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, Functor m, 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, Functor m, 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, Functor m, 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

src/Language/PureScript/TypeChecker/Types.hs+11−6

@@ -468,11 +468,12 @@ check val ty = rethrow (addHint (ErrorCheckingType val ty)) $ check' val ty

468-- |

469-- Check the type of a value

470--

471+check'

471−check' :: forall m.

472+ :: forall m

472− (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

473+ . (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

473− Expr ->

474+ => Expr

474− Type ->

475+ -> Type

475− m Expr

476+ -> m Expr

476check' val (ForAll ident ty _) = do

477check' val (ForAll ident ty _) = do

477 scope <- newSkolemScope

478 scope <- newSkolemScope

478 sko <- newSkolemConstant

479 sko <- newSkolemConstant

@@ -492,7 +493,11 @@ check' val t@(ConstrainedType constraints ty) = do

492 where

493 where

493 -- | Add a dictionary for the constraint to the scope, and dictionaries

494 -- | Add a dictionary for the constraint to the scope, and dictionaries

494 -- for all implied superclass instances.

495 -- for all implied superclass instances.

496+ newDictionaries

497+ :: [(Qualified (ProperName 'ClassName), Integer)]

498+ -> Qualified Ident

499+ -> (Qualified (ProperName 'ClassName), [Type])

495− newDictionaries :: [(Qualified ProperName, Integer)] -> Qualified Ident -> (Qualified ProperName, [Type]) -> m [TypeClassDictionaryInScope]

500+ -> m [TypeClassDictionaryInScope]

496 newDictionaries path name (className, instanceTy) = do

501 newDictionaries path name (className, instanceTy) = do

497 tcs <- gets (typeClasses . checkEnv)

502 tcs <- gets (typeClasses . checkEnv)

498 let (args, _, superclasses) = fromMaybe (internalError "newDictionaries: type class lookup failed") $ M.lookup className tcs

503 let (args, _, superclasses) = fromMaybe (internalError "newDictionaries: type class lookup failed") $ M.lookup className tcs

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+9−21

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

tests/Main.hs+18−2

@@ -30,6 +30,7 @@

30-- -- @shouldFailWith TypesDoNotUnify

31-- -- @shouldFailWith TypesDoNotUnify

32-- -- @shouldFailWith TransitiveExportError

33+--

33

34

34module Main (main) where

35module Main (main) where

35

36

@@ -39,6 +40,7 @@ import Prelude.Compat

39import qualified Language.PureScript as P

40import qualified Language.PureScript as P

40import qualified Language.PureScript.CodeGen.JS as J

41import qualified Language.PureScript.CodeGen.JS as J

41import qualified Language.PureScript.CoreFn as CF

42import qualified Language.PureScript.CoreFn as CF

43+import qualified Language.PureScript.Docs as Docs

42

44

43import Data.Char (isSpace)

45import Data.Char (isSpace)

44import Data.Maybe (mapMaybe, fromMaybe)

46import Data.Maybe (mapMaybe, fromMaybe)

@@ -69,6 +71,7 @@ import Text.Parsec (ParseError)

69

71

70import TestsSetup

72import TestsSetup

71import TestPscPublish

73import TestPscPublish

74+import qualified TestDocs

72

75

73modulesDir :: FilePath

76modulesDir :: FilePath

74modulesDir = ".test_modules" </> "node_modules"

77modulesDir = ".test_modules" </> "node_modules"

@@ -172,8 +175,20 @@ assertDoesNotCompile inputFiles foreigns = do

172

175

173main :: IO ()

176main :: IO ()

174main = do

177main = do

178+ heading "Main compiler test suite"

175 testCompiler

179 testCompiler

180+ heading "Documentation test suite"

181+ TestDocs.main

182+ -- heading "psc-publish test suite"

176− testPscPublish

183+ -- testPscPublish

184+

185+ where

186+ heading msg = do

187+ putStrLn ""

188+ putStrLn $ replicate 79 '#'

189+ putStrLn $ "# " ++ msg

190+ putStrLn $ replicate 79 '#'

191+ putStrLn ""

177

192

178testCompiler :: IO ()

193testCompiler :: IO ()

179testCompiler = do

194testCompiler = do

@@ -201,7 +216,7 @@ testCompiler = do

201 assertDoesNotCompile (supportPurs ++ [failing </> inputFile]) foreigns

216 assertDoesNotCompile (supportPurs ++ [failing </> inputFile]) foreigns

202

217

203 if null failures

218 if null failures

204− then exitSuccess

219+ then pure ()

205 else do

220 else do

206 putStrLn "Failures:"

221 putStrLn "Failures:"

207 forM_ failures $ \(fp, err) ->

222 forM_ failures $ \(fp, err) ->

@@ -213,6 +228,7 @@ testPscPublish :: IO ()

213testPscPublish = do

228testPscPublish = do

214 testPackage "tests/support/prelude"

229 testPackage "tests/support/prelude"

215

230

231+

216supportModules :: [String]

232supportModules :: [String]

217supportModules =

233supportModules =

218 [ "Control.Monad.Eff.Class"

234 [ "Control.Monad.Eff.Class"

tests/TestDocs.hsnew file+232

@@ -0,0 +1,232 @@

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 Control.Monad hiding (forM_)

13+import Control.Applicative

14+import Control.Arrow

15+import Data.Maybe (fromMaybe)

16+import Data.List ((\\))

17+import Data.Foldable

18+import Data.Traversable

19+import System.Exit

20+import qualified Text.Parsec as Parsec

21+

22+import qualified Language.PureScript as P

23+import qualified Language.PureScript.Docs as Docs

24+import qualified Language.PureScript.Publish as Publish

25+

26+import qualified TestPscPublish

27+

28+publishOpts :: Publish.PublishOptions

29+publishOpts = Publish.defaultPublishOptions

30+ { Publish.publishGetVersion = return testVersion

31+ , Publish.publishWorkingTreeDirty = return ()

32+ }

33+ where testVersion = ("v999.0.0", Version [999,0,0] [])

34+

35+main :: IO ()

36+main = do

37+ TestPscPublish.pushd "examples/docs" $ do

38+ Docs.Package{..} <- Publish.preparePackage publishOpts

39+ forM_ testCases $ \(mn, pragmas) ->

40+ let mdl = takeJust ("module not found in docs: " ++ mn)

41+ (find ((==) mn . Docs.modName) pkgModules)

42+ in forM_ pragmas (flip runAssertionIO mdl)

43+

44+takeJust :: String -> Maybe a -> a

45+takeJust msg = maybe (error msg) id

46+

47+data Assertion

48+ -- | Assert that a particular declaration is documented with the given

49+ -- children

50+ = ShouldBeDocumented P.ModuleName String [String]

51+ -- | Assert that a particular declaration is not documented

52+ | ShouldNotBeDocumented P.ModuleName String

53+ -- | Assert that a particular declaration exists, but without a particular

54+ -- child.

55+ | ChildShouldNotBeDocumented P.ModuleName String String

56+ -- | Assert that a particular declaration has a particular type class

57+ -- constraint.

58+ | ShouldBeConstrained P.ModuleName String String

59+ deriving (Show)

60+

61+data AssertionFailure

62+ -- | A declaration was not documented, but should have been

63+ = NotDocumented P.ModuleName String

64+ -- | A child declaration was not documented, but should have been

65+ | ChildrenNotDocumented P.ModuleName String [String]

66+ -- | A declaration was documented, but should not have been

67+ | Documented P.ModuleName String

68+ -- | A child declaration was documented, but should not have been

69+ | ChildDocumented P.ModuleName String String

70+ -- | A constraint was missing.

71+ | ConstraintMissing P.ModuleName String String

72+ -- | A declaration had the wrong "type" (ie, value, type, type class)

73+ -- Fields: declaration title, expected "type", actual "type".

74+ | WrongDeclarationType P.ModuleName String String String

75+ deriving (Show)

76+

77+data AssertionResult

78+ = Pass

79+ | Fail AssertionFailure

80+ deriving (Show)

81+

82+runAssertion :: Assertion -> Docs.Module -> AssertionResult

83+runAssertion assertion Docs.Module{..} =

84+ case assertion of

85+ ShouldBeDocumented mn decl children ->

86+ case findChildren decl (declarationsFor mn) of

87+ Nothing ->

88+ Fail (NotDocumented mn decl)

89+ Just actualChildren ->

90+ case children \\ actualChildren of

91+ [] -> Pass

92+ cs -> Fail (ChildrenNotDocumented mn decl cs)

93+

94+ ShouldNotBeDocumented mn decl ->

95+ case findChildren decl (declarationsFor mn) of

96+ Just _ ->

97+ Fail (Documented mn decl)

98+ Nothing ->

99+ Pass

100+

101+ ChildShouldNotBeDocumented mn decl child ->

102+ case findChildren decl (declarationsFor mn) of

103+ Just children ->

104+ if child `elem` children

105+ then Fail (ChildDocumented mn decl child)

106+ else Pass

107+ Nothing ->

108+ Fail (NotDocumented mn decl)

109+

110+ ShouldBeConstrained mn decl tyClass ->

111+ case find ((==) decl . Docs.declTitle) (declarationsFor mn) of

112+ Nothing ->

113+ Fail (NotDocumented mn decl)

114+ Just Docs.Declaration{..} ->

115+ case declInfo of

116+ Docs.ValueDeclaration ty ->

117+ if checkConstrained ty tyClass

118+ then Pass

119+ else Fail (ConstraintMissing mn decl tyClass)

120+ _ ->

121+ Fail (WrongDeclarationType mn decl "value"

122+ (Docs.declInfoToString declInfo))

123+

124+ where

125+ declarationsFor mn =

126+ if P.runModuleName mn == modName

127+ then modDeclarations

128+ else fromMaybe [] (lookup mn modReExports)

129+

130+ findChildren title =

131+ fmap childrenTitles . find ((==) title . Docs.declTitle)

132+

133+ childrenTitles = map Docs.cdeclTitle . Docs.declChildren

134+

135+checkConstrained ty tyClass =

136+ -- Note that we don't recurse on ConstrainedType if none of the constraints

137+ -- match; this is by design, as constraints should be moved to the front

138+ -- anyway.

139+ case ty of

140+ P.ConstrainedType cs _ | any (matches tyClass) cs ->

141+ True

142+ P.ForAll _ ty' _ ->

143+ checkConstrained ty' tyClass

144+ _ ->

145+ False

146+ where

147+ matches className =

148+ (==) className . P.runProperName . P.disqualify . fst

149+

150+runAssertionIO :: Assertion -> Docs.Module -> IO ()

151+runAssertionIO assertion mdl = do

152+ putStrLn ("In " ++ Docs.modName mdl ++ ": " ++ show assertion)

153+ case runAssertion assertion mdl of

154+ Pass -> pure ()

155+ fail -> do

156+ putStrLn (show fail)

157+ exitFailure

158+

159+testCases :: [(String, [Assertion])]

160+testCases =

161+ [ ("Example",

162+ [ -- From dependencies

163+ ShouldBeDocumented (n "Prelude") "Unit" []

164+ , ShouldNotBeDocumented (n "Prelude") "unit"

165+

166+ -- From local files

167+ , ShouldBeDocumented (n "Example2") "one" []

168+ , ShouldNotBeDocumented (n "Example2") "two"

169+ ])

170+ , ("Example2",

171+ [ ShouldBeDocumented (n "Example2") "one" []

172+ , ShouldBeDocumented (n "Example2") "two" []

173+ ])

174+

175+ , ("UTF8",

176+ [ ShouldBeDocumented (n "UTF8") "thing" []

177+ ])

178+

179+ , ("Transitive1",

180+ [ ShouldBeDocumented (n "Transitive2") "transitive3" []

181+ ])

182+

183+ , ("NotAllCtors",

184+ [ ShouldBeDocumented (n "Prelude") "Boolean2" ["True"]

185+ , ChildShouldNotBeDocumented (n "Prelude") "Boolean2" "False"

186+ ])

187+

188+ , ("DuplicateNames",

189+ [ ShouldBeDocumented (n "Prelude") "Unit" []

190+ , ShouldBeDocumented (n "DuplicateNames") "unit" []

191+ , ShouldNotBeDocumented (n "Prelude") "unit"

192+ ])

193+

194+ , ("MultiVirtual",

195+ [ ShouldBeDocumented (n "MultiVirtual1") "foo" []

196+ , ShouldBeDocumented (n "MultiVirtual2") "bar" []

197+ , ShouldBeDocumented (n "MultiVirtual2") "baz" []

198+ ])

199+

200+ , ("Clash",

201+ [ ShouldBeDocumented (n "Clash1") "value" []

202+ , ShouldBeDocumented (n "Clash1") "Type" []

203+ , ShouldBeDocumented (n "Clash1") "TypeClass" ["typeClassMember"]

204+ ])

205+

206+ , ("SolitaryTypeClassMember",

207+ [ ShouldBeDocumented (n "SomeTypeClass") "member" []

208+ , ShouldNotBeDocumented (n "SomeTypeClass") "SomeClass"

209+ , ShouldBeConstrained (n "SomeTypeClass") "member" "SomeClass"

210+ ])

211+

212+ , ("ReExportedTypeClass",

213+ [ ShouldBeDocumented (n "SomeTypeClass") "SomeClass" ["member"]

214+ ])

215+

216+ , ("TypeClassWithoutMembers",

217+ [ ShouldBeDocumented (n "Intermediate") "SomeClass" []

218+ , ChildShouldNotBeDocumented (n "Intermediate") "SomeClass" "member"

219+ ])

220+

221+ -- Remove this after 0.9.

222+ , ("OldOperators",

223+ [ ShouldBeDocumented (n "OldOperators2") "(>>)" []

224+ ])

225+

226+ , ("NewOperators",

227+ [ ShouldBeDocumented (n "NewOperators2") "(>>>)" []

228+ ])

229+ ]

230+

231+ where

232+ n = P.moduleNameFromString

tests/TestPscPublish.hs+3−3

@@ -60,6 +60,6 @@ testPackage dir = do

60 case r of

61 Pass _ -> pure ()

62 other -> do

63− hPutStrLn stderr ("psc-publish tests failed on " ++ dir ++ ":")

63+ putStrLn ("psc-publish tests failed on " ++ dir ++ ":")

64− hPutStrLn stderr (show other)

64+ putStrLn (show other)

65− exitFailure

65+ exitFailure