2c0c2ab · rowtype-yoga/purescript-native

.travis.yml+3−18

compare with golang

unifiedsplit

@@ -1,32 +1,17 @@

1language: c

2−sudo: false

2+dist: trusty

3+sudo: required

3matrix:

4matrix:

4 include:

5 include:

5− - env: GHCVER=7.8.4 CABALVER=1.22 COVERAGE=true

6− compiler: ": #GHC 7.8.4 - tests"

7− # ^ HACK before https://github.com/travis-ci/travis-ci/issues/4393 is resolved

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

9− - env: GHCVER=7.6.3 CABALVER=1.22

10− compiler: ": #GHC 7.6.3"

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

12− - env: GHCVER=7.10.1 CABALVER=1.22 DEPLOY=yes

13− compiler: ": #GHC 7.10.1"

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

15− - env: GHCVER=7.10.2 CABALVER=1.22 STACKAGE=lts-3.22 RUNSDISTTESTS=YES

16− compiler: ": #GHC 7.10.2 lts-3.22"

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

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

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

19 compiler: ": #GHC 7.10.3 lts-5.4"

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

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

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

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

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

22 compiler: ": #GHC 7.10.3 nightly-2016-02-25"

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

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

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

24− - env: GHCVER=7.10.3 CABALVER=1.22

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

25 compiler: ": #GHC 7.10.3"

13 compiler: ": #GHC 7.10.3"

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

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

27− - env: GHCVER=8.0.1 CABALVER=1.24

28− compiler: ": #GHC 8.0.1"

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

30before_install:

15before_install:

31 - unset CC

16 - unset CC

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

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

CONTRIBUTORS.md+1

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

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

10- [@ardumont](https://github.com/ardumont) (Antoine R. Dumont) My existing contributions and all future contributions until further notice are Copyright Antoine R. Dumont, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

11- [@aspidites](https://github.com/aspidites) (Edwin Marshall) My existing contributions and all future contributions until further notice are Copyright Edwin Marshall, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

12+- [@bagl](https://github.com/bagl) (Petr Vapenka) My existing contributions and all future contributions until further notice are Copyright Petr Vapenka, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

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

INSTALL.md+4−8

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

6

7## Using prebuilt binaries

8

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

9+The prebuilt binaries are compiled with GHC 7.10.3, and therefore they should

10−run on any operating system supported by GHC 7.8.4, such as:

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

11

12* Windows 2000 or later,

13* OS X 10.7 or later,

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

23

24## Compiling from source

25

26−GHC 7.6.1 or newer is required to compile from source. The easiest way is to

26+GHC 7.10.1 or newer is required to compile from source. The easiest way is to

27use stack:

28

29```

30−$ stack install --resolver lts purescript

30+$ stack install --resolver=nightly purescript

31```

32

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

@@ -39,10 +39,6 @@ If you don't have stack installed yet there are install instructions

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

40which will install ghc for you.

41

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

43−7.6.

44−

45−

46## The "curses" library

42## The "curses" library

47

43

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

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

bundle/winbuild.sh+2−2

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

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

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

19strip ../dist/build/psc-bundle/psc-bundle.exe

20−strip ../dist/build/psc-ide-server/psc-ide-server

20+strip ../dist/build/psc-ide-server/psc-ide-server.exe

21−strip ../dist/build/psc-ide-client/psc-ide-client

21+strip ../dist/build/psc-ide-client/psc-ide-client.exe

22

23# Copy files to staging directory

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

examples/failing/ConstraintInference.pursnew file+10

@@ -0,0 +1,10 @@

1+-- @shouldFailWith NoInstanceFound

2+

3+module Main where

4+

5+import Prelude

6+

7+spin :: forall a b. a -> b

8+spin x = spin x

9+

10+test = show <<< spin

examples/failing/OperatorSections.pursnew file+8

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

1+-- @shouldFailWith CannotApplyFunction

2+module Main where

3+

4+import Prelude

5+

6+main = do

7+ (true `not` _)

8+

examples/passing/ConstraintInference.pursnew file+7

@@ -0,0 +1,7 @@

1+module Main where

2+

3+import Prelude

4+

5+shout = Control.Monad.Eff.Console.log <<< (<> "!") <<< show

6+

7+main = shout "Done"

examples/passing/ContextSimplification.pursnew file+13

@@ -0,0 +1,13 @@

1+module Main where

2+

3+import Prelude

4+import Control.Monad.Eff.Console

5+

6+shout = log <<< (<> "!") <<< show

7+

8+-- Here, we should simplify the context so that only one Show

9+-- constraint is added.

10+usesShowTwice true = shout

11+usesShowTwice false = print

12+

13+main = usesShowTwice true "Done"

examples/passing/MonadState.purs+32−19

@@ -1,12 +1,16 @@

1module Main where

2

3import Prelude

4+import Control.Monad.Eff.Console

4

5

5data Tuple a b = Tuple a b

6data Tuple a b = Tuple a b

6

7

8+instance showTuple :: (Show a, Show b) => Show (Tuple a b) where

9+ show (Tuple a b) = "(" <> show a <> ", " <> show b <> ")"

10+

7−class MonadState s m where

11+class Monad m <= MonadState s m where

8 get :: m s

12 get :: m s

9− put :: s -> m {}

13+ put :: s -> m Unit

10

14

11data State s a = State (s -> Tuple s a)

15data State s a = State (s -> Tuple s a)

12

16

@@ -29,20 +33,29 @@ instance monadState :: Monad (State s)

29

33

30instance monadStateState :: MonadState s (State s) where

34instance monadStateState :: MonadState s (State s) where

31 get = State (\s -> Tuple s s)

35 get = State (\s -> Tuple s s)

32− put s = State (\_ -> Tuple s {})

36+ put s = State (\_ -> Tuple s unit)

33−

37+

38+-- Without the call to same, the following strange (but correct, in the absence of

39+-- functional dependencies) type:

40+--

41+-- forall m t1 t2.

42+-- ( Bind m

43+-- , MonadState t1 m

44+-- , MonadState t2 m

45+-- ) => (t1 -> t2) -> m Unit

46+--

47+-- With the type hint, the inferred type is more sensible:

48+--

49+-- forall m t.

50+-- ( Bind m

34−modify :: forall m s. (Prelude.Monad m, MonadState s m) => (s -> s) -> m {}

51+-- , MonadState t m

52+-- ) => (t -> t) -> m Unit

35−modify f = do

53+modify f =

54+ do

36− s <- get

55+ s <- get

37− put (f s)

56+ put (same f s)

38−

57+ where

39−test :: Tuple String String

58+ same :: forall a. (a -> a) -> (a -> a)

40−test = runState "" $ do

59+ same = id

41− modify $ (++) "World!"

60+

42− modify $ (++) "Hello, "

61+main = print $ runState 0 (modify (+ 1))

43− get

44−

45−main = do

46− let t1 = test

47− Control.Monad.Eff.Console.log "Done"

48−

psc-bundle/Main.hs+4−4

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

51 } deriving Show

52

53-- | Given a filename, assuming it is in the correct place on disk, infer a ModuleIdentifier.

54−guessModuleIdentifier :: (Applicative m, MonadError ErrorMessage m) => FilePath -> m ModuleIdentifier

54+guessModuleIdentifier :: (MonadError ErrorMessage m) => FilePath -> m ModuleIdentifier

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

56 where

57 guessModuleType "index.js" = pure Regular

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

61-- | The main application function.

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

63-- and generates and prints the final Javascript bundle.

64−app :: (Applicative m, MonadError ErrorMessage m, MonadIO m) => Options -> m String

64+app :: (MonadError ErrorMessage m, MonadIO m) => Options -> m String

65app Options{..} = do

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

67 when (null inputFiles) . liftIO $ do

@@ -119,13 +119,13 @@ options = Options <$> some inputFile

119 requirePath = strOption $

120 short 'r'

121 <> long "require-path"

122− <> Opts.value ""

123− <> help "The path prefix used in require() calls in the generated JavaScript"

122+ <> help "The path prefix used in require() calls in the generated JavaScript [deprecated]"

124

123

125-- | Make it go.

124-- | Make it go.

126main :: IO ()

125main :: IO ()

127main = do

126main = do

128 opts <- execParser (info (version <*> helper <*> options) infoModList)

127 opts <- execParser (info (version <*> helper <*> options) infoModList)

128+ when (optionsRequirePath opts /= Nothing) $ hPutStrLn stderr "The require-path option is deprecated and will be removed in PureScript 0.9."

129 output <- runExceptT (app opts)

130 case output of

131 Left err -> do

psc-ide-client/Main.hs+6−7

@@ -5,7 +5,6 @@ import Prelude ()

5import Prelude.Compat

6

7import Control.Exception

8−import Data.Maybe (fromMaybe)

9import Data.Text (Text)

8import Data.Text (Text)

10import qualified Data.Text as T

9import qualified Data.Text as T

11import qualified Data.Text.IO as T

10import qualified Data.Text.IO as T

@@ -18,19 +17,19 @@ import System.IO

18import qualified Paths_purescript as Paths

17import qualified Paths_purescript as Paths

19

18

20data Options = Options

19data Options = Options

21− { optionsPort :: Maybe Int

20+ { optionsPort :: PortID

22− }

21+ }

23

22

24main :: IO ()

23main :: IO ()

25main = do

24main = do

26 Options port <- execParser opts

25 Options port <- execParser opts

27− let port' = PortNumber . fromIntegral $ fromMaybe 4242 port

28− client port'

26+ client port

29 where

27 where

30 parser =

28 parser =

31 Options <$>

29 Options <$>

30+ (PortNumber . fromIntegral <$>

32− optional (option auto (long "port" <> short 'p'))

31+ option auto (long "port" <> short 'p' <> value (4242 :: Integer)))

33− opts = info (version <*> parser) mempty

32+ opts = info (version <*> helper <*> parser) mempty

34 version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> help "Show the version number" <> hidden

33 version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> help "Show the version number" <> hidden

35

34

36client :: PortID -> IO ()

35client :: PortID -> IO ()

psc-ide-server/Main.hs+35−22

@@ -11,8 +11,9 @@ import Prelude.Compat

11

12import Control.Concurrent (forkFinally)

13import Control.Concurrent.STM

14−import Control.Exception (bracketOnError)

14+import Control.Exception (bracketOnError, catchJust)

15import Control.Monad

16+import Control.Monad.Error.Class

16import "monad-logger" Control.Monad.Logger

17import "monad-logger" Control.Monad.Logger

17import Control.Monad.Reader

18import Control.Monad.Reader

18import Control.Monad.Trans.Except

19import Control.Monad.Trans.Except

@@ -32,6 +33,7 @@ import Options.Applicative

32import System.Directory

33import System.Directory

33import System.FilePath

34import System.FilePath

34import System.IO

35import System.IO

36+import System.IO.Error (isEOFError)

35

37

36import qualified Paths_purescript as Paths

38import qualified Paths_purescript as Paths

37

39

@@ -87,7 +89,7 @@ main = do

87 (PortNumber . fromIntegral <$>

89 (PortNumber . fromIntegral <$>

88 option auto (long "port" <> short 'p' <> value (4242 :: Integer))) <*>

90 option auto (long "port" <> short 'p' <> value (4242 :: Integer))) <*>

89 switch (long "debug")

91 switch (long "debug")

90− opts = info (version <*> parser) mempty

92+ opts = info (version <*> helper <*> parser) mempty

91 version = abortOption

93 version = abortOption

92 (InfoMsg (showVersion Paths.version))

94 (InfoMsg (showVersion Paths.version))

93 (long "version" <> help "Show the version number")

95 (long "version" <> help "Show the version number")

@@ -101,32 +103,43 @@ startServer port env = withSocketsDo $ do

101

103

102 loop :: (PscIde m, MonadLogger m) => Socket -> m ()

104 loop :: (PscIde m, MonadLogger m) => Socket -> m ()

103 loop sock = do

105 loop sock = do

104− (cmd,h) <- acceptCommand sock

106+ accepted <- runExceptT $ acceptCommand sock

107+ case accepted of

108+ Left err -> $(logDebug) err

109+ Right (cmd, h) -> do

105− case decodeT cmd of

110+ case decodeT cmd of

106− Just cmd' -> do

111+ Just cmd' -> do

107− result <- runExceptT (handleCommand cmd')

112+ result <- runExceptT (handleCommand cmd')

108− $(logDebug) ("Answer was: " <> T.pack (show result))

113+ $(logDebug) ("Answer was: " <> T.pack (show result))

109− liftIO (hFlush stdout)

114+ liftIO (hFlush stdout)

110− case result of

115+ case result of

111− -- What function can I use to clean this up?

116+ -- What function can I use to clean this up?

112− Right r -> liftIO $ T.hPutStrLn h (encodeT r)

117+ Right r -> liftIO $ T.hPutStrLn h (encodeT r)

113− Left err -> liftIO $ T.hPutStrLn h (encodeT err)

118+ Left err -> liftIO $ T.hPutStrLn h (encodeT err)

114− Nothing -> do

119+ Nothing -> do

115− $(logDebug) ("Parsing the command failed. Command: " <> cmd)

120+ $(logDebug) ("Parsing the command failed. Command: " <> cmd)

116− liftIO $ do

121+ liftIO $ do

117− T.hPutStrLn h (encodeT (GeneralError "Error parsing Command."))

122+ T.hPutStrLn h (encodeT (GeneralError "Error parsing Command."))

118− hFlush stdout

123+ hFlush stdout

119− liftIO (hClose h)

124+ liftIO (hClose h)

120

125

121

126

122−acceptCommand :: (Applicative m, MonadIO m, MonadLogger m)

127+acceptCommand :: (MonadIO m, MonadLogger m, MonadError T.Text m)

123 => Socket -> m (T.Text, Handle)

128 => Socket -> m (T.Text, Handle)

124acceptCommand sock = do

129acceptCommand sock = do

125 h <- acceptConnection

130 h <- acceptConnection

126 $(logDebug) "Accepted a connection"

131 $(logDebug) "Accepted a connection"

132+ cmd' <- liftIO (catchJust

133+ -- this means that the connection was

134+ -- terminated without receiving any input

135+ (\e -> if isEOFError e then Just () else Nothing)

127− cmd <- liftIO (T.hGetLine h)

136+ (Just <$> T.hGetLine h)

137+ (const (pure Nothing)))

138+ case cmd' of

139+ Nothing -> throwError "Connection was closed before any input arrived"

140+ Just cmd -> do

128− $(logDebug) cmd

141+ $(logDebug) cmd

129− pure (cmd, h)

142+ pure (cmd, h)

130 where

143 where

131 acceptConnection = liftIO $ do

144 acceptConnection = liftIO $ do

132 (h,_,_) <- accept sock

145 (h,_,_) <- accept sock

psc/Main.hs+2−2

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

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

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

109

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

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

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

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

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

@@ -138,7 +138,7 @@ requirePath :: Parser (Maybe FilePath)

138requirePath = optional $ strOption $

139 short 'r'

140 <> long "require-path"

141− <> help "The path prefix to use for require() calls in the generated JavaScript"

141+ <> help "The path prefix to use for require() calls in the generated JavaScript [deprecated]"

142

143noTco :: Parser Bool

144noTco = switch $

psci/PSCi.hs+1−1

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

214handleDecls ds = do

215 st <- PSCI $ lift get

216 let st' = updateLets ds st

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

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

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

219 case e of

220 Left err -> PSCI $ printErrors err

purescript.cabal+12−13

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

1name: purescript

2−version: 0.8.1.0

2+version: 0.8.2.0

3cabal-version: >=1.8

4build-type: Simple

5license: MIT

@@ -17,7 +17,7 @@ author: Phil Freeman <paf31@cantab.net>,

17 Harry Garrood <harry@garrood.me>,

18 Christoph Hegemann <christoph.hegemann1337@gmail.com>

19

20−tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.1

20+tested-with: GHC==7.10.3

21

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

23 , examples/failing/*.purs

@@ -36,8 +36,7 @@ extra-source-files: examples/passing/*.purs

36 , tests/support/flattened/*.js

37 , tests/support/psci/*.purs

38 , stack.yaml

39− , stack-lts-2.yaml

39+ , stack-lts-5.yaml

40− , stack-lts-3.yaml

41 , stack-nightly.yaml

40 , stack-nightly.yaml

42 , README.md

41 , README.md

43 , INSTALL.md

42 , INSTALL.md

@@ -50,7 +49,7 @@ source-repository head

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

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

51

50

52library

51library

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

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

54 base-compat >=0.6.0,

53 base-compat >=0.6.0,

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

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

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

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

@@ -97,6 +96,7 @@ library

97 Language.PureScript.AST.Binders

96 Language.PureScript.AST.Binders

98 Language.PureScript.AST.Declarations

97 Language.PureScript.AST.Declarations

99 Language.PureScript.AST.Operators

98 Language.PureScript.AST.Operators

99+ Language.PureScript.AST.Literals

100 Language.PureScript.AST.SourcePos

101 Language.PureScript.AST.Traversals

102 Language.PureScript.AST.Exported

@@ -135,7 +135,6 @@ library

135 Language.PureScript.CoreFn.Binders

136 Language.PureScript.CoreFn.Desugar

137 Language.PureScript.CoreFn.Expr

138− Language.PureScript.CoreFn.Literals

139 Language.PureScript.CoreFn.Meta

138 Language.PureScript.CoreFn.Meta

140 Language.PureScript.CoreFn.Module

139 Language.PureScript.CoreFn.Module

141 Language.PureScript.CoreFn.Traversals

140 Language.PureScript.CoreFn.Traversals

@@ -245,7 +244,7 @@ library

245executable psc

244executable psc

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

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

247 containers -any, directory -any, filepath -any,

246 containers -any, directory -any, filepath -any,

248− mtl -any, optparse-applicative >= 0.10.0, parsec -any, purescript -any,

247+ mtl -any, optparse-applicative >= 0.12.1, parsec -any, purescript -any,

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

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

250 aeson >= 0.8 && < 0.12, bytestring -any, utf8-string >= 1 && < 2

249 aeson >= 0.8 && < 0.12, bytestring -any, utf8-string >= 1 && < 2

251 main-is: Main.hs

250 main-is: Main.hs

@@ -256,7 +255,7 @@ executable psc

256

255

257executable psci

256executable psci

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

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

259− mtl -any, optparse-applicative >= 0.10.0, parsec -any,

258+ mtl -any, optparse-applicative >= 0.12.1, parsec -any,

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

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

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

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

262 boxes >= 0.1.4 && < 0.2.0

261 boxes >= 0.1.4 && < 0.2.0

@@ -279,7 +278,7 @@ executable psci

279

278

280executable psc-docs

279executable psc-docs

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

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

282− optparse-applicative >= 0.10.0, process -any, mtl -any,

281+ optparse-applicative >= 0.12.1, process -any, mtl -any,

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

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

284 filepath -any, Glob -any, transformers -any,

283 filepath -any, Glob -any, transformers -any,

285 transformers-compat -any

284 transformers-compat -any

@@ -301,7 +300,7 @@ executable psc-publish

301 ghc-options: -Wall -O2

300 ghc-options: -Wall -O2

302

301

303executable psc-hierarchy

302executable psc-hierarchy

304− build-depends: base >=4 && <5, purescript -any, optparse-applicative >= 0.10.0,

303+ build-depends: base >=4 && <5, purescript -any, optparse-applicative >= 0.12.1,

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

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

306 Glob -any

305 Glob -any

307 main-is: Main.hs

306 main-is: Main.hs

@@ -322,7 +321,7 @@ executable psc-bundle

322 mtl -any,

321 mtl -any,

323 transformers -any,

322 transformers -any,

324 transformers-compat -any,

323 transformers-compat -any,

325− optparse-applicative >= 0.10.0,

324+ optparse-applicative >= 0.12.1,

326 Glob -any

325 Glob -any

327 ghc-options: -Wall -O2

326 ghc-options: -Wall -O2

328 hs-source-dirs: psc-bundle

327 hs-source-dirs: psc-bundle

@@ -340,7 +339,7 @@ executable psc-ide-server

340 , transformers -any

339 , transformers -any

341 , transformers-compat -any

340 , transformers-compat -any

342 , network -any

341 , network -any

343− , optparse-applicative >= 0.10.0

342+ , optparse-applicative >= 0.12.1

344 , stm -any

343 , stm -any

345 , text -any

344 , text -any

346 , base-compat >=0.6.0

345 , base-compat >=0.6.0

@@ -354,7 +353,7 @@ executable psc-ide-client

354 build-depends: base >=4 && <5

353 build-depends: base >=4 && <5

355 , mtl -any

354 , mtl -any

356 , text -any

355 , text -any

357− , optparse-applicative >= 0.10.0

356+ , optparse-applicative >= 0.12.1

358 , network -any

357 , network -any

359 , base-compat >=0.6.0

358 , base-compat >=0.6.0

360 ghc-options: -Wall -O2

359 ghc-options: -Wall -O2

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

@@ -27,7 +27,7 @@ import Control.Monad.Error.Class (MonadError(..))

27import Control.Monad.Reader

28import Control.Monad.Writer

29

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

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

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

32

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

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

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

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

1+-- |

2+-- The initial PureScript AST

2--

3--

3−-- Module : Language.PureScript.AST

5−-- License : MIT

6−--

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

8−-- Stability : experimental

9−-- Portability :

10−--

11−-- | The initial PureScript AST

12−--

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

14−

15module Language.PureScript.AST (

4module Language.PureScript.AST (

16 module AST

5 module AST

17) where

6) where

18

7

19import Language.PureScript.AST.Binders as AST

8import Language.PureScript.AST.Binders as AST

20import Language.PureScript.AST.Declarations as AST

9import Language.PureScript.AST.Declarations as AST

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

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

21import Language.PureScript.AST.Operators as AST

12import Language.PureScript.AST.Operators as AST

22import Language.PureScript.AST.SourcePos as AST

13import Language.PureScript.AST.SourcePos as AST

23import Language.PureScript.AST.Traversals as AST

14import Language.PureScript.AST.Traversals as AST

24−import Language.PureScript.AST.Exported as AST

src/Language/PureScript/AST/Binders.hs+7−24

@@ -4,6 +4,7 @@

4module Language.PureScript.AST.Binders where

5

6import Language.PureScript.AST.SourcePos

7+import Language.PureScript.AST.Literals

7import Language.PureScript.Names

8import Language.PureScript.Names

8import Language.PureScript.Comments

9import Language.PureScript.Comments

9import Language.PureScript.Types

10import Language.PureScript.Types

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

17 --

18 --

18 = NullBinder

19 = NullBinder

19 -- |

20 -- |

20− -- A binder which matches a boolean literal

21+ -- A binder which matches a literal

21 --

22 --

22− | BooleanBinder Bool

23+ | LiteralBinder (Literal Binder)

23− -- |

24− -- A binder which matches a string literal

25− --

26− | StringBinder String

27− -- |

28− -- A binder which matches a character literal

29− --

30− | CharBinder Char

31− -- |

32− -- A binder which matches a numeric literal

33− --

34− | NumberBinder (Either Integer Double)

35 -- |

24 -- |

36 -- A binder which binds an identifier

25 -- A binder which binds an identifier

37 --

26 --

@@ -59,14 +48,6 @@ data Binder

59 --

48 --

60 | ParensInBinder Binder

49 | ParensInBinder Binder

61 -- |

50 -- |

62− -- A binder which matches a record and binds its properties

63− --

64− | ObjectBinder [(String, Binder)]

65− -- |

66− -- A binder which matches an array and binds its elements

67− --

68− | ArrayBinder [Binder]

69− -- |

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

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

71 --

52 --

72 | NamedBinder Ident Binder

53 | NamedBinder Ident Binder

@@ -86,13 +67,15 @@ data Binder

86binderNames :: Binder -> [Ident]

67binderNames :: Binder -> [Ident]

87binderNames = go []

68binderNames = go []

88 where

69 where

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

89 go ns (VarBinder name) = name : ns

71 go ns (VarBinder name) = name : ns

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

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

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

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

92 go ns (ParensInBinder b) = go ns b

74 go ns (ParensInBinder b) = go ns b

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

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

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

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

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

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

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

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

98 go ns _ = ns

78 go ns _ = ns

79+ lit ns (ObjectLiteral bs) = foldl go ns (map snd bs)

80+ lit ns (ArrayLiteral bs) = foldl go ns bs

81+ lit ns _ = ns

src/Language/PureScript/AST/Declarations.hs+4−24

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

19import Control.Monad.Identity

20

21import Language.PureScript.AST.Binders

22+import Language.PureScript.AST.Literals

22import Language.PureScript.AST.Operators

23import Language.PureScript.AST.Operators

23import Language.PureScript.AST.SourcePos

24import Language.PureScript.AST.SourcePos

24import Language.PureScript.Types

25import Language.PureScript.Types

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

309--

310--

310data Expr

311data Expr

311 -- |

312 -- |

312− -- A numeric literal

313+ -- A literal value

313 --

314 --

314− = NumericLiteral (Either Integer Double)

315+ = Literal (Literal Expr)

315− -- |

316− -- A string literal

317− --

318− | StringLiteral String

319− -- |

320− -- A character literal

321− --

322− | CharLiteral Char

323− -- |

324− -- A boolean literal

325− --

326− | BooleanLiteral Bool

327 -- |

316 -- |

328 -- A prefix -, will be desugared

317 -- A prefix -, will be desugared

329 --

318 --

@@ -342,19 +331,10 @@ data Expr

342 --

331 --

343 | Parens Expr

332 | Parens Expr

344 -- |

333 -- |

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

334+ -- Operator section. This will be removed during desugaring and replaced with lambda.

346− -- operator or lambda to flip the arguments.

347 --

335 --

348 | OperatorSection Expr (Either Expr Expr)

336 | OperatorSection Expr (Either Expr Expr)

349 -- |

337 -- |

350− -- An array literal

351− --

352− | ArrayLiteral [Expr]

353− -- |

354− -- An object literal

355− --

356− | ObjectLiteral [(String, Expr)]

357− -- |

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

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

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

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

360 --

340 --

src/Language/PureScript/CoreFn/Literals.hs → src/Language/PureScript/AST/Literals.hsrenamed+2−2

@@ -3,7 +3,7 @@

3-- |

4-- The core functional representation for literal values.

5--

6−module Language.PureScript.CoreFn.Literals where

6+module Language.PureScript.AST.Literals where

7

8-- |

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

@@ -34,4 +34,4 @@ data Literal a

34 -- An object literal

35 --

36 | ObjectLiteral [(String, a)]

37− deriving (Show, Read, Functor)

37+ deriving (Eq, Ord, Show, Read, Functor)

src/Language/PureScript/AST/Traversals.hs+195−105

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

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

1+{-# LANGUAGE ScopedTypeVariables #-}

2−--

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

5−-- License : MIT

6−--

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

8−-- Stability : experimental

9−-- Portability :

10−--

11−-- | AST traversal helpers

12−--

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

14

2

3+-- |

4+-- AST traversal helpers

5+--

15module Language.PureScript.AST.Traversals where

6module Language.PureScript.AST.Traversals where

16

7

17import Prelude ()

8import Prelude ()

@@ -26,15 +17,20 @@ import Control.Monad

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

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

27

18

28import Language.PureScript.AST.Binders

19import Language.PureScript.AST.Binders

20+import Language.PureScript.AST.Literals

29import Language.PureScript.AST.Declarations

21import Language.PureScript.AST.Declarations

30import Language.PureScript.Types

22import Language.PureScript.Types

31import Language.PureScript.Traversals

23import Language.PureScript.Traversals

32import Language.PureScript.Names

24import Language.PureScript.Names

33

25

26+everywhereOnValues

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

27+ :: (Declaration -> Declaration)

35− (Expr -> Expr) ->

28+ -> (Expr -> Expr)

36− (Binder -> Binder) ->

29+ -> (Binder -> Binder)

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

30+ -> ( Declaration -> Declaration

31+ , Expr -> Expr

32+ , Binder -> Binder

33+ )

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

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

39 where

35 where

40 f' :: Declaration -> Declaration

36 f' :: Declaration -> Declaration

@@ -47,13 +43,12 @@ everywhereOnValues f g h = (f', g', h')

47 f' other = f other

43 f' other = f other

48

44

49 g' :: Expr -> Expr

45 g' :: Expr -> Expr

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

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

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

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

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

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

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

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

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

54 g' (OperatorSection op (Right v)) = g (OperatorSection (g' op) (Right $ g' v))

51 g' (OperatorSection op (Right v)) = g (OperatorSection (g' op) (Right $ g' v))

55− g' (ArrayLiteral vs) = g (ArrayLiteral (map g' vs))

56− g' (ObjectLiteral vs) = g (ObjectLiteral (map (fmap g') vs))

57 g' (TypeClassDictionaryConstructorApp name v) = g (TypeClassDictionaryConstructorApp name (g' v))

52 g' (TypeClassDictionaryConstructorApp name v) = g (TypeClassDictionaryConstructorApp name (g' v))

58 g' (Accessor prop v) = g (Accessor prop (g' v))

53 g' (Accessor prop v) = g (Accessor prop (g' v))

59 g' (ObjectUpdate obj vs) = g (ObjectUpdate (g' obj) (map (fmap g') vs))

54 g' (ObjectUpdate obj vs) = g (ObjectUpdate (g' obj) (map (fmap g') vs))

@@ -71,13 +66,17 @@ everywhereOnValues f g h = (f', g', h')

71 h' (ConstructorBinder ctor bs) = h (ConstructorBinder ctor (map h' bs))

66 h' (ConstructorBinder ctor bs) = h (ConstructorBinder ctor (map h' bs))

72 h' (BinaryNoParensBinder b1 b2 b3) = h (BinaryNoParensBinder (h' b1) (h' b2) (h' b3))

67 h' (BinaryNoParensBinder b1 b2 b3) = h (BinaryNoParensBinder (h' b1) (h' b2) (h' b3))

73 h' (ParensInBinder b) = h (ParensInBinder (h' b))

68 h' (ParensInBinder b) = h (ParensInBinder (h' b))

74− h' (ObjectBinder bs) = h (ObjectBinder (map (fmap h') bs))

69+ h' (LiteralBinder l) = h (LiteralBinder (lit h' l))

75− h' (ArrayBinder bs) = h (ArrayBinder (map h' bs))

76 h' (NamedBinder name b) = h (NamedBinder name (h' b))

70 h' (NamedBinder name b) = h (NamedBinder name (h' b))

77 h' (PositionedBinder pos com b) = h (PositionedBinder pos com (h' b))

71 h' (PositionedBinder pos com b) = h (PositionedBinder pos com (h' b))

78 h' (TypedBinder t b) = h (TypedBinder t (h' b))

72 h' (TypedBinder t b) = h (TypedBinder t (h' b))

79 h' other = h other

73 h' other = h other

80

74

75+ lit :: (a -> a) -> Literal a -> Literal a

76+ lit go (ArrayLiteral as) = ArrayLiteral (map go as)

77+ lit go (ObjectLiteral as) = ObjectLiteral (map (fmap go) as)

78+ lit _ other = other

79+

81 handleCaseAlternative :: CaseAlternative -> CaseAlternative

80 handleCaseAlternative :: CaseAlternative -> CaseAlternative

82 handleCaseAlternative ca =

81 handleCaseAlternative ca =

83 ca { caseAlternativeBinders = map h' (caseAlternativeBinders ca)

82 ca { caseAlternativeBinders = map h' (caseAlternativeBinders ca)

@@ -90,13 +89,20 @@ everywhereOnValues f g h = (f', g', h')

90 handleDoNotationElement (DoNotationLet ds) = DoNotationLet (map f' ds)

89 handleDoNotationElement (DoNotationLet ds) = DoNotationLet (map f' ds)

91 handleDoNotationElement (PositionedDoNotationElement pos com e) = PositionedDoNotationElement pos com (handleDoNotationElement e)

90 handleDoNotationElement (PositionedDoNotationElement pos com e) = PositionedDoNotationElement pos com (handleDoNotationElement e)

92

91

93−everywhereOnValuesTopDownM :: (Functor m, Applicative m, Monad m) =>

92+everywhereOnValuesTopDownM

93+ :: forall m

94+ . (Monad m)

94− (Declaration -> m Declaration) ->

95+ => (Declaration -> m Declaration)

95− (Expr -> m Expr) ->

96+ -> (Expr -> m Expr)

96− (Binder -> m Binder) ->

97+ -> (Binder -> m Binder)

97− (Declaration -> m Declaration, Expr -> m Expr, Binder -> m Binder)

98+ -> ( Declaration -> m Declaration

99+ , Expr -> m Expr

100+ , Binder -> m Binder

101+ )

98everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)

102everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)

99 where

103 where

104+

105+ f' :: Declaration -> m Declaration

100 f' (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> traverse (f' <=< f) ds

106 f' (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> traverse (f' <=< f) ds

101 f' (ValueDeclaration name nameKind bs val) = ValueDeclaration name nameKind <$> traverse (h' <=< h) bs <*> eitherM (traverse (pairM (g' <=< g) (g' <=< g))) (g' <=< g) val

107 f' (ValueDeclaration name nameKind bs val) = ValueDeclaration name nameKind <$> traverse (h' <=< h) bs <*> eitherM (traverse (pairM (g' <=< g) (g' <=< g))) (g' <=< g) val

102 f' (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> traverse (\(name, nameKind, val) -> (,,) name nameKind <$> (g val >>= g')) ds

108 f' (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> traverse (\(name, nameKind, val) -> (,,) name nameKind <$> (g val >>= g')) ds

@@ -105,13 +111,13 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)

105 f' (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> (f d >>= f')

111 f' (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> (f d >>= f')

106 f' other = f other

112 f' other = f other

107

113

114+ g' :: Expr -> m Expr

115+ g' (Literal l) = Literal <$> lit (g >=> g') l

108 g' (UnaryMinus v) = UnaryMinus <$> (g v >>= g')

116 g' (UnaryMinus v) = UnaryMinus <$> (g v >>= g')

109 g' (BinaryNoParens op v1 v2) = BinaryNoParens <$> (g op >>= g') <*> (g v1 >>= g') <*> (g v2 >>= g')

117 g' (BinaryNoParens op v1 v2) = BinaryNoParens <$> (g op >>= g') <*> (g v1 >>= g') <*> (g v2 >>= g')

110 g' (Parens v) = Parens <$> (g v >>= g')

118 g' (Parens v) = Parens <$> (g v >>= g')

111 g' (OperatorSection op (Left v)) = OperatorSection <$> (g op >>= g') <*> (Left <$> (g v >>= g'))

119 g' (OperatorSection op (Left v)) = OperatorSection <$> (g op >>= g') <*> (Left <$> (g v >>= g'))

112 g' (OperatorSection op (Right v)) = OperatorSection <$> (g op >>= g') <*> (Right <$> (g v >>= g'))

120 g' (OperatorSection op (Right v)) = OperatorSection <$> (g op >>= g') <*> (Right <$> (g v >>= g'))

113− g' (ArrayLiteral vs) = ArrayLiteral <$> traverse (g' <=< g) vs

114− g' (ObjectLiteral vs) = ObjectLiteral <$> traverse (sndM (g' <=< g)) vs

115 g' (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> (g v >>= g')

121 g' (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> (g v >>= g')

116 g' (Accessor prop v) = Accessor prop <$> (g v >>= g')

122 g' (Accessor prop v) = Accessor prop <$> (g v >>= g')

117 g' (ObjectUpdate obj vs) = ObjectUpdate <$> (g obj >>= g') <*> traverse (sndM (g' <=< g)) vs

123 g' (ObjectUpdate obj vs) = ObjectUpdate <$> (g obj >>= g') <*> traverse (sndM (g' <=< g)) vs

@@ -125,31 +131,47 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)

125 g' (PositionedValue pos com v) = PositionedValue pos com <$> (g v >>= g')

131 g' (PositionedValue pos com v) = PositionedValue pos com <$> (g v >>= g')

126 g' other = g other

132 g' other = g other

127

133

134+ h' :: Binder -> m Binder

135+ h' (LiteralBinder l) = LiteralBinder <$> lit (h >=> h') l

128 h' (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> traverse (h' <=< h) bs

136 h' (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> traverse (h' <=< h) bs

129 h' (BinaryNoParensBinder b1 b2 b3) = BinaryNoParensBinder <$> (h b1 >>= h') <*> (h b2 >>= h') <*> (h b3 >>= h')

137 h' (BinaryNoParensBinder b1 b2 b3) = BinaryNoParensBinder <$> (h b1 >>= h') <*> (h b2 >>= h') <*> (h b3 >>= h')

130 h' (ParensInBinder b) = ParensInBinder <$> (h b >>= h')

138 h' (ParensInBinder b) = ParensInBinder <$> (h b >>= h')

131− h' (ObjectBinder bs) = ObjectBinder <$> traverse (sndM (h' <=< h)) bs

132− h' (ArrayBinder bs) = ArrayBinder <$> traverse (h' <=< h) bs

133 h' (NamedBinder name b) = NamedBinder name <$> (h b >>= h')

139 h' (NamedBinder name b) = NamedBinder name <$> (h b >>= h')

134 h' (PositionedBinder pos com b) = PositionedBinder pos com <$> (h b >>= h')

140 h' (PositionedBinder pos com b) = PositionedBinder pos com <$> (h b >>= h')

135 h' (TypedBinder t b) = TypedBinder t <$> (h b >>= h')

141 h' (TypedBinder t b) = TypedBinder t <$> (h b >>= h')

136 h' other = h other

142 h' other = h other

137

143

144+ lit :: (a -> m a) -> Literal a -> m (Literal a)

145+ lit go (ObjectLiteral as) = ObjectLiteral <$> traverse (sndM go) as

146+ lit go (ArrayLiteral as) = ArrayLiteral <$> traverse go as

147+ lit _ other = pure other

148+

149+ handleCaseAlternative :: CaseAlternative -> m CaseAlternative

138− handleCaseAlternative (CaseAlternative bs val) = CaseAlternative <$> traverse (h' <=< h) bs

150+ handleCaseAlternative (CaseAlternative bs val) =

151+ CaseAlternative

152+ <$> traverse (h' <=< h) bs

139− <*> eitherM (traverse (pairM (g' <=< g) (g' <=< g))) (g' <=< g) val

153+ <*> eitherM (traverse (pairM (g' <=< g) (g' <=< g))) (g' <=< g) val

140

154

155+ handleDoNotationElement :: DoNotationElement -> m DoNotationElement

141 handleDoNotationElement (DoNotationValue v) = DoNotationValue <$> (g' <=< g) v

156 handleDoNotationElement (DoNotationValue v) = DoNotationValue <$> (g' <=< g) v

142 handleDoNotationElement (DoNotationBind b v) = DoNotationBind <$> (h' <=< h) b <*> (g' <=< g) v

157 handleDoNotationElement (DoNotationBind b v) = DoNotationBind <$> (h' <=< h) b <*> (g' <=< g) v

143 handleDoNotationElement (DoNotationLet ds) = DoNotationLet <$> traverse (f' <=< f) ds

158 handleDoNotationElement (DoNotationLet ds) = DoNotationLet <$> traverse (f' <=< f) ds

144 handleDoNotationElement (PositionedDoNotationElement pos com e) = PositionedDoNotationElement pos com <$> handleDoNotationElement e

159 handleDoNotationElement (PositionedDoNotationElement pos com e) = PositionedDoNotationElement pos com <$> handleDoNotationElement e

145

160

146−everywhereOnValuesM :: (Functor m, Applicative m, Monad m) =>

161+everywhereOnValuesM

162+ :: forall m

163+ . (Monad m)

147− (Declaration -> m Declaration) ->

164+ => (Declaration -> m Declaration)

148− (Expr -> m Expr) ->

165+ -> (Expr -> m Expr)

149− (Binder -> m Binder) ->

166+ -> (Binder -> m Binder)

150− (Declaration -> m Declaration, Expr -> m Expr, Binder -> m Binder)

167+ -> ( Declaration -> m Declaration

168+ , Expr -> m Expr

169+ , Binder -> m Binder

170+ )

151everywhereOnValuesM f g h = (f', g', h')

171everywhereOnValuesM f g h = (f', g', h')

152 where

172 where

173+

174+ f' :: Declaration -> m Declaration

153 f' (DataBindingGroupDeclaration ds) = (DataBindingGroupDeclaration <$> traverse f' ds) >>= f

175 f' (DataBindingGroupDeclaration ds) = (DataBindingGroupDeclaration <$> traverse f' ds) >>= f

154 f' (ValueDeclaration name nameKind bs val) = (ValueDeclaration name nameKind <$> traverse h' bs <*> eitherM (traverse (pairM g' g')) g' val) >>= f

176 f' (ValueDeclaration name nameKind bs val) = (ValueDeclaration name nameKind <$> traverse h' bs <*> eitherM (traverse (pairM g' g')) g' val) >>= f

155 f' (BindingGroupDeclaration ds) = (BindingGroupDeclaration <$> traverse (\(name, nameKind, val) -> (,,) name nameKind <$> g' val) ds) >>= f

177 f' (BindingGroupDeclaration ds) = (BindingGroupDeclaration <$> traverse (\(name, nameKind, val) -> (,,) name nameKind <$> g' val) ds) >>= f

@@ -158,13 +180,13 @@ everywhereOnValuesM f g h = (f', g', h')

158 f' (PositionedDeclaration pos com d) = (PositionedDeclaration pos com <$> f' d) >>= f

180 f' (PositionedDeclaration pos com d) = (PositionedDeclaration pos com <$> f' d) >>= f

159 f' other = f other

181 f' other = f other

160

182

183+ g' :: Expr -> m Expr

184+ g' (Literal l) = (Literal <$> lit g' l) >>= g

161 g' (UnaryMinus v) = (UnaryMinus <$> g' v) >>= g

185 g' (UnaryMinus v) = (UnaryMinus <$> g' v) >>= g

162 g' (BinaryNoParens op v1 v2) = (BinaryNoParens <$> g' op <*> g' v1 <*> g' v2) >>= g

186 g' (BinaryNoParens op v1 v2) = (BinaryNoParens <$> g' op <*> g' v1 <*> g' v2) >>= g

163 g' (Parens v) = (Parens <$> g' v) >>= g

187 g' (Parens v) = (Parens <$> g' v) >>= g

164 g' (OperatorSection op (Left v)) = (OperatorSection <$> g' op <*> (Left <$> g' v)) >>= g

188 g' (OperatorSection op (Left v)) = (OperatorSection <$> g' op <*> (Left <$> g' v)) >>= g

165 g' (OperatorSection op (Right v)) = (OperatorSection <$> g' op <*> (Right <$> g' v)) >>= g

189 g' (OperatorSection op (Right v)) = (OperatorSection <$> g' op <*> (Right <$> g' v)) >>= g

166− g' (ArrayLiteral vs) = (ArrayLiteral <$> traverse g' vs) >>= g

167− g' (ObjectLiteral vs) = (ObjectLiteral <$> traverse (sndM g') vs) >>= g

168 g' (TypeClassDictionaryConstructorApp name v) = (TypeClassDictionaryConstructorApp name <$> g' v) >>= g

190 g' (TypeClassDictionaryConstructorApp name v) = (TypeClassDictionaryConstructorApp name <$> g' v) >>= g

169 g' (Accessor prop v) = (Accessor prop <$> g' v) >>= g

191 g' (Accessor prop v) = (Accessor prop <$> g' v) >>= g

170 g' (ObjectUpdate obj vs) = (ObjectUpdate <$> g' obj <*> traverse (sndM g') vs) >>= g

192 g' (ObjectUpdate obj vs) = (ObjectUpdate <$> g' obj <*> traverse (sndM g') vs) >>= g

@@ -178,33 +200,51 @@ everywhereOnValuesM f g h = (f', g', h')

178 g' (PositionedValue pos com v) = (PositionedValue pos com <$> g' v) >>= g

200 g' (PositionedValue pos com v) = (PositionedValue pos com <$> g' v) >>= g

179 g' other = g other

201 g' other = g other

180

202

203+ h' :: Binder -> m Binder

204+ h' (LiteralBinder l) = (LiteralBinder <$> lit h' l) >>= h

181 h' (ConstructorBinder ctor bs) = (ConstructorBinder ctor <$> traverse h' bs) >>= h

205 h' (ConstructorBinder ctor bs) = (ConstructorBinder ctor <$> traverse h' bs) >>= h

182 h' (BinaryNoParensBinder b1 b2 b3) = (BinaryNoParensBinder <$> h' b1 <*> h' b2 <*> h' b3) >>= h

206 h' (BinaryNoParensBinder b1 b2 b3) = (BinaryNoParensBinder <$> h' b1 <*> h' b2 <*> h' b3) >>= h

183 h' (ParensInBinder b) = (ParensInBinder <$> h' b) >>= h

207 h' (ParensInBinder b) = (ParensInBinder <$> h' b) >>= h

184− h' (ObjectBinder bs) = (ObjectBinder <$> traverse (sndM h') bs) >>= h

185− h' (ArrayBinder bs) = (ArrayBinder <$> traverse h' bs) >>= h

186 h' (NamedBinder name b) = (NamedBinder name <$> h' b) >>= h

208 h' (NamedBinder name b) = (NamedBinder name <$> h' b) >>= h

187 h' (PositionedBinder pos com b) = (PositionedBinder pos com <$> h' b) >>= h

209 h' (PositionedBinder pos com b) = (PositionedBinder pos com <$> h' b) >>= h

188 h' (TypedBinder t b) = (TypedBinder t <$> h' b) >>= h

210 h' (TypedBinder t b) = (TypedBinder t <$> h' b) >>= h

189 h' other = h other

211 h' other = h other

190

212

191− handleCaseAlternative (CaseAlternative bs val) = CaseAlternative <$> traverse h' bs

213+ lit :: (a -> m a) -> Literal a -> m (Literal a)

214+ lit go (ObjectLiteral as) = ObjectLiteral <$> traverse (sndM go) as

215+ lit go (ArrayLiteral as) = ArrayLiteral <$> traverse go as

216+ lit _ other = pure other

217+

218+ handleCaseAlternative :: CaseAlternative -> m CaseAlternative

219+ handleCaseAlternative (CaseAlternative bs val) =

220+ CaseAlternative

221+ <$> traverse h' bs

192− <*> eitherM (traverse (pairM g' g')) g' val

222+ <*> eitherM (traverse (pairM g' g')) g' val

193

223

224+ handleDoNotationElement :: DoNotationElement -> m DoNotationElement

194 handleDoNotationElement (DoNotationValue v) = DoNotationValue <$> g' v

225 handleDoNotationElement (DoNotationValue v) = DoNotationValue <$> g' v

195 handleDoNotationElement (DoNotationBind b v) = DoNotationBind <$> h' b <*> g' v

226 handleDoNotationElement (DoNotationBind b v) = DoNotationBind <$> h' b <*> g' v

196 handleDoNotationElement (DoNotationLet ds) = DoNotationLet <$> traverse f' ds

227 handleDoNotationElement (DoNotationLet ds) = DoNotationLet <$> traverse f' ds

197 handleDoNotationElement (PositionedDoNotationElement pos com e) = PositionedDoNotationElement pos com <$> handleDoNotationElement e

228 handleDoNotationElement (PositionedDoNotationElement pos com e) = PositionedDoNotationElement pos com <$> handleDoNotationElement e

198

229

199−everythingOnValues :: (r -> r -> r) ->

230+everythingOnValues

231+ :: forall r

232+ . (r -> r -> r)

200− (Declaration -> r) ->

233+ -> (Declaration -> r)

201− (Expr -> r) ->

234+ -> (Expr -> r)

202− (Binder -> r) ->

235+ -> (Binder -> r)

203− (CaseAlternative -> r) ->

236+ -> (CaseAlternative -> r)

204− (DoNotationElement -> r) ->

237+ -> (DoNotationElement -> r)

238+ -> ( Declaration -> r

239+ , Expr -> r

240+ , Binder -> r

241+ , CaseAlternative -> r

205− (Declaration -> r, Expr -> r, Binder -> r, CaseAlternative -> r, DoNotationElement -> r)

242+ , DoNotationElement -> r

243+ )

206everythingOnValues (<>) f g h i j = (f', g', h', i', j')

244everythingOnValues (<>) f g h i j = (f', g', h', i', j')

207 where

245 where

246+

247+ f' :: Declaration -> r

208 f' d@(DataBindingGroupDeclaration ds) = foldl (<>) (f d) (map f' ds)

248 f' d@(DataBindingGroupDeclaration ds) = foldl (<>) (f d) (map f' ds)

209 f' d@(ValueDeclaration _ _ bs (Right val)) = foldl (<>) (f d) (map h' bs) <> g' val

249 f' d@(ValueDeclaration _ _ bs (Right val)) = foldl (<>) (f d) (map h' bs) <> g' val

210 f' d@(ValueDeclaration _ _ bs (Left gs)) = foldl (<>) (f d) (map h' bs ++ concatMap (\(grd, val) -> [g' grd, g' val]) gs)

250 f' d@(ValueDeclaration _ _ bs (Left gs)) = foldl (<>) (f d) (map h' bs ++ concatMap (\(grd, val) -> [g' grd, g' val]) gs)

@@ -214,13 +254,13 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j')

214 f' d@(PositionedDeclaration _ _ d1) = f d <> f' d1

254 f' d@(PositionedDeclaration _ _ d1) = f d <> f' d1

215 f' d = f d

255 f' d = f d

216

256

257+ g' :: Expr -> r

258+ g' v@(Literal l) = lit (g v) g' l

217 g' v@(UnaryMinus v1) = g v <> g' v1

259 g' v@(UnaryMinus v1) = g v <> g' v1

218 g' v@(BinaryNoParens op v1 v2) = g v <> g' op <> g' v1 <> g' v2

260 g' v@(BinaryNoParens op v1 v2) = g v <> g' op <> g' v1 <> g' v2

219 g' v@(Parens v1) = g v <> g' v1

261 g' v@(Parens v1) = g v <> g' v1

220 g' v@(OperatorSection op (Left v1)) = g v <> g' op <> g' v1

262 g' v@(OperatorSection op (Left v1)) = g v <> g' op <> g' v1

221 g' v@(OperatorSection op (Right v1)) = g v <> g' op <> g' v1

263 g' v@(OperatorSection op (Right v1)) = g v <> g' op <> g' v1

222− g' v@(ArrayLiteral vs) = foldl (<>) (g v) (map g' vs)

223− g' v@(ObjectLiteral vs) = foldl (<>) (g v) (map (g' . snd) vs)

224 g' v@(TypeClassDictionaryConstructorApp _ v1) = g v <> g' v1

264 g' v@(TypeClassDictionaryConstructorApp _ v1) = g v <> g' v1

225 g' v@(Accessor _ v1) = g v <> g' v1

265 g' v@(Accessor _ v1) = g v <> g' v1

226 g' v@(ObjectUpdate obj vs) = foldl (<>) (g v <> g' obj) (map (g' . snd) vs)

266 g' v@(ObjectUpdate obj vs) = foldl (<>) (g v <> g' obj) (map (g' . snd) vs)

@@ -234,42 +274,53 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j')

234 g' v@(PositionedValue _ _ v1) = g v <> g' v1

274 g' v@(PositionedValue _ _ v1) = g v <> g' v1

235 g' v = g v

275 g' v = g v

236

276

277+ h' :: Binder -> r

278+ h' b@(LiteralBinder l) = lit (h b) h' l

237 h' b@(ConstructorBinder _ bs) = foldl (<>) (h b) (map h' bs)

279 h' b@(ConstructorBinder _ bs) = foldl (<>) (h b) (map h' bs)

238 h' b@(BinaryNoParensBinder b1 b2 b3) = h b <> h' b1 <> h' b2 <> h' b3

280 h' b@(BinaryNoParensBinder b1 b2 b3) = h b <> h' b1 <> h' b2 <> h' b3

239 h' b@(ParensInBinder b1) = h b <> h' b1

281 h' b@(ParensInBinder b1) = h b <> h' b1

240− h' b@(ObjectBinder bs) = foldl (<>) (h b) (map (h' . snd) bs)

241− h' b@(ArrayBinder bs) = foldl (<>) (h b) (map h' bs)

242 h' b@(NamedBinder _ b1) = h b <> h' b1

282 h' b@(NamedBinder _ b1) = h b <> h' b1

243 h' b@(PositionedBinder _ _ b1) = h b <> h' b1

283 h' b@(PositionedBinder _ _ b1) = h b <> h' b1

244 h' b@(TypedBinder _ b1) = h b <> h' b1

284 h' b@(TypedBinder _ b1) = h b <> h' b1

245 h' b = h b

285 h' b = h b

246

286

287+ lit :: r -> (a -> r) -> Literal a -> r

288+ lit r go (ArrayLiteral as) = foldl (<>) r (map go as)

289+ lit r go (ObjectLiteral as) = foldl (<>) r (map (go . snd) as)

290+ lit r _ _ = r

291+

292+ i' :: CaseAlternative -> r

247 i' ca@(CaseAlternative bs (Right val)) = foldl (<>) (i ca) (map h' bs) <> g' val

293 i' ca@(CaseAlternative bs (Right val)) = foldl (<>) (i ca) (map h' bs) <> g' val

248 i' ca@(CaseAlternative bs (Left gs)) = foldl (<>) (i ca) (map h' bs ++ concatMap (\(grd, val) -> [g' grd, g' val]) gs)

294 i' ca@(CaseAlternative bs (Left gs)) = foldl (<>) (i ca) (map h' bs ++ concatMap (\(grd, val) -> [g' grd, g' val]) gs)

249

295

296+ j' :: DoNotationElement -> r

250 j' e@(DoNotationValue v) = j e <> g' v

297 j' e@(DoNotationValue v) = j e <> g' v

251 j' e@(DoNotationBind b v) = j e <> h' b <> g' v

298 j' e@(DoNotationBind b v) = j e <> h' b <> g' v

252 j' e@(DoNotationLet ds) = foldl (<>) (j e) (map f' ds)

299 j' e@(DoNotationLet ds) = foldl (<>) (j e) (map f' ds)

253 j' e@(PositionedDoNotationElement _ _ e1) = j e <> j' e1

300 j' e@(PositionedDoNotationElement _ _ e1) = j e <> j' e1

254

301

255−everythingWithContextOnValues ::

302+everythingWithContextOnValues

256− s ->

303+ :: forall s r

257− r ->

304+ . s

305+ -> r

258− (r -> r -> r) ->

306+ -> (r -> r -> r)

259− (s -> Declaration -> (s, r)) ->

307+ -> (s -> Declaration -> (s, r))

260− (s -> Expr -> (s, r)) ->

308+ -> (s -> Expr -> (s, r))

261− (s -> Binder -> (s, r)) ->

309+ -> (s -> Binder -> (s, r))

262− (s -> CaseAlternative -> (s, r)) ->

310+ -> (s -> CaseAlternative -> (s, r))

263− (s -> DoNotationElement -> (s, r)) ->

311+ -> (s -> DoNotationElement -> (s, r))

264− ( Declaration -> r

312+ -> ( Declaration -> r

265− , Expr -> r

313+ , Expr -> r

266− , Binder -> r

314+ , Binder -> r

267− , CaseAlternative -> r

315+ , CaseAlternative -> r

268− , DoNotationElement -> r)

316+ , DoNotationElement -> r)

269everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j'' s0)

317everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j'' s0)

270 where

318 where

319+

320+ f'' :: s -> Declaration -> r

271 f'' s d = let (s', r) = f s d in r <> f' s' d

321 f'' s d = let (s', r) = f s d in r <> f' s' d

272

322

323+ f' :: s -> Declaration -> r

273 f' s (DataBindingGroupDeclaration ds) = foldl (<>) r0 (map (f'' s) ds)

324 f' s (DataBindingGroupDeclaration ds) = foldl (<>) r0 (map (f'' s) ds)

274 f' s (ValueDeclaration _ _ bs (Right val)) = foldl (<>) r0 (map (h'' s) bs) <> g'' s val

325 f' s (ValueDeclaration _ _ bs (Right val)) = foldl (<>) r0 (map (h'' s) bs) <> g'' s val

275 f' s (ValueDeclaration _ _ bs (Left gs)) = foldl (<>) r0 (map (h'' s) bs ++ concatMap (\(grd, val) -> [g'' s grd, g'' s val]) gs)

326 f' s (ValueDeclaration _ _ bs (Left gs)) = foldl (<>) r0 (map (h'' s) bs ++ concatMap (\(grd, val) -> [g'' s grd, g'' s val]) gs)

@@ -279,15 +330,16 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'

279 f' s (PositionedDeclaration _ _ d1) = f'' s d1

330 f' s (PositionedDeclaration _ _ d1) = f'' s d1

280 f' _ _ = r0

331 f' _ _ = r0

281

332

333+ g'' :: s -> Expr -> r

282 g'' s v = let (s', r) = g s v in r <> g' s' v

334 g'' s v = let (s', r) = g s v in r <> g' s' v

283

335

336+ g' :: s -> Expr -> r

337+ g' s (Literal l) = lit g'' s l

284 g' s (UnaryMinus v1) = g'' s v1

338 g' s (UnaryMinus v1) = g'' s v1

285 g' s (BinaryNoParens op v1 v2) = g'' s op <> g'' s v1 <> g'' s v2

339 g' s (BinaryNoParens op v1 v2) = g'' s op <> g'' s v1 <> g'' s v2

286 g' s (Parens v1) = g'' s v1

340 g' s (Parens v1) = g'' s v1

287 g' s (OperatorSection op (Left v)) = g'' s op <> g'' s v

341 g' s (OperatorSection op (Left v)) = g'' s op <> g'' s v

288 g' s (OperatorSection op (Right v)) = g'' s op <> g'' s v

342 g' s (OperatorSection op (Right v)) = g'' s op <> g'' s v

289− g' s (ArrayLiteral vs) = foldl (<>) r0 (map (g'' s) vs)

290− g' s (ObjectLiteral vs) = foldl (<>) r0 (map (g'' s . snd) vs)

291 g' s (TypeClassDictionaryConstructorApp _ v1) = g'' s v1

343 g' s (TypeClassDictionaryConstructorApp _ v1) = g'' s v1

292 g' s (Accessor _ v1) = g'' s v1

344 g' s (Accessor _ v1) = g'' s v1

293 g' s (ObjectUpdate obj vs) = foldl (<>) (g'' s obj) (map (g'' s . snd) vs)

345 g' s (ObjectUpdate obj vs) = foldl (<>) (g'' s obj) (map (g'' s . snd) vs)

@@ -301,42 +353,54 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'

301 g' s (PositionedValue _ _ v1) = g'' s v1

353 g' s (PositionedValue _ _ v1) = g'' s v1

302 g' _ _ = r0

354 g' _ _ = r0

303

355

356+ h'' :: s -> Binder -> r

304 h'' s b = let (s', r) = h s b in r <> h' s' b

357 h'' s b = let (s', r) = h s b in r <> h' s' b

305

358

359+ h' :: s -> Binder -> r

360+ h' s (LiteralBinder l) = lit h'' s l

306 h' s (ConstructorBinder _ bs) = foldl (<>) r0 (map (h'' s) bs)

361 h' s (ConstructorBinder _ bs) = foldl (<>) r0 (map (h'' s) bs)

307 h' s (BinaryNoParensBinder b1 b2 b3) = h'' s b1 <> h'' s b2 <> h'' s b3

362 h' s (BinaryNoParensBinder b1 b2 b3) = h'' s b1 <> h'' s b2 <> h'' s b3

308 h' s (ParensInBinder b) = h'' s b

363 h' s (ParensInBinder b) = h'' s b

309− h' s (ObjectBinder bs) = foldl (<>) r0 (map (h'' s . snd) bs)

310− h' s (ArrayBinder bs) = foldl (<>) r0 (map (h'' s) bs)

311 h' s (NamedBinder _ b1) = h'' s b1

364 h' s (NamedBinder _ b1) = h'' s b1

312 h' s (PositionedBinder _ _ b1) = h'' s b1

365 h' s (PositionedBinder _ _ b1) = h'' s b1

313 h' s (TypedBinder _ b1) = h'' s b1

366 h' s (TypedBinder _ b1) = h'' s b1

314 h' _ _ = r0

367 h' _ _ = r0

315

368

369+ lit :: (s -> a -> r) -> s -> Literal a -> r

370+ lit go s (ArrayLiteral as) = foldl (<>) r0 (map (go s) as)

371+ lit go s (ObjectLiteral as) = foldl (<>) r0 (map (go s . snd) as)

372+ lit _ _ _ = r0

373+

374+ i'' :: s -> CaseAlternative -> r

316 i'' s ca = let (s', r) = i s ca in r <> i' s' ca

375 i'' s ca = let (s', r) = i s ca in r <> i' s' ca

317

376

377+ i' :: s -> CaseAlternative -> r

318 i' s (CaseAlternative bs (Right val)) = foldl (<>) r0 (map (h'' s) bs) <> g'' s val

378 i' s (CaseAlternative bs (Right val)) = foldl (<>) r0 (map (h'' s) bs) <> g'' s val

319 i' s (CaseAlternative bs (Left gs)) = foldl (<>) r0 (map (h'' s) bs ++ concatMap (\(grd, val) -> [g'' s grd, g'' s val]) gs)

379 i' s (CaseAlternative bs (Left gs)) = foldl (<>) r0 (map (h'' s) bs ++ concatMap (\(grd, val) -> [g'' s grd, g'' s val]) gs)

320

380

381+ j'' :: s -> DoNotationElement -> r

321 j'' s e = let (s', r) = j s e in r <> j' s' e

382 j'' s e = let (s', r) = j s e in r <> j' s' e

322

383

384+ j' :: s -> DoNotationElement -> r

323 j' s (DoNotationValue v) = g'' s v

385 j' s (DoNotationValue v) = g'' s v

324 j' s (DoNotationBind b v) = h'' s b <> g'' s v

386 j' s (DoNotationBind b v) = h'' s b <> g'' s v

325 j' s (DoNotationLet ds) = foldl (<>) r0 (map (f'' s) ds)

387 j' s (DoNotationLet ds) = foldl (<>) r0 (map (f'' s) ds)

326 j' s (PositionedDoNotationElement _ _ e1) = j'' s e1

388 j' s (PositionedDoNotationElement _ _ e1) = j'' s e1

327

389

328−everywhereWithContextOnValuesM :: (Functor m, Applicative m, Monad m) =>

390+everywhereWithContextOnValuesM

329− s ->

391+ :: forall m s

392+ . (Monad m)

393+ => s

330− (s -> Declaration -> m (s, Declaration)) ->

394+ -> (s -> Declaration -> m (s, Declaration))

331− (s -> Expr -> m (s, Expr)) ->

395+ -> (s -> Expr -> m (s, Expr))

332− (s -> Binder -> m (s, Binder)) ->

396+ -> (s -> Binder -> m (s, Binder))

333− (s -> CaseAlternative -> m (s, CaseAlternative)) ->

397+ -> (s -> CaseAlternative -> m (s, CaseAlternative))

334− (s -> DoNotationElement -> m (s, DoNotationElement)) ->

398+ -> (s -> DoNotationElement -> m (s, DoNotationElement))

335− ( Declaration -> m Declaration

399+ -> ( Declaration -> m Declaration

336− , Expr -> m Expr

400+ , Expr -> m Expr

337− , Binder -> m Binder

401+ , Binder -> m Binder

338− , CaseAlternative -> m CaseAlternative

402+ , CaseAlternative -> m CaseAlternative

339− , DoNotationElement -> m DoNotationElement)

403+ , DoNotationElement -> m DoNotationElement)

340everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j'' s0)

404everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j'' s0)

341 where

405 where

342 f'' s = uncurry f' <=< f s

406 f'' s = uncurry f' <=< f s

@@ -351,13 +415,12 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j

351

415

352 g'' s = uncurry g' <=< g s

416 g'' s = uncurry g' <=< g s

353

417

418+ g' s (Literal l) = Literal <$> lit g'' s l

354 g' s (UnaryMinus v) = UnaryMinus <$> g'' s v

419 g' s (UnaryMinus v) = UnaryMinus <$> g'' s v

355 g' s (BinaryNoParens op v1 v2) = BinaryNoParens <$> g'' s op <*> g'' s v1 <*> g'' s v2

420 g' s (BinaryNoParens op v1 v2) = BinaryNoParens <$> g'' s op <*> g'' s v1 <*> g'' s v2

356 g' s (Parens v) = Parens <$> g'' s v

421 g' s (Parens v) = Parens <$> g'' s v

357 g' s (OperatorSection op (Left v)) = OperatorSection <$> g'' s op <*> (Left <$> g'' s v)

422 g' s (OperatorSection op (Left v)) = OperatorSection <$> g'' s op <*> (Left <$> g'' s v)

358 g' s (OperatorSection op (Right v)) = OperatorSection <$> g'' s op <*> (Right <$> g'' s v)

423 g' s (OperatorSection op (Right v)) = OperatorSection <$> g'' s op <*> (Right <$> g'' s v)

359− g' s (ArrayLiteral vs) = ArrayLiteral <$> traverse (g'' s) vs

360− g' s (ObjectLiteral vs) = ObjectLiteral <$> traverse (sndM (g'' s)) vs

361 g' s (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> g'' s v

424 g' s (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> g'' s v

362 g' s (Accessor prop v) = Accessor prop <$> g'' s v

425 g' s (Accessor prop v) = Accessor prop <$> g'' s v

363 g' s (ObjectUpdate obj vs) = ObjectUpdate <$> g'' s obj <*> traverse (sndM (g'' s)) vs

426 g' s (ObjectUpdate obj vs) = ObjectUpdate <$> g'' s obj <*> traverse (sndM (g'' s)) vs

@@ -373,16 +436,20 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j

373

436

374 h'' s = uncurry h' <=< h s

437 h'' s = uncurry h' <=< h s

375

438

439+ h' s (LiteralBinder l) = LiteralBinder <$> lit h'' s l

376 h' s (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> traverse (h'' s) bs

440 h' s (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> traverse (h'' s) bs

377 h' s (BinaryNoParensBinder b1 b2 b3) = BinaryNoParensBinder <$> h'' s b1 <*> h'' s b2 <*> h'' s b3

441 h' s (BinaryNoParensBinder b1 b2 b3) = BinaryNoParensBinder <$> h'' s b1 <*> h'' s b2 <*> h'' s b3

378 h' s (ParensInBinder b) = ParensInBinder <$> h'' s b

442 h' s (ParensInBinder b) = ParensInBinder <$> h'' s b

379− h' s (ObjectBinder bs) = ObjectBinder <$> traverse (sndM (h'' s)) bs

380− h' s (ArrayBinder bs) = ArrayBinder <$> traverse (h'' s) bs

381 h' s (NamedBinder name b) = NamedBinder name <$> h'' s b

443 h' s (NamedBinder name b) = NamedBinder name <$> h'' s b

382 h' s (PositionedBinder pos com b) = PositionedBinder pos com <$> h'' s b

444 h' s (PositionedBinder pos com b) = PositionedBinder pos com <$> h'' s b

383 h' s (TypedBinder t b) = TypedBinder t <$> h'' s b

445 h' s (TypedBinder t b) = TypedBinder t <$> h'' s b

384 h' _ other = return other

446 h' _ other = return other

385

447

448+ lit :: (s -> a -> m a) -> s -> Literal a -> m (Literal a)

449+ lit go s (ArrayLiteral as) = ArrayLiteral <$> traverse (go s) as

450+ lit go s (ObjectLiteral as) = ObjectLiteral <$> traverse (sndM (go s)) as

451+ lit _ _ other = return other

452+

386 i'' s = uncurry i' <=< i s

453 i'' s = uncurry i' <=< i s

387

454

388 i' s (CaseAlternative bs val) = CaseAlternative <$> traverse (h'' s) bs <*> eitherM (traverse (pairM (g'' s) (g'' s))) (g'' s) val

455 i' s (CaseAlternative bs val) = CaseAlternative <$> traverse (h'' s) bs <*> eitherM (traverse (pairM (g'' s) (g'' s))) (g'' s) val

@@ -394,25 +461,29 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j

394 j' s (DoNotationLet ds) = DoNotationLet <$> traverse (f'' s) ds

461 j' s (DoNotationLet ds) = DoNotationLet <$> traverse (f'' s) ds

395 j' s (PositionedDoNotationElement pos com e1) = PositionedDoNotationElement pos com <$> j'' s e1

462 j' s (PositionedDoNotationElement pos com e1) = PositionedDoNotationElement pos com <$> j'' s e1

396

463

397−everythingWithScope ::

464+everythingWithScope

465+ :: forall r

398− (Monoid r) =>

466+ . (Monoid r)

399− (S.Set Ident -> Declaration -> r) ->

467+ => (S.Set Ident -> Declaration -> r)

400− (S.Set Ident -> Expr -> r) ->

468+ -> (S.Set Ident -> Expr -> r)

401− (S.Set Ident -> Binder -> r) ->

469+ -> (S.Set Ident -> Binder -> r)

402− (S.Set Ident -> CaseAlternative -> r) ->

470+ -> (S.Set Ident -> CaseAlternative -> r)

403− (S.Set Ident -> DoNotationElement -> r) ->

471+ -> (S.Set Ident -> DoNotationElement -> r)

404− ( S.Set Ident -> Declaration -> r

472+ -> ( S.Set Ident -> Declaration -> r

405− , S.Set Ident -> Expr -> r

473+ , S.Set Ident -> Expr -> r

406− , S.Set Ident -> Binder -> r

474+ , S.Set Ident -> Binder -> r

407− , S.Set Ident -> CaseAlternative -> r

475+ , S.Set Ident -> CaseAlternative -> r

408− , S.Set Ident -> DoNotationElement -> r)

476+ , S.Set Ident -> DoNotationElement -> r

477+ )

409everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)

478everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)

410 where

479 where

411 -- Avoid importing Data.Monoid and getting shadowed names above

480 -- Avoid importing Data.Monoid and getting shadowed names above

412 (<>) = mappend

481 (<>) = mappend

413

482

483+ f'' :: S.Set Ident -> Declaration -> r

414 f'' s a = f s a <> f' s a

484 f'' s a = f s a <> f' s a

415

485

486+ f' :: S.Set Ident -> Declaration -> r

416 f' s (DataBindingGroupDeclaration ds) =

487 f' s (DataBindingGroupDeclaration ds) =

417 let s' = S.union s (S.fromList (mapMaybe getDeclIdent ds))

488 let s' = S.union s (S.fromList (mapMaybe getDeclIdent ds))

418 in foldMap (f'' s') ds

489 in foldMap (f'' s') ds

@@ -431,15 +502,16 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)

431 f' s (PositionedDeclaration _ _ d) = f'' s d

502 f' s (PositionedDeclaration _ _ d) = f'' s d

432 f' _ _ = mempty

503 f' _ _ = mempty

433

504

505+ g'' :: S.Set Ident -> Expr -> r

434 g'' s a = g s a <> g' s a

506 g'' s a = g s a <> g' s a

435

507

508+ g' :: S.Set Ident -> Expr -> r

509+ g' s (Literal l) = lit g'' s l

436 g' s (UnaryMinus v1) = g'' s v1

510 g' s (UnaryMinus v1) = g'' s v1

437 g' s (BinaryNoParens op v1 v2) = g' s op <> g' s v1 <> g' s v2

511 g' s (BinaryNoParens op v1 v2) = g' s op <> g' s v1 <> g' s v2

438 g' s (Parens v1) = g'' s v1

512 g' s (Parens v1) = g'' s v1

439 g' s (OperatorSection op (Left v)) = g'' s op <> g'' s v

513 g' s (OperatorSection op (Left v)) = g'' s op <> g'' s v

440 g' s (OperatorSection op (Right v)) = g'' s op <> g'' s v

514 g' s (OperatorSection op (Right v)) = g'' s op <> g'' s v

441− g' s (ArrayLiteral vs) = foldMap (g'' s) vs

442− g' s (ObjectLiteral vs) = foldMap (g'' s . snd) vs

443 g' s (TypeClassDictionaryConstructorApp _ v1) = g'' s v1

515 g' s (TypeClassDictionaryConstructorApp _ v1) = g'' s v1

444 g' s (Accessor _ v1) = g'' s v1

516 g' s (Accessor _ v1) = g'' s v1

445 g' s (ObjectUpdate obj vs) = g'' s obj <> foldMap (g'' s . snd) vs

517 g' s (ObjectUpdate obj vs) = g'' s obj <> foldMap (g'' s . snd) vs

@@ -460,20 +532,28 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)

460 g' s (PositionedValue _ _ v1) = g'' s v1

532 g' s (PositionedValue _ _ v1) = g'' s v1

461 g' _ _ = mempty

533 g' _ _ = mempty

462

534

535+ h'' :: S.Set Ident -> Binder -> r

463 h'' s a = h s a <> h' s a

536 h'' s a = h s a <> h' s a

464

537

538+ h' :: S.Set Ident -> Binder -> r

539+ h' s (LiteralBinder l) = lit h'' s l

465 h' s (ConstructorBinder _ bs) = foldMap (h'' s) bs

540 h' s (ConstructorBinder _ bs) = foldMap (h'' s) bs

466 h' s (BinaryNoParensBinder b1 b2 b3) = foldMap (h'' s) [b1, b2, b3]

541 h' s (BinaryNoParensBinder b1 b2 b3) = foldMap (h'' s) [b1, b2, b3]

467 h' s (ParensInBinder b) = h'' s b

542 h' s (ParensInBinder b) = h'' s b

468− h' s (ObjectBinder bs) = foldMap (h'' s . snd) bs

469− h' s (ArrayBinder bs) = foldMap (h'' s) bs

470 h' s (NamedBinder name b1) = h'' (S.insert name s) b1

543 h' s (NamedBinder name b1) = h'' (S.insert name s) b1

471 h' s (PositionedBinder _ _ b1) = h'' s b1

544 h' s (PositionedBinder _ _ b1) = h'' s b1

472 h' s (TypedBinder _ b1) = h'' s b1

545 h' s (TypedBinder _ b1) = h'' s b1

473 h' _ _ = mempty

546 h' _ _ = mempty

474

547

548+ lit :: (S.Set Ident -> a -> r) -> S.Set Ident -> Literal a -> r

549+ lit go s (ArrayLiteral as) = foldMap (go s) as

550+ lit go s (ObjectLiteral as) = foldMap (go s . snd) as

551+ lit _ _ _ = mempty

552+

553+ i'' :: S.Set Ident -> CaseAlternative -> r

475 i'' s a = i s a <> i' s a

554 i'' s a = i s a <> i' s a

476

555

556+ i' :: S.Set Ident -> CaseAlternative -> r

477 i' s (CaseAlternative bs (Right val)) =

557 i' s (CaseAlternative bs (Right val)) =

478 let s' = S.union s (S.fromList (concatMap binderNames bs))

558 let s' = S.union s (S.fromList (concatMap binderNames bs))

479 in foldMap (h'' s) bs <> g'' s' val

559 in foldMap (h'' s) bs <> g'' s' val

@@ -481,8 +561,10 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)

481 let s' = S.union s (S.fromList (concatMap binderNames bs))

561 let s' = S.union s (S.fromList (concatMap binderNames bs))

482 in foldMap (h'' s) bs <> foldMap (\(grd, val) -> g'' s' grd <> g'' s' val) gs

562 in foldMap (h'' s) bs <> foldMap (\(grd, val) -> g'' s' grd <> g'' s' val) gs

483

563

564+ j'' :: S.Set Ident -> DoNotationElement -> (S.Set Ident, r)

484 j'' s a = let (s', r) = j' s a in (s', j s a <> r)

565 j'' s a = let (s', r) = j' s a in (s', j s a <> r)

485

566

567+ j' :: S.Set Ident -> DoNotationElement -> (S.Set Ident, r)

486 j' s (DoNotationValue v) = (s, g'' s v)

568 j' s (DoNotationValue v) = (s, g'' s v)

487 j' s (DoNotationBind b v) =

569 j' s (DoNotationBind b v) =

488 let s' = S.union (S.fromList (binderNames b)) s

570 let s' = S.union (S.fromList (binderNames b)) s

@@ -498,7 +580,15 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)

498 getDeclIdent (TypeDeclaration ident _) = Just ident

580 getDeclIdent (TypeDeclaration ident _) = Just ident

499 getDeclIdent _ = Nothing

581 getDeclIdent _ = Nothing

500

582

501−accumTypes :: (Monoid r) => (Type -> r) -> (Declaration -> r, Expr -> r, Binder -> r, CaseAlternative -> r, DoNotationElement -> r)

583+accumTypes

584+ :: (Monoid r)

585+ => (Type -> r)

586+ -> ( Declaration -> r

587+ , Expr -> r

588+ , Binder -> r

589+ , CaseAlternative -> r

590+ , DoNotationElement -> r

591+ )

502accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (const mempty) (const mempty)

592accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (const mempty) (const mempty)

503 where

593 where

504 forDecls (DataDeclaration _ _ _ dctors) = mconcat (concatMap (map f . snd) dctors)

594 forDecls (DataDeclaration _ _ _ dctors) = mconcat (concatMap (map f . snd) dctors)

src/Language/PureScript/Bundle.hs+3−3

@@ -141,7 +141,7 @@ checkImportPath :: Maybe FilePath -> String -> ModuleIdentifier -> S.Set String

141checkImportPath _ "./foreign" m _ =

142 Right (ModuleIdentifier (moduleName m) Foreign)

143checkImportPath requirePath name _ names

144− | Just name' <- stripPrefix (fromMaybe "" requirePath) name

144+ | Just name' <- stripPrefix (fromMaybe "../" requirePath) name

145 , name' `S.member` names = Right (ModuleIdentifier name' Regular)

146checkImportPath _ name _ _ = Left name

147

@@ -209,7 +209,7 @@ withDeps (Module modulePath es) = Module modulePath (map expandDeps es)

209--

210-- Each type of module element is matched using pattern guards, and everything else is bundled into the

211-- Other constructor.

212−toModule :: forall m. (Applicative m, MonadError ErrorMessage m) => Maybe FilePath -> S.Set String -> ModuleIdentifier -> JSNode -> m Module

212+toModule :: forall m. (MonadError ErrorMessage m) => Maybe FilePath -> S.Set String -> ModuleIdentifier -> JSNode -> m Module

213toModule requirePath mids mid top

214 | JSSourceElementsTop ns <- node top = Module mid <$> traverse toModuleElement ns

215 | otherwise = err InvalidTopLevel

@@ -533,7 +533,7 @@ codeGen optionsMainModule optionsNamespace ms = renderToString (NN (JSSourceElem

533-- | The bundling function.

534-- This function performs dead code elimination, filters empty modules

535-- and generates and prints the final Javascript bundle.

536−bundle :: (Applicative m, MonadError ErrorMessage m)

536+bundle :: (MonadError ErrorMessage m)

537 => [(ModuleIdentifier, String)] -- ^ The input modules. Each module should be javascript rendered from 'Language.PureScript.Make' or @psc@.

538 -> [ModuleIdentifier] -- ^ Entry points. These module identifiers are used as the roots for dead-code elimination

539 -> Maybe String -- ^ An optional main module.

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

@@ -47,7 +47,7 @@ import System.FilePath.Posix ((</>))

47--

48moduleToJs

49 :: forall m

50− . (Applicative m, Monad m, MonadReader Options m, MonadSupply m, MonadError MultipleErrors m)

50+ . (Monad m, MonadReader Options m, MonadSupply m, MonadError MultipleErrors m)

51 => Module Ann

52 -> Maybe JS

53 -> m [JS]

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

111 importToJs mnLookup mn' = do

112 path <- asks optionsRequirePath

113 let ((ss, _, _, _), mnSafe) = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup

114− let moduleBody = JSApp Nothing (JSVar Nothing "require") [JSStringLiteral Nothing (maybe id (</>) path $ runModuleName mn')]

114+ let moduleBody = JSApp Nothing (JSVar Nothing "require") [JSStringLiteral Nothing (fromMaybe ".." path </> runModuleName mn')]

115 withPos ss $ JSVariableIntroduction Nothing (moduleNameToJs mnSafe) (Just moduleBody)

116

117 -- |

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

@@ -347,7 +347,7 @@ everywhereOnJS f = go

347everywhereOnJSTopDown :: (JS -> JS) -> JS -> JS

348everywhereOnJSTopDown f = runIdentity . everywhereOnJSTopDownM (Identity . f)

349

350−everywhereOnJSTopDownM :: (Applicative m, Monad m) => (JS -> m JS) -> JS -> m JS

350+everywhereOnJSTopDownM :: (Monad m) => (JS -> m JS) -> JS -> m JS

351everywhereOnJSTopDownM f = f >=> go

352 where

353 f' = f >=> go

src/Language/PureScript/CodeGen/JS/Optimizer.hs+2−2

@@ -43,12 +43,12 @@ import Language.PureScript.CodeGen.JS.Optimizer.Blocks

43-- |

44-- Apply a series of optimizer passes to simplified Javascript code

45--

46−optimize :: (Monad m, MonadReader Options m, Applicative m, MonadSupply m) => JS -> m JS

46+optimize :: (Monad m, MonadReader Options m, MonadSupply m) => JS -> m JS

47optimize js = do

48 noOpt <- asks optionsNoOptimizations

49 if noOpt then return js else optimize' js

50

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

51+optimize' :: (Monad m, MonadReader Options m, MonadSupply m) => JS -> m JS

52optimize' js = do

53 opts <- ask

54 js' <- untilFixedPoint (inlineFnComposition . tidyUp . applyAll

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

@@ -235,7 +235,7 @@ inlineCommonOperators = applyAll $

235

236-- (f <<< g $ x) = f (g x)

237-- (f <<< g) = \x -> f (g x)

238−inlineFnComposition :: (Applicative m, MonadSupply m) => JS -> m JS

238+inlineFnComposition :: (MonadSupply m) => JS -> m JS

239inlineFnComposition = everywhereOnJSTopDownM convert

240 where

241 convert :: (MonadSupply m) => JS -> m JS

src/Language/PureScript/CoreFn.hs+3−14

@@ -1,17 +1,6 @@

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

1+-- |

2+-- The core functional representation

2--

3--

3−-- Module : Language.PureScript.CoreFn

5−-- License : MIT

6−--

7−-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>

8−-- Stability : experimental

9−-- Portability :

10−--

11−-- | The core functional representation

12−--

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

14−

15module Language.PureScript.CoreFn (

4module Language.PureScript.CoreFn (

16 module C

5 module C

17) where

6) where

@@ -20,7 +9,7 @@ import Language.PureScript.CoreFn.Ann as C

20import Language.PureScript.CoreFn.Binders as C

9import Language.PureScript.CoreFn.Binders as C

21import Language.PureScript.CoreFn.Desugar as C

10import Language.PureScript.CoreFn.Desugar as C

22import Language.PureScript.CoreFn.Expr as C

11import Language.PureScript.CoreFn.Expr as C

23−import Language.PureScript.CoreFn.Literals as C

12+import Language.PureScript.AST.Literals as C

24import Language.PureScript.CoreFn.Meta as C

13import Language.PureScript.CoreFn.Meta as C

25import Language.PureScript.CoreFn.Module as C

14import Language.PureScript.CoreFn.Module as C

26import Language.PureScript.CoreFn.Traversals as C

15import Language.PureScript.CoreFn.Traversals as C

src/Language/PureScript/CoreFn/Binders.hs+1−1

@@ -5,7 +5,7 @@

5--

6module Language.PureScript.CoreFn.Binders where

7

8−import Language.PureScript.CoreFn.Literals

8+import Language.PureScript.AST.Literals

9import Language.PureScript.Names

10

11-- |

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

@@ -17,7 +17,7 @@ import Language.PureScript.AST.Traversals

17import Language.PureScript.CoreFn.Ann

18import Language.PureScript.CoreFn.Binders

19import Language.PureScript.CoreFn.Expr

20−import Language.PureScript.CoreFn.Literals

20+import Language.PureScript.AST.Literals

21import Language.PureScript.CoreFn.Meta

22import Language.PureScript.CoreFn.Module

23import Language.PureScript.Environment

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

88 -- Desugars expressions from AST to CoreFn representation.

89 --

90 exprToCoreFn :: Maybe SourceSpan -> [Comment] -> Maybe Type -> A.Expr -> Expr Ann

91− exprToCoreFn ss com ty (A.NumericLiteral v) =

91+ exprToCoreFn ss com ty (A.Literal lit) =

92− Literal (ss, com, ty, Nothing) (NumericLiteral v)

93− exprToCoreFn ss com ty (A.StringLiteral v) =

94− Literal (ss, com, ty, Nothing) (StringLiteral v)

95− exprToCoreFn ss com ty (A.CharLiteral v) =

96− Literal (ss, com, ty, Nothing) (CharLiteral v)

97− exprToCoreFn ss com ty (A.BooleanLiteral v) =

98− Literal (ss, com, ty, Nothing) (BooleanLiteral v)

99− exprToCoreFn ss com ty (A.ArrayLiteral vs) =

100− Literal (ss, com, ty, Nothing) (ArrayLiteral $ map (exprToCoreFn ss [] Nothing) vs)

92+ Literal (ss, com, ty, Nothing) (fmap (exprToCoreFn ss com Nothing) lit)

101− exprToCoreFn ss com ty (A.ObjectLiteral vs) =

102− Literal (ss, com, ty, Nothing) (ObjectLiteral $ map (second (exprToCoreFn ss [] Nothing)) vs)

103 exprToCoreFn ss com ty (A.Accessor name v) =

93 exprToCoreFn ss com ty (A.Accessor name v) =

104 Accessor (ss, com, ty, Nothing) name (exprToCoreFn ss [] Nothing v)

94 Accessor (ss, com, ty, Nothing) name (exprToCoreFn ss [] Nothing v)

105 exprToCoreFn ss com ty (A.ObjectUpdate obj vs) =

95 exprToCoreFn ss com ty (A.ObjectUpdate obj vs) =

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

126 exprToCoreFn ss com (Just ty) v

116 exprToCoreFn ss com (Just ty) v

127 exprToCoreFn ss com ty (A.Let ds v) =

117 exprToCoreFn ss com ty (A.Let ds v) =

128 Let (ss, com, ty, Nothing) (concatMap (declToCoreFn ss []) ds) (exprToCoreFn ss [] Nothing v)

118 Let (ss, com, ty, Nothing) (concatMap (declToCoreFn ss []) ds) (exprToCoreFn ss [] Nothing v)

129− exprToCoreFn ss com _ (A.TypeClassDictionaryConstructorApp name (A.TypedValue _ (A.ObjectLiteral vs) _)) =

119+ exprToCoreFn ss com _ (A.TypeClassDictionaryConstructorApp name (A.TypedValue _ (A.Literal (A.ObjectLiteral vs)) _)) =

130 let args = map (exprToCoreFn ss [] Nothing . snd) $ sortBy (compare `on` fst) vs

120 let args = map (exprToCoreFn ss [] Nothing . snd) $ sortBy (compare `on` fst) vs

131 ctor = Var (ss, [], Nothing, Just IsTypeClassConstructor) (fmap properToIdent name)

121 ctor = Var (ss, [], Nothing, Just IsTypeClassConstructor) (fmap properToIdent name)

132 in foldl (App (ss, com, Nothing, Nothing)) ctor args

122 in foldl (App (ss, com, Nothing, Nothing)) ctor args

@@ -152,25 +142,15 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =

152 -- Desugars case binders from AST to CoreFn representation.

142 -- Desugars case binders from AST to CoreFn representation.

153 --

143 --

154 binderToCoreFn :: Maybe SourceSpan -> [Comment] -> A.Binder -> Binder Ann

144 binderToCoreFn :: Maybe SourceSpan -> [Comment] -> A.Binder -> Binder Ann

145+ binderToCoreFn ss com (A.LiteralBinder lit) =

146+ LiteralBinder (ss, com, Nothing, Nothing) (fmap (binderToCoreFn ss com) lit)

155 binderToCoreFn ss com (A.NullBinder) =

147 binderToCoreFn ss com (A.NullBinder) =

156 NullBinder (ss, com, Nothing, Nothing)

148 NullBinder (ss, com, Nothing, Nothing)

157− binderToCoreFn ss com (A.BooleanBinder b) =

158− LiteralBinder (ss, com, Nothing, Nothing) (BooleanLiteral b)

159− binderToCoreFn ss com (A.StringBinder s) =

160− LiteralBinder (ss, com, Nothing, Nothing) (StringLiteral s)

161− binderToCoreFn ss com (A.CharBinder c) =

162− LiteralBinder (ss, com, Nothing, Nothing) (CharLiteral c)

163− binderToCoreFn ss com (A.NumberBinder n) =

164− LiteralBinder (ss, com, Nothing, Nothing) (NumericLiteral n)

165 binderToCoreFn ss com (A.VarBinder name) =

149 binderToCoreFn ss com (A.VarBinder name) =

166 VarBinder (ss, com, Nothing, Nothing) name

150 VarBinder (ss, com, Nothing, Nothing) name

167 binderToCoreFn ss com (A.ConstructorBinder dctor@(Qualified mn' _) bs) =

151 binderToCoreFn ss com (A.ConstructorBinder dctor@(Qualified mn' _) bs) =

168 let (_, tctor, _, _) = lookupConstructor env dctor

152 let (_, tctor, _, _) = lookupConstructor env dctor

169 in ConstructorBinder (ss, com, Nothing, Just $ getConstructorMeta dctor) (Qualified mn' tctor) dctor (map (binderToCoreFn ss []) bs)

153 in ConstructorBinder (ss, com, Nothing, Just $ getConstructorMeta dctor) (Qualified mn' tctor) dctor (map (binderToCoreFn ss []) bs)

170− binderToCoreFn ss com (A.ObjectBinder bs) =

171− LiteralBinder (ss, com, Nothing, Nothing) (ObjectLiteral $ map (second (binderToCoreFn ss [])) bs)

172− binderToCoreFn ss com (A.ArrayBinder bs) =

173− LiteralBinder (ss, com, Nothing, Nothing) (ArrayLiteral $ map (binderToCoreFn ss []) bs)

174 binderToCoreFn ss com (A.NamedBinder name b) =

154 binderToCoreFn ss com (A.NamedBinder name b) =

175 NamedBinder (ss, com, Nothing, Nothing) name (binderToCoreFn ss [] b)

155 NamedBinder (ss, com, Nothing, Nothing) name (binderToCoreFn ss [] b)

176 binderToCoreFn _ com (A.PositionedBinder ss com1 b) =

156 binderToCoreFn _ com (A.PositionedBinder ss com1 b) =

src/Language/PureScript/CoreFn/Expr.hs+1−1

@@ -8,7 +8,7 @@ module Language.PureScript.CoreFn.Expr where

8import Control.Arrow ((***))

9

10import Language.PureScript.CoreFn.Binders

11−import Language.PureScript.CoreFn.Literals

11+import Language.PureScript.AST.Literals

12import Language.PureScript.Names

13

14-- |

src/Language/PureScript/CoreFn/Traversals.hs+3−14

@@ -1,24 +1,13 @@

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

1+-- |

2+-- CoreFn traversal helpers

2--

3--

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

5−-- License : MIT

6−--

7−-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>

8−-- Stability : experimental

9−-- Portability :

10−--

11−-- | CoreFn traversal helpers

12−--

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

14−

15module Language.PureScript.CoreFn.Traversals where

4module Language.PureScript.CoreFn.Traversals where

16

5

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

6import Control.Arrow (second, (***), (+++))

18

7

19import Language.PureScript.CoreFn.Binders

8import Language.PureScript.CoreFn.Binders

20import Language.PureScript.CoreFn.Expr

9import Language.PureScript.CoreFn.Expr

21−import Language.PureScript.CoreFn.Literals

10+import Language.PureScript.AST.Literals

22

11

23everywhereOnValues :: (Bind a -> Bind a) ->

12everywhereOnValues :: (Bind a -> Bind a) ->

24 (Expr a -> Expr a) ->

13 (Expr a -> Expr a) ->

src/Language/PureScript/Docs/AsMarkdown.hs+1−2

@@ -29,8 +29,7 @@ import qualified Language.PureScript.Docs.Render as Render

29-- Markdown-formatted String.

30--

31renderModulesAsMarkdown ::

32− (Functor m, Applicative m,

33− MonadError P.MultipleErrors m) =>

32+ (MonadError P.MultipleErrors m) =>

34 [P.Module] ->

33 [P.Module] ->

35 m String

34 m String

36renderModulesAsMarkdown =

35renderModulesAsMarkdown =

src/Language/PureScript/Docs/Convert.hs+6−6

@@ -38,7 +38,7 @@ import Language.PureScript.Docs.Convert.ReExports (updateReExports)

38-- documentation.

39--

40convertModulesInPackage ::

41− (Functor m, Applicative m, MonadError P.MultipleErrors m) =>

41+ (MonadError P.MultipleErrors m) =>

42 [InPackage P.Module] ->

43 m [Module]

44convertModulesInPackage modules =

@@ -66,7 +66,7 @@ convertModulesInPackage modules =

66-- types.

67--

68convertModules ::

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

69+ (MonadError P.MultipleErrors m) =>

70 [P.Module] ->

71 m [Module]

72convertModules =

@@ -81,7 +81,7 @@ importPrim = P.addDefaultImport (P.ModuleName [P.ProperName C.prim])

81-- Convert a sorted list of modules.

82--

83convertSorted ::

84− (Functor m, Applicative m, MonadError P.MultipleErrors m) =>

84+ (MonadError P.MultipleErrors m) =>

85 [P.Module] ->

86 m [Module]

87convertSorted modules = do

@@ -99,7 +99,7 @@ convertSorted modules = do

99-- types.

100--

101typeCheckIfNecessary ::

102− (Functor m, Applicative m, MonadError P.MultipleErrors m) =>

102+ (MonadError P.MultipleErrors m) =>

103 [P.Module] ->

104 [Module] ->

105 m [Module]

@@ -122,7 +122,7 @@ typeCheckIfNecessary modules convertedModules =

122-- were not provided.

123--

124typeCheck ::

125− (Functor m, MonadError P.MultipleErrors m) =>

125+ (MonadError P.MultipleErrors m) =>

126 [P.Module] ->

127 m ([P.Module], P.Environment)

128typeCheck =

@@ -182,7 +182,7 @@ runParser p s = either (Left . show) Right $ do

182-- documentation information from.

183--

184partiallyDesugar ::

185− (Functor m, Applicative m, MonadError P.MultipleErrors m) =>

185+ (MonadError P.MultipleErrors m) =>

186 [P.Module]

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

188partiallyDesugar = P.evalSupplyT 0 . desugar'

src/Language/PureScript/Docs/Convert/ReExports.hs+13−22

@@ -69,8 +69,7 @@ updateReExports env order modules =

69-- have already been converted.

70--

71getReExports ::

72− (Functor m, Applicative m,

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

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

74 P.Env ->

73 P.Env ->

75 P.ModuleName ->

74 P.ModuleName ->

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

75 m [(P.ModuleName, [Declaration])]

@@ -105,9 +104,7 @@ getReExports env mn =

105-- class members are listed.

104-- class members are listed.

106--

105--

107collectDeclarations ::

106collectDeclarations ::

108− (Functor m, Applicative m,

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

107+ (MonadState (Map P.ModuleName Module) m, MonadReader P.ModuleName m) =>

110− MonadReader P.ModuleName m) =>

111 P.Imports ->

108 P.Imports ->

112 P.Exports ->

109 P.Exports ->

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

110 m [(P.ModuleName, [Declaration])]

@@ -154,7 +151,7 @@ collectDeclarations imports exports = do

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

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

155--

152--

156findImport ::

153findImport ::

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

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

158 [P.ImportRecord name] ->

155 [P.ImportRecord name] ->

159 (name, P.ModuleName) ->

156 (name, P.ModuleName) ->

160 m (P.ModuleName, name)

157 m (P.ModuleName, name)

@@ -174,9 +171,8 @@ findImport imps (name, orig) =

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

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

175

172

176lookupValueDeclaration ::

173lookupValueDeclaration ::

177− (Applicative m,

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

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

179− MonadReader P.ModuleName m) =>

175+ MonadReader P.ModuleName m) =>

180 P.ModuleName ->

176 P.ModuleName ->

181 P.Ident ->

177 P.Ident ->

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

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

@@ -233,9 +229,8 @@ lookupValueDeclaration importedFrom ident = do

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

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

234--

230--

235lookupTypeDeclaration ::

231lookupTypeDeclaration ::

236− (Applicative m,

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

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

238− MonadReader P.ModuleName m) =>

233+ MonadReader P.ModuleName m) =>

239 P.ModuleName ->

234 P.ModuleName ->

240 P.ProperName 'P.TypeName ->

235 P.ProperName 'P.TypeName ->

241 m (P.ModuleName, [Declaration])

236 m (P.ModuleName, [Declaration])

@@ -251,9 +246,8 @@ lookupTypeDeclaration importedFrom ty = do

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

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

252

247

253lookupTypeClassDeclaration ::

248lookupTypeClassDeclaration ::

254− (Applicative m,

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

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

256− MonadReader P.ModuleName m) =>

250+ MonadReader P.ModuleName m) =>

257 P.ModuleName ->

251 P.ModuleName ->

258 P.ProperName 'P.ClassName ->

252 P.ProperName 'P.ClassName ->

259 m (P.ModuleName, [Declaration])

253 m (P.ModuleName, [Declaration])

@@ -276,9 +270,8 @@ lookupTypeClassDeclaration importedFrom tyClass = do

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

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

277--

271--

278lookupModuleDeclarations ::

272lookupModuleDeclarations ::

279− (Applicative m,

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

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

281− MonadReader P.ModuleName m) =>

274+ MonadReader P.ModuleName m) =>

282 String ->

275 String ->

283 P.ModuleName ->

276 P.ModuleName ->

284 m [Declaration]

277 m [Declaration]

@@ -293,8 +286,7 @@ lookupModuleDeclarations definedIn moduleName = do

293 pure (allDeclarations mdl)

286 pure (allDeclarations mdl)

294

287

295handleTypeClassMembers ::

288handleTypeClassMembers ::

296− (Functor m, Applicative m,

297− MonadReader P.ModuleName m) =>

289+ (MonadReader P.ModuleName m) =>

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

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

299 Map P.ModuleName [Declaration] ->

291 Map P.ModuleName [Declaration] ->

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

292 m (Map P.ModuleName [Declaration], Map P.ModuleName [Declaration])

@@ -364,8 +356,7 @@ instance Monoid TypeClassEnv where

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

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

365--

357--

366handleEnv ::

358handleEnv ::

367− (Functor m, Applicative m,

368− MonadReader P.ModuleName m) =>

359+ (MonadReader P.ModuleName m) =>

369 TypeClassEnv ->

360 TypeClassEnv ->

370 m ([Declaration], [Declaration])

361 m ([Declaration], [Declaration])

371handleEnv TypeClassEnv{..} =

362handleEnv TypeClassEnv{..} =

src/Language/PureScript/Docs/ParseAndBookmark.hs+2−2

@@ -35,7 +35,7 @@ import Language.PureScript.Docs.Convert (collectBookmarks)

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

36-- * Return the parsed modules and the bookmarks

37parseAndBookmark ::

38− (Functor m, Applicative m, MonadError P.MultipleErrors m, MonadIO m) =>

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

39 [FilePath]

40 -> [(PackageName, FilePath)]

41 -> m ([InPackage P.Module], [Bookmark])

@@ -82,7 +82,7 @@ fileInfoToString (FromDep _ fn) = fn

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

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

84

85−parseAs :: (Functor m, MonadIO m) => (FilePath -> a) -> FilePath -> m (a, String)

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

86parseAs g = fmap (first g) . liftIO . parseFile

87

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

src/Language/PureScript/Errors.hs+23−16

@@ -148,6 +148,7 @@ data SimpleErrorMessage

148 | CaseBinderLengthDiffers Int [Binder]

149 | IncorrectAnonymousArgument

150 | InvalidOperatorInBinder Ident Ident

151+ | DeprecatedRequirePath

151 deriving (Show)

152 deriving (Show)

152

153

153-- | Error message hints, providing more detailed information about failure.

154-- | Error message hints, providing more detailed information about failure.

@@ -328,6 +329,7 @@ errorCode em = case unwrapErrorMessage em of

328 CaseBinderLengthDiffers{} -> "CaseBinderLengthDiffers"

329 CaseBinderLengthDiffers{} -> "CaseBinderLengthDiffers"

329 IncorrectAnonymousArgument -> "IncorrectAnonymousArgument"

330 IncorrectAnonymousArgument -> "IncorrectAnonymousArgument"

330 InvalidOperatorInBinder{} -> "InvalidOperatorInBinder"

331 InvalidOperatorInBinder{} -> "InvalidOperatorInBinder"

332+ DeprecatedRequirePath{} -> "DeprecatedRequirePath"

331

333

332-- |

334-- |

333-- A stack trace for an error

335-- A stack trace for an error

@@ -447,6 +449,7 @@ errorSuggestion err = case err of

447 UnusedExplicitImport mn _ qual refs -> suggest $ importSuggestion mn refs qual

449 UnusedExplicitImport mn _ qual refs -> suggest $ importSuggestion mn refs qual

448 ImplicitImport mn refs -> suggest $ importSuggestion mn refs Nothing

450 ImplicitImport mn refs -> suggest $ importSuggestion mn refs Nothing

449 ImplicitQualifiedImport mn asModule refs -> suggest $ importSuggestion mn refs (Just asModule)

451 ImplicitQualifiedImport mn asModule refs -> suggest $ importSuggestion mn refs (Just asModule)

452+ HidingImport mn refs -> suggest $ importSuggestion mn refs Nothing

450 _ -> Nothing

453 _ -> Nothing

451

454

452 where

455 where

@@ -955,9 +958,9 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap

955 , indent $ line $ showSuggestion msg

958 , indent $ line $ showSuggestion msg

956 ]

959 ]

957

960

958− renderSimpleErrorMessage (HidingImport mn refs) =

961+ renderSimpleErrorMessage msg@(HidingImport mn _) =

959 paras [ line $ "Module " ++ runModuleName mn ++ " has unspecified imports, consider using the inclusive form: "

962 paras [ line $ "Module " ++ runModuleName mn ++ " has unspecified imports, consider using the inclusive form: "

960− , indent $ line $ "import " ++ runModuleName mn ++ " (" ++ intercalate ", " (map prettyPrintRef refs) ++ ")"

963+ , indent $ line $ showSuggestion msg

961 ]

964 ]

962

965

963 renderSimpleErrorMessage (CaseBinderLengthDiffers l bs) =

966 renderSimpleErrorMessage (CaseBinderLengthDiffers l bs) =

@@ -974,6 +977,9 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap

974 , line "Only aliases for data constructors may be used in patterns."

977 , line "Only aliases for data constructors may be used in patterns."

975 ]

978 ]

976

979

980+ renderSimpleErrorMessage DeprecatedRequirePath =

981+ line "The require-path option is deprecated and will be removed in PureScript 0.9."

982+

977 renderHint :: ErrorMessageHint -> Box.Box -> Box.Box

983 renderHint :: ErrorMessageHint -> Box.Box -> Box.Box

978 renderHint (ErrorUnifyingTypes t1 t2) detail =

984 renderHint (ErrorUnifyingTypes t1 t2) detail =

979 paras [ detail

985 paras [ detail

@@ -1181,31 +1187,32 @@ prettyPrintRef (PositionedDeclarationRef _ _ ref) = prettyPrintExport ref

1181-- Pretty print multiple errors

1187-- Pretty print multiple errors

1182--

1188--

1183prettyPrintMultipleErrors :: Bool -> MultipleErrors -> String

1189prettyPrintMultipleErrors :: Bool -> MultipleErrors -> String

1184−prettyPrintMultipleErrors full = renderBox . prettyPrintMultipleErrorsBox full

1190+prettyPrintMultipleErrors full = unlines . map renderBox . prettyPrintMultipleErrorsBox full

1185

1191

1186-- |

1192-- |

1187-- Pretty print multiple warnings

1193-- Pretty print multiple warnings

1188--

1194--

1189−prettyPrintMultipleWarnings :: Bool -> MultipleErrors -> String

1195+prettyPrintMultipleWarnings :: Bool -> MultipleErrors -> String

1190−prettyPrintMultipleWarnings full = renderBox . prettyPrintMultipleWarningsBox full

1196+prettyPrintMultipleWarnings full = unlines . map renderBox . prettyPrintMultipleWarningsBox full

1191

1197

1192-- | Pretty print warnings as a Box

1198-- | Pretty print warnings as a Box

1193−prettyPrintMultipleWarningsBox :: Bool -> MultipleErrors -> Box.Box

1199+prettyPrintMultipleWarningsBox :: Bool -> MultipleErrors -> [Box.Box]

1194prettyPrintMultipleWarningsBox full = prettyPrintMultipleErrorsWith Warning "Warning found:" "Warning" full

1200prettyPrintMultipleWarningsBox full = prettyPrintMultipleErrorsWith Warning "Warning found:" "Warning" full

1195

1201

1196-- | Pretty print errors as a Box

1202-- | Pretty print errors as a Box

1197−prettyPrintMultipleErrorsBox :: Bool -> MultipleErrors -> Box.Box

1203+prettyPrintMultipleErrorsBox :: Bool -> MultipleErrors -> [Box.Box]

1198prettyPrintMultipleErrorsBox full = prettyPrintMultipleErrorsWith Error "Error found:" "Error" full

1204prettyPrintMultipleErrorsBox full = prettyPrintMultipleErrorsWith Error "Error found:" "Error" full

1199

1205

1200−prettyPrintMultipleErrorsWith :: Level -> String -> String -> Bool -> MultipleErrors -> Box.Box

1206+prettyPrintMultipleErrorsWith :: Level -> String -> String -> Bool -> MultipleErrors -> [Box.Box]

1201prettyPrintMultipleErrorsWith level intro _ full (MultipleErrors [e]) =

1207prettyPrintMultipleErrorsWith level intro _ full (MultipleErrors [e]) =

1202 let result = prettyPrintSingleError full level True e

1208 let result = prettyPrintSingleError full level True e

1203− in Box.vcat Box.left [ Box.text intro

1209+ in [ Box.vcat Box.left [ Box.text intro

1204− , result

1210+ , result

1211+ ]

1205− ]

1212+ ]

1206prettyPrintMultipleErrorsWith level _ intro full (MultipleErrors es) =

1213prettyPrintMultipleErrorsWith level _ intro full (MultipleErrors es) =

1207 let result = map (prettyPrintSingleError full level True) es

1214 let result = map (prettyPrintSingleError full level True) es

1208− in Box.vsep 1 Box.left $ concat $ zipWith withIntro [1 :: Int ..] result

1215+ in concat $ zipWith withIntro [1 :: Int ..] result

1209 where

1216 where

1210 withIntro i err = [ Box.text (intro ++ " " ++ show i ++ " of " ++ show (length es) ++ ":")

1217 withIntro i err = [ Box.text (intro ++ " " ++ show i ++ " of " ++ show (length es) ++ ":")

1211 , Box.moveRight 2 err

1218 , Box.moveRight 2 err

@@ -1283,7 +1290,7 @@ renderBox = unlines

1283rethrow :: (MonadError e m) => (e -> e) -> m a -> m a

1290rethrow :: (MonadError e m) => (e -> e) -> m a -> m a

1284rethrow f = flip catchError $ \e -> throwError (f e)

1291rethrow f = flip catchError $ \e -> throwError (f e)

1285

1292

1286−reifyErrors :: (Functor m, MonadError e m) => m a -> m (Either e a)

1293+reifyErrors :: (MonadError e m) => m a -> m (Either e a)

1287reifyErrors ma = catchError (fmap Right ma) (return . Left)

1294reifyErrors ma = catchError (fmap Right ma) (return . Left)

1288

1295

1289reflectErrors :: (MonadError e m) => m (Either e a) -> m a

1296reflectErrors :: (MonadError e m) => m (Either e a) -> m a

@@ -1310,13 +1317,13 @@ withPosition pos (ErrorMessage hints se) = ErrorMessage (PositionedError pos : h

1310-- |

1317-- |

1311-- Collect errors in in parallel

1318-- Collect errors in in parallel

1312--

1319--

1313−parU :: (MonadError MultipleErrors m, Functor m) => [a] -> (a -> m b) -> m [b]

1320+parU :: (MonadError MultipleErrors m) => [a] -> (a -> m b) -> m [b]

1314parU xs f = forM xs (withError . f) >>= collectErrors

1321parU xs f = forM xs (withError . f) >>= collectErrors

1315 where

1322 where

1316− withError :: (MonadError MultipleErrors m, Functor m) => m a -> m (Either MultipleErrors a)

1323+ withError :: (MonadError MultipleErrors m) => m a -> m (Either MultipleErrors a)

1317 withError u = catchError (Right <$> u) (return . Left)

1324 withError u = catchError (Right <$> u) (return . Left)

1318

1325

1319− collectErrors :: (MonadError MultipleErrors m, Functor m) => [Either MultipleErrors a] -> m [a]

1326+ collectErrors :: (MonadError MultipleErrors m) => [Either MultipleErrors a] -> m [a]

1320 collectErrors es = case lefts es of

1327 collectErrors es = case lefts es of

1321 [] -> return $ rights es

1328 [] -> return $ rights es

1322 errs -> throwError $ fold errs

1329 errs -> throwError $ fold errs

src/Language/PureScript/Ide.hs+3−3

@@ -74,12 +74,12 @@ findType :: (PscIde m, MonadLogger m) =>

74findType search filters =

75 CompletionResult . getExactMatches search filters <$> getAllModulesWithReexports

76

77−findPursuitCompletions :: (Applicative m, MonadIO m, MonadLogger m) =>

77+findPursuitCompletions :: (MonadIO m, MonadLogger m) =>

78 PursuitQuery -> m Success

79findPursuitCompletions (PursuitQuery q) =

80 PursuitResult <$> liftIO (searchPursuitForDeclarations q)

81

82−findPursuitPackages :: (Applicative m, MonadIO m, MonadLogger m) =>

82+findPursuitPackages :: (MonadIO m, MonadLogger m) =>

83 PursuitQuery -> m Success

84findPursuitPackages (PursuitQuery q) =

85 PursuitResult <$> liftIO (findPackagesForModuleIdent q)

@@ -118,7 +118,7 @@ caseSplit l b e csa t = do

118addClause :: Text -> CS.WildcardAnnotations -> Success

119addClause t wca = MultilineTextResult (CS.addClause t wca)

120

121−importsForFile :: (Applicative m, MonadIO m, MonadLogger m, MonadError PscIdeError m) =>

121+importsForFile :: (MonadIO m, MonadLogger m, MonadError PscIdeError m) =>

122 FilePath -> m Success

123importsForFile fp = do

124 imports <- getImportsForFile fp

src/Language/PureScript/Ide/CaseSplit.hs+1−10

@@ -60,15 +60,6 @@ caseSplit q = do

60 let appliedCtors = map (\(n, ts) -> (n, map applyTypeVars ts)) ctors

61 pure appliedCtors

62

63−{- ["EDType {

64− edTypeName = ProperName {runProperName = \"Either\"}

65− , edTypeKind = FunKind Star (FunKind Star Star)

66− , edTypeDeclarationKind =

67− DataType [(\"a\",Just Star),(\"b\",Just Star)]

68− [(ProperName {runProperName = \"Left\"},[TypeVar \"a\"])

69− ,(ProperName {runProperName = \"Right\"},[TypeVar \"b\"])]}"]

70−-}

71−

72findTypeDeclaration :: (PscIde m, MonadLogger m, MonadError PscIdeError m) =>

63findTypeDeclaration :: (PscIde m, MonadLogger m, MonadError PscIdeError m) =>

73 ProperName 'TypeName -> m ExternsDeclaration

64 ProperName 'TypeName -> m ExternsDeclaration

74findTypeDeclaration q = do

65findTypeDeclaration q = do

@@ -87,7 +78,7 @@ findTypeDeclaration' t ExternsFile{..} =

87 EDType tn _ _ -> tn == t

78 EDType tn _ _ -> tn == t

88 _ -> False) efDeclarations

79 _ -> False) efDeclarations

89

80

90−splitTypeConstructor :: (Applicative m, MonadError PscIdeError m) =>

81+splitTypeConstructor :: (MonadError PscIdeError m) =>

91 Type -> m (ProperName 'TypeName, [Type])

82 Type -> m (ProperName 'TypeName, [Type])

92splitTypeConstructor = go []

83splitTypeConstructor = go []

93 where

84 where

src/Language/PureScript/Ide/Completion.hs+4−4

@@ -24,12 +24,12 @@ getExactMatches search filters modules =

24

25completionsFromModules :: [Module] -> [Completion]

26completionsFromModules = foldMap completionFromModule

27− where

27+ where

28− completionFromModule :: Module -> [Completion]

28+ completionFromModule :: Module -> [Completion]

29− completionFromModule (moduleIdent, decls) = mapMaybe (completionFromDecl moduleIdent) decls

29+ completionFromModule (moduleIdent, decls) = mapMaybe (completionFromDecl moduleIdent) decls

30

31completionFromDecl :: ModuleIdent -> ExternDecl -> Maybe Completion

32completionFromDecl mi (FunctionDecl name type') = Just (Completion (mi, name, type'))

33completionFromDecl mi (DataDecl name kind) = Just (Completion (mi, name, kind))

34−completionFromDecl _ (ModuleDecl name _) = Just (Completion ("module", name, "module"))

34+completionFromDecl _ (ModuleDecl name _) = Just (Completion ("module", name, "module"))

35completionFromDecl _ _ = Nothing

src/Language/PureScript/Ide/Error.hs+11−12

@@ -21,21 +21,20 @@ data PscIdeError

21

22instance ToJSON PscIdeError where

23 toJSON err = object

24− [

25− "resultType" .= ("error" :: Text),

24+ [ "resultType" .= ("error" :: Text)

26− "result" .= textError err

25+ , "result" .= textError err

27− ]

26+ ]

28

27

29textError :: PscIdeError -> Text

28textError :: PscIdeError -> Text

30−textError (GeneralError msg) = pack msg

29+textError (GeneralError msg) = pack msg

31−textError (NotFound ident) = "Symbol '" <> ident <> "' not found."

30+textError (NotFound ident) = "Symbol '" <> ident <> "' not found."

32−textError (ModuleNotFound ident) = "Module '" <> ident <> "' not found."

31+textError (ModuleNotFound ident) = "Module '" <> ident <> "' not found."

33−textError (ModuleFileNotFound ident) = "Extern file for module " <> ident <>" could not be found"

32+textError (ModuleFileNotFound ident) = "Extern file for module " <> ident <>" could not be found"

34−textError (ParseError parseError msg) = pack $ msg <> ": " <> show (escape parseError)

33+textError (ParseError parseError msg) = pack $ msg <> ": " <> show (escape parseError)

35− where

34+ where

36 -- escape newlines and other special chars so we can send the error over the socket as a single line

35 -- escape newlines and other special chars so we can send the error over the socket as a single line

37− escape :: P.ParseError -> String

36+ escape :: P.ParseError -> String

38− escape = show

37+ escape = show

39

38

40-- | Specialized version of `first` from `Data.Bifunctors`

39-- | Specialized version of `first` from `Data.Bifunctors`

41first :: (a -> b) -> Either a r -> Either b r

40first :: (a -> b) -> Either a r -> Either b r

src/Language/PureScript/Ide/Externs.hs+1−1

@@ -34,7 +34,7 @@ import Language.PureScript.Ide.Types

34import qualified Language.PureScript.Names as N

35import qualified Language.PureScript.Pretty as PP

36

37−readExternFile :: (Applicative m, MonadIO m, MonadError PscIdeError m) =>

37+readExternFile :: (MonadIO m, MonadError PscIdeError m) =>

38 FilePath -> m PE.ExternsFile

39readExternFile fp = do

40 parseResult <- liftIO (decodeT <$> T.readFile fp)

src/Language/PureScript/Ide/Matcher.hs+6−6

@@ -76,8 +76,8 @@ flexMatch pattern = mapMaybe (flexRate pattern)

76

77flexRate :: Text -> Completion -> Maybe ScoredCompletion

78flexRate pattern c@(Completion (_,ident,_)) = do

79− score <- flexScore pattern ident

79+ score <- flexScore pattern ident

80− return (c, score)

80+ return (c, score)

81

82-- FlexMatching ala Sublime.

83-- Borrowed from: http://cdewaka.com/2013/06/fuzzy-pattern-matching-in-haskell/

@@ -88,13 +88,13 @@ flexRate pattern c@(Completion (_,ident,_)) = do

88flexScore :: Text -> DeclIdent -> Maybe Double

89flexScore "" _ = Nothing

90flexScore pat str =

91− case TE.encodeUtf8 str =~ TE.encodeUtf8 pat' :: (Int, Int) of

91+ case TE.encodeUtf8 str =~ TE.encodeUtf8 pat' :: (Int, Int) of

92− (-1,0) -> Nothing

92+ (-1,0) -> Nothing

93− (start,len) -> Just $ calcScore start (start + len)

93+ (start,len) -> Just $ calcScore start (start + len)

94 where

95 Just (first,pattern) = T.uncons pat

96 -- This just interleaves the search string with .*

97 -- abcd -> a.*b.*c.*d

98 pat' = first `T.cons` T.concatMap (T.snoc ".*") pattern

99 calcScore start end =

100− 100.0 / fromIntegral ((1 + start) * (end - start + 1))

100+ 100.0 / fromIntegral ((1 + start) * (end - start + 1))

src/Language/PureScript/Ide/Pursuit.hs+11−11

@@ -10,9 +10,9 @@ import qualified Control.Exception as E

10import Data.Aeson

11import Data.ByteString (ByteString)

12import Data.ByteString.Lazy (fromStrict)

13−import Data.Foldable (toList)

13+import Data.Foldable (toList)

14+import Data.Maybe (mapMaybe)

14import Data.Monoid ((<>))

15import Data.Monoid ((<>))

15−import Data.Maybe (mapMaybe)

16import Data.String

17import Data.Text (Text)

18import qualified Data.Text as T

@@ -33,12 +33,12 @@ queryPursuit q = do

33 }

34 m <- newManager tlsManagerSettings

35 withHTTP req m $ \resp ->

36− P.fold (\x a -> x <> a) "" id $ responseBody resp

36+ P.fold (<>) "" id $ responseBody resp

37

38

39handler :: HttpException -> IO [a]

40−handler StatusCodeException{} = return []

40+handler StatusCodeException{} = pure []

41−handler _ = return []

41+handler _ = pure []

42

43searchPursuitForDeclarations :: Text -> IO [PursuitResponse]

44searchPursuitForDeclarations query =

@@ -54,12 +54,12 @@ searchPursuitForDeclarations query =

54

55findPackagesForModuleIdent :: Text -> IO [PursuitResponse]

56findPackagesForModuleIdent query =

57− (do r <- queryPursuit query

57+ (do r <- queryPursuit query

58− let results' = decode (fromStrict r) :: Maybe Array

58+ let results' = decode (fromStrict r) :: Maybe Array

59− case results' of

59+ case results' of

60− Nothing -> pure []

60+ Nothing -> pure []

61− Just results -> pure (mapMaybe isModuleResponse (map fromJSON (toList results)))) `E.catch`

61+ Just results -> pure (mapMaybe isModuleResponse (map fromJSON (toList results)))) `E.catch`

62− handler

62+ handler

63 where

64 isModuleResponse (Success a@ModuleResponse{}) = Just a

65 isModuleResponse _ = Nothing

src/Language/PureScript/Ide/Reexports.hs+21−19

@@ -15,10 +15,10 @@ import Language.PureScript.Ide.Types

15

16getReexports :: Module -> [ExternDecl]

17getReexports (mn, decls)= concatMap getExport decls

18− where getExport d

18+ where getExport d

19− | (Export mn') <- d

19+ | (Export mn') <- d

20− , mn /= mn' = replaceExportWithAliases decls mn'

20+ , mn /= mn' = replaceExportWithAliases decls mn'

21− | otherwise = []

21+ | otherwise = []

22

23dependencyToExport :: ExternDecl -> ExternDecl

24dependencyToExport (Dependency m _ _) = Export m

@@ -51,23 +51,25 @@ removeExportDecls = fmap (filter (not . isExport))

51

52replaceReexports :: Module -> Map ModuleIdent [ExternDecl] -> Module

53replaceReexports m db = result

54+ where

54− where reexports = getReexports m

55+ reexports = getReexports m

55− result = foldl go (removeExportDecls m) reexports

56+ result = foldl go (removeExportDecls m) reexports

56

57

57− go :: Module -> ExternDecl -> Module

58+ go :: Module -> ExternDecl -> Module

58− go m' re@(Export name) = replaceReexport re m' (getModule name)

59+ go m' re@(Export name) = replaceReexport re m' (getModule name)

59− go _ _ = error "partiality! woohoo"

60+ go _ _ = error "partiality! woohoo"

60

61

61− getModule :: ModuleIdent -> Module

62+ getModule :: ModuleIdent -> Module

62− getModule name = clean res

63+ getModule name = clean res

64+ where

63− where res = fromMaybe emptyModule $ (name , ) <$> Map.lookup name db

65+ res = fromMaybe emptyModule $ (name , ) <$> Map.lookup name db

64− -- we have to do this because keeping self exports in will result in

66+ -- we have to do this because keeping self exports in will result in

65− -- infinite loops

67+ -- infinite loops

66− clean (mn, decls) = (mn,) (filter (/= Export mn) decls)

68+ clean (mn, decls) = (mn,) (filter (/= Export mn) decls)

67

69

68resolveReexports :: Map ModuleIdent [ExternDecl] -> Module -> Module

70resolveReexports :: Map ModuleIdent [ExternDecl] -> Module -> Module

69−resolveReexports modules m = do

71+resolveReexports modules m =

70 let replaced = replaceReexports m modules

72 let replaced = replaceReexports m modules

71− if null . getReexports $ replaced

73+ in if null (getReexports replaced)

72− then replaced

74+ then replaced

73− else resolveReexports modules replaced

75+ else resolveReexports modules replaced

src/Language/PureScript/Ide/SourceFile.hs+40−40

@@ -3,8 +3,7 @@

3{-# LANGUAGE OverloadedStrings #-}

4module Language.PureScript.Ide.SourceFile where

5

6−import Prelude ()

6+import Prelude

7−import Prelude.Compat

8

7

9import Control.Monad.Error.Class

8import Control.Monad.Error.Class

10import Control.Monad.IO.Class

9import Control.Monad.IO.Class

@@ -22,7 +21,7 @@ import qualified Language.PureScript.Names as N

22import qualified Language.PureScript.Parser as P

21import qualified Language.PureScript.Parser as P

23import System.Directory

22import System.Directory

24

23

25−parseModuleFromFile :: (Applicative m, MonadIO m, MonadError PscIdeError m) =>

24+parseModuleFromFile :: (MonadIO m, MonadError PscIdeError m) =>

26 FilePath -> m D.Module

25 FilePath -> m D.Module

27parseModuleFromFile fp = do

26parseModuleFromFile fp = do

28 exists <- liftIO (doesFileExist fp)

27 exists <- liftIO (doesFileExist fp)

@@ -46,24 +45,25 @@ getImports (D.Module _ _ _ declarations _) =

46 isImport (D.PositionedDeclaration _ _ (i@D.ImportDeclaration{})) = Just i

45 isImport (D.PositionedDeclaration _ _ (i@D.ImportDeclaration{})) = Just i

47 isImport _ = Nothing

46 isImport _ = Nothing

48

47

49−getImportsForFile :: (Applicative m, MonadIO m, MonadError PscIdeError m) =>

48+getImportsForFile :: (MonadIO m, MonadError PscIdeError m) =>

50 FilePath -> m [ModuleImport]

49 FilePath -> m [ModuleImport]

51getImportsForFile fp = do

50getImportsForFile fp = do

52 module' <- parseModuleFromFile fp

51 module' <- parseModuleFromFile fp

53 let imports = getImports module'

52 let imports = getImports module'

54 pure (mkModuleImport . unwrapPositionedImport <$> imports)

53 pure (mkModuleImport . unwrapPositionedImport <$> imports)

54+ where

55− where mkModuleImport (D.ImportDeclaration mn importType' qualifier _) =

55+ mkModuleImport (D.ImportDeclaration mn importType' qualifier _) =

56− ModuleImport

56+ ModuleImport

57− (T.pack (N.runModuleName mn))

57+ (T.pack (N.runModuleName mn))

58− importType'

58+ importType'

59− (T.pack . N.runModuleName <$> qualifier)

59+ (T.pack . N.runModuleName <$> qualifier)

60− mkModuleImport _ = error "Shouldn't have gotten anything but Imports here"

60+ mkModuleImport _ = error "Shouldn't have gotten anything but Imports here"

61− unwrapPositionedImport (D.ImportDeclaration mn importType' qualifier b) =

61+ unwrapPositionedImport (D.ImportDeclaration mn importType' qualifier b) =

62− D.ImportDeclaration mn (unwrapImportType importType') qualifier b

62+ D.ImportDeclaration mn (unwrapImportType importType') qualifier b

63− unwrapPositionedImport x = x

63+ unwrapPositionedImport x = x

64− unwrapImportType (D.Explicit decls) = D.Explicit (map unwrapPositionedRef decls)

64+ unwrapImportType (D.Explicit decls) = D.Explicit (map unwrapPositionedRef decls)

65− unwrapImportType (D.Hiding decls) = D.Hiding (map unwrapPositionedRef decls)

65+ unwrapImportType (D.Hiding decls) = D.Hiding (map unwrapPositionedRef decls)

66− unwrapImportType D.Implicit = D.Implicit

66+ unwrapImportType D.Implicit = D.Implicit

67

68getPositionedImports :: D.Module -> [D.Declaration]

69getPositionedImports (D.Module _ _ _ declarations _) =

@@ -73,34 +73,34 @@ getPositionedImports (D.Module _ _ _ declarations _) =

73 isImport _ = Nothing

74

75getDeclPosition :: D.Module -> String -> Maybe SP.SourceSpan

76−getDeclPosition m ident =

77− let decls = getDeclarations m

78− in getFirst (foldMap (match ident) decls)

76+getDeclPosition m ident = getFirst (foldMap (match ident) decls)

77+ where

78+ decls = getDeclarations m

79− where match q (D.PositionedDeclaration ss _ decl) = First (if go q decl

79+ match q (D.PositionedDeclaration ss _ decl) = First (if go q decl

80− then Just ss

80+ then Just ss

81− else Nothing)

81+ else Nothing)

82− match _ _ = First Nothing

82+ match _ _ = First Nothing

83

84− go q (D.DataDeclaration _ name _ constructors) =

84+ go q (D.DataDeclaration _ name _ constructors) =

85− properEqual name q || any (\(x,_) -> properEqual x q) constructors

85+ properEqual name q || any (\(x,_) -> properEqual x q) constructors

86− go q (D.DataBindingGroupDeclaration decls) = any (go q) decls

86+ go q (D.DataBindingGroupDeclaration decls') = any (go q) decls'

87− go q (D.TypeSynonymDeclaration name _ _) = properEqual name q

87+ go q (D.TypeSynonymDeclaration name _ _) = properEqual name q

88− go q (D.TypeDeclaration ident' _) = identEqual ident' q

88+ go q (D.TypeDeclaration ident' _) = identEqual ident' q

89− go q (D.ValueDeclaration ident' _ _ _) = identEqual ident' q

89+ go q (D.ValueDeclaration ident' _ _ _) = identEqual ident' q

90− go q (D.ExternDeclaration ident' _) = identEqual ident' q

90+ go q (D.ExternDeclaration ident' _) = identEqual ident' q

91− go q (D.ExternDataDeclaration name _) = properEqual name q

91+ go q (D.ExternDataDeclaration name _) = properEqual name q

92− go q (D.TypeClassDeclaration name _ _ members) =

92+ go q (D.TypeClassDeclaration name _ _ members) =

93− properEqual name q || any (go q . unwrapPositioned) members

93+ properEqual name q || any (go q . unwrapPositioned) members

94− go q (D.TypeInstanceDeclaration ident' _ _ _ _) =

94+ go q (D.TypeInstanceDeclaration ident' _ _ _ _) =

95− identEqual ident' q

95+ identEqual ident' q

96− go _ _ = False

96+ go _ _ = False

97

98− properEqual x q = N.runProperName x == q

98+ properEqual x q = N.runProperName x == q

99− identEqual x q = N.runIdent x == q

99+ identEqual x q = N.runIdent x == q

100

101goToDefinition :: String -> FilePath -> IO (Maybe SP.SourceSpan)

102goToDefinition q fp = do

103 m <- runExceptT (parseModuleFromFile fp)

104 case m of

105− Right module' -> return $ getDeclPosition module' q

105+ Right module' -> pure (getDeclPosition module' q)

106− Left _ -> return Nothing

106+ Left _ -> pure Nothing

src/Language/PureScript/Ide/State.hs+10−10

@@ -25,38 +25,38 @@ import Language.PureScript.Ide.Reexports

25import Language.PureScript.Ide.Types

26import Language.PureScript.Names

27

28−getPscIdeState :: (PscIde m, Functor m) =>

28+getPscIdeState :: (PscIde m) =>

29 m (M.Map ModuleIdent [ExternDecl])

30getPscIdeState = do

31 stateVar <- envStateVar <$> ask

32 liftIO $ pscStateModules <$> readTVarIO stateVar

33

34−getExternFiles :: (PscIde m, Functor m) =>

34+getExternFiles :: (PscIde m) =>

35 m (M.Map ModuleName ExternsFile)

36getExternFiles = do

37 stateVar <- envStateVar <$> ask

38 liftIO (externsFiles <$> readTVarIO stateVar)

39

40−getAllDecls :: (PscIde m, Functor m) => m [ExternDecl]

40+getAllDecls :: (PscIde m) => m [ExternDecl]

41getAllDecls = concat <$> getPscIdeState

42

43−getAllModules :: (PscIde m, Functor m) => m [Module]

43+getAllModules :: (PscIde m) => m [Module]

44getAllModules = M.toList <$> getPscIdeState

45

46−getAllModulesWithReexports :: (PscIde m, MonadLogger m, Applicative m) =>

46+getAllModulesWithReexports :: (PscIde m, MonadLogger m) =>

47 m [Module]

48getAllModulesWithReexports = do

49 mis <- M.keys <$> getPscIdeState

50 ms <- traverse getModuleWithReexports mis

51 pure (catMaybes ms)

52

53−getModule :: (PscIde m, MonadLogger m, Applicative m) =>

53+getModule :: (PscIde m, MonadLogger m) =>

54 ModuleIdent -> m (Maybe Module)

55getModule m = do

56 modules <- getPscIdeState

57 pure ((m,) <$> M.lookup m modules)

58

59−getModuleWithReexports :: (PscIde m, MonadLogger m, Applicative m) =>

59+getModuleWithReexports :: (PscIde m, MonadLogger m) =>

60 ModuleIdent -> m (Maybe Module)

61getModuleWithReexports mi = do

62 m <- getModule mi

@@ -73,8 +73,8 @@ insertModule externsFile = do

73

74insertModule' :: TVar PscIdeState -> ExternsFile -> STM ()

75insertModule' st ef = do

76− modifyTVar (st) $ \x ->

76+ modifyTVar st $ \x ->

77 x { externsFiles = M.insert (efModuleName ef) ef (externsFiles x)

78− , pscStateModules = let (mn, decls ) = convertExterns ef

78+ , pscStateModules = let (mn, decls) = convertExterns ef

79− in M.insert mn decls (pscStateModules x)

79+ in M.insert mn decls (pscStateModules x)

80 }

src/Language/PureScript/Ide/Types.hs+76−78

@@ -33,21 +33,26 @@ type Type = Text

33data Fixity = Infix | Infixl | Infixr deriving(Show, Eq, Ord)

34

35data ExternDecl

36+ -- | A function/value declaration

36− = FunctionDecl { functionName :: DeclIdent

37+ = FunctionDecl

37− , functionType :: Type

38+ DeclIdent -- The functions name

38− }

39+ Type -- The functions type

39− | FixityDeclaration Fixity

40+ | FixityDeclaration Fixity Int DeclIdent

40− Int

41+ -- | A Dependency onto another Module

41− DeclIdent

42+ | Dependency

42− | Dependency { dependencyModule :: ModuleIdent

43+ ModuleIdent -- name of the dependency

43− , dependencyNames :: [Text]

44+ [Text] -- explicit imports

44− , dependencyAlias :: Maybe Text

45+ (Maybe Text) -- An eventual qualifier

45− }

46+

47+ -- | A module declaration

46− | ModuleDecl ModuleIdent

48+ | ModuleDecl

49+ ModuleIdent -- The modules name

47− [DeclIdent]

50+ [DeclIdent] -- The exported identifiers

51+ -- | A data/newtype declaration

48− | DataDecl DeclIdent

52+ | DataDecl DeclIdent -- The type name

49− Text

53+ Text -- The "type"

54+ -- | An exported module

50− | Export ModuleIdent

55+ | Export ModuleIdent -- The exported Modules name

51 deriving (Show,Eq,Ord)

56 deriving (Show,Eq,Ord)

52

57

53instance ToJSON ExternDecl where

58instance ToJSON ExternDecl where

@@ -63,22 +68,22 @@ instance ToJSON ExternDecl where

63type Module = (ModuleIdent, [ExternDecl])

68type Module = (ModuleIdent, [ExternDecl])

64

69

65data Configuration =

70data Configuration =

66− Configuration {

71+ Configuration

67− confOutputPath :: FilePath

72+ { confOutputPath :: FilePath

68 , confDebug :: Bool

73 , confDebug :: Bool

69 }

74 }

70

75

71data PscIdeEnvironment =

76data PscIdeEnvironment =

72− PscIdeEnvironment {

77+ PscIdeEnvironment

73− envStateVar :: TVar PscIdeState

78+ { envStateVar :: TVar PscIdeState

74 , envConfiguration :: Configuration

79 , envConfiguration :: Configuration

75 }

80 }

76

81

77−type PscIde m = (Applicative m, MonadIO m, MonadReader PscIdeEnvironment m)

82+type PscIde m = (MonadIO m, MonadReader PscIdeEnvironment m)

78

83

79data PscIdeState =

84data PscIdeState =

80− PscIdeState {

85+ PscIdeState

81− pscStateModules :: M.Map Text [ExternDecl]

86+ { pscStateModules :: M.Map Text [ExternDecl]

82 , externsFiles :: M.Map ModuleName ExternsFile

87 , externsFiles :: M.Map ModuleName ExternsFile

83 } deriving Show

88 } deriving Show

84

89

@@ -90,29 +95,32 @@ newtype Completion =

90 deriving (Show,Eq)

95 deriving (Show,Eq)

91

96

92data ModuleImport =

97data ModuleImport =

93− ModuleImport {

98+ ModuleImport

94− importModuleName :: ModuleIdent

99+ { importModuleName :: ModuleIdent

95 , importType :: D.ImportDeclarationType

100 , importType :: D.ImportDeclarationType

96 , importQualifier :: Maybe Text

101 , importQualifier :: Maybe Text

97 } deriving(Show)

102 } deriving(Show)

98

103

99instance Eq ModuleImport where

104instance Eq ModuleImport where

105+ mi1 == mi2 =

100− mi1 == mi2 = importModuleName mi1 == importModuleName mi2

106+ importModuleName mi1 == importModuleName mi2

101− && importQualifier mi1 == importQualifier mi2

107+ && importQualifier mi1 == importQualifier mi2

102

108

103instance ToJSON ModuleImport where

109instance ToJSON ModuleImport where

104 toJSON (ModuleImport mn D.Implicit qualifier) =

110 toJSON (ModuleImport mn D.Implicit qualifier) =

105− object $ ["module" .= mn

111+ object $ [ "module" .= mn

106− , "importType" .= ("implicit" :: Text)

112+ , "importType" .= ("implicit" :: Text)

107− ] ++ fmap (\x -> "qualifier" .= x) (maybeToList qualifier)

113+ ] ++ fmap (\x -> "qualifier" .= x) (maybeToList qualifier)

108 toJSON (ModuleImport mn (D.Explicit refs) _) =

114 toJSON (ModuleImport mn (D.Explicit refs) _) =

109− object ["module" .= mn

115+ object [ "module" .= mn

110 , "importType" .= ("explicit" :: Text)

116 , "importType" .= ("explicit" :: Text)

111− , "identifiers" .= (identifierFromDeclarationRef <$> refs)]

117+ , "identifiers" .= (identifierFromDeclarationRef <$> refs)

118+ ]

112 toJSON (ModuleImport mn (D.Hiding refs) _) =

119 toJSON (ModuleImport mn (D.Hiding refs) _) =

113− object ["module" .= mn

120+ object [ "module" .= mn

114 , "importType" .= ("hiding" :: Text)

121 , "importType" .= ("hiding" :: Text)

115− , "identifiers" .= (identifierFromDeclarationRef <$> refs)]

122+ , "identifiers" .= (identifierFromDeclarationRef <$> refs)

123+ ]

116

124

117identifierFromDeclarationRef :: D.DeclarationRef -> String

125identifierFromDeclarationRef :: D.DeclarationRef -> String

118identifierFromDeclarationRef (D.TypeRef name _) = N.runProperName name

126identifierFromDeclarationRef (D.TypeRef name _) = N.runProperName name

@@ -121,16 +129,16 @@ identifierFromDeclarationRef (D.TypeClassRef name) = N.runProperName name

121identifierFromDeclarationRef _ = ""

129identifierFromDeclarationRef _ = ""

122

130

123instance FromJSON Completion where

131instance FromJSON Completion where

124− parseJSON (Object o) = do

132+ parseJSON (Object o) = do

125− m <- o .: "module"

133+ m <- o .: "module"

126− d <- o .: "identifier"

134+ d <- o .: "identifier"

127− t <- o .: "type"

135+ t <- o .: "type"

128− return $ Completion (m, d, t)

136+ pure (Completion (m, d, t))

129− parseJSON _ = mzero

137+ parseJSON _ = mzero

130

138

131instance ToJSON Completion where

139instance ToJSON Completion where

132− toJSON (Completion (m,d,t)) =

140+ toJSON (Completion (m,d,t)) =

133− object ["module" .= m, "identifier" .= d, "type" .= t]

141+ object ["module" .= m, "identifier" .= d, "type" .= t]

134

142

135data Success =

143data Success =

136 CompletionResult [Completion]

144 CompletionResult [Completion]

@@ -161,23 +169,22 @@ data PursuitSearchType = Package | Identifier

161

169

162instance FromJSON PursuitSearchType where

170instance FromJSON PursuitSearchType where

163 parseJSON (String t) = case t of

171 parseJSON (String t) = case t of

164− "package" -> return Package

172+ "package" -> pure Package

165− "completion" -> return Identifier

173+ "completion" -> pure Identifier

166 _ -> mzero

174 _ -> mzero

167 parseJSON _ = mzero

175 parseJSON _ = mzero

168

176

169instance FromJSON PursuitQuery where

177instance FromJSON PursuitQuery where

170− parseJSON o = fmap PursuitQuery (parseJSON o)

178+ parseJSON o = PursuitQuery <$> (parseJSON o)

171−

179+

172−data PursuitResponse

180+data PursuitResponse =

181+ -- | A Pursuit Response for a module. Consists of the modules name and the

182+ -- package it belongs to

173− = ModuleResponse { moduleResponseName :: Text

183+ ModuleResponse ModuleIdent Text

174− , moduleResponsePackage :: Text}

184+ -- | A Pursuit Response for a declaration. Consist of the declarations type,

185+ -- module, name and package

175− | DeclarationResponse { declarationResponseType :: Text

186+ | DeclarationResponse Type ModuleIdent DeclIdent Text

176− , declarationResponseModule :: Text

177− , declarationResponseIdent :: Text

178− , declarationResponsePackage :: Text

179− }

180− deriving (Show,Eq)

187+ deriving (Show,Eq)

181

188

182instance FromJSON PursuitResponse where

189instance FromJSON PursuitResponse where

183 parseJSON (Object o) = do

190 parseJSON (Object o) = do

@@ -186,22 +193,12 @@ instance FromJSON PursuitResponse where

186 (type' :: String) <- info .: "type"

193 (type' :: String) <- info .: "type"

187 case type' of

194 case type' of

188 "module" -> do

195 "module" -> do

189− name <- info .: "module"

196+ name <- info .: "module"

190− return

191− ModuleResponse

197+ pure (ModuleResponse name package)

192− { moduleResponseName = name

193− , moduleResponsePackage = package

194− }

195 "declaration" -> do

198 "declaration" -> do

196− moduleName <- info .: "module"

199+ moduleName <- info .: "module"

197− Right (ident, declType) <- typeParse <$> o .: "text"

200+ Right (ident, declType) <- typeParse <$> o .: "text"

198− return

199− DeclarationResponse

201+ pure (DeclarationResponse declType moduleName ident package)

200− { declarationResponseType = declType

201− , declarationResponseModule = moduleName

202− , declarationResponseIdent = ident

203− , declarationResponsePackage = package

204− }

205 _ -> mzero

202 _ -> mzero

206 parseJSON _ = mzero

203 parseJSON _ = mzero

207

204

@@ -217,7 +214,7 @@ typeParse t = case parse parseType "" t of

217 _ <- string "::"

214 _ <- string "::"

218 spaces

215 spaces

219 type' <- many1 anyChar

216 type' <- many1 anyChar

220− return (unpack name, type')

217+ pure (unpack name, type')

221

218

222identifier :: Parser Text

219identifier :: Parser Text

223identifier = do

220identifier = do

@@ -227,14 +224,15 @@ identifier = do

227 between (char '(') (char ')') (many1 (noneOf ", )")) <|>

224 between (char '(') (char ')') (many1 (noneOf ", )")) <|>

228 many1 (noneOf ", )")

225 many1 (noneOf ", )")

229 spaces

226 spaces

230− return (pack ident)

227+ pure (pack ident)

231

228

232instance ToJSON PursuitResponse where

229instance ToJSON PursuitResponse where

233− toJSON ModuleResponse{..} =

230+ toJSON (ModuleResponse name package) =

234− object ["module" .= moduleResponseName, "package" .= moduleResponsePackage]

231+ object ["module" .= name, "package" .= package]

235− toJSON DeclarationResponse{..} =

232+ toJSON (DeclarationResponse module' ident type' package) =

236 object

233 object

237− [ "module" .= declarationResponseModule

234+ [ "module" .= module'

238− , "ident" .= declarationResponseIdent

235+ , "ident" .= ident

239− , "type" .= declarationResponseType

236+ , "type" .= type'

240− , "package" .= declarationResponsePackage]

237+ , "package" .= package

238+ ]

src/Language/PureScript/Kinds.hs+1−1

@@ -42,7 +42,7 @@ everywhereOnKinds f = go

42 go (FunKind k1 k2) = f (FunKind (go k1) (go k2))

43 go other = f other

44

45−everywhereOnKindsM :: (Functor m, Applicative m, Monad m) => (Kind -> m Kind) -> Kind -> m Kind

45+everywhereOnKindsM :: Monad m => (Kind -> m Kind) -> Kind -> m Kind

46everywhereOnKindsM f = go

47 where

48 go (Row k1) = (Row <$> go k1) >>= f

src/Language/PureScript/Linter.hs+1−1

@@ -29,7 +29,7 @@ import Language.PureScript.Linter.Imports as L

29-- | Lint the PureScript AST.

30-- |

31-- | Right now, this pass only performs a shadowing check.

32−lint :: forall m. (Applicative m, MonadWriter MultipleErrors m) => Module -> m ()

32+lint :: forall m. (MonadWriter MultipleErrors m) => Module -> m ()

33lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDeclaration ds

34 where

35 moduleNames :: S.Set Ident

src/Language/PureScript/Linter/Exhaustive.hs+17−14

@@ -24,6 +24,7 @@ import Control.Monad.Writer.Class

24

25import Language.PureScript.Crash

26import Language.PureScript.AST.Binders

27+import Language.PureScript.AST.Literals

27import Language.PureScript.AST.Declarations

28import Language.PureScript.AST.Declarations

28import Language.PureScript.Environment

29import Language.PureScript.Environment

29import Language.PureScript.Names as P

30import Language.PureScript.Names as P

@@ -119,12 +120,12 @@ missingCasesSingle env mn NullBinder cb@(ConstructorBinder con _) =

119missingCasesSingle env mn cb@(ConstructorBinder con bs) (ConstructorBinder con' bs')

120missingCasesSingle env mn cb@(ConstructorBinder con bs) (ConstructorBinder con' bs')

120 | con == con' = let (bs'', pr) = missingCasesMultiple env mn bs bs' in (map (ConstructorBinder con) bs'', pr)

121 | con == con' = let (bs'', pr) = missingCasesMultiple env mn bs bs' in (map (ConstructorBinder con) bs'', pr)

121 | otherwise = ([cb], return False)

122 | otherwise = ([cb], return False)

122−missingCasesSingle env mn NullBinder (ObjectBinder bs) =

123+missingCasesSingle env mn NullBinder (LiteralBinder (ObjectLiteral bs)) =

123− (map (ObjectBinder . zip (map fst bs)) allMisses, pr)

124+ (map (LiteralBinder . ObjectLiteral . zip (map fst bs)) allMisses, pr)

124 where

125 where

125 (allMisses, pr) = missingCasesMultiple env mn (initialize $ length bs) (map snd bs)

126 (allMisses, pr) = missingCasesMultiple env mn (initialize $ length bs) (map snd bs)

126−missingCasesSingle env mn (ObjectBinder bs) (ObjectBinder bs') =

127+missingCasesSingle env mn (LiteralBinder (ObjectLiteral bs)) (LiteralBinder (ObjectLiteral bs')) =

127− (map (ObjectBinder . zip sortedNames) allMisses, pr)

128+ (map (LiteralBinder . ObjectLiteral . zip sortedNames) allMisses, pr)

128 where

129 where

129 (allMisses, pr) = uncurry (missingCasesMultiple env mn) (unzip binders)

130 (allMisses, pr) = uncurry (missingCasesMultiple env mn) (unzip binders)

130

131

@@ -141,10 +142,10 @@ missingCasesSingle env mn (ObjectBinder bs) (ObjectBinder bs') =

141 compBS e s b b' = (s, compB e b b')

142 compBS e s b b' = (s, compB e b b')

142

143

143 (sortedNames, binders) = unzip $ genericMerge (compBS NullBinder) sbs sbs'

144 (sortedNames, binders) = unzip $ genericMerge (compBS NullBinder) sbs sbs'

144−missingCasesSingle _ _ NullBinder (BooleanBinder b) = ([BooleanBinder $ not b], return True)

145+missingCasesSingle _ _ NullBinder (LiteralBinder (BooleanLiteral b)) = ([LiteralBinder . BooleanLiteral $ not b], return True)

145−missingCasesSingle _ _ (BooleanBinder bl) (BooleanBinder br)

146+missingCasesSingle _ _ (LiteralBinder (BooleanLiteral bl)) (LiteralBinder (BooleanLiteral br))

146 | bl == br = ([], return True)

147 | bl == br = ([], return True)

147− | otherwise = ([BooleanBinder bl], return False)

148+ | otherwise = ([LiteralBinder $ BooleanLiteral bl], return False)

148missingCasesSingle env mn b (PositionedBinder _ _ cb) = missingCasesSingle env mn b cb

149missingCasesSingle env mn b (PositionedBinder _ _ cb) = missingCasesSingle env mn b cb

149missingCasesSingle env mn b (TypedBinder _ cb) = missingCasesSingle env mn b cb

150missingCasesSingle env mn b (TypedBinder _ cb) = missingCasesSingle env mn b cb

150missingCasesSingle _ _ b _ = ([b], Left Unknown)

151missingCasesSingle _ _ b _ = ([b], Left Unknown)

@@ -201,9 +202,11 @@ isExhaustiveGuard :: Either [(Guard, Expr)] Expr -> Bool

201isExhaustiveGuard (Left gs) = not . null $ filter (\(g, _) -> isOtherwise g) gs

202isExhaustiveGuard (Left gs) = not . null $ filter (\(g, _) -> isOtherwise g) gs

202 where

203 where

203 isOtherwise :: Expr -> Bool

204 isOtherwise :: Expr -> Bool

204− isOtherwise (TypedValue _ (BooleanLiteral True) _) = True

205+ isOtherwise (Literal (BooleanLiteral True)) = True

205− isOtherwise (TypedValue _ (Var (Qualified (Just (ModuleName [ProperName "Prelude"])) (Ident "otherwise"))) _) = True

206+ isOtherwise (Var (Qualified (Just (ModuleName [ProperName "Prelude"])) (Ident "otherwise"))) = True

206− isOtherwise (TypedValue _ (Var (Qualified (Just (ModuleName [ProperName "Data", ProperName "Boolean"])) (Ident "otherwise"))) _) = True

207+ isOtherwise (Var (Qualified (Just (ModuleName [ProperName "Data", ProperName "Boolean"])) (Ident "otherwise"))) = True

208+ isOtherwise (TypedValue _ e _) = isOtherwise e

209+ isOtherwise (PositionedValue _ _ e) = isOtherwise e

207 isOtherwise _ = False

210 isOtherwise _ = False

208isExhaustiveGuard (Right _) = True

211isExhaustiveGuard (Right _) = True

209

212

@@ -258,7 +261,7 @@ checkExhaustive hasConstraint env mn numArgs cas = makeResult . first nub $ fold

258-- |

261-- |

259-- Exhaustivity checking over a list of declarations

262-- Exhaustivity checking over a list of declarations

260--

263--

261−checkExhaustiveDecls :: forall m. (Applicative m, MonadWriter MultipleErrors m) => Environment -> ModuleName -> [Declaration] -> m ()

264+checkExhaustiveDecls :: forall m. MonadWriter MultipleErrors m => Environment -> ModuleName -> [Declaration] -> m ()

262checkExhaustiveDecls env mn = mapM_ onDecl

265checkExhaustiveDecls env mn = mapM_ onDecl

263 where

266 where

264 onDecl :: Declaration -> m ()

267 onDecl :: Declaration -> m ()

@@ -272,8 +275,8 @@ checkExhaustiveDecls env mn = mapM_ onDecl

272

275

273 onExpr :: Bool -> Expr -> m ()

276 onExpr :: Bool -> Expr -> m ()

274 onExpr isP (UnaryMinus e) = onExpr isP e

277 onExpr isP (UnaryMinus e) = onExpr isP e

275− onExpr isP (ArrayLiteral es) = mapM_ (onExpr isP) es

278+ onExpr isP (Literal (ArrayLiteral es)) = mapM_ (onExpr isP) es

276− onExpr isP (ObjectLiteral es) = mapM_ (onExpr isP . snd) es

279+ onExpr isP (Literal (ObjectLiteral es)) = mapM_ (onExpr isP . snd) es

277 onExpr isP (TypeClassDictionaryConstructorApp _ e) = onExpr isP e

280 onExpr isP (TypeClassDictionaryConstructorApp _ e) = onExpr isP e

278 onExpr isP (Accessor _ e) = onExpr isP e

281 onExpr isP (Accessor _ e) = onExpr isP e

279 onExpr isP (ObjectUpdate o es) = onExpr isP o >> mapM_ (onExpr isP . snd) es

282 onExpr isP (ObjectUpdate o es) = onExpr isP o >> mapM_ (onExpr isP . snd) es

@@ -307,5 +310,5 @@ checkExhaustiveDecls env mn = mapM_ onDecl

307-- |

310-- |

308-- Exhaustivity checking over a single module

311-- Exhaustivity checking over a single module

309--

312--

310−checkExhaustiveModule :: forall m. (Applicative m, MonadWriter MultipleErrors m) => Environment -> Module -> m ()

313+checkExhaustiveModule :: forall m. MonadWriter MultipleErrors m => Environment -> Module -> m ()

311checkExhaustiveModule env (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ checkExhaustiveDecls env mn ds

314checkExhaustiveModule env (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ checkExhaustiveDecls env mn ds

src/Language/PureScript/Linter/Imports.hs+9−8

@@ -70,7 +70,7 @@ type UsedImports = M.Map ModuleName [Name]

70--

71lintImports

72 :: forall m

73− . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

73+ . (MonadError MultipleErrors m, MonadWriter MultipleErrors m)

74 => Module

75 -> Env

76 -> UsedImports

@@ -79,8 +79,8 @@ lintImports (Module _ _ mn mdecls mexports) env usedImps = do

79

80 let scope = maybe nullImports (\(_, imps, _) -> imps) (M.lookup mn env)

81 usedImps' = foldr (elaborateUsed scope) usedImps exportedModules

82− numImplicitImports = getSum $ foldMap (Sum . countImplicitImports) mdecls

82+ numOpenImports = getSum $ foldMap (Sum . countOpenImports) mdecls

83− allowImplicit = numImplicitImports == 1

83+ allowImplicit = numOpenImports == 1

84

85 imps <- M.toAscList <$> findImports mdecls

86

@@ -106,10 +106,11 @@ lintImports (Module _ _ mn mdecls mexports) env usedImps = do

106

107 where

108

109− countImplicitImports :: Declaration -> Int

109+ countOpenImports :: Declaration -> Int

110− countImplicitImports (ImportDeclaration mn' Implicit _ _) | not (isPrim mn') = 1

110+ countOpenImports (ImportDeclaration mn' Implicit Nothing _) | not (isPrim mn') = 1

111+ countOpenImports (ImportDeclaration mn' (Hiding _) Nothing _) | not (isPrim mn') = 1

111− countImplicitImports (PositionedDeclaration _ _ d) = countImplicitImports d

112+ countOpenImports (PositionedDeclaration _ _ d) = countOpenImports d

112− countImplicitImports _ = 0

113+ countOpenImports _ = 0

113

114

114 -- Checks whether a module is the Prim module - used to suppress any checks

115 -- Checks whether a module is the Prim module - used to suppress any checks

115 -- made, as Prim is always implicitly imported.

116 -- made, as Prim is always implicitly imported.

@@ -169,7 +170,7 @@ lintImports (Module _ _ mn mdecls mexports) env usedImps = do

169

170

170lintImportDecl

171lintImportDecl

171 :: forall m

172 :: forall m

172− . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

173+ . (MonadError MultipleErrors m, MonadWriter MultipleErrors m)

173 => Env

174 => Env

174 -> ModuleName

175 -> ModuleName

175 -> Maybe ModuleName

176 -> Maybe ModuleName

src/Language/PureScript/Make.hs+4−1

@@ -145,11 +145,14 @@ data RebuildPolicy

145-- If timestamps have not changed, the externs file can be used to provide the module's types without

146-- having to typecheck the module again.

147--

148−make :: forall m. (Functor m, Applicative m, Monad m, MonadBaseControl IO m, MonadReader Options m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

148+make :: forall m. (Monad m, MonadBaseControl IO m, MonadReader Options m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

149 => MakeActions m

150 -> [Module]

151 -> m Environment

152make MakeActions{..} ms = do

153+ requirePath <- asks optionsRequirePath

154+ when (requirePath /= Nothing) $ tell $ errorMessage DeprecatedRequirePath

155+

153 checkModuleNamesAreUnique

156 checkModuleNamesAreUnique

154

157

155 (sorted, graph) <- sortModules ms

158 (sorted, graph) <- sortModules ms

src/Language/PureScript/Parser/Declarations.hs+28−37

@@ -260,7 +260,7 @@ parseModule = do

260 return $ Module ss comments name decls exports

261

262-- | Parse a collection of modules in parallel

263−parseModulesFromFiles :: forall m k. (MonadError MultipleErrors m, Functor m) =>

263+parseModulesFromFiles :: forall m k. (MonadError MultipleErrors m) =>

264 (k -> FilePath) -> [(k, String)] -> m [(k, Module)]

265parseModulesFromFiles toFilePath input = do

266 modules <- flip parU id $ map wrapError $ inParallel $ flip map input $ \(k, content) -> do

@@ -299,23 +299,23 @@ parseModules = mark (P.many (same *> parseModule)) <* P.eof

299booleanLiteral :: TokenParser Bool

300booleanLiteral = (reserved "true" >> return True) P.<|> (reserved "false" >> return False)

301

302−parseNumericLiteral :: TokenParser Expr

302+parseNumericLiteral :: TokenParser (Literal a)

303parseNumericLiteral = NumericLiteral <$> number

304

305−parseCharLiteral :: TokenParser Expr

305+parseCharLiteral :: TokenParser (Literal a)

306parseCharLiteral = CharLiteral <$> charLiteral

307

308−parseStringLiteral :: TokenParser Expr

308+parseStringLiteral :: TokenParser (Literal a)

309parseStringLiteral = StringLiteral <$> stringLiteral

310

311−parseBooleanLiteral :: TokenParser Expr

311+parseBooleanLiteral :: TokenParser (Literal a)

312parseBooleanLiteral = BooleanLiteral <$> booleanLiteral

313

314−parseArrayLiteral :: TokenParser Expr

314+parseArrayLiteral :: TokenParser a -> TokenParser (Literal a)

315−parseArrayLiteral = ArrayLiteral <$> squares (commaSep parseValue)

315+parseArrayLiteral p = ArrayLiteral <$> squares (commaSep p)

316

317−parseObjectLiteral :: TokenParser Expr

317+parseObjectLiteral :: TokenParser (String, a) -> TokenParser (Literal a)

318−parseObjectLiteral = ObjectLiteral <$> braces (commaSep parseIdentifierAndValue)

318+parseObjectLiteral p = ObjectLiteral <$> braces (commaSep p)

319

320parseIdentifierAndValue :: TokenParser (String, Expr)

321parseIdentifierAndValue =

@@ -376,12 +376,12 @@ parseLet = do

376parseValueAtom :: TokenParser Expr

377parseValueAtom = P.choice

378 [ parseAnonymousArgument

379− , parseNumericLiteral

379+ , Literal <$> parseNumericLiteral

380− , parseCharLiteral

380+ , Literal <$> parseCharLiteral

381− , parseStringLiteral

381+ , Literal <$> parseStringLiteral

382− , parseBooleanLiteral

382+ , Literal <$> parseBooleanLiteral

383− , parseArrayLiteral

383+ , Literal <$> parseArrayLiteral parseValue

384− , P.try parseObjectLiteral

384+ , Literal <$> P.try (parseObjectLiteral parseIdentifierAndValue)

385 , parseAbs

386 , P.try parseConstructor

387 , P.try parseVar

@@ -469,17 +469,8 @@ parseUpdaterBody v = ObjectUpdate v <$> (C.indented *> braces (commaSep1 (C.inde

469parseAnonymousArgument :: TokenParser Expr

470parseAnonymousArgument = underscore *> pure AnonymousArgument

471

472−parseStringBinder :: TokenParser Binder

473−parseStringBinder = StringBinder <$> stringLiteral

474−

475−parseCharBinder :: TokenParser Binder

476−parseCharBinder = CharBinder <$> charLiteral

477−

478−parseBooleanBinder :: TokenParser Binder

472+parseNumberLiteral :: TokenParser Binder

479−parseBooleanBinder = BooleanBinder <$> booleanLiteral

473+parseNumberLiteral = LiteralBinder . NumericLiteral <$> (sign <*> number)

480−

481−parseNumberBinder :: TokenParser Binder

482−parseNumberBinder = NumberBinder <$> (sign <*> number)

483 where

474 where

484 sign :: TokenParser (Either Integer Double -> Either Integer Double)

475 sign :: TokenParser (Either Integer Double -> Either Integer Double)

485 sign = (symbol' "-" >> return (negate +++ negate))

476 sign = (symbol' "-" >> return (negate +++ negate))

@@ -492,11 +483,11 @@ parseNullaryConstructorBinder = ConstructorBinder <$> C.parseQualified C.properN

492parseConstructorBinder :: TokenParser Binder

483parseConstructorBinder :: TokenParser Binder

493parseConstructorBinder = ConstructorBinder <$> C.parseQualified C.properName <*> many (C.indented *> parseBinderNoParens)

484parseConstructorBinder = ConstructorBinder <$> C.parseQualified C.properName <*> many (C.indented *> parseBinderNoParens)

494

485

495−parseObjectBinder :: TokenParser Binder

486+parseObjectBinder:: TokenParser Binder

496−parseObjectBinder = ObjectBinder <$> braces (commaSep (C.indented *> parseIdentifierAndBinder))

487+parseObjectBinder= LiteralBinder <$> parseObjectLiteral (C.indented *> parseIdentifierAndBinder)

497

488

498parseArrayBinder :: TokenParser Binder

489parseArrayBinder :: TokenParser Binder

499−parseArrayBinder = squares $ ArrayBinder <$> commaSep (C.indented *> parseBinder)

490+parseArrayBinder = LiteralBinder <$> parseArrayLiteral (C.indented *> parseBinder)

500

491

501parseVarOrNamedBinder :: TokenParser Binder

492parseVarOrNamedBinder :: TokenParser Binder

502parseVarOrNamedBinder = do

493parseVarOrNamedBinder = do

@@ -541,10 +532,10 @@ parseBinder =

541 parseBinderAtom :: TokenParser Binder

532 parseBinderAtom :: TokenParser Binder

542 parseBinderAtom = P.choice

533 parseBinderAtom = P.choice

543 [ parseNullBinder

534 [ parseNullBinder

544− , parseCharBinder

535+ , LiteralBinder <$> parseCharLiteral

545− , parseStringBinder

536+ , LiteralBinder <$> parseStringLiteral

546− , parseBooleanBinder

537+ , LiteralBinder <$> parseBooleanLiteral

547− , parseNumberBinder

538+ , parseNumberLiteral

548 , parseVarOrNamedBinder

539 , parseVarOrNamedBinder

549 , parseConstructorBinder

540 , parseConstructorBinder

550 , parseObjectBinder

541 , parseObjectBinder

@@ -561,10 +552,10 @@ parseBinder =

561parseBinderNoParens :: TokenParser Binder

552parseBinderNoParens :: TokenParser Binder

562parseBinderNoParens = P.choice

553parseBinderNoParens = P.choice

563 [ parseNullBinder

554 [ parseNullBinder

564− , parseCharBinder

555+ , LiteralBinder <$> parseCharLiteral

565− , parseStringBinder

556+ , LiteralBinder <$> parseStringLiteral

566− , parseBooleanBinder

557+ , LiteralBinder <$> parseBooleanLiteral

567− , parseNumberBinder

558+ , parseNumberLiteral

568 , parseVarOrNamedBinder

559 , parseVarOrNamedBinder

569 , parseNullaryConstructorBinder

560 , parseNullaryConstructorBinder

570 , parseObjectBinder

561 , parseObjectBinder

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

@@ -36,7 +36,7 @@ import qualified Text.Parsec as PS

36

37type ForeignJS = String

38

39−parseForeignModulesFromFiles :: (Functor m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

39+parseForeignModulesFromFiles :: (MonadError MultipleErrors m, MonadWriter MultipleErrors m)

40 => [(FilePath, ForeignJS)]

41 -> m (M.Map ModuleName FilePath)

42parseForeignModulesFromFiles files = do

src/Language/PureScript/Pretty/Values.hs+48−31

@@ -1,18 +1,6 @@

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

2−--

3−-- Module : Language.PureScript.Pretty.Values

4−-- Copyright : (c) Phil Freeman 2013

5−-- License : MIT

6−--

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

8−-- Stability : experimental

9−-- Portability :

10−--

11-- |

1-- |

12-- Pretty printer for values

2-- Pretty printer for values

13--

3--

14−-----------------------------------------------------------------------------

15−

16module Language.PureScript.Pretty.Values (

4module Language.PureScript.Pretty.Values (

17 prettyPrintValue,

5 prettyPrintValue,

18 prettyPrintBinder,

6 prettyPrintBinder,

@@ -57,6 +45,7 @@ prettyPrintValue d (Accessor prop val) = prettyPrintValueAtom (d - 1) val <> tex

57prettyPrintValue d (ObjectUpdate o ps) = prettyPrintValueAtom (d - 1) o <> text " " <> list '{' '}' (\(key, val) -> text (key ++ " = ") <> prettyPrintValue (d - 1) val) ps

45prettyPrintValue d (ObjectUpdate o ps) = prettyPrintValueAtom (d - 1) o <> text " " <> list '{' '}' (\(key, val) -> text (key ++ " = ") <> prettyPrintValue (d - 1) val) ps

58prettyPrintValue d (App val arg) = prettyPrintValueAtom (d - 1) val `beforeWithSpace` prettyPrintValueAtom (d - 1) arg

46prettyPrintValue d (App val arg) = prettyPrintValueAtom (d - 1) val `beforeWithSpace` prettyPrintValueAtom (d - 1) arg

59prettyPrintValue d (Abs (Left arg) val) = text ('\\' : showIdent arg ++ " -> ") // moveRight 2 (prettyPrintValue (d - 1) val)

47prettyPrintValue d (Abs (Left arg) val) = text ('\\' : showIdent arg ++ " -> ") // moveRight 2 (prettyPrintValue (d - 1) val)

48+prettyPrintValue d (Abs (Right arg) val) = text ('\\' : prettyPrintBinder arg ++ " -> ") // moveRight 2 (prettyPrintValue (d - 1) val)

60prettyPrintValue d (TypeClassDictionaryConstructorApp className ps) =

49prettyPrintValue d (TypeClassDictionaryConstructorApp className ps) =

61 text (runProperName (disqualify className) ++ " ") <> prettyPrintValueAtom (d - 1) ps

50 text (runProperName (disqualify className) ++ " ") <> prettyPrintValueAtom (d - 1) ps

62prettyPrintValue d (Case values binders) =

51prettyPrintValue d (Case values binders) =

@@ -70,28 +59,49 @@ prettyPrintValue d (Do els) =

70 text "do " <> vcat left (map (prettyPrintDoNotationElement (d - 1)) els)

59 text "do " <> vcat left (map (prettyPrintDoNotationElement (d - 1)) els)

71prettyPrintValue _ (TypeClassDictionary (name, tys) _) = foldl1 beforeWithSpace $ text ("#dict " ++ runProperName (disqualify name)) : map typeAtomAsBox tys

60prettyPrintValue _ (TypeClassDictionary (name, tys) _) = foldl1 beforeWithSpace $ text ("#dict " ++ runProperName (disqualify name)) : map typeAtomAsBox tys

72prettyPrintValue _ (SuperClassDictionary name _) = text $ "#dict " ++ runProperName (disqualify name)

61prettyPrintValue _ (SuperClassDictionary name _) = text $ "#dict " ++ runProperName (disqualify name)

62+prettyPrintValue _ (TypeClassDictionaryAccessor className ident) =

63+ text "#dict-accessor " <> text (runProperName (disqualify className)) <> text "." <> text (showIdent ident) <> text ">"

73prettyPrintValue d (TypedValue _ val _) = prettyPrintValue d val

64prettyPrintValue d (TypedValue _ val _) = prettyPrintValue d val

74prettyPrintValue d (PositionedValue _ _ val) = prettyPrintValue d val

65prettyPrintValue d (PositionedValue _ _ val) = prettyPrintValue d val

66+prettyPrintValue d (Literal l) = prettyPrintLiteralValue d l

67+prettyPrintValue d expr@AnonymousArgument{} = prettyPrintValueAtom d expr

68+prettyPrintValue d expr@Constructor{} = prettyPrintValueAtom d expr

69+prettyPrintValue d expr@Var{} = prettyPrintValueAtom d expr

70+prettyPrintValue d expr@OperatorSection{} = prettyPrintValueAtom d expr

71+prettyPrintValue d expr@BinaryNoParens{} = prettyPrintValueAtom d expr

72+prettyPrintValue d expr@Parens{} = prettyPrintValueAtom d expr

73+prettyPrintValue d expr@UnaryMinus{} = prettyPrintValueAtom d expr

75−prettyPrintValue d expr = prettyPrintValueAtom d expr

74+prettyPrintValue d expr@ObjectGetter{} = prettyPrintValueAtom d expr

76

75

77-- | Pretty-print an atomic expression, adding parentheses if necessary.

76-- | Pretty-print an atomic expression, adding parentheses if necessary.

78prettyPrintValueAtom :: Int -> Expr -> Box

77prettyPrintValueAtom :: Int -> Expr -> Box

79−prettyPrintValueAtom _ (NumericLiteral n) = text $ either show show n

78+prettyPrintValueAtom d (Literal l) = prettyPrintLiteralValue d l

80−prettyPrintValueAtom _ (StringLiteral s) = text $ show s

81−prettyPrintValueAtom _ (CharLiteral c) = text $ show c

82−prettyPrintValueAtom _ (BooleanLiteral True) = text "true"

83−prettyPrintValueAtom _ (BooleanLiteral False) = text "false"

84−prettyPrintValueAtom d (ArrayLiteral xs) = list '[' ']' (prettyPrintValue (d - 1)) xs

85−prettyPrintValueAtom d (ObjectLiteral ps) = prettyPrintObject (d - 1) $ second Just `map` ps

86prettyPrintValueAtom _ AnonymousArgument = text "_"

79prettyPrintValueAtom _ AnonymousArgument = text "_"

87prettyPrintValueAtom _ (Constructor name) = text $ runProperName (disqualify name)

80prettyPrintValueAtom _ (Constructor name) = text $ runProperName (disqualify name)

88prettyPrintValueAtom _ (Var ident) = text $ showIdent (disqualify ident)

81prettyPrintValueAtom _ (Var ident) = text $ showIdent (disqualify ident)

89prettyPrintValueAtom d (OperatorSection op (Right val)) = ((text "(" <> prettyPrintValue (d - 1) op) `beforeWithSpace` prettyPrintValue (d - 1) val) `before` text ")"

82prettyPrintValueAtom d (OperatorSection op (Right val)) = ((text "(" <> prettyPrintValue (d - 1) op) `beforeWithSpace` prettyPrintValue (d - 1) val) `before` text ")"

90prettyPrintValueAtom d (OperatorSection op (Left val)) = ((text "(" <> prettyPrintValue (d - 1) val) `beforeWithSpace` prettyPrintValue (d - 1) op) `before` text ")"

83prettyPrintValueAtom d (OperatorSection op (Left val)) = ((text "(" <> prettyPrintValue (d - 1) val) `beforeWithSpace` prettyPrintValue (d - 1) op) `before` text ")"

84+prettyPrintValueAtom d (BinaryNoParens op lhs rhs) =

85+ prettyPrintValue (d - 1) lhs `beforeWithSpace` printOp op `beforeWithSpace` prettyPrintValue (d - 1) rhs

86+ where

87+ printOp (Var (Qualified _ (Op opName))) = text opName

88+ printOp expr = text "`" <> prettyPrintValue (d - 1) expr <> text "`"

91prettyPrintValueAtom d (TypedValue _ val _) = prettyPrintValueAtom d val

89prettyPrintValueAtom d (TypedValue _ val _) = prettyPrintValueAtom d val

92prettyPrintValueAtom d (PositionedValue _ _ val) = prettyPrintValueAtom d val

90prettyPrintValueAtom d (PositionedValue _ _ val) = prettyPrintValueAtom d val

91+prettyPrintValueAtom d (Parens expr) = (text "(" <> prettyPrintValue d expr) `before` text ")"

92+prettyPrintValueAtom d (UnaryMinus expr) = text "(-" <> prettyPrintValue d expr <> text ")"

93+prettyPrintValueAtom _ (ObjectGetter field) = text "_." <> text field

93prettyPrintValueAtom d expr = (text "(" <> prettyPrintValue d expr) `before` text ")"

94prettyPrintValueAtom d expr = (text "(" <> prettyPrintValue d expr) `before` text ")"

94

95

96+prettyPrintLiteralValue :: Int -> Literal Expr -> Box

97+prettyPrintLiteralValue _ (NumericLiteral n) = text $ either show show n

98+prettyPrintLiteralValue _ (StringLiteral s) = text $ show s

99+prettyPrintLiteralValue _ (CharLiteral c) = text $ show c

100+prettyPrintLiteralValue _ (BooleanLiteral True) = text "true"

101+prettyPrintLiteralValue _ (BooleanLiteral False) = text "false"

102+prettyPrintLiteralValue d (ArrayLiteral xs) = list '[' ']' (prettyPrintValue (d - 1)) xs

103+prettyPrintLiteralValue d (ObjectLiteral ps) = prettyPrintObject (d - 1) $ second Just `map` ps

104+

95prettyPrintDeclaration :: Int -> Declaration -> Box

105prettyPrintDeclaration :: Int -> Declaration -> Box

96prettyPrintDeclaration d _ | d < 0 = ellipsis

106prettyPrintDeclaration d _ | d < 0 = ellipsis

97prettyPrintDeclaration _ (TypeDeclaration ident ty) =

107prettyPrintDeclaration _ (TypeDeclaration ident ty) =

@@ -136,28 +146,35 @@ prettyPrintDoNotationElement d (PositionedDoNotationElement _ _ el) = prettyPrin

136

146

137prettyPrintBinderAtom :: Binder -> String

147prettyPrintBinderAtom :: Binder -> String

138prettyPrintBinderAtom NullBinder = "_"

148prettyPrintBinderAtom NullBinder = "_"

139−prettyPrintBinderAtom (StringBinder str) = show str

149+prettyPrintBinderAtom (LiteralBinder l) = prettyPrintLiteralBinder l

140−prettyPrintBinderAtom (CharBinder c) = show c

141−prettyPrintBinderAtom (NumberBinder num) = either show show num

142−prettyPrintBinderAtom (BooleanBinder True) = "true"

143−prettyPrintBinderAtom (BooleanBinder False) = "false"

144prettyPrintBinderAtom (VarBinder ident) = showIdent ident

150prettyPrintBinderAtom (VarBinder ident) = showIdent ident

145prettyPrintBinderAtom (ConstructorBinder ctor []) = runProperName (disqualify ctor)

151prettyPrintBinderAtom (ConstructorBinder ctor []) = runProperName (disqualify ctor)

146−prettyPrintBinderAtom (ObjectBinder bs) =

152+prettyPrintBinderAtom b@ConstructorBinder{} = parens (prettyPrintBinder b)

153+prettyPrintBinderAtom (NamedBinder ident binder) = showIdent ident ++ "@" ++ prettyPrintBinder binder

154+prettyPrintBinderAtom (PositionedBinder _ _ binder) = prettyPrintBinderAtom binder

155+prettyPrintBinderAtom (TypedBinder _ binder) = prettyPrintBinderAtom binder

156+prettyPrintBinderAtom (OpBinder op) = showIdent (disqualify op)

157+prettyPrintBinderAtom (BinaryNoParensBinder op b1 b2) =

158+ prettyPrintBinderAtom b1 ++ " " ++ prettyPrintBinderAtom op ++ " " ++ prettyPrintBinderAtom b2

159+prettyPrintBinderAtom (ParensInBinder b) = parens (prettyPrintBinder b)

160+

161+prettyPrintLiteralBinder :: Literal Binder -> String

162+prettyPrintLiteralBinder (StringLiteral str) = show str

163+prettyPrintLiteralBinder (CharLiteral c) = show c

164+prettyPrintLiteralBinder (NumericLiteral num) = either show show num

165+prettyPrintLiteralBinder (BooleanLiteral True) = "true"

166+prettyPrintLiteralBinder (BooleanLiteral False) = "false"

167+prettyPrintLiteralBinder (ObjectLiteral bs) =

147 "{ "

168 "{ "

148 ++ intercalate ", " (map prettyPrintObjectPropertyBinder bs)

169 ++ intercalate ", " (map prettyPrintObjectPropertyBinder bs)

149 ++ " }"

170 ++ " }"

150 where

171 where

151 prettyPrintObjectPropertyBinder :: (String, Binder) -> String

172 prettyPrintObjectPropertyBinder :: (String, Binder) -> String

152 prettyPrintObjectPropertyBinder (key, binder) = prettyPrintObjectKey key ++ ": " ++ prettyPrintBinder binder

173 prettyPrintObjectPropertyBinder (key, binder) = prettyPrintObjectKey key ++ ": " ++ prettyPrintBinder binder

153−prettyPrintBinderAtom (ArrayBinder bs) =

174+prettyPrintLiteralBinder (ArrayLiteral bs) =

154 "[ "

175 "[ "

155 ++ intercalate ", " (map prettyPrintBinder bs)

176 ++ intercalate ", " (map prettyPrintBinder bs)

156 ++ " ]"

177 ++ " ]"

157−prettyPrintBinderAtom (NamedBinder ident binder) = showIdent ident ++ "@" ++ prettyPrintBinder binder

158−prettyPrintBinderAtom (PositionedBinder _ _ binder) = prettyPrintBinderAtom binder

159−prettyPrintBinderAtom (TypedBinder _ binder) = prettyPrintBinderAtom binder

160−prettyPrintBinderAtom b = parens (prettyPrintBinder b)

161

178

162-- |

179-- |

163-- Generate a pretty-printed string representing a Binder

180-- Generate a pretty-printed string representing a Binder

src/Language/PureScript/Publish/ErrorsWarnings.hs+1−1

@@ -190,7 +190,7 @@ displayUserError e = case e of

190 CompileError err ->

191 vcat

192 [ para "Compile error:"

193− , indented (P.prettyPrintMultipleErrorsBox False err)

193+ , indented (vcat (P.prettyPrintMultipleErrorsBox False err))

194 ]

195 DirtyWorkingTree ->

196 para (

src/Language/PureScript/Sugar.hs+1−1

@@ -63,7 +63,7 @@ import Language.PureScript.Sugar.TypeDeclarations as S

63--

64-- * Group mutually recursive value and data declarations into binding groups.

65--

66−desugar :: (Applicative m, MonadSupply m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module]

66+desugar :: (MonadSupply m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module]

67desugar externs =

68 map removeSignedLiterals

69 >>> traverse desugarObjectConstructors

src/Language/PureScript/Sugar/BindingGroups.hs+3−3

@@ -35,7 +35,7 @@ import Language.PureScript.Types

35-- Replace all sets of mutually-recursive declarations in a module with binding groups

36--

37createBindingGroupsModule

38− :: (Functor m, Applicative m, MonadError MultipleErrors m)

38+ :: (MonadError MultipleErrors m)

39 => [Module]

40 -> m [Module]

41createBindingGroupsModule =

@@ -52,7 +52,7 @@ collapseBindingGroupsModule =

52

53createBindingGroups

54 :: forall m

55− . (Functor m, Applicative m, MonadError MultipleErrors m)

55+ . (MonadError MultipleErrors m)

56 => ModuleName

57 -> [Declaration]

58 -> m [Declaration]

@@ -171,7 +171,7 @@ getTypeName _ = internalError "Expected DataDeclaration"

171--

172toBindingGroup

173 :: forall m

174− . (Functor m, MonadError MultipleErrors m)

174+ . (MonadError MultipleErrors m)

175 => ModuleName

176 -> SCC Declaration

177 -> m Declaration

src/Language/PureScript/Sugar/CaseDeclarations.hs+6−6

@@ -36,7 +36,7 @@ isLeft (Right _) = False

36-- |

37-- Replace all top-level binders in a module with case expressions.

38--

39−desugarCasesModule :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Module] -> m [Module]

39+desugarCasesModule :: (MonadSupply m, MonadError MultipleErrors m) => [Module] -> m [Module]

40desugarCasesModule ms = forM ms $ \(Module ss coms name ds exps) ->

41 rethrow (addHint (ErrorInModule name)) $

42 Module ss coms name <$> (desugarCases <=< desugarAbs <=< validateCases $ ds) <*> pure exps

@@ -44,7 +44,7 @@ desugarCasesModule ms = forM ms $ \(Module ss coms name ds exps) ->

44-- |

45-- Validates that case head and binder lengths match.

46--

47−validateCases :: forall m. (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]

47+validateCases :: forall m. (MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]

48validateCases = flip parU f

49 where

50 (f, _, _) = everywhereOnValuesM return validate return

@@ -69,7 +69,7 @@ validateCases = flip parU f

69 positionedBinder (PositionedBinder p _ _) = Just p

70 positionedBinder _ = Nothing

71

72−desugarAbs :: forall m. (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]

72+desugarAbs :: forall m. (MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]

73desugarAbs = flip parU f

74 where

75 (f, _, _) = everywhereOnValuesM return replace return

@@ -83,7 +83,7 @@ desugarAbs = flip parU f

83-- |

84-- Replace all top-level binders with case expressions.

85--

86−desugarCases :: forall m. (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]

86+desugarCases :: forall m. (MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]

87desugarCases = desugarRest <=< fmap join . flip parU toDecls . groupBy inSameGroup

88 where

89 desugarRest :: [Declaration] -> m [Declaration]

@@ -109,7 +109,7 @@ inSameGroup (PositionedDeclaration _ _ d1) d2 = inSameGroup d1 d2

109inSameGroup d1 (PositionedDeclaration _ _ d2) = inSameGroup d1 d2

110inSameGroup _ _ = False

111

112−toDecls :: forall m. (Functor m, Applicative m, Monad m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]

112+toDecls :: forall m. (MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]

113toDecls [ValueDeclaration ident nameKind bs (Right val)] | all isVarBinder bs = do

114 args <- mapM fromVarBinder bs

115 let body = foldr (Abs . Left) val args

@@ -147,7 +147,7 @@ toTuple (ValueDeclaration _ _ bs result) = (bs, result)

147toTuple (PositionedDeclaration _ _ d) = toTuple d

148toTuple _ = internalError "Not a value declaration"

149

150−makeCaseDeclaration :: forall m. (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Ident -> [([Binder], Either [(Guard, Expr)] Expr)] -> m Declaration

150+makeCaseDeclaration :: forall m. (MonadSupply m, MonadError MultipleErrors m) => Ident -> [([Binder], Either [(Guard, Expr)] Expr)] -> m Declaration

151makeCaseDeclaration ident alternatives = do

152 let namedArgs = map findName . fst <$> alternatives

153 argNames = foldl1 resolveNames namedArgs

src/Language/PureScript/Sugar/DoNotation.hs+2−2

@@ -26,10 +26,10 @@ import Control.Monad.Supply.Class

26-- Replace all @DoNotationBind@ and @DoNotationValue@ constructors with applications of the Prelude.bind function,

27-- and all @DoNotationLet@ constructors with let expressions.

28--

29−desugarDoModule :: forall m. (Applicative m, MonadSupply m, MonadError MultipleErrors m) => Module -> m Module

29+desugarDoModule :: forall m. (MonadSupply m, MonadError MultipleErrors m) => Module -> m Module

30desugarDoModule (Module ss coms mn ds exts) = Module ss coms mn <$> parU ds desugarDo <*> pure exts

31

32−desugarDo :: forall m. (Applicative m, MonadSupply m, MonadError MultipleErrors m) => Declaration -> m Declaration

32+desugarDo :: forall m. (MonadSupply m, MonadError MultipleErrors m) => Declaration -> m Declaration

33desugarDo (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> rethrowWithPosition pos (desugarDo d)

34desugarDo d =

35 let (f, _, _) = everywhereOnValuesM return replace return

src/Language/PureScript/Sugar/Names.hs+4−4

@@ -44,13 +44,13 @@ import Language.PureScript.Linter.Imports

44-- Replaces all local names with qualified names within a list of modules. The

45-- modules should be topologically sorted beforehand.

46--

47−desugarImports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module]

47+desugarImports :: forall m. (MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module]

48desugarImports externs modules =

49 fmap snd (desugarImportsWithEnv externs modules)

50

51desugarImportsWithEnv

52 :: forall m

53− . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

53+ . (MonadError MultipleErrors m, MonadWriter MultipleErrors m)

54 => [ExternsFile]

55 -> [Module]

56 -> m (Env, [Module])

@@ -141,7 +141,7 @@ elaborateExports exps (Module ss coms mn decls refs) =

141--

142renameInModule

143 :: forall m

144− . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadState UsedImports m)

144+ . (MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadState UsedImports m)

145 => Env

146 -> Imports

147 -> Module

@@ -334,7 +334,7 @@ renameInModule env imports (Module ss coms mn decls exps) =

334--

335updateExportRefs

336 :: forall m

337− . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

337+ . (MonadError MultipleErrors m, MonadWriter MultipleErrors m)

338 => Module

339 -> m Module

340updateExportRefs (Module ss coms mn decls exps) =

src/Language/PureScript/Sugar/Names/Exports.hs+3−3

@@ -31,7 +31,7 @@ import Language.PureScript.Sugar.Names.Env

31-- |

32-- Finds all exportable members of a module, disregarding any explicit exports.

33--

34−findExportable :: forall m. (Applicative m, MonadError MultipleErrors m) => Module -> m Exports

34+findExportable :: forall m. (MonadError MultipleErrors m) => Module -> m Exports

35findExportable (Module _ _ mn ds _) =

36 rethrow (addHint (ErrorInModule mn)) $ foldM updateExports nullExports ds

37 where

@@ -56,7 +56,7 @@ findExportable (Module _ _ mn ds _) =

56-- Resolves the exports for a module, filtering out members that have not been

57-- exported and elaborating re-exports of other modules.

58--

59−resolveExports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Env -> ModuleName -> Imports -> Exports -> [DeclarationRef] -> m Exports

59+resolveExports :: forall m. (MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Env -> ModuleName -> Imports -> Exports -> [DeclarationRef] -> m Exports

60resolveExports env mn imps exps refs =

61 rethrow (addHint (ErrorInModule mn)) $ do

62 filtered <- filterModule mn exps refs

@@ -199,7 +199,7 @@ resolveExports env mn imps exps refs =

199--

200filterModule

201 :: forall m

202− . (Applicative m, MonadError MultipleErrors m)

202+ . (MonadError MultipleErrors m)

203 => ModuleName

204 -> Exports

205 -> [DeclarationRef]

src/Language/PureScript/Sugar/Names/Imports.hs+4−4

@@ -37,7 +37,7 @@ import Language.PureScript.Sugar.Names.Env

37--

38findImports

39 :: forall m

40− . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

40+ . (MonadError MultipleErrors m, MonadWriter MultipleErrors m)

41 => [Declaration]

42 -> m (M.Map ModuleName [(Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)])

43findImports = foldM (go Nothing) M.empty

@@ -56,7 +56,7 @@ type ImportDef = (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)

56--

57resolveImports

58 :: forall m

59− . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

59+ . (MonadError MultipleErrors m, MonadWriter MultipleErrors m)

60 => Env

61 -> Module

62 -> m (Module, Imports)

@@ -160,7 +160,7 @@ resolveImports env (Module ss coms currentModule decls exps) =

160-- | Constructs a set of imports for a single module import.

161resolveModuleImport

162 :: forall m

163− . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

163+ . (MonadError MultipleErrors m, MonadWriter MultipleErrors m)

164 => Env

165 -> Imports

166 -> (ModuleName, [(Maybe SourceSpan, Maybe ImportDeclarationType, Maybe ModuleName)])

@@ -187,7 +187,7 @@ resolveModuleImport env ie (mn, imps) = foldM go ie imps

187--

188resolveImport

189 :: forall m

190− . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

190+ . (MonadError MultipleErrors m, MonadWriter MultipleErrors m)

191 => ModuleName

192 -> Exports

193 -> Imports

src/Language/PureScript/Sugar/ObjectWildcards.hs+6−2

@@ -19,7 +19,11 @@ import Language.PureScript.AST

19import Language.PureScript.Errors

20import Language.PureScript.Names

21

22+desugarObjectConstructors

23+ :: forall m

22−desugarObjectConstructors :: forall m. (Applicative m, MonadSupply m, MonadError MultipleErrors m) => Module -> m Module

24+ . (MonadSupply m, MonadError MultipleErrors m)

25+ => Module

26+ -> m Module

23desugarObjectConstructors (Module ss coms mn ds exts) = Module ss coms mn <$> mapM desugarDecl ds <*> pure exts

27desugarObjectConstructors (Module ss coms mn ds exts) = Module ss coms mn <$> mapM desugarDecl ds <*> pure exts

24 where

28 where

25

29

@@ -38,7 +42,7 @@ desugarObjectConstructors (Module ss coms mn ds exts) = Module ss coms mn <$> ma

38 | b' <- stripPositionInfo b

42 | b' <- stripPositionInfo b

39 , BinaryNoParens op u val <- b'

43 , BinaryNoParens op u val <- b'

40 , isAnonymousArgument u = return $ OperatorSection op (Right val)

44 , isAnonymousArgument u = return $ OperatorSection op (Right val)

41− desugarExpr (ObjectLiteral ps) = wrapLambda ObjectLiteral ps

45+ desugarExpr (Literal (ObjectLiteral ps)) = wrapLambda (Literal . ObjectLiteral) ps

42 desugarExpr (ObjectUpdate u ps) | isAnonymousArgument u = do

46 desugarExpr (ObjectUpdate u ps) | isAnonymousArgument u = do

43 obj <- freshIdent'

47 obj <- freshIdent'

44 Abs (Left obj) <$> wrapLambda (ObjectUpdate (Var (Qualified Nothing obj))) ps

48 Abs (Left obj) <$> wrapLambda (ObjectUpdate (Var (Qualified Nothing obj))) ps

src/Language/PureScript/Sugar/Operators.hs+9−6

@@ -57,7 +57,7 @@ type AliasName = Either (Qualified Ident) (Qualified (ProperName 'ConstructorNam

57--

58rebracket

59 :: forall m

60− . (Applicative m, MonadError MultipleErrors m)

60+ . (MonadError MultipleErrors m)

61 => [ExternsFile]

62 -> [Module]

63 -> m [Module]

@@ -116,7 +116,7 @@ removeSignedLiterals (Module ss coms mn ds exts) = Module ss coms mn (map f' ds)

116 go other = other

117

118rebracketModule

119− :: (Applicative m, MonadError MultipleErrors m)

119+ :: (MonadError MultipleErrors m)

120 => [[(Qualified Ident, Associativity)]]

121 -> Module

122 -> m Module

@@ -178,7 +178,7 @@ customOperatorTable fixities =

178

179desugarOperatorSections

180 :: forall m

181− . (Applicative m, MonadSupply m, MonadError MultipleErrors m)

181+ . (MonadSupply m, MonadError MultipleErrors m)

182 => Module

183 -> m Module

184desugarOperatorSections (Module ss coms mn ds exts) =

@@ -189,8 +189,11 @@ desugarOperatorSections (Module ss coms mn ds exts) =

189 (goDecl, _, _) = everywhereOnValuesM return goExpr return

190

191 goExpr :: Expr -> m Expr

192− goExpr (OperatorSection op (Left val)) = return $ App op val

192+ goExpr (OperatorSection op eVal) = do

193− goExpr (OperatorSection op (Right val)) = do

194 arg <- freshIdent'

193 arg <- freshIdent'

195− return $ Abs (Left arg) $ App (App op (Var (Qualified Nothing arg))) val

194+ let var = Var (Qualified Nothing arg)

195+ f2 a b = Abs (Left arg) $ App (App op a) b

196+ return $ case eVal of

197+ Left val -> f2 val var

198+ Right val -> f2 var val

196 goExpr other = return other

199 goExpr other = return other

src/Language/PureScript/Sugar/TypeClasses.hs+5−5

@@ -45,7 +45,7 @@ type Desugar = StateT MemberMap

45-- instance dictionary expressions.

46--

47desugarTypeClasses

48− :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m)

48+ :: (MonadSupply m, MonadError MultipleErrors m)

49 => [ExternsFile]

50 -> [Module]

51 -> m [Module]

@@ -62,7 +62,7 @@ desugarTypeClasses externs = flip evalStateT initialState . traverse desugarModu

62 fromExternsDecl _ _ = Nothing

63

64desugarModule

65− :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m)

65+ :: (MonadSupply m, MonadError MultipleErrors m)

66 => Module

67 -> Desugar m Module

68desugarModule (Module ss coms name decls (Just exps)) = do

@@ -171,7 +171,7 @@ desugarModule _ = internalError "Exports should have been elaborated in name des

171-- };

172-}

173desugarDecl

174− :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m)

174+ :: (MonadSupply m, MonadError MultipleErrors m)

175 => ModuleName

176 -> [DeclarationRef]

177 -> Declaration

@@ -259,7 +259,7 @@ unit = TypeApp tyObject REmpty

259

260typeInstanceDictionaryDeclaration

261 :: forall m

262− . (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m)

262+ . (MonadSupply m, MonadError MultipleErrors m)

263 => Ident

264 -> ModuleName

265 -> [Constraint]

@@ -297,7 +297,7 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =

297 , let tyArgs = map (replaceAllTypeVars (zip (map fst args) tys)) suTyArgs

298 ]

299

300− let props = ObjectLiteral (members ++ superclasses)

300+ let props = Literal $ ObjectLiteral (members ++ superclasses)

301 dictTy = foldl TypeApp (TypeConstructor (fmap coerceProperName className)) tys

302 constrainedTy = quantify (if null deps then dictTy else ConstrainedType deps dictTy)

303 dict = TypeClassDictionaryConstructorApp className props

src/Language/PureScript/Sugar/TypeClasses/Deriving.hs+55−35

@@ -32,7 +32,7 @@ import qualified Language.PureScript.Constants as C

32

33-- | Elaborates deriving instance declarations by code generation.

34deriveInstances

35− :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadSupply m)

35+ :: (MonadError MultipleErrors m, MonadSupply m)

36 => Module

37 -> m Module

38deriveInstances (Module ss coms mn ds exts) = Module ss coms mn <$> mapM (deriveInstance mn ds) ds <*> pure exts

@@ -40,7 +40,7 @@ deriveInstances (Module ss coms mn ds exts) = Module ss coms mn <$> mapM (derive

40-- | Takes a declaration, and if the declaration is a deriving TypeInstanceDeclaration,

41-- elaborates that into an instance declaration via code generation.

42deriveInstance

43− :: (Functor m, MonadError MultipleErrors m, MonadSupply m)

43+ :: (MonadError MultipleErrors m, MonadSupply m)

44 => ModuleName

45 -> [Declaration]

46 -> Declaration

@@ -82,7 +82,7 @@ typesProxy :: ModuleName

82typesProxy = ModuleName [ ProperName "Type", ProperName "Proxy" ]

83

84deriveGeneric

85− :: forall m. (Functor m, MonadError MultipleErrors m, MonadSupply m)

85+ :: forall m. (MonadError MultipleErrors m, MonadSupply m)

86 => ModuleName

87 -> [Declaration]

88 -> ProperName 'TypeName

@@ -115,15 +115,21 @@ deriveGeneric mn ds tyConNm dargs = do

115 return $ CaseAlternative [ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)] (Right (caseResult idents))

116 where

117 caseResult idents =

118− App (prodConstructor (StringLiteral . showQualified runProperName $ Qualified (Just mn) ctorName))

118+ App (prodConstructor (Literal . StringLiteral . showQualified runProperName $ Qualified (Just mn) ctorName))

119− . ArrayLiteral

119+ . Literal . ArrayLiteral

120 $ zipWith toSpineFun (map (Var . Qualified Nothing) idents) tys

121

122 toSpineFun :: Expr -> Type -> Expr

123 toSpineFun i r | Just rec <- objectType r =

124− lamNull . recordConstructor . ArrayLiteral .

124+ lamNull . recordConstructor . Literal . ArrayLiteral

125+ . map

126+ (\(str,typ) ->

127+ Literal $ ObjectLiteral

128+ [ ("recLabel", Literal (StringLiteral str))

125− map (\(str,typ) -> ObjectLiteral [("recLabel", StringLiteral str), ("recValue", toSpineFun (Accessor str i) typ)])

129+ , ("recValue", toSpineFun (Accessor str i) typ)

130+ ]

131+ )

126− $ decomposeRec rec

132+ $ decomposeRec rec

127 toSpineFun i _ = lamNull $ App (mkGenVar (Ident C.toSpine)) i

133 toSpineFun i _ = lamNull $ App (mkGenVar (Ident C.toSpine)) i

128 mkSpineFunction (PositionedDeclaration _ _ d) = mkSpineFunction d

134 mkSpineFunction (PositionedDeclaration _ _ d) = mkSpineFunction d

129 mkSpineFunction _ = internalError "mkSpineFunction: expected DataDeclaration"

135 mkSpineFunction _ = internalError "mkSpineFunction: expected DataDeclaration"

@@ -132,30 +138,37 @@ deriveGeneric mn ds tyConNm dargs = do

132 mkSignatureFunction (DataDeclaration _ name tyArgs args) classArgs = lamNull . mkSigProd $ map mkProdClause args

138 mkSignatureFunction (DataDeclaration _ name tyArgs args) classArgs = lamNull . mkSigProd $ map mkProdClause args

133 where

139 where

134 mkSigProd :: [Expr] -> Expr

140 mkSigProd :: [Expr] -> Expr

141+ mkSigProd =

142+ App

143+ (App

135− mkSigProd = App (App (Constructor (Qualified (Just dataGeneric) (ProperName "SigProd")))

144+ (Constructor (Qualified (Just dataGeneric) (ProperName "SigProd")))

136− (StringLiteral (showQualified runProperName (Qualified (Just mn) name)))

145+ (Literal (StringLiteral (showQualified runProperName (Qualified (Just mn) name))))

146+ )

147+ . Literal

137− ) . ArrayLiteral

148+ . ArrayLiteral

138

149

139 mkSigRec :: [Expr] -> Expr

150 mkSigRec :: [Expr] -> Expr

140− mkSigRec = App (Constructor (Qualified (Just dataGeneric) (ProperName "SigRecord"))) . ArrayLiteral

151+ mkSigRec = App (Constructor (Qualified (Just dataGeneric) (ProperName "SigRecord"))) . Literal . ArrayLiteral

141

152

142 proxy :: Type -> Type

153 proxy :: Type -> Type

143 proxy = TypeApp (TypeConstructor (Qualified (Just typesProxy) (ProperName "Proxy")))

154 proxy = TypeApp (TypeConstructor (Qualified (Just typesProxy) (ProperName "Proxy")))

144

155

145 mkProdClause :: (ProperName 'ConstructorName, [Type]) -> Expr

156 mkProdClause :: (ProperName 'ConstructorName, [Type]) -> Expr

146 mkProdClause (ctorName, tys) =

157 mkProdClause (ctorName, tys) =

147− ObjectLiteral

158+ Literal $ ObjectLiteral

148− [ ("sigConstructor", StringLiteral (showQualified runProperName (Qualified (Just mn) ctorName)))

159+ [ ("sigConstructor", Literal (StringLiteral (showQualified runProperName (Qualified (Just mn) ctorName))))

149− , ("sigValues", ArrayLiteral . map (mkProductSignature . instantiate) $ tys)

160+ , ("sigValues", Literal . ArrayLiteral . map (mkProductSignature . instantiate) $ tys)

150 ]

161 ]

151

162

152 mkProductSignature :: Type -> Expr

163 mkProductSignature :: Type -> Expr

153 mkProductSignature r | Just rec <- objectType r =

164 mkProductSignature r | Just rec <- objectType r =

165+ lamNull . mkSigRec $

166+ [ Literal $ ObjectLiteral

154− lamNull . mkSigRec $ [ ObjectLiteral [ ("recLabel", StringLiteral str)

167+ [ ("recLabel", Literal (StringLiteral str))

155− , ("recValue", mkProductSignature typ)

168+ , ("recValue", mkProductSignature typ)

156− ]

169+ ]

157− | (str, typ) <- decomposeRec rec

170+ | (str, typ) <- decomposeRec rec

158− ]

171+ ]

159 mkProductSignature typ = lamNull $ App (mkGenVar (Ident C.toSignature))

172 mkProductSignature typ = lamNull $ App (mkGenVar (Ident C.toSignature))

160 (TypedValue False (mkGenVar (Ident "anyProxy")) (proxy typ))

173 (TypedValue False (mkGenVar (Ident "anyProxy")) (proxy typ))

161 instantiate = replaceAllTypeVars (zipWith (\(arg, _) ty -> (arg, ty)) tyArgs classArgs)

174 instantiate = replaceAllTypeVars (zipWith (\(arg, _) ty -> (arg, ty)) tyArgs classArgs)

@@ -182,10 +195,17 @@ deriveGeneric mn ds tyConNm dargs = do

182 mkAlternative :: (ProperName 'ConstructorName, [Type]) -> m CaseAlternative

195 mkAlternative :: (ProperName 'ConstructorName, [Type]) -> m CaseAlternative

183 mkAlternative (ctorName, tys) = do

196 mkAlternative (ctorName, tys) = do

184 idents <- replicateM (length tys) freshIdent'

197 idents <- replicateM (length tys) freshIdent'

198+ return $

199+ CaseAlternative

200+ [ prodBinder

185− return $ CaseAlternative [ prodBinder [ StringBinder (showQualified runProperName (Qualified (Just mn) ctorName)), ArrayBinder (map VarBinder idents)]]

201+ [ LiteralBinder (StringLiteral (showQualified runProperName (Qualified (Just mn) ctorName)))

202+ , LiteralBinder (ArrayLiteral (map VarBinder idents))

203+ ]

204+ ]

186− . Right

205+ . Right

206+ $ liftApplicative

187− $ liftApplicative (mkJust $ Constructor (Qualified (Just mn) ctorName))

207+ (mkJust $ Constructor (Qualified (Just mn) ctorName))

188− (zipWith fromSpineFun (map (Var . Qualified Nothing) idents) tys)

208+ (zipWith fromSpineFun (map (Var . Qualified Nothing) idents) tys)

189

209

190 addCatch :: [CaseAlternative] -> [CaseAlternative]

210 addCatch :: [CaseAlternative] -> [CaseAlternative]

191 addCatch = (++ [catchAll])

211 addCatch = (++ [catchAll])

@@ -202,15 +222,15 @@ deriveGeneric mn ds tyConNm dargs = do

202 fromSpineFun e _ = App (mkGenVar (Ident C.fromSpine)) (App e (mkPrelVar (Ident "unit")))

222 fromSpineFun e _ = App (mkGenVar (Ident C.fromSpine)) (App e (mkPrelVar (Ident "unit")))

203

223

204 mkRecCase :: [(String, Type)] -> CaseAlternative

224 mkRecCase :: [(String, Type)] -> CaseAlternative

225+ mkRecCase rs =

226+ CaseAlternative

205− mkRecCase rs = CaseAlternative [ recordBinder [ ArrayBinder (map (VarBinder . Ident . fst) rs)

227+ [ recordBinder [ LiteralBinder (ArrayLiteral (map (VarBinder . Ident . fst) rs)) ] ]

206− ]

207− ]

208− . Right

228+ . Right

209− $ liftApplicative (mkRecFun rs) (map (\(x, y) -> fromSpineFun (Accessor "recValue" (mkVar (Ident x))) y) rs)

229+ $ liftApplicative (mkRecFun rs) (map (\(x, y) -> fromSpineFun (Accessor "recValue" (mkVar (Ident x))) y) rs)

210

230

211 mkRecFun :: [(String, Type)] -> Expr

231 mkRecFun :: [(String, Type)] -> Expr

212 mkRecFun xs = mkJust $ foldr lam recLiteral (map (Ident . fst) xs)

232 mkRecFun xs = mkJust $ foldr lam recLiteral (map (Ident . fst) xs)

213− where recLiteral = ObjectLiteral $ map (\(s,_) -> (s, mkVar (Ident s))) xs

233+ where recLiteral = Literal . ObjectLiteral $ map (\(s,_) -> (s, mkVar (Ident s))) xs

214 mkFromSpineFunction (PositionedDeclaration _ _ d) = mkFromSpineFunction d

234 mkFromSpineFunction (PositionedDeclaration _ _ d) = mkFromSpineFunction d

215 mkFromSpineFunction _ = internalError "mkFromSpineFunction: expected DataDeclaration"

235 mkFromSpineFunction _ = internalError "mkFromSpineFunction: expected DataDeclaration"

216

236

@@ -226,7 +246,7 @@ deriveGeneric mn ds tyConNm dargs = do

226 mkGenVar = mkVarMn (Just (ModuleName [ProperName "Data", ProperName C.generic]))

246 mkGenVar = mkVarMn (Just (ModuleName [ProperName "Data", ProperName C.generic]))

227

247

228deriveEq ::

248deriveEq ::

229− forall m. (Functor m, MonadError MultipleErrors m, MonadSupply m)

249+ forall m. (MonadError MultipleErrors m, MonadSupply m)

230 => ModuleName

250 => ModuleName

231 -> [Declaration]

251 -> [Declaration]

232 -> ProperName 'TypeName

252 -> ProperName 'TypeName

@@ -255,7 +275,7 @@ deriveEq mn ds tyConNm = do

255 | length xs /= 1 = xs ++ [catchAll]

275 | length xs /= 1 = xs ++ [catchAll]

256 | otherwise = xs -- Avoid redundant case

276 | otherwise = xs -- Avoid redundant case

257 where

277 where

258− catchAll = CaseAlternative [NullBinder, NullBinder] (Right (BooleanLiteral False))

278+ catchAll = CaseAlternative [NullBinder, NullBinder] (Right (Literal (BooleanLiteral False)))

259

279

260 mkCtorClause :: (ProperName 'ConstructorName, [Type]) -> m CaseAlternative

280 mkCtorClause :: (ProperName 'ConstructorName, [Type]) -> m CaseAlternative

261 mkCtorClause (ctorName, tys) = do

281 mkCtorClause (ctorName, tys) = do

@@ -267,7 +287,7 @@ deriveEq mn ds tyConNm = do

267 caseBinder idents = ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)

287 caseBinder idents = ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)

268

288

269 conjAll :: [Expr] -> Expr

289 conjAll :: [Expr] -> Expr

270− conjAll [] = BooleanLiteral True

290+ conjAll [] = Literal (BooleanLiteral True)

271 conjAll xs = foldl1 preludeConj xs

291 conjAll xs = foldl1 preludeConj xs

272

292

273 toEqTest :: Expr -> Expr -> Type -> Expr

293 toEqTest :: Expr -> Expr -> Type -> Expr

@@ -278,7 +298,7 @@ deriveEq mn ds tyConNm = do

278 toEqTest l r _ = preludeEq l r

298 toEqTest l r _ = preludeEq l r

279

299

280deriveOrd ::

300deriveOrd ::

281− forall m. (Functor m, MonadError MultipleErrors m, MonadSupply m)

301+ forall m. (MonadError MultipleErrors m, MonadSupply m)

282 => ModuleName

302 => ModuleName

283 -> [Declaration]

303 -> [Declaration]

284 -> ProperName 'TypeName

304 -> ProperName 'TypeName

@@ -357,7 +377,7 @@ deriveOrd mn ds tyConNm = do

357 toOrdering l r _ = preludeCompare l r

377 toOrdering l r _ = preludeCompare l r

358

378

359findTypeDecl

379findTypeDecl

360− :: (Functor m, MonadError MultipleErrors m)

380+ :: (MonadError MultipleErrors m)

361 => ProperName 'TypeName

381 => ProperName 'TypeName

362 -> [Declaration]

382 -> [Declaration]

363 -> m Declaration

383 -> m Declaration

src/Language/PureScript/Sugar/TypeDeclarations.hs+1−1

@@ -36,7 +36,7 @@ import Language.PureScript.Traversals

36-- |

37-- Replace all top level type declarations in a module with type annotations

38--

39−desugarTypeDeclarationsModule :: forall m. (Functor m, Applicative m, MonadError MultipleErrors m) => [Module] -> m [Module]

39+desugarTypeDeclarationsModule :: forall m. (MonadError MultipleErrors m) => [Module] -> m [Module]

40desugarTypeDeclarationsModule ms = forM ms $ \(Module ss coms name ds exps) ->

41 rethrow (addHint (ErrorInModule name)) $

42 Module ss coms name <$> desugarTypeDeclarations ds <*> pure exps

src/Language/PureScript/TypeChecker.hs+12−12

@@ -40,7 +40,7 @@ import Language.PureScript.TypeClassDictionaries

40import Language.PureScript.Types

41

42addDataType

43− :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

43+ :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

44 => ModuleName

45 -> DataDeclType

46 -> ProperName 'TypeName

@@ -56,7 +56,7 @@ addDataType moduleName dtype name args dctors ctorKind = do

56 addDataConstructor moduleName dtype name (map fst args) dctor tys

57

58addDataConstructor

59− :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

59+ :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

60 => ModuleName

61 -> DataDeclType

62 -> ProperName 'TypeName

@@ -74,7 +74,7 @@ addDataConstructor moduleName dtype name args dctor tys = do

74 putEnv $ env { dataConstructors = M.insert (Qualified (Just moduleName) dctor) (dtype, name, polyType, fields) (dataConstructors env) }

75

76addTypeSynonym

77− :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

77+ :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

78 => ModuleName

79 -> ProperName 'TypeName

80 -> [(String, Maybe Kind)]

@@ -88,7 +88,7 @@ addTypeSynonym moduleName name args ty kind = do

88 , typeSynonyms = M.insert (Qualified (Just moduleName) name) (args, ty) (typeSynonyms env) }

89

90valueIsNotDefined

91− :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

91+ :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

92 => ModuleName

93 -> Ident

94 -> m ()

@@ -99,7 +99,7 @@ valueIsNotDefined moduleName name = do

99 Nothing -> return ()

100

101addValue

102− :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

102+ :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

103 => ModuleName

104 -> Ident

105 -> Type

@@ -110,7 +110,7 @@ addValue moduleName name ty nameKind = do

110 putEnv (env { names = M.insert (moduleName, name) (ty, nameKind, Defined) (names env) })

111

112addTypeClass

113− :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

113+ :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

114 => ModuleName

115 -> ProperName 'ClassName

116 -> [(String, Maybe Kind)]

@@ -126,7 +126,7 @@ addTypeClass moduleName pn args implies ds =

126 toPair _ = internalError "Invalid declaration in TypeClassDeclaration"

127

128addTypeClassDictionaries

129− :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

129+ :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

130 => Maybe ModuleName

131 -> M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope)

132 -> m ()

@@ -135,7 +135,7 @@ addTypeClassDictionaries mn entries =

135 where insertState st = M.insertWith (M.unionWith M.union) mn entries (typeClassDictionaries . checkEnv $ st)

136

137checkDuplicateTypeArguments

138− :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

138+ :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

139 => [String]

140 -> m ()

141checkDuplicateTypeArguments args = for_ firstDup $ \dup ->

@@ -145,7 +145,7 @@ checkDuplicateTypeArguments args = for_ firstDup $ \dup ->

145 firstDup = listToMaybe $ args \\ nub args

146

147checkTypeClassInstance

148− :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

148+ :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

149 => ModuleName

150 -> Type

151 -> m ()

@@ -161,7 +161,7 @@ checkTypeClassInstance _ ty = throwError . errorMessage $ InvalidInstanceHead ty

161-- Check that type synonyms are fully-applied in a type

162--

163checkTypeSynonyms

164− :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

164+ :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

165 => Type

166 -> m ()

167checkTypeSynonyms = void . replaceAllTypeSynonyms

@@ -181,7 +181,7 @@ checkTypeSynonyms = void . replaceAllTypeSynonyms

181--

182typeCheckAll

183 :: forall m

184− . (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

184+ . (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

185 => ModuleName

186 -> [DeclarationRef]

187 -> [Declaration]

@@ -343,7 +343,7 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds

343--

344typeCheckModule

345 :: forall m

346− . (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

346+ . (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

347 => Module

348 -> m Module

349typeCheckModule (Module _ _ _ _ Nothing) = internalError "exports should have been elaborated"

src/Language/PureScript/TypeChecker/Entailment.hs+81−32

@@ -4,7 +4,7 @@

4-- |

5-- Type class entailment

6--

7−module Language.PureScript.TypeChecker.Entailment (entails) where

7+module Language.PureScript.TypeChecker.Entailment (Context, replaceTypeClassDictionaries) where

8

9import Prelude ()

10import Prelude.Compat

@@ -16,8 +16,9 @@ import qualified Data.Map as M

16

17import Control.Arrow (Arrow(..))

18import Control.Monad.State

19+import Control.Monad.Writer

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

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

20−import Control.Monad.Writer.Class (MonadWriter(..))

21+import Control.Monad.Supply.Class (MonadSupply(..))

21

22

22import Language.PureScript.Crash

23import Language.PureScript.Crash

23import Language.PureScript.AST

24import Language.PureScript.AST

@@ -28,22 +29,47 @@ import Language.PureScript.TypeClassDictionaries

28import Language.PureScript.Types

29import Language.PureScript.Types

29import qualified Language.PureScript.Constants as C

30import qualified Language.PureScript.Constants as C

30

31

32+-- | The 'Context' tracks those constraints which can be satisfied.

33+type Context = M.Map (Maybe ModuleName)

34+ (M.Map (Qualified (ProperName 'ClassName))

35+ (M.Map (Qualified Ident)

36+ TypeClassDictionaryInScope))

37+

38+-- | Merge two type class contexts

39+combineContexts :: Context -> Context -> Context

40+combineContexts = M.unionWith (M.unionWith M.union)

41+

42+-- | Replace type class dictionary placeholders with inferred type class dictionaries

43+replaceTypeClassDictionaries

44+ :: (MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m)

45+ => Bool

46+ -> ModuleName

47+ -> Expr

48+ -> m (Expr, [(Ident, Constraint)])

49+replaceTypeClassDictionaries shouldGeneralize mn =

50+ let (_, f, _) = everywhereOnValuesTopDownM return (WriterT . go) return

51+ in flip evalStateT M.empty . runWriterT . f

52+ where

53+ go (TypeClassDictionary constraint dicts) = entails shouldGeneralize mn dicts constraint

54+ go other = return (other, [])

55+

31-- |

56-- |

32-- Check that the current set of type class dictionaries entail the specified type class goal, and, if so,

57-- Check that the current set of type class dictionaries entail the specified type class goal, and, if so,

33-- return a type class dictionary reference.

58-- return a type class dictionary reference.

34--

59--

35entails

60entails

36 :: forall m

61 :: forall m

37− . (Functor m, Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

62+ . (MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m)

38− => ModuleName

63+ => Bool

39− -> M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope))

64+ -> ModuleName

65+ -> Context

40 -> Constraint

66 -> Constraint

41− -> m Expr

67+ -> StateT Context m (Expr, [(Ident, Constraint)])

42−entails moduleName context = solve

68+entails shouldGeneralize moduleName context = solve

43 where

69 where

44− forClassName :: Qualified (ProperName 'ClassName) -> [Type] -> [TypeClassDictionaryInScope]

70+ forClassName :: Context -> Qualified (ProperName 'ClassName) -> [Type] -> [TypeClassDictionaryInScope]

45− forClassName cn@(Qualified (Just mn) _) tys = concatMap (findDicts cn) (Nothing : Just mn : map Just (mapMaybe ctorModules tys))

71+ forClassName ctx cn@(Qualified (Just mn) _) tys = concatMap (findDicts ctx cn) (Nothing : Just mn : map Just (mapMaybe ctorModules tys))

46− forClassName _ _ = internalError "forClassName: expected qualified class name"

72+ forClassName _ _ _ = internalError "forClassName: expected qualified class name"

47

73

48 ctorModules :: Type -> Maybe ModuleName

74 ctorModules :: Type -> Maybe ModuleName

49 ctorModules (TypeConstructor (Qualified (Just mn) _)) = Just mn

75 ctorModules (TypeConstructor (Qualified (Just mn) _)) = Just mn

@@ -51,37 +77,58 @@ entails moduleName context = solve

51 ctorModules (TypeApp ty _) = ctorModules ty

77 ctorModules (TypeApp ty _) = ctorModules ty

52 ctorModules _ = Nothing

78 ctorModules _ = Nothing

53

79

54− findDicts :: Qualified (ProperName 'ClassName) -> Maybe ModuleName -> [TypeClassDictionaryInScope]

80+ findDicts :: Context -> Qualified (ProperName 'ClassName) -> Maybe ModuleName -> [TypeClassDictionaryInScope]

55− findDicts cn = maybe [] M.elems . (>>= M.lookup cn) . flip M.lookup context

81+ findDicts ctx cn = maybe [] M.elems . (>>= M.lookup cn) . flip M.lookup ctx

56

82

57− solve :: Constraint -> m Expr

83+ solve :: Constraint -> StateT Context m (Expr, [(Ident, Constraint)])

58 solve (className, tys) = do

84 solve (className, tys) = do

59− dict <- go 0 className tys

85+ (dict, unsolved) <- go 0 className tys

60− return $ dictionaryValueToValue dict

86+ return (dictionaryValueToValue dict, unsolved)

61 where

87 where

62− go :: Int -> Qualified (ProperName 'ClassName) -> [Type] -> m DictionaryValue

88+ go :: Int -> Qualified (ProperName 'ClassName) -> [Type] -> StateT Context m (DictionaryValue, [(Ident, Constraint)])

63 go work className' tys' | work > 1000 = throwError . errorMessage $ PossiblyInfiniteInstance className' tys'

89 go work className' tys' | work > 1000 = throwError . errorMessage $ PossiblyInfiniteInstance className' tys'

64 go work className' tys' = do

90 go work className' tys' = do

91+ -- Get the inferred constraint context so far, and merge it with the global context

92+ inferred <- get

65 let instances = do

93 let instances = do

66− tcd <- forClassName className' tys'

94+ tcd <- forClassName (combineContexts context inferred) className' tys'

67 -- Make sure the type unifies with the type in the type instance definition

95 -- Make sure the type unifies with the type in the type instance definition

68 subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName) tys' (tcdInstanceTypes tcd)

96 subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName) tys' (tcdInstanceTypes tcd)

69 return (subst, tcd)

97 return (subst, tcd)

70− (subst, tcd) <- unique instances

98+ solution <- lift $ unique instances

99+ case solution of

100+ Left (subst, tcd) -> do

71− -- Solve any necessary subgoals

101+ -- Solve any necessary subgoals

72− args <- solveSubgoals subst (tcdDependencies tcd)

102+ (args, unsolved) <- solveSubgoals subst (tcdDependencies tcd)

73− return $ foldr (\(superclassName, index) dict -> SubclassDictionaryValue dict superclassName index)

103+ let match = foldr (\(superclassName, index) dict -> SubclassDictionaryValue dict superclassName index)

74− (mkDictionary (tcdName tcd) args)

104+ (mkDictionary (tcdName tcd) args)

75− (tcdPath tcd)

105+ (tcdPath tcd)

106+ return (match, unsolved)

107+ Right unsolved@(unsolvedClassName@(Qualified _ pn), unsolvedTys) -> do

108+ -- Generate a fresh name for the unsolved constraint's new dictionary

109+ ident <- freshIdent ("dict" ++ runProperName pn)

110+ let qident = Qualified Nothing ident

111+ -- Store the new dictionary in the Context so that we can solve this goal in

112+ -- future.

113+ let newDict = TypeClassDictionaryInScope qident [] unsolvedClassName unsolvedTys Nothing

114+ newContext = M.singleton Nothing (M.singleton unsolvedClassName (M.singleton qident newDict))

115+ modify (combineContexts newContext)

116+ return (LocalDictionaryValue qident, [(ident, unsolved)])

76 where

117 where

77

118

78− unique :: [(a, TypeClassDictionaryInScope)] -> m (a, TypeClassDictionaryInScope)

119+ unique :: [(a, TypeClassDictionaryInScope)] -> m (Either (a, TypeClassDictionaryInScope) Constraint)

120+ unique [] | shouldGeneralize && all canBeGeneralized tys' = return $ Right (className, tys)

79− unique [] = throwError . errorMessage $ NoInstanceFound className' tys'

121+ | otherwise = throwError . errorMessage $ NoInstanceFound className' tys'

80− unique [a] = return a

122+ unique [a] = return $ Left a

81 unique tcds | pairwise overlapping (map snd tcds) = do

123 unique tcds | pairwise overlapping (map snd tcds) = do

82 tell . errorMessage $ OverlappingInstances className' tys' (map (tcdName . snd) tcds)

124 tell . errorMessage $ OverlappingInstances className' tys' (map (tcdName . snd) tcds)

83− return (head tcds)

125+ return $ Left (head tcds)

84− | otherwise = return (minimumBy (compare `on` length . tcdPath . snd) tcds)

126+ | otherwise = return $ Left (minimumBy (compare `on` length . tcdPath . snd) tcds)

127+

128+ canBeGeneralized :: Type -> Bool

129+ canBeGeneralized TUnknown{} = True

130+ canBeGeneralized Skolem{} = True

131+ canBeGeneralized _ = False

85

132

86 -- |

133 -- |

87 -- Check if two dictionaries are overlapping

134 -- Check if two dictionaries are overlapping

@@ -98,11 +145,12 @@ entails moduleName context = solve

98 -- Create dictionaries for subgoals which still need to be solved by calling go recursively

145 -- Create dictionaries for subgoals which still need to be solved by calling go recursively

99 -- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type

146 -- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type

100 -- unifies with Either a b, and we can satisfy the subgoals Show a and Show b recursively.

147 -- unifies with Either a b, and we can satisfy the subgoals Show a and Show b recursively.

101− solveSubgoals :: [(String, Type)] -> Maybe [Constraint] -> m (Maybe [DictionaryValue])

148+ solveSubgoals :: [(String, Type)] -> Maybe [Constraint] -> StateT Context m (Maybe [DictionaryValue], [(Ident, Constraint)])

102− solveSubgoals _ Nothing = return Nothing

149+ solveSubgoals _ Nothing = return (Nothing, [])

103 solveSubgoals subst (Just subgoals) = do

150 solveSubgoals subst (Just subgoals) = do

104− dict <- traverse (uncurry (go (work + 1)) . second (map (replaceAllTypeVars subst))) subgoals

151+ zipped <- traverse (uncurry (go (work + 1)) . second (map (replaceAllTypeVars subst))) subgoals

152+ let (dicts, unsolved) = unzip zipped

105− return $ Just dict

153+ return (Just dicts, concat unsolved)

106

154

107 -- Make a dictionary from subgoal dictionaries by applying the correct function

155 -- Make a dictionary from subgoal dictionaries by applying the correct function

108 mkDictionary :: Qualified Ident -> Maybe [DictionaryValue] -> DictionaryValue

156 mkDictionary :: Qualified Ident -> Maybe [DictionaryValue] -> DictionaryValue

@@ -134,6 +182,7 @@ entails moduleName context = solve

134-- and return a substitution from type variables to types which makes the type heads unify.

182-- and return a substitution from type variables to types which makes the type heads unify.

135--

183--

136typeHeadsAreEqual :: ModuleName -> Type -> Type -> Maybe [(String, Type)]

184typeHeadsAreEqual :: ModuleName -> Type -> Type -> Maybe [(String, Type)]

185+typeHeadsAreEqual _ (TUnknown u1) (TUnknown u2) | u1 == u2 = Just []

137typeHeadsAreEqual _ (Skolem _ s1 _ _) (Skolem _ s2 _ _) | s1 == s2 = Just []

186typeHeadsAreEqual _ (Skolem _ s1 _ _) (Skolem _ s2 _ _) | s1 == s2 = Just []

138typeHeadsAreEqual _ t (TypeVar v) = Just [(v, t)]

187typeHeadsAreEqual _ t (TypeVar v) = Just [(v, t)]

139typeHeadsAreEqual _ (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = Just []

188typeHeadsAreEqual _ (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = Just []

src/Language/PureScript/TypeChecker/Kinds.hs+11−11

@@ -43,7 +43,7 @@ freshKind = do

43

44-- | Update the substitution to solve a kind constraint

45solveKind

46− :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m)

46+ :: (MonadError MultipleErrors m, MonadState CheckState m)

47 => Int

48 -> Kind

49 -> m ()

@@ -68,7 +68,7 @@ substituteKind sub = everywhereOnKinds go

68

69-- | Make sure that an unknown does not occur in a kind

70occursCheck

71− :: (Functor m, Applicative m, MonadError MultipleErrors m)

71+ :: (MonadError MultipleErrors m)

72 => Int

73 -> Kind

74 -> m ()

@@ -80,7 +80,7 @@ occursCheck u k = void $ everywhereOnKindsM go k

80

81-- | Unify two kinds

82unifyKinds

83− :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m)

83+ :: (MonadError MultipleErrors m, MonadState CheckState m)

84 => Kind

85 -> Kind

86 -> m ()

@@ -101,14 +101,14 @@ unifyKinds k1 k2 = do

101

102-- | Infer the kind of a single type

103kindOf

104− :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m)

104+ :: (MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m)

105 => Type

106 -> m Kind

107kindOf ty = fst <$> kindOfWithScopedVars ty

108

109-- | Infer the kind of a single type, returning the kinds of any scoped type variables

110kindOfWithScopedVars ::

111− (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m) =>

111+ (MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m) =>

112 Type ->

113 m (Kind, [(String, Kind)])

114kindOfWithScopedVars ty =

@@ -121,7 +121,7 @@ kindOfWithScopedVars ty =

121

122-- | Infer the kind of a type constructor with a collection of arguments and a collection of associated data constructors

123kindsOf

124− :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m)

124+ :: (MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m)

125 => Bool

126 -> ModuleName

127 -> ProperName 'TypeName

@@ -139,7 +139,7 @@ kindsOf isData moduleName name args ts = fmap tidyUp . liftUnify $ do

139 tidyUp (k, sub) = starIfUnknown $ substituteKind sub k

140

141freshKindVar

142− :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m)

142+ :: (MonadError MultipleErrors m, MonadState CheckState m)

143 => (String, Maybe Kind)

144 -> Kind

145 -> m (ProperName 'TypeName, Kind)

@@ -150,7 +150,7 @@ freshKindVar (arg, Just kind') kind = do

150

151-- | Simultaneously infer the kinds of several mutually recursive type constructors

152kindsOfAll

153− :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m)

153+ :: (MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m)

154 => ModuleName

155 -> [(ProperName 'TypeName, [(String, Maybe Kind)], Type)]

156 -> [(ProperName 'TypeName, [(String, Maybe Kind)], [Type])]

@@ -178,7 +178,7 @@ kindsOfAll moduleName syns tys = fmap tidyUp . liftUnify $ do

178

179-- | Solve the set of kind constraints associated with the data constructors for a type constructor

180solveTypes

181− :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m)

181+ :: (MonadError MultipleErrors m, MonadState CheckState m)

182 => Bool

183 -> [Type]

184 -> [Kind]

@@ -202,14 +202,14 @@ starIfUnknown k = k

202

203-- | Infer a kind for a type

204infer

205− :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m)

205+ :: (MonadError MultipleErrors m, MonadState CheckState m)

206 => Type

207 -> m (Kind, [(String, Kind)])

208infer ty = rethrow (addHint (ErrorCheckingKind ty)) $ infer' ty

209

210infer'

211 :: forall m

212− . (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m)

212+ . (MonadError MultipleErrors m, MonadState CheckState m)

213 => Type

214 -> m (Kind, [(String, Kind)])

215infer' (ForAll ident ty _) = do

src/Language/PureScript/TypeChecker/Monad.hs+15−15

@@ -84,7 +84,7 @@ bindTypes newNames action = do

84

85-- | Temporarily bind a collection of names to types

86withScopedTypeVars

87− :: (Functor m, Applicative m, MonadState CheckState m, MonadWriter MultipleErrors m)

87+ :: (MonadState CheckState m, MonadWriter MultipleErrors m)

88 => ModuleName

89 -> [(String, Kind)]

90 -> m a

@@ -112,20 +112,20 @@ withTypeClassDictionaries entries action = do

112

113-- | Get the currently available map of type class dictionaries

114getTypeClassDictionaries

115− :: (Functor m, MonadState CheckState m)

115+ :: (MonadState CheckState m)

116 => m (M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope)))

117getTypeClassDictionaries = typeClassDictionaries . checkEnv <$> get

118

119-- | Lookup type class dictionaries in a module.

120lookupTypeClassDictionaries

121− :: (Functor m, MonadState CheckState m)

121+ :: (MonadState CheckState m)

122 => Maybe ModuleName

123 -> m (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope))

124lookupTypeClassDictionaries mn = fromMaybe M.empty . M.lookup mn . typeClassDictionaries . checkEnv <$> get

125

126-- | Temporarily bind a collection of names to local variables

127bindLocalVariables

128− :: (Functor m, MonadState CheckState m)

128+ :: (MonadState CheckState m)

129 => ModuleName

130 -> [(Ident, Type, NameVisibility)]

131 -> m a

@@ -135,7 +135,7 @@ bindLocalVariables moduleName bindings =

135

136-- | Temporarily bind a collection of names to local type variables

137bindLocalTypeVariables

138− :: (Functor m, MonadState CheckState m)

138+ :: (MonadState CheckState m)

139 => ModuleName

140 -> [(ProperName 'TypeName, Kind)]

141 -> m a

@@ -144,15 +144,15 @@ bindLocalTypeVariables moduleName bindings =

144 bindTypes (M.fromList $ flip map bindings $ \(pn, kind) -> (Qualified (Just moduleName) pn, (kind, LocalTypeVariable)))

145

146-- | Update the visibility of all names to Defined

147−makeBindingGroupVisible :: (Functor m, MonadState CheckState m) => m ()

147+makeBindingGroupVisible :: (MonadState CheckState m) => m ()

148makeBindingGroupVisible = modifyEnv $ \e -> e { names = M.map (\(ty, nk, _) -> (ty, nk, Defined)) (names e) }

149

150-- | Update the visibility of all names to Defined in the scope of the provided action

151−withBindingGroupVisible :: (Functor m, MonadState CheckState m) => m a -> m a

151+withBindingGroupVisible :: (MonadState CheckState m) => m a -> m a

152withBindingGroupVisible action = preservingNames $ makeBindingGroupVisible >> action

153

154-- | Perform an action while preserving the names from the @Environment@.

155−preservingNames :: (Functor m, MonadState CheckState m) => m a -> m a

155+preservingNames :: (MonadState CheckState m) => m a -> m a

156preservingNames action = do

157 orig <- gets (names . checkEnv)

158 a <- action

@@ -161,7 +161,7 @@ preservingNames action = do

161

162-- | Lookup the type of a value by name in the @Environment@

163lookupVariable

164− :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m)

164+ :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m)

165 => ModuleName

166 -> Qualified Ident

167 -> m Type

@@ -173,7 +173,7 @@ lookupVariable currentModule (Qualified moduleName var) = do

173

174-- | Lookup the visibility of a value by name in the @Environment@

175getVisibility

176− :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m)

176+ :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m)

177 => ModuleName

178 -> Qualified Ident

179 -> m NameVisibility

@@ -185,7 +185,7 @@ getVisibility currentModule (Qualified moduleName var) = do

185

186-- | Assert that a name is visible

187checkVisibility

188− :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m)

188+ :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m)

189 => ModuleName

190 -> Qualified Ident

191 -> m ()

@@ -197,7 +197,7 @@ checkVisibility currentModule name@(Qualified _ var) = do

197

198-- | Lookup the kind of a type by name in the @Environment@

199lookupTypeVariable

200− :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m)

200+ :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m)

201 => ModuleName

202 -> Qualified (ProperName 'TypeName)

203 -> m Kind

@@ -208,7 +208,7 @@ lookupTypeVariable currentModule (Qualified moduleName name) = do

208 Just (k, _) -> return k

209

210-- | Get the current @Environment@

211−getEnv :: (Functor m, MonadState CheckState m) => m Environment

211+getEnv :: (MonadState CheckState m) => m Environment

212getEnv = checkEnv <$> get

213

214-- | Update the @Environment@

@@ -234,14 +234,14 @@ guardWith e False = throwError e

234

235-- | Run a computation in the substitution monad, generating a return value and the final substitution.

236liftUnify ::

237− (Functor m, MonadState CheckState m, MonadWriter MultipleErrors m, MonadError MultipleErrors m) =>

237+ (MonadState CheckState m, MonadWriter MultipleErrors m, MonadError MultipleErrors m) =>

238 m a ->

239 m (a, Substitution)

240liftUnify = liftUnifyWarnings (const id)

241

242-- | Run a computation in the substitution monad, generating a return value, the final substitution and updating warnings values.

243liftUnifyWarnings ::

244− (Functor m, MonadState CheckState m, MonadWriter MultipleErrors m, MonadError MultipleErrors m) =>

244+ (MonadState CheckState m, MonadWriter MultipleErrors m, MonadError MultipleErrors m) =>

245 (Substitution -> ErrorMessage -> ErrorMessage) ->

246 m a ->

247 m (a, Substitution)

src/Language/PureScript/TypeChecker/Rows.hs+1−1

@@ -36,7 +36,7 @@ import Language.PureScript.TypeChecker.Monad

36import Language.PureScript.Types

37

38-- | Ensure rows do not contain duplicate labels

39−checkDuplicateLabels :: forall m. (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Expr -> m ()

39+checkDuplicateLabels :: forall m. (MonadError MultipleErrors m, MonadState CheckState m) => Expr -> m ()

40checkDuplicateLabels =

41 let (_, f, _) = everywhereOnValuesM def go def

42 in void . f

src/Language/PureScript/TypeChecker/Skolems.hs+1−1

@@ -53,7 +53,7 @@ newSkolemConstant = do

53-- |

54-- Introduce skolem scope at every occurence of a ForAll

55--

56−introduceSkolemScope :: (Functor m, Applicative m, MonadState CheckState m) => Type -> m Type

56+introduceSkolemScope :: (MonadState CheckState m) => Type -> m Type

57introduceSkolemScope = everywhereOnTypesM go

58 where

59 go (ForAll ident ty Nothing) = ForAll ident ty <$> (Just <$> newSkolemScope)

src/Language/PureScript/TypeChecker/Subsumption.hs+2−2

@@ -39,11 +39,11 @@ import Language.PureScript.TypeChecker.Unify

39import Language.PureScript.Types

40

41-- | Check that one type subsumes another, rethrowing errors to provide a better error message

42−subsumes :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Maybe Expr -> Type -> Type -> m (Maybe Expr)

42+subsumes :: (MonadError MultipleErrors m, MonadState CheckState m) => Maybe Expr -> Type -> Type -> m (Maybe Expr)

43subsumes val ty1 ty2 = rethrow (addHint (ErrorInSubsumption ty1 ty2)) $ subsumes' val ty1 ty2

44

45-- | Check tahat one type subsumes another

46−subsumes' :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) =>

46+subsumes' :: (MonadError MultipleErrors m, MonadState CheckState m) =>

47 Maybe Expr ->

48 Type ->

49 Type ->

src/Language/PureScript/TypeChecker/Synonyms.hs+1−1

@@ -57,7 +57,7 @@ replaceAllTypeSynonyms' env = everywhereOnTypesTopDownM try

57 go c args (TypeApp f arg) = go (c + 1) (arg : args) f

58 go _ _ _ = return Nothing

59

60−replaceAllTypeSynonyms :: (e ~ MultipleErrors, Functor m, Monad m, MonadState CheckState m, MonadError e m) => Type -> m Type

60+replaceAllTypeSynonyms :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m) => Type -> m Type

61replaceAllTypeSynonyms d = do

62 env <- getEnv

63 either throwError return $ replaceAllTypeSynonyms' env d

src/Language/PureScript/TypeChecker/Types.hs+72−90

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

2{-# LANGUAGE ScopedTypeVariables #-}

3{-# LANGUAGE MultiParamTypeClasses #-}

4{-# LANGUAGE OverloadedStrings #-}

5+{-# LANGUAGE TupleSections #-}

5

6

6-- |

7-- |

7-- This module implements the type checker

8-- This module implements the type checker

@@ -61,7 +62,7 @@ import Language.PureScript.Types

61-- | Infer the types of multiple mutually-recursive values, and return elaborated values including

62-- | Infer the types of multiple mutually-recursive values, and return elaborated values including

62-- type class dictionaries and type annotations.

63-- type class dictionaries and type annotations.

63typesOf ::

64typesOf ::

64− (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

65+ (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

65 ModuleName ->

66 ModuleName ->

66 [(Ident, Expr)] ->

67 [(Ident, Expr)] ->

67 m [(Ident, (Expr, Type))]

68 m [(Ident, (Expr, Type))]

@@ -69,23 +70,38 @@ typesOf moduleName vals = do

69 tys <- fmap tidyUp . liftUnifyWarnings replace $ do

70 tys <- fmap tidyUp . liftUnifyWarnings replace $ do

70 (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName vals

71 (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName vals

71 ds1 <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict

72 ds1 <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict

72− ds2 <- forM untyped $ \e -> typeForBindingGroupElement True e dict untypedDict

73+ ds2 <- forM untyped $ \e -> typeForBindingGroupElement e dict untypedDict

73− return $ ds1 ++ ds2

74+ return (map (\x -> (False, x)) ds1 ++ map (\x -> (True, x)) ds2)

74

75

75− forM tys $ \(ident, (val, ty)) -> do

76+ forM tys $ \(shouldGeneralize, (ident, (val, ty))) -> do

76 -- Replace type class dictionary placeholders with actual dictionaries

77 -- Replace type class dictionary placeholders with actual dictionaries

77− val' <- replaceTypeClassDictionaries moduleName val

78+ (val', unsolved) <- replaceTypeClassDictionaries shouldGeneralize moduleName val

79+ let unsolvedTypeVars = nub $ unknownsInType ty

80+ -- Generalize and constrain the type

81+ let generalized = generalize unsolved ty

82+ -- Make sure any unsolved type constraints only use type variables which appear

83+ -- unknown in the inferred type.

84+ when shouldGeneralize $ do

85+ tell . errorMessage $ MissingTypeDeclaration ident generalized

86+ forM_ unsolved $ \(_, (className, classTys)) -> do

87+ let constraintTypeVars = nub $ foldMap unknownsInType classTys

88+ when (any (`notElem` unsolvedTypeVars) constraintTypeVars) $

89+ throwError . errorMessage $ NoInstanceFound className classTys

78 -- Check skolem variables did not escape their scope

90 -- Check skolem variables did not escape their scope

79 skolemEscapeCheck val'

91 skolemEscapeCheck val'

80 -- Check rows do not contain duplicate labels

92 -- Check rows do not contain duplicate labels

81 checkDuplicateLabels val'

93 checkDuplicateLabels val'

82− return (ident, (val', varIfUnknown ty))

94+ return (ident, (foldr (Abs . Left . fst) val' unsolved, generalized))

83 where

95 where

96+ -- | Generalize type vars using forall and add inferred constraints

97+ generalize unsolved = varIfUnknown . constrain unsolved

98+ -- | Add any unsolved constraints

99+ constrain [] = id

100+ constrain cs = ConstrainedType (map snd cs)

84 -- Apply the substitution that was returned from runUnify to both types and (type-annotated) values

101 -- Apply the substitution that was returned from runUnify to both types and (type-annotated) values

85− tidyUp (ts, sub) = map (\(i, (val, ty)) -> (i, (overTypes (substituteType sub) val, substituteType sub ty))) ts

102+ tidyUp (ts, sub) = map (\(b, (i, (val, ty))) -> (b, (i, (overTypes (substituteType sub) val, substituteType sub ty)))) ts

86 -- Replace all the wildcards types with their inferred types

103 -- Replace all the wildcards types with their inferred types

87 replace sub (ErrorMessage hints (WildcardInferredType ty)) = ErrorMessage hints . WildcardInferredType $ substituteType sub ty

104 replace sub (ErrorMessage hints (WildcardInferredType ty)) = ErrorMessage hints . WildcardInferredType $ substituteType sub ty

88− replace sub (ErrorMessage hints (MissingTypeDeclaration name ty)) = ErrorMessage hints $ MissingTypeDeclaration name (varIfUnknown (substituteType sub ty))

89 replace _ em = em

105 replace _ em = em

90

106

91type TypeData = M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility)

107type TypeData = M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility)

@@ -93,7 +109,7 @@ type TypeData = M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility)

93type UntypedData = [(Ident, Type)]

109type UntypedData = [(Ident, Type)]

94

110

95typeDictionaryForBindingGroup ::

111typeDictionaryForBindingGroup ::

96− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

112+ (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

97 ModuleName ->

113 ModuleName ->

98 [(Ident, Expr)] ->

114 [(Ident, Expr)] ->

99 m ([(Ident, Expr)], [(Ident, (Expr, Type, Bool))], TypeData, UntypedData)

115 m ([(Ident, Expr)], [(Ident, (Expr, Type, Bool))], TypeData, UntypedData)

@@ -118,7 +134,7 @@ typeDictionaryForBindingGroup moduleName vals = do

118 return (untyped, typed, dict, untypedDict)

134 return (untyped, typed, dict, untypedDict)

119

135

120checkTypedBindingGroupElement ::

136checkTypedBindingGroupElement ::

121− (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

137+ (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

122 ModuleName ->

138 ModuleName ->

123 (Ident, (Expr, Type, Bool)) ->

139 (Ident, (Expr, Type, Bool)) ->

124 TypeData ->

140 TypeData ->

@@ -137,17 +153,15 @@ checkTypedBindingGroupElement mn (ident, (val', ty, checkType)) dict = do

137 return (ident, (val'', ty''))

153 return (ident, (val'', ty''))

138

154

139typeForBindingGroupElement ::

155typeForBindingGroupElement ::

140− (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

156+ (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

141− Bool ->

142 (Ident, Expr) ->

157 (Ident, Expr) ->

143 TypeData ->

158 TypeData ->

144 UntypedData ->

159 UntypedData ->

145 m (Ident, (Expr, Type))

160 m (Ident, (Expr, Type))

146−typeForBindingGroupElement warn (ident, val) dict untypedDict = do

161+typeForBindingGroupElement (ident, val) dict untypedDict = do

147 -- Infer the type with the new names in scope

162 -- Infer the type with the new names in scope

148 TypedValue _ val' ty <- bindNames dict $ infer val

163 TypedValue _ val' ty <- bindNames dict $ infer val

149 unifyTypes ty $ fromMaybe (internalError "name not found in dictionary") (lookup ident untypedDict)

164 unifyTypes ty $ fromMaybe (internalError "name not found in dictionary") (lookup ident untypedDict)

150− when warn . tell . errorMessage $ MissingTypeDeclaration ident ty

151 return (ident, (TypedValue True val' ty, ty))

165 return (ident, (TypedValue True val' ty, ty))

152

166

153-- | Check if a value contains a type annotation

167-- | Check if a value contains a type annotation

@@ -165,23 +179,10 @@ overTypes f = let (_, f', _) = everywhereOnValues id g id in f'

165 g (TypedValue checkTy val t) = TypedValue checkTy val (f t)

179 g (TypedValue checkTy val t) = TypedValue checkTy val (f t)

166 g (TypeClassDictionary (nm, tys) sco) = TypeClassDictionary (nm, map f tys) sco

180 g (TypeClassDictionary (nm, tys) sco) = TypeClassDictionary (nm, map f tys) sco

167 g other = other

181 g other = other

168−

182+

169−-- | Replace type class dictionary placeholders with inferred type class dictionaries

170−replaceTypeClassDictionaries ::

171− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

172− ModuleName ->

173− Expr ->

174− m Expr

175−replaceTypeClassDictionaries mn =

176− let (_, f, _) = everywhereOnValuesTopDownM return go return

177− in f

178− where

179− go (TypeClassDictionary constraint dicts) = entails mn dicts constraint

180− go other = return other

181−

182-- | Check the kind of a type, failing if it is not of kind *.

183-- | Check the kind of a type, failing if it is not of kind *.

183checkTypeKind ::

184checkTypeKind ::

184− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m) =>

185+ (MonadState CheckState m, MonadError MultipleErrors m) =>

185 Type ->

186 Type ->

186 Kind ->

187 Kind ->

187 m ()

188 m ()

@@ -193,7 +194,7 @@ checkTypeKind ty kind = guardWith (errorMessage (ExpectedType ty kind)) $ kind =

193-- This is necessary during type checking to avoid unifying a polymorphic type with a

194-- This is necessary during type checking to avoid unifying a polymorphic type with a

194-- unification variable.

195-- unification variable.

195instantiatePolyTypeWithUnknowns ::

196instantiatePolyTypeWithUnknowns ::

196− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m) =>

197+ (MonadState CheckState m, MonadError MultipleErrors m) =>

197 Expr ->

198 Expr ->

198 Type ->

199 Type ->

199 m (Expr, Type)

200 m (Expr, Type)

@@ -207,32 +208,32 @@ instantiatePolyTypeWithUnknowns val ty = return (val, ty)

207

208

208-- | Infer a type for a value, rethrowing any error to provide a more useful error message

209-- | Infer a type for a value, rethrowing any error to provide a more useful error message

209infer ::

210infer ::

210− (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

211+ (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

211 Expr ->

212 Expr ->

212 m Expr

213 m Expr

213infer val = rethrow (addHint (ErrorInferringType val)) $ infer' val

214infer val = rethrow (addHint (ErrorInferringType val)) $ infer' val

214

215

215-- | Infer a type for a value

216-- | Infer a type for a value

216infer' ::

217infer' ::

217− (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

218+ (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

218 Expr ->

219 Expr ->

219 m Expr

220 m Expr

220−infer' v@(NumericLiteral (Left _)) = return $ TypedValue True v tyInt

221+infer' v@(Literal (NumericLiteral (Left _))) = return $ TypedValue True v tyInt

221−infer' v@(NumericLiteral (Right _)) = return $ TypedValue True v tyNumber

222+infer' v@(Literal (NumericLiteral (Right _))) = return $ TypedValue True v tyNumber

222−infer' v@(StringLiteral _) = return $ TypedValue True v tyString

223+infer' v@(Literal (StringLiteral _)) = return $ TypedValue True v tyString

223−infer' v@(CharLiteral _) = return $ TypedValue True v tyChar

224+infer' v@(Literal (CharLiteral _)) = return $ TypedValue True v tyChar

224−infer' v@(BooleanLiteral _) = return $ TypedValue True v tyBoolean

225+infer' v@(Literal (BooleanLiteral _)) = return $ TypedValue True v tyBoolean

225−infer' (ArrayLiteral vals) = do

226+infer' (Literal (ArrayLiteral vals)) = do

226 ts <- traverse infer vals

227 ts <- traverse infer vals

227 els <- freshType

228 els <- freshType

228 forM_ ts $ \(TypedValue _ _ t) -> unifyTypes els t

229 forM_ ts $ \(TypedValue _ _ t) -> unifyTypes els t

229− return $ TypedValue True (ArrayLiteral ts) (TypeApp tyArray els)

230+ return $ TypedValue True (Literal (ArrayLiteral ts)) (TypeApp tyArray els)

230−infer' (ObjectLiteral ps) = do

231+infer' (Literal (ObjectLiteral ps)) = do

231 ensureNoDuplicateProperties ps

232 ensureNoDuplicateProperties ps

232 ts <- traverse (infer . snd) ps

233 ts <- traverse (infer . snd) ps

233 let fields = zipWith (\name (TypedValue _ _ t) -> (name, t)) (map fst ps) ts

234 let fields = zipWith (\name (TypedValue _ _ t) -> (name, t)) (map fst ps) ts

234 ty = TypeApp tyObject $ rowFromList (fields, REmpty)

235 ty = TypeApp tyObject $ rowFromList (fields, REmpty)

235− return $ TypedValue True (ObjectLiteral (zip (map fst ps) ts)) ty

236+ return $ TypedValue True (Literal (ObjectLiteral (zip (map fst ps) ts))) ty

236infer' (ObjectUpdate o ps) = do

237infer' (ObjectUpdate o ps) = do

237 ensureNoDuplicateProperties ps

238 ensureNoDuplicateProperties ps

238 row <- freshType

239 row <- freshType

@@ -280,10 +281,10 @@ infer' (Case vals binders) = do

280 return $ TypedValue True (Case vals' binders') ret

281 return $ TypedValue True (Case vals' binders') ret

281infer' (IfThenElse cond th el) = do

282infer' (IfThenElse cond th el) = do

282 cond' <- check cond tyBoolean

283 cond' <- check cond tyBoolean

283− v2@(TypedValue _ _ t2) <- infer th

284+ th'@(TypedValue _ _ thTy) <- infer th

284− v3@(TypedValue _ _ t3) <- infer el

285+ el'@(TypedValue _ _ elTy) <- infer el

285− (v2', v3', t) <- meet v2 v3 t2 t3

286+ unifyTypes thTy elTy

286− return $ TypedValue True (IfThenElse cond' v2' v3') t

287+ return $ TypedValue True (IfThenElse cond' th' el') thTy

287infer' (Let ds val) = do

288infer' (Let ds val) = do

288 (ds', val'@(TypedValue _ _ valTy)) <- inferLetBinding [] ds val infer

289 (ds', val'@(TypedValue _ _ valTy)) <- inferLetBinding [] ds val infer

289 return $ TypedValue True (Let ds' val') valTy

290 return $ TypedValue True (Let ds' val') valTy

@@ -303,7 +304,7 @@ infer' (PositionedValue pos c val) = warnAndRethrowWithPosition pos $ do

303infer' _ = internalError "Invalid argument to infer"

304infer' _ = internalError "Invalid argument to infer"

304

305

305inferLetBinding ::

306inferLetBinding ::

306− (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

307+ (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

307 [Declaration] ->

308 [Declaration] ->

309 [Declaration] ->

309 Expr ->

310 Expr ->

@@ -329,7 +330,7 @@ inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do

329 Just moduleName <- checkCurrentModule <$> get

330 Just moduleName <- checkCurrentModule <$> get

330 (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName (map (\(i, _, v) -> (i, v)) ds)

331 (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName (map (\(i, _, v) -> (i, v)) ds)

331 ds1' <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict

332 ds1' <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict

332− ds2' <- forM untyped $ \e -> typeForBindingGroupElement False e dict untypedDict

333+ ds2' <- forM untyped $ \e -> typeForBindingGroupElement e dict untypedDict

333 let ds' = [(ident, Private, val') | (ident, (val', _)) <- ds1' ++ ds2']

334 let ds' = [(ident, Private, val') | (ident, (val', _)) <- ds1' ++ ds2']

334 bindNames dict $ do

335 bindNames dict $ do

335 makeBindingGroupVisible

336 makeBindingGroupVisible

@@ -341,16 +342,16 @@ inferLetBinding _ _ _ _ = internalError "Invalid argument to inferLetBinding"

341

342

342-- | Infer the types of variables brought into scope by a binder

343-- | Infer the types of variables brought into scope by a binder

343inferBinder :: forall m.

344inferBinder :: forall m.

344− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

345+ (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

345 Type ->

346 Type ->

346 Binder ->

347 Binder ->

347 m (M.Map Ident Type)

348 m (M.Map Ident Type)

348inferBinder _ NullBinder = return M.empty

349inferBinder _ NullBinder = return M.empty

349−inferBinder val (StringBinder _) = unifyTypes val tyString >> return M.empty

350+inferBinder val (LiteralBinder (StringLiteral _)) = unifyTypes val tyString >> return M.empty

350−inferBinder val (CharBinder _) = unifyTypes val tyChar >> return M.empty

351+inferBinder val (LiteralBinder (CharLiteral _)) = unifyTypes val tyChar >> return M.empty

351−inferBinder val (NumberBinder (Left _)) = unifyTypes val tyInt >> return M.empty

352+inferBinder val (LiteralBinder (NumericLiteral (Left _))) = unifyTypes val tyInt >> return M.empty

352−inferBinder val (NumberBinder (Right _)) = unifyTypes val tyNumber >> return M.empty

353+inferBinder val (LiteralBinder (NumericLiteral (Right _))) = unifyTypes val tyNumber >> return M.empty

353−inferBinder val (BooleanBinder _) = unifyTypes val tyBoolean >> return M.empty

354+inferBinder val (LiteralBinder (BooleanLiteral _)) = unifyTypes val tyBoolean >> return M.empty

354inferBinder val (VarBinder name) = return $ M.singleton name val

355inferBinder val (VarBinder name) = return $ M.singleton name val

355inferBinder val (ConstructorBinder ctor binders) = do

356inferBinder val (ConstructorBinder ctor binders) = do

356 env <- getEnv

357 env <- getEnv

@@ -369,7 +370,7 @@ inferBinder val (ConstructorBinder ctor binders) = do

369 where

370 where

370 go args (TypeApp (TypeApp fn arg) ret) | fn == tyFunction = go (arg : args) ret

371 go args (TypeApp (TypeApp fn arg) ret) | fn == tyFunction = go (arg : args) ret

371 go args ret = (args, ret)

372 go args ret = (args, ret)

372−inferBinder val (ObjectBinder props) = do

373+inferBinder val (LiteralBinder (ObjectLiteral props)) = do

373 row <- freshType

374 row <- freshType

374 rest <- freshType

375 rest <- freshType

375 m1 <- inferRowProperties row rest props

376 m1 <- inferRowProperties row rest props

@@ -383,7 +384,7 @@ inferBinder val (ObjectBinder props) = do

383 m1 <- inferBinder propTy binder

384 m1 <- inferBinder propTy binder

384 m2 <- inferRowProperties nrow (RCons name propTy row) binders

385 m2 <- inferRowProperties nrow (RCons name propTy row) binders

385 return $ m1 `M.union` m2

386 return $ m1 `M.union` m2

386−inferBinder val (ArrayBinder binders) = do

387+inferBinder val (LiteralBinder (ArrayLiteral binders)) = do

387 el <- freshType

388 el <- freshType

388 m1 <- M.unions <$> traverse (inferBinder el) binders

389 m1 <- M.unions <$> traverse (inferBinder el) binders

389 unifyTypes val (TypeApp tyArray el)

390 unifyTypes val (TypeApp tyArray el)

@@ -420,7 +421,7 @@ binderRequiresMonotype _ = True

420

421

421-- | Instantiate polytypes only when necessitated by a binder.

422-- | Instantiate polytypes only when necessitated by a binder.

422instantiateForBinders ::

423instantiateForBinders ::

423− (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

424+ (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

424 [Expr] ->

425 [Expr] ->

425 [CaseAlternative] ->

426 [CaseAlternative] ->

426 m ([Expr], [Type])

427 m ([Expr], [Type])

@@ -437,7 +438,7 @@ instantiateForBinders vals cas = unzip <$> zipWithM (\val inst -> do

437-- Check the types of the return values in a set of binders in a case statement

438-- Check the types of the return values in a set of binders in a case statement

438--

439--

439checkBinders ::

440checkBinders ::

440− (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

441+ (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

441 [Type] ->

442 [Type] ->

442 Type ->

443 Type ->

443 [CaseAlternative] ->

444 [CaseAlternative] ->

@@ -467,7 +468,7 @@ checkBinders nvals ret (CaseAlternative binders result : bs) = do

467-- Check the type of a value, rethrowing errors to provide a better error message

468-- Check the type of a value, rethrowing errors to provide a better error message

468--

469--

469check ::

470check ::

470− (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

471+ (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

471 Expr ->

472 Expr ->

472 Type ->

473 Type ->

473 m Expr

474 m Expr

@@ -478,7 +479,7 @@ check val ty = rethrow (addHint (ErrorCheckingType val ty)) $ check' val ty

478--

479--

479check'

480check'

480 :: forall m

481 :: forall m

481− . (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

482+ . (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)

482 => Expr

483 => Expr

483 -> Type

484 -> Type

484 -> m Expr

485 -> m Expr

@@ -524,19 +525,19 @@ check' val u@(TUnknown _) = do

524 (val'', ty') <- instantiatePolyTypeWithUnknowns val' ty

525 (val'', ty') <- instantiatePolyTypeWithUnknowns val' ty

525 unifyTypes ty' u

526 unifyTypes ty' u

526 return $ TypedValue True val'' ty'

527 return $ TypedValue True val'' ty'

527−check' v@(NumericLiteral (Left _)) t | t == tyInt =

528+check' v@(Literal (NumericLiteral (Left _))) t | t == tyInt =

528 return $ TypedValue True v t

529 return $ TypedValue True v t

529−check' v@(NumericLiteral (Right _)) t | t == tyNumber =

530+check' v@(Literal (NumericLiteral (Right _))) t | t == tyNumber =

530 return $ TypedValue True v t

531 return $ TypedValue True v t

531−check' v@(StringLiteral _) t | t == tyString =

532+check' v@(Literal (StringLiteral _)) t | t == tyString =

532 return $ TypedValue True v t

533 return $ TypedValue True v t

533−check' v@(CharLiteral _) t | t == tyChar =

534+check' v@(Literal (CharLiteral _)) t | t == tyChar =

534 return $ TypedValue True v t

535 return $ TypedValue True v t

535−check' v@(BooleanLiteral _) t | t == tyBoolean =

536+check' v@(Literal (BooleanLiteral _)) t | t == tyBoolean =

536 return $ TypedValue True v t

537 return $ TypedValue True v t

537−check' (ArrayLiteral vals) t@(TypeApp a ty) = do

538+check' (Literal (ArrayLiteral vals)) t@(TypeApp a ty) = do

538 unifyTypes a tyArray

539 unifyTypes a tyArray

539− array <- ArrayLiteral <$> forM vals (`check` ty)

540+ array <- Literal . ArrayLiteral <$> forM vals (`check` ty)

540 return $ TypedValue True array t

541 return $ TypedValue True array t

541check' (Abs (Left arg) ret) ty@(TypeApp (TypeApp t argTy) retTy) = do

542check' (Abs (Left arg) ret) ty@(TypeApp (TypeApp t argTy) retTy) = do

542 unifyTypes t tyFunction

543 unifyTypes t tyFunction

@@ -587,10 +588,10 @@ check' (IfThenElse cond th el) ty = do

587 th' <- check th ty

588 th' <- check th ty

588 el' <- check el ty

589 el' <- check el ty

589 return $ TypedValue True (IfThenElse cond' th' el') ty

590 return $ TypedValue True (IfThenElse cond' th' el') ty

590−check' e@(ObjectLiteral ps) t@(TypeApp obj row) | obj == tyObject = do

591+check' e@(Literal (ObjectLiteral ps)) t@(TypeApp obj row) | obj == tyObject = do

591 ensureNoDuplicateProperties ps

592 ensureNoDuplicateProperties ps

592 ps' <- checkProperties e ps row False

593 ps' <- checkProperties e ps row False

593− return $ TypedValue True (ObjectLiteral ps') t

594+ return $ TypedValue True (Literal (ObjectLiteral ps')) t

594check' (TypeClassDictionaryConstructorApp name ps) t = do

595check' (TypeClassDictionaryConstructorApp name ps) t = do

595 ps' <- check' ps t

596 ps' <- check' ps t

596 return $ TypedValue True (TypeClassDictionaryConstructorApp name ps') t

597 return $ TypedValue True (TypeClassDictionaryConstructorApp name ps') t

@@ -641,7 +642,7 @@ check' val ty = do

641-- The @lax@ parameter controls whether or not every record member has to be provided. For object updates, this is not the case.

642-- The @lax@ parameter controls whether or not every record member has to be provided. For object updates, this is not the case.

642--

643--

643checkProperties ::

644checkProperties ::

644− (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

645+ (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

645 Expr ->

646 Expr ->

646 [(String, Expr)] ->

647 [(String, Expr)] ->

647 Type ->

648 Type ->

@@ -673,7 +674,7 @@ checkProperties expr ps row lax = let (ts, r') = rowToList row in go ps ts r' wh

673

674

674-- | Check the type of a function application, rethrowing errors to provide a better error message

675-- | Check the type of a function application, rethrowing errors to provide a better error message

675checkFunctionApplication ::

676checkFunctionApplication ::

676− (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

677+ (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

677 Expr ->

678 Expr ->

678 Type ->

679 Type ->

679 Expr ->

680 Expr ->

@@ -685,7 +686,7 @@ checkFunctionApplication fn fnTy arg ret = rethrow (addHint (ErrorInApplication

685

686

686-- | Check the type of a function application

687-- | Check the type of a function application

687checkFunctionApplication' ::

688checkFunctionApplication' ::

688− (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

689+ (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

689 Expr ->

690 Expr ->

690 Type ->

691 Type ->

691 Expr ->

692 Expr ->

@@ -720,25 +721,6 @@ checkFunctionApplication' fn fnTy dict@TypeClassDictionary{} _ =

720 return (fnTy, App fn dict)

721 return (fnTy, App fn dict)

721checkFunctionApplication' _ fnTy arg _ = throwError . errorMessage $ CannotApplyFunction fnTy arg

722checkFunctionApplication' _ fnTy arg _ = throwError . errorMessage $ CannotApplyFunction fnTy arg

722

723

723−-- | Compute the meet of two types, i.e. the most general type which both types subsume.

724−-- TODO: is this really needed?

725−meet ::

726− (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m) =>

727− Expr ->

728− Expr ->

729− Type ->

730− Type ->

731− m (Expr, Expr, Type)

732−meet e1 e2 (ForAll ident t1 _) t2 = do

733− t1' <- replaceVarWithUnknown ident t1

734− meet e1 e2 t1' t2

735−meet e1 e2 t1 (ForAll ident t2 _) = do

736− t2' <- replaceVarWithUnknown ident t2

737− meet e1 e2 t1 t2'

738−meet e1 e2 t1 t2 = do

739− unifyTypes t1 t2

740− return (e1, e2, t1)

741−

742-- |

724-- |

743-- Ensure a set of property names and value does not contain duplicate labels

725-- Ensure a set of property names and value does not contain duplicate labels

744--

726--

src/Language/PureScript/TypeChecker/Unify.hs+6−5

@@ -23,6 +23,7 @@ module Language.PureScript.TypeChecker.Unify (

23 freshType,

24 solveType,

25 substituteType,

26+ unknownsInType,

26 unifyTypes,

27 unifyTypes,

27 unifyRows,

28 unifyRows,

28 unifiesWith,

29 unifiesWith,

@@ -56,7 +57,7 @@ freshType = do

56 return $ TUnknown t

57 return $ TUnknown t

57

58

58-- | Update the substitution to solve a type constraint

59-- | Update the substitution to solve a type constraint

59−solveType :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Int -> Type -> m ()

60+solveType :: (MonadError MultipleErrors m, MonadState CheckState m) => Int -> Type -> m ()

60solveType u t = do

61solveType u t = do

61 occursCheck u t

62 occursCheck u t

62 modify $ \cs -> cs { checkSubstitution =

63 modify $ \cs -> cs { checkSubstitution =

@@ -77,7 +78,7 @@ substituteType sub = everywhereOnTypes go

77 go other = other

78 go other = other

78

79

79-- | Make sure that an unknown does not occur in a type

80-- | Make sure that an unknown does not occur in a type

80−occursCheck :: (Functor m, Applicative m, MonadError MultipleErrors m) => Int -> Type -> m ()

81+occursCheck :: (MonadError MultipleErrors m) => Int -> Type -> m ()

81occursCheck _ TUnknown{} = return ()

82occursCheck _ TUnknown{} = return ()

82occursCheck u t = void $ everywhereOnTypesM go t

83occursCheck u t = void $ everywhereOnTypesM go t

83 where

84 where

@@ -93,7 +94,7 @@ unknownsInType t = everythingOnTypes (.) go t []

93 go _ = id

94 go _ = id

94

95

95-- | Unify two types, updating the current substitution

96-- | Unify two types, updating the current substitution

96−unifyTypes :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Type -> Type -> m ()

97+unifyTypes :: (MonadError MultipleErrors m, MonadState CheckState m) => Type -> Type -> m ()

97unifyTypes t1 t2 = do

98unifyTypes t1 t2 = do

98 sub <- gets checkSubstitution

99 sub <- gets checkSubstitution

99 rethrow (addHint (ErrorUnifyingTypes t1 t2)) $ unifyTypes' (substituteType sub t1) (substituteType sub t2)

100 rethrow (addHint (ErrorUnifyingTypes t1 t2)) $ unifyTypes' (substituteType sub t1) (substituteType sub t2)

@@ -139,7 +140,7 @@ unifyTypes t1 t2 = do

139-- trailing row unification variable, if appropriate, otherwise leftover labels result in a unification

140-- trailing row unification variable, if appropriate, otherwise leftover labels result in a unification

140-- error.

141-- error.

141--

142--

142−unifyRows :: forall m. (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Type -> Type -> m ()

143+unifyRows :: forall m. (MonadError MultipleErrors m, MonadState CheckState m) => Type -> Type -> m ()

143unifyRows r1 r2 =

144unifyRows r1 r2 =

144 let

145 let

145 (s1, r1') = rowToList r1

146 (s1, r1') = rowToList r1

@@ -205,7 +206,7 @@ replaceVarWithUnknown ident ty = do

205-- |

206-- |

206-- Replace type wildcards with unknowns

207-- Replace type wildcards with unknowns

207--

208--

208−replaceTypeWildcards :: (Functor m, Applicative m, MonadWriter MultipleErrors m, MonadState CheckState m) => Type -> m Type

209+replaceTypeWildcards :: (MonadWriter MultipleErrors m, MonadState CheckState m) => Type -> m Type

209replaceTypeWildcards = everywhereOnTypesM replace

210replaceTypeWildcards = everywhereOnTypesM replace

210 where

211 where

211 replace TypeWildcard = do

212 replace TypeWildcard = do

src/Language/PureScript/Types.hs+2−2

@@ -248,7 +248,7 @@ everywhereOnTypesTopDown f = go . f

248 go (PrettyPrintForAll args t) = PrettyPrintForAll args (go (f t))

249 go other = f other

250

251−everywhereOnTypesM :: (Functor m, Applicative m, Monad m) => (Type -> m Type) -> Type -> m Type

251+everywhereOnTypesM :: Monad m => (Type -> m Type) -> Type -> m Type

252everywhereOnTypesM f = go

253 where

254 go (TypeApp t1 t2) = (TypeApp <$> go t1 <*> go t2) >>= f

@@ -261,7 +261,7 @@ everywhereOnTypesM f = go

261 go (PrettyPrintForAll args t) = (PrettyPrintForAll args <$> go t) >>= f

262 go other = f other

263

264−everywhereOnTypesTopDownM :: (Functor m, Applicative m, Monad m) => (Type -> m Type) -> Type -> m Type

264+everywhereOnTypesTopDownM :: Monad m => (Type -> m Type) -> Type -> m Type

265everywhereOnTypesTopDownM f = go <=< f

266 where

267 go (TypeApp t1 t2) = TypeApp <$> (f t1 >>= go) <*> (f t2 >>= go)

stack-lts-2.yamldeleted−13

@@ -1,13 +0,0 @@

1−resolver: lts-2.22

2−packages:

3−- '.'

4−extra-deps:

5−- aeson-better-errors-0.8.0

6−- bower-json-0.7.0.0

7−- boxes-0.1.4

8−- pattern-arrows-0.0.2

9−- sourcemap-0.1.6

10−- fsnotify-0.2.1

11−- hfsevents-0.1.6

12−- pipes-http-1.0.2

13−flags: {}

stack-lts-3.yamldeleted−6

@@ -1,6 +0,0 @@

1−resolver: lts-3.22

2−packages:

3−- '.'

4−extra-deps:

5−- sourcemap-0.1.6

6−flags: {}